diff options
Diffstat (limited to 'typing')
46 files changed, 5854 insertions, 2317 deletions
diff --git a/typing/btype.ml b/typing/btype.ml index 91b8520b87..0e864e00d5 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -57,6 +57,8 @@ let newmarkedgenvar () = let is_Tvar = function {desc=Tvar _} -> true | _ -> false let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false +let dummy_method = "*dummy method*" + (**** Representative of a type ****) let rec field_kind_repr = @@ -124,6 +126,14 @@ let rec row_more row = | {desc=Tvariant row'} -> row_more row' | ty -> ty +let row_fixed row = + let row = row_repr row in + row.row_fixed || + match (repr row.row_more).desc with + Tvar _ | Tnil -> false + | Tunivar _ | Tconstr _ -> true + | _ -> assert false + let static_row row = let row = row_repr row in row.row_closed && @@ -256,8 +266,8 @@ let rec norm_univar ty = | Ttuple (ty :: _) -> norm_univar ty | _ -> assert false -let rec copy_type_desc f = function - Tvar _ -> Tvar None (* forget the name *) +let rec copy_type_desc ?(keep_names=false) f = function + Tvar _ as ty -> if keep_names then ty else Tvar None | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) | Ttuple l -> Ttuple (List.map f l) | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) @@ -270,7 +280,7 @@ let rec copy_type_desc f = function | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc | Tsubst ty -> assert false - | Tunivar _ as ty -> ty (* keep the name *) + | Tunivar _ as ty -> ty (* always keep the name *) | Tpoly (ty, tyl) -> let tyl = List.map (fun x -> norm_univar (f x)) tyl in Tpoly (f ty, tyl) @@ -352,11 +362,11 @@ let unmark_class_signature sign = let rec unmark_class_type = function - Tcty_constr (p, tyl, cty) -> + Cty_constr (p, tyl, cty) -> List.iter unmark_type tyl; unmark_class_type cty - | Tcty_signature sign -> + | Cty_signature sign -> unmark_class_signature sign - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> unmark_type ty; unmark_class_type cty diff --git a/typing/btype.mli b/typing/btype.mli index e2e4c9d6db..ddb34a8fb7 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -43,6 +43,7 @@ val newmarkedgenvar: unit -> type_expr val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool +val dummy_method: label val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) @@ -63,6 +64,8 @@ val row_field: label -> row_desc -> row_field (* Return the canonical representative of a row field *) val row_more: row_desc -> type_expr (* Return the extension variable of the row *) +val row_fixed: row_desc -> bool + (* Return whether the row should be treated as fixed or not *) val static_row: row_desc -> bool (* Return whether the row is static or not *) val hash_variant: label -> int @@ -85,7 +88,8 @@ val iter_row: (type_expr -> unit) -> row_desc -> unit val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit (* Iteration on types in an abbreviation list *) -val copy_type_desc: (type_expr -> type_expr) -> type_desc -> type_desc +val copy_type_desc: + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc (* Copy on types *) val copy_row: (type_expr -> type_expr) -> diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml new file mode 100644 index 0000000000..d40b1977d0 --- /dev/null +++ b/typing/cmi_format.ml @@ -0,0 +1,93 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type pers_flags = Rectypes + +type error = + Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + +exception Error of error + +type cmi_infos = { + cmi_name : string; + cmi_sign : Types.signature_item list; + cmi_crcs : (string * Digest.t) list; + cmi_flags : pers_flags list; +} + +let input_cmi ic = + let (name, sign) = input_value ic in + let crcs = input_value ic in + let flags = input_value ic in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + let msg = + if buffer < Config.cmi_magic_number then "an older" else "a newer" in + raise (Error (Wrong_version_interface (filename, msg))) + end else begin + raise(Error(Not_an_interface filename)) + end + end; + let cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + output_value oc (cmi.cmi_name, cmi.cmi_sign); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs in + output_value oc crcs; + output_value oc cmi.cmi_flags; + crc + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + Location.print_filename filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.\ + It seems to be for %s version of OCaml." + Location.print_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + Location.print_filename filename diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli new file mode 100644 index 0000000000..2d6fdec6bb --- /dev/null +++ b/typing/cmi_format.mli @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type pers_flags = Rectypes + +type cmi_infos = { + cmi_name : string; + cmi_sign : Types.signature_item list; + cmi_crcs : (string * Digest.t) list; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report *) + +type error = + Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml new file mode 100644 index 0000000000..af4b75f0ef --- /dev/null +++ b/typing/cmt_format.ml @@ -0,0 +1,1036 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Cmi_format +open Typedtree + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + let magic_number = String.create len_magic_number in + really_input ic magic_number 0 len_magic_number; + magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = +| Partial_structure of structure +| Partial_structure_item of structure_item +| Partial_expression of expression +| Partial_pattern of pattern +| Partial_class_expr of class_expr +| Partial_signature of signature +| Partial_signature_item of signature_item +| Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + + + + + + + + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +(* Re-introduce sharing after clearing environments *) +let env_hcons = Hashtbl.create 133 +let keep_only_summary env = + let new_env = Env.keep_only_summary env in + try + Hashtbl.find env_hcons new_env + with Not_found -> + Hashtbl.add env_hcons new_env new_env; + new_env +let clear_env_hcons () = Hashtbl.clear env_hcons + + + + +module TypedtreeMap : sig + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + module MakeMap : + functor + (Iter : MapArgument) -> + sig + val map_structure : structure -> structure + val map_pattern : pattern -> pattern + val map_structure_item : structure_item -> structure_item + val map_expression : expression -> expression + val map_class_expr : class_expr -> class_expr + + val map_signature : signature -> signature + val map_signature_item : signature_item -> signature_item + val map_module_type : module_type -> module_type + end + + module DefaultMapArgument : MapArgument + +end = struct + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + + module MakeMap(Map : MapArgument) = struct + + let may_map f v = + match v with + None -> v + | Some x -> Some (f x) + + + open Misc + open Asttypes + + let rec map_structure str = + let str = Map.enter_structure str in + let str_items = List.map map_structure_item str.str_items in + Map.leave_structure { str with str_items = str_items } + + and map_binding (pat, exp) = (map_pattern pat, map_expression exp) + + and map_bindings rec_flag list = + List.map map_binding list + +(*>JOCAML *) + and map_joinautomaton d = d (* TODO *) + + and map_joinautomata ds = List.map map_joinautomaton ds + +(*<JOCAML *) + and map_structure_item item = + let item = Map.enter_structure_item item in + let str_desc = + match item.str_desc with + Tstr_eval exp -> Tstr_eval (map_expression exp) + | Tstr_value (rec_flag, list) -> + Tstr_value (rec_flag, map_bindings rec_flag list) + | Tstr_primitive (id, name, v) -> + Tstr_primitive (id, name, map_value_description v) + | Tstr_type list -> + Tstr_type (List.map ( + fun (id, name, decl) -> + (id, name, map_type_declaration decl) ) list) + | Tstr_exception (id, name, decl) -> + Tstr_exception (id, name, map_exception_declaration decl) + | Tstr_exn_rebind (id, name, path, lid) -> + Tstr_exn_rebind (id, name, path, lid) + | Tstr_module (id, name, mexpr) -> + Tstr_module (id, name, map_module_expr mexpr) + | Tstr_recmodule list -> + let list = + List.map (fun (id, name, mtype, mexpr) -> + (id, name, map_module_type mtype, map_module_expr mexpr) + ) list + in + Tstr_recmodule list + | Tstr_modtype (id, name, mtype) -> + Tstr_modtype (id, name, map_module_type mtype) + | Tstr_open (path, lid) -> Tstr_open (path, lid) + | Tstr_class list -> + let list = + List.map (fun (ci, string_list, virtual_flag) -> + let ci = Map.enter_class_infos ci in + let ci_expr = map_class_expr ci.ci_expr in + (Map.leave_class_infos { ci with ci_expr = ci_expr}, + string_list, virtual_flag) + ) list + in + Tstr_class list + | Tstr_class_type list -> + let list = List.map (fun (id, name, ct) -> + let ct = Map.enter_class_infos ct in + let ci_expr = map_class_type ct.ci_expr in + (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) + ) list in + Tstr_class_type list + | Tstr_include (mexpr, idents) -> + Tstr_include (map_module_expr mexpr, idents) +(*> JOCAML *) + | Tstr_def d -> Tstr_def (map_joinautomata d) + | Tstr_loc _ -> assert false + | Tstr_exn_global (path,loc) -> Tstr_exn_global (path,loc) +(*< JOCAML *) + in + Map.leave_structure_item { item with str_desc = str_desc} + + and map_value_description v = + let v = Map.enter_value_description v in + let val_desc = map_core_type v.val_desc in + Map.leave_value_description { v with val_desc = val_desc } + + and map_type_declaration decl = + let decl = Map.enter_type_declaration decl in + let typ_cstrs = List.map (fun (ct1, ct2, loc) -> + (map_core_type ct1, + map_core_type ct2, + loc) + ) decl.typ_cstrs in + let typ_kind = match decl.typ_kind with + Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> + let list = List.map (fun (s, name, cts, loc) -> + (s, name, List.map map_core_type cts, loc) + ) list in + Ttype_variant list + | Ttype_record list -> + let list = + List.map (fun (s, name, mut, ct, loc) -> + (s, name, mut, map_core_type ct, loc) + ) list in + Ttype_record list + in + let typ_manifest = + match decl.typ_manifest with + None -> None + | Some ct -> Some (map_core_type ct) + in + Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; + typ_kind = typ_kind; typ_manifest = typ_manifest } + + and map_exception_declaration decl = + let decl = Map.enter_exception_declaration decl in + let exn_params = List.map map_core_type decl.exn_params in + let decl = { exn_params = exn_params; + exn_exn = decl.exn_exn; + exn_loc = decl.exn_loc } in + Map.leave_exception_declaration decl; + + and map_pattern pat = + let pat = Map.enter_pattern pat in + let pat_desc = + match pat.pat_desc with + | Tpat_alias (pat1, p, text) -> + let pat1 = map_pattern pat1 in + Tpat_alias (pat1, p, text) + | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) + | Tpat_construct (path, lid, cstr_decl, args, arity) -> + Tpat_construct (path, lid, cstr_decl, + List.map map_pattern args, arity) + | Tpat_variant (label, pato, rowo) -> + let pato = match pato with + None -> pato + | Some pat -> Some (map_pattern pat) + in + Tpat_variant (label, pato, rowo) + | Tpat_record (list, closed) -> + Tpat_record (List.map (fun (path, lid, lab_desc, pat) -> + (path, lid, lab_desc, map_pattern pat) ) list, closed) + | Tpat_array list -> Tpat_array (List.map map_pattern list) + | Tpat_or (p1, p2, rowo) -> + Tpat_or (map_pattern p1, map_pattern p2, rowo) + | Tpat_lazy p -> Tpat_lazy (map_pattern p) + | Tpat_constant _ + | Tpat_any + | Tpat_var _ -> pat.pat_desc + + in + let pat_extra = List.map map_pat_extra pat.pat_extra in + Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } + + and map_pat_extra pat_extra = + match pat_extra with + | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) + | (Tpat_type _ | Tpat_unpack), _ -> pat_extra + + and map_expression exp = + let exp = Map.enter_expression exp in + let exp_desc = + match exp.exp_desc with + Texp_ident (_, _, _) + | Texp_constant _ -> exp.exp_desc + | Texp_let (rec_flag, list, exp) -> + Texp_let (rec_flag, + map_bindings rec_flag list, + map_expression exp) + | Texp_function (label, cases, partial) -> + Texp_function (label, map_bindings Nonrecursive cases, partial) + | Texp_apply (exp, list) -> + Texp_apply (map_expression exp, + List.map (fun (label, expo, optional) -> + let expo = + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + (label, expo, optional) + ) list ) + | Texp_match (exp, list, partial) -> + Texp_match ( + map_expression exp, + map_bindings Nonrecursive list, + partial + ) + | Texp_try (exp, list) -> + Texp_try ( + map_expression exp, + map_bindings Nonrecursive list + ) + | Texp_tuple list -> + Texp_tuple (List.map map_expression list) + | Texp_construct (path, lid, cstr_desc, args, arity) -> + Texp_construct (path, lid, cstr_desc, + List.map map_expression args, arity ) + | Texp_variant (label, expo) -> + let expo =match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_variant (label, expo) + | Texp_record (list, expo) -> + let list = + List.map (fun (path, lid, lab_desc, exp) -> + (path, lid, lab_desc, map_expression exp) + ) list in + let expo = match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_record (list, expo) + | Texp_field (exp, path, lid, label) -> + Texp_field (map_expression exp, path, lid, label) + | Texp_setfield (exp1, path, lid, label, exp2) -> + Texp_setfield ( + map_expression exp1, + path, lid, + label, + map_expression exp2) + | Texp_array list -> + Texp_array (List.map map_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + map_expression exp1, + map_expression exp2, + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + map_expression exp1, + map_expression exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + map_expression exp1, + map_expression exp2 + ) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Texp_for ( + id, name, + map_expression exp1, + map_expression exp2, + dir, + map_expression exp3 + ) + | Texp_when (exp1, exp2) -> + Texp_when ( + map_expression exp1, + map_expression exp2 + ) + | Texp_send (exp, meth, expo) -> + Texp_send (map_expression exp, meth, may_map map_expression expo) + | Texp_new (path, lid, cl_decl) -> exp.exp_desc + | Texp_instvar (_, path, _) -> exp.exp_desc + | Texp_setinstvar (path, lid, path2, exp) -> + Texp_setinstvar (path, lid, path2, map_expression exp) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (fun (path, lid, exp) -> + (path, lid, map_expression exp) + ) list + ) + | Texp_letmodule (id, name, mexpr, exp) -> + Texp_letmodule ( + id, name, + map_module_expr mexpr, + map_expression exp + ) + | Texp_assert exp -> Texp_assert (map_expression exp) + | Texp_assertfalse -> exp.exp_desc + | Texp_lazy exp -> Texp_lazy (map_expression exp) + | Texp_object (cl, string_list) -> + Texp_object (map_class_structure cl, string_list) + | Texp_pack (mexpr) -> + Texp_pack (map_module_expr mexpr) +(*>JOCAML *) + | Texp_asyncsend (e1,e2) -> + Texp_asyncsend (map_expression e1,map_expression e2) + |Texp_spawn e -> + Texp_spawn (map_expression e) + |Texp_par (e1, e2) -> + Texp_par (map_expression e1,map_expression e2) + |Texp_null -> + Texp_null + | Texp_reply (e, id) -> + Texp_reply (map_expression e,id) + |Texp_def (d, e) -> + Texp_def(map_joinautomata d,map_expression e) + |Texp_loc (_, _) -> assert false +(*<JOCAML *) + in + let exp_extra = List.map map_exp_extra exp.exp_extra in + Map.leave_expression { + exp with + exp_desc = exp_desc; + exp_extra = exp_extra } + + and map_exp_extra exp_extra = + let loc = snd exp_extra in + match fst exp_extra with + | Texp_constraint (Some ct, None) -> + Texp_constraint (Some (map_core_type ct), None), loc + | Texp_constraint (None, Some ct) -> + Texp_constraint (None, Some (map_core_type ct)), loc + | Texp_constraint (Some ct1, Some ct2) -> + Texp_constraint (Some (map_core_type ct1), + Some (map_core_type ct2)), loc + | Texp_poly (Some ct) -> + Texp_poly (Some ( map_core_type ct )), loc + | Texp_newtype _ + | Texp_constraint (None, None) + | Texp_open _ + | Texp_poly None -> exp_extra + + + and map_package_type pack = + let pack = Map.enter_package_type pack in + let pack_fields = List.map ( + fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in + Map.leave_package_type { pack with pack_fields = pack_fields } + + and map_signature sg = + let sg = Map.enter_signature sg in + let sig_items = List.map map_signature_item sg.sig_items in + Map.leave_signature { sg with sig_items = sig_items } + + and map_signature_item item = + let item = Map.enter_signature_item item in + let sig_desc = + match item.sig_desc with + Tsig_value (id, name, v) -> + Tsig_value (id, name, map_value_description v) + | Tsig_type list -> Tsig_type ( + List.map (fun (id, name, decl) -> + (id, name, map_type_declaration decl) + ) list + ) + | Tsig_exception (id, name, decl) -> + Tsig_exception (id, name, map_exception_declaration decl) + | Tsig_module (id, name, mtype) -> + Tsig_module (id, name, map_module_type mtype) + | Tsig_recmodule list -> + Tsig_recmodule (List.map ( + fun (id, name, mtype) -> + (id, name, map_module_type mtype) ) list) + | Tsig_modtype (id, name, mdecl) -> + Tsig_modtype (id, name, map_modtype_declaration mdecl) + | Tsig_open (path, lid) -> item.sig_desc + | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) + | Tsig_class list -> Tsig_class (List.map map_class_description list) + | Tsig_class_type list -> + Tsig_class_type (List.map map_class_type_declaration list) + in + Map.leave_signature_item { item with sig_desc = sig_desc } + + and map_modtype_declaration mdecl = + let mdecl = Map.enter_modtype_declaration mdecl in + let mdecl = + match mdecl with + Tmodtype_abstract -> Tmodtype_abstract + | Tmodtype_manifest mtype -> + Tmodtype_manifest (map_module_type mtype) + in + Map.leave_modtype_declaration mdecl + + + and map_class_description cd = + let cd = Map.enter_class_description cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_description { cd with ci_expr = ci_expr} + + and map_class_type_declaration cd = + let cd = Map.enter_class_type_declaration cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_type_declaration { cd with ci_expr = ci_expr } + + and map_module_type mty = + let mty = Map.enter_module_type mty in + let mty_desc = + match mty.mty_desc with + Tmty_ident (path, lid) -> mty.mty_desc + | Tmty_signature sg -> Tmty_signature (map_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Tmty_functor (id, name, map_module_type mtype1, + map_module_type mtype2) + | Tmty_with (mtype, list) -> + Tmty_with (map_module_type mtype, + List.map (fun (path, lid, withc) -> + (path, lid, map_with_constraint withc) + ) list) + | Tmty_typeof mexpr -> + Tmty_typeof (map_module_expr mexpr) + in + Map.leave_module_type { mty with mty_desc = mty_desc} + + and map_with_constraint cstr = + let cstr = Map.enter_with_constraint cstr in + let cstr = + match cstr with + Twith_type decl -> Twith_type (map_type_declaration decl) + | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) + | Twith_module (path, lid) -> cstr + | Twith_modsubst (path, lid) -> cstr + in + Map.leave_with_constraint cstr + + and map_module_expr mexpr = + let mexpr = Map.enter_module_expr mexpr in + let mod_desc = + match mexpr.mod_desc with + Tmod_ident (p, lid) -> mexpr.mod_desc + | Tmod_structure st -> Tmod_structure (map_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Tmod_functor (id, name, map_module_type mtype, + map_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, coercion) -> + Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_implicit, coercion) + | Tmod_constraint (mexpr, mod_type, + Tmodtype_explicit mtype, coercion) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_explicit (map_module_type mtype), + coercion) + | Tmod_unpack (exp, mod_type) -> + Tmod_unpack (map_expression exp, mod_type) + in + Map.leave_module_expr { mexpr with mod_desc = mod_desc } + + and map_class_expr cexpr = + let cexpr = Map.enter_class_expr cexpr in + let cl_desc = + match cexpr.cl_desc with + | Tcl_constraint (cl, None, string_list1, string_list2, concr ) -> + Tcl_constraint (map_class_expr cl, None, string_list1, + string_list2, concr) + | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun (label, map_pattern pat, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) priv, + map_class_expr cl, partial) + + | Tcl_apply (cl, args) -> + Tcl_apply (map_class_expr cl, + List.map (fun (label, expo, optional) -> + (label, may_map map_expression expo, + optional) + ) args) + | Tcl_let (rec_flat, bindings, ivars, cl) -> + Tcl_let (rec_flat, map_bindings rec_flat bindings, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) ivars, + map_class_expr cl) + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + Tcl_constraint ( map_class_expr cl, + Some (map_class_type clty), vals, meths, concrs) + + | Tcl_ident (id, name, tyl) -> + Tcl_ident (id, name, List.map map_core_type tyl) + in + Map.leave_class_expr { cexpr with cl_desc = cl_desc } + + and map_class_type ct = + let ct = Map.enter_class_type ct in + let cltyp_desc = + match ct.cltyp_desc with + Tcty_signature csg -> Tcty_signature (map_class_signature csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr (path, lid, List.map map_core_type list) + | Tcty_fun (label, ct, cl) -> + Tcty_fun (label, map_core_type ct, map_class_type cl) + in + Map.leave_class_type { ct with cltyp_desc = cltyp_desc } + + and map_class_signature cs = + let cs = Map.enter_class_signature cs in + let csig_self = map_core_type cs.csig_self in + let csig_fields = List.map map_class_type_field cs.csig_fields in + Map.leave_class_signature { cs with + csig_self = csig_self; csig_fields = csig_fields } + + + and map_class_type_field ctf = + let ctf = Map.enter_class_type_field ctf in + let ctf_desc = + match ctf.ctf_desc with + Tctf_inher ct -> Tctf_inher (map_class_type ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, map_core_type ct) + | Tctf_virt (s, priv, ct) -> + Tctf_virt (s, priv, map_core_type ct) + | Tctf_meth (s, priv, ct) -> + Tctf_meth (s, priv, map_core_type ct) + | Tctf_cstr (ct1, ct2) -> + Tctf_cstr (map_core_type ct1, map_core_type ct2) + in + Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } + + and map_core_type ct = + let ct = Map.enter_core_type ct in + let ctyp_desc = + match ct.ctyp_desc with + Ttyp_any + | Ttyp_var _ -> ct.ctyp_desc + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map map_core_type list) + | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list) + | Ttyp_class (path, lid, list, labels) -> + Ttyp_class (path, lid, List.map map_core_type list, labels) + | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ttyp_variant (List.map map_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) + | Ttyp_package pack -> Ttyp_package (map_package_type pack) + in + Map.leave_core_type { ct with ctyp_desc = ctyp_desc } + + and map_core_field_type cft = + let cft = Map.enter_core_field_type cft in + let field_desc = match cft.field_desc with + Tcfield_var -> Tcfield_var + | Tcfield (s, ct) -> Tcfield (s, map_core_type ct) + in + Map.leave_core_field_type { cft with field_desc = field_desc } + + and map_class_structure cs = + let cs = Map.enter_class_structure cs in + let cstr_pat = map_pattern cs.cstr_pat in + let cstr_fields = List.map map_class_field cs.cstr_fields in + Map.leave_class_structure { cs with cstr_pat = cstr_pat; + cstr_fields = cstr_fields } + + and map_row_field rf = + match rf with + Ttag (label, bool, list) -> + Ttag (label, bool, List.map map_core_type list) + | Tinherit ct -> Tinherit (map_core_type ct) + + and map_class_field cf = + let cf = Map.enter_class_field cf in + let cf_desc = + match cf.cf_desc with + Tcf_inher (ovf, cl, super, vals, meths) -> + Tcf_inher (ovf, map_class_expr cl, super, vals, meths) + | Tcf_constr (cty, cty') -> + Tcf_constr (map_core_type cty, map_core_type cty') + | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty), + override) + | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp), + override) + | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> + Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty), + override) + | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> + Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp), + override) + | Tcf_init exp -> Tcf_init (map_expression exp) + in + Map.leave_class_field { cf with cf_desc = cf_desc } + + end + +module DefaultMapArgument = struct + + let enter_structure t = t + let enter_value_description t = t + let enter_type_declaration t = t + let enter_exception_declaration t = t + let enter_pattern t = t + let enter_expression t = t + let enter_package_type t = t + let enter_signature t = t + let enter_signature_item t = t + let enter_modtype_declaration t = t + let enter_module_type t = t + let enter_module_expr t = t + let enter_with_constraint t = t + let enter_class_expr t = t + let enter_class_signature t = t + let enter_class_description t = t + let enter_class_type_declaration t = t + let enter_class_infos t = t + let enter_class_type t = t + let enter_class_type_field t = t + let enter_core_type t = t + let enter_core_field_type t = t + let enter_class_structure t = t + let enter_class_field t = t + let enter_structure_item t = t + + + let leave_structure t = t + let leave_value_description t = t + let leave_type_declaration t = t + let leave_exception_declaration t = t + let leave_pattern t = t + let leave_expression t = t + let leave_package_type t = t + let leave_signature t = t + let leave_signature_item t = t + let leave_modtype_declaration t = t + let leave_module_type t = t + let leave_module_expr t = t + let leave_with_constraint t = t + let leave_class_expr t = t + let leave_class_signature t = t + let leave_class_description t = t + let leave_class_type_declaration t = t + let leave_class_infos t = t + let leave_class_type t = t + let leave_class_type_field t = t + let leave_core_type t = t + let leave_core_field_type t = t + let leave_class_structure t = t + let leave_class_field t = t + let leave_structure_item t = t + + end + +end + +module ClearEnv = TypedtreeMap.MakeMap (struct + open TypedtreeMap + include DefaultMapArgument + + let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } + let leave_expression e = + let exp_extra = List.map (function + (Texp_open (path, lloc, env), loc) -> + (Texp_open (path, lloc, keep_only_summary env), loc) + | exp_extra -> exp_extra) e.exp_extra in + { e with + exp_env = keep_only_summary e.exp_env; + exp_extra = exp_extra } + let leave_class_expr c = + { c with cl_env = keep_only_summary c.cl_env } + let leave_module_expr m = + { m with mod_env = keep_only_summary m.mod_env } + let leave_structure s = + { s with str_final_env = keep_only_summary s.str_final_env } + let leave_structure_item str = + { str with str_env = keep_only_summary str.str_env } + let leave_module_type m = + { m with mty_env = keep_only_summary m.mty_env } + let leave_signature s = + { s with sig_final_env = keep_only_summary s.sig_final_env } + let leave_signature_item s = + { s with sig_env = keep_only_summary s.sig_env } + let leave_core_type c = + { c with ctyp_env = keep_only_summary c.ctyp_env } + let leave_class_type c = + { c with cltyp_env = keep_only_summary c.cltyp_env } + +end) + +let rec clear_part p = match p with + | Partial_structure s -> Partial_structure (ClearEnv.map_structure s) + | Partial_structure_item s -> + Partial_structure_item (ClearEnv.map_structure_item s) + | Partial_expression e -> Partial_expression (ClearEnv.map_expression e) + | Partial_pattern p -> Partial_pattern (ClearEnv.map_pattern p) + | Partial_class_expr ce -> Partial_class_expr (ClearEnv.map_class_expr ce) + | Partial_signature s -> Partial_signature (ClearEnv.map_signature s) + | Partial_signature_item s -> + Partial_signature_item (ClearEnv.map_signature_item s) + | Partial_module_type s -> Partial_module_type (ClearEnv.map_module_type s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (ClearEnv.map_structure s) + | Interface s -> Interface (ClearEnv.map_signature s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + + + + +exception Error of error + +let input_cmt ic = (input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + try + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + close_in ic; +(* Printf.fprintf stderr "Cmt_format.read done\n%!"; *) + cmi, cmt + with e -> + close_in ic; + raise e + +let string_of_file filename = + let ic = open_in filename in + let s = Misc.string_of_file ic in + close_in ic; + s + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +let save_cmt filename modname binary_annots sourcefile initial_env sg = + if !Clflags.binary_annotations + && not !Clflags.print_types + && not !Clflags.dont_write_files + then begin + let imports = Env.imported_units () in + let oc = open_out_bin filename in + let this_crc = + match sg with + None -> None + | Some (sg) -> + let cmi = { + cmi_name = modname; + cmi_sign = sg; + cmi_flags = + if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; + cmi_crcs = imports; + } in + Some (output_cmi filename oc cmi) + in + let source_digest = Misc.may_map Digest.file sourcefile in + let cmt = { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Sys.getcwd (); + cmt_loadpath = !Config.load_path; + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort compare imports; + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + } in + clear_env_hcons (); + output_cmt oc cmt; + close_out oc; + set_saved_types []; + end; + set_saved_types [] diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli new file mode 100644 index 0000000000..578d1743f3 --- /dev/null +++ b/typing/cmt_format.mli @@ -0,0 +1,112 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(** cmt and cmti files format. *) + +(** The layout of a cmt file is as follows: + <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\} + where <cmi> is the cmi file format: + <cmi> := <cmi magic> <cmi info>. + More precisely, the optional <cmi> part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern of pattern + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt modname filename binary_annots sourcefile initial_env sg] + writes a cmt(i) file. *) +val save_cmt : + string -> (* filename.cmt to generate *) + string -> (* module name *) + binary_annots -> + string option -> (* source file *) + Env.t -> (* initial env *) + Types.signature option -> (* if a .cmi was generated, + the signature saved there *) + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/typing/ctype.ml b/typing/ctype.ml index d9945d2853..0d6a1039af 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -189,14 +189,14 @@ module TypePairs = (**** unification mode ****) -type unification_mode = +type unification_mode = | Expression (* unification in expression *) | Pattern (* unification in pattern which may add local constraints *) let umode = ref Expression let generate_equations = ref false -let set_mode mode ?(generate = (mode = Pattern)) f = +let set_mode mode ?(generate = (mode = Pattern)) f = let old_unification_mode = !umode and old_gen = !generate_equations in try @@ -218,10 +218,10 @@ let in_current_module = function | Path.Pident _ -> true | Path.Pdot _ | Path.Papply _ -> false -let in_pervasives p = +let in_pervasives p = try ignore (Env.find_type p Env.initial); true with Not_found -> false - + let is_datatype decl= match decl.type_kind with Type_record _ | Type_variant _ -> true @@ -240,8 +240,6 @@ let is_datatype decl= (**** Object field manipulation. ****) -let dummy_method = "*dummy method*" - let object_fields ty = match (repr ty).desc with Tobject (fields, _) -> fields @@ -368,18 +366,18 @@ let hide_private_methods ty = let rec signature_of_class_type = function - Tcty_constr (_, _, cty) -> signature_of_class_type cty - | Tcty_signature sign -> sign - | Tcty_fun (_, ty, cty) -> signature_of_class_type cty + Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_fun (_, ty, cty) -> signature_of_class_type cty let self_type cty = repr (signature_of_class_type cty).cty_self let rec class_type_arity = function - Tcty_constr (_, _, cty) -> class_type_arity cty - | Tcty_signature _ -> 0 - | Tcty_fun (_, _, cty) -> 1 + class_type_arity cty + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_fun (_, _, cty) -> 1 + class_type_arity cty (*******************************************) @@ -521,13 +519,13 @@ let closed_type_decl decl = Type_abstract -> () | Type_variant v -> - List.iter + List.iter (fun (_, tyl,ret_type_opt) -> match ret_type_opt with | Some _ -> () | None -> List.iter closed_type tyl) - v + v | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; @@ -633,12 +631,14 @@ let rec generalize_structure var_level ty = if ty.level <> generic_level then begin if is_Tvar ty && ty.level > var_level then set_level ty var_level - else if ty.level > !current_level then begin + else if + ty.level > !current_level && + match ty.desc with + Tconstr (p, _, abbrev) -> + not (is_object_type p) && (abbrev := Mnil; true) + | _ -> true + then begin set_level ty generic_level; - begin match ty.desc with - Tconstr (_, _, abbrev) -> abbrev := Mnil - | _ -> () - end; iter_type_expr (generalize_structure var_level) ty end end @@ -653,9 +653,21 @@ let rec generalize_spine ty = let ty = repr ty in if ty.level < !current_level || ty.level = generic_level then () else match ty.desc with - Tarrow (_, _, ty', _) | Tpoly (ty', _) -> + Tarrow (_, ty1, ty2, _) -> + set_level ty generic_level; + generalize_spine ty1; + generalize_spine ty2; + | Tpoly (ty', _) -> set_level ty generic_level; generalize_spine ty' + | Ttuple tyl + | Tpackage (_, _, tyl) -> + set_level ty generic_level; + List.iter generalize_spine tyl + | Tconstr (p, tyl, memo) when not (is_object_type p) -> + set_level ty generic_level; + memo := Mnil; + List.iter generalize_spine tyl | _ -> () let forward_try_expand_once = (* Forward declaration *) @@ -673,13 +685,13 @@ let forward_try_expand_once = (* Forward declaration *) module M = struct type t let _ = (x : t list ref) end (without this constraint, the type system would actually be unsound.) *) -let get_level env p = +let get_level env p = try match (Env.find_type p env).type_newtype_level with | None -> Path.binding_time p | Some (x, _) -> x - with - | _ -> + with + | Not_found -> (* no newtypes in predef *) Path.binding_time p @@ -720,7 +732,8 @@ let rec update_level env level ty = end; set_level ty level; iter_type_expr (update_level env level) ty - | Tfield(lab, _, _, _) when lab = dummy_method -> + | Tfield(lab, _, ty1, _) + when lab = dummy_method && (repr ty1).level > level-> raise (Unify [(ty, newvar2 level)]) | _ -> set_level ty level; @@ -906,8 +919,8 @@ let abbreviations = ref (ref Mnil) (* partial: we may not wish to copy the non generic types before we call type_pat *) -let rec copy ?env ?partial ty = - let copy = copy ?env ?partial in +let rec copy ?env ?partial ?keep_names ty = + let copy = copy ?env ?partial ?keep_names in let ty = repr ty in match ty.desc with Tsubst ty -> ty @@ -996,7 +1009,9 @@ let rec copy ?env ?partial ty = dup_kind r; copy_type_desc copy desc end - | _ -> copy_type_desc copy desc + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc end; t @@ -1021,7 +1036,7 @@ let instance ?partial env sch = let instance_def sch = let ty = copy sch in cleanup_types (); - ty + ty let instance_list env schl = let env = gadt_env env in @@ -1030,9 +1045,9 @@ let instance_list env schl = tyl let reified_var_counter = ref Vars.empty - -(* names given to new type constructors. - Used for existential types and + +(* names given to new type constructors. + Used for existential types and local constraints *) let get_new_abstract_name s = let index = @@ -1041,7 +1056,7 @@ let get_new_abstract_name s = reified_var_counter := Vars.add s index !reified_var_counter; Printf.sprintf "%s#%d" s index -let new_declaration newtype manifest = +let new_declaration newtype manifest = { type_params = []; type_arity = 0; @@ -1059,7 +1074,7 @@ let instance_constructor ?in_pattern cstr = begin match in_pattern with | None -> () | Some (env, newtype_lev) -> - let process existential = + let process existential = let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in let name = match repr existential with @@ -1069,16 +1084,16 @@ let instance_constructor ?in_pattern cstr = let (id, new_env) = Env.enter_type (get_new_abstract_name name) decl !env in env := new_env; - let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in - link_type (copy existential) to_unify + let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in + link_type (copy existential) to_unify in List.iter process cstr.cstr_existentials end; cleanup_types (); (ty_args, ty_res) -let instance_parameterized_type sch_args sch = - let ty_args = List.map copy sch_args in +let instance_parameterized_type ?keep_names sch_args sch = + let ty_args = List.map (copy ?keep_names) sch_args in let ty = copy sch in cleanup_types (); (ty_args, ty) @@ -1109,18 +1124,18 @@ let instance_declaration decl = let instance_class params cty = let rec copy_class_type = function - Tcty_constr (path, tyl, cty) -> - Tcty_constr (path, List.map copy tyl, copy_class_type cty) - | Tcty_signature sign -> - Tcty_signature + Cty_constr (path, tyl, cty) -> + Cty_constr (path, List.map copy tyl, copy_class_type cty) + | Cty_signature sign -> + Cty_signature {cty_self = copy sign.cty_self; cty_vars = Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, copy ty, copy_class_type cty) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, copy ty, copy_class_type cty) in let params' = List.map copy params in let cty' = copy_class_type cty in @@ -1347,7 +1362,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = | _ -> assert false -(* inside objects and variants we do not want to +(* inside objects and variants we do not want to use local constraints *) let expand_abbrev ty = expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty @@ -1434,10 +1449,13 @@ let expand_head_opt env ty = let enforce_constraints env ty = match ty with {desc = Tconstr (path, args, abbrev); level = level} -> - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) + begin try + let decl = Env.find_type path env in + ignore + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) + with Not_found -> () + end | _ -> assert false @@ -1487,7 +1505,7 @@ let rec non_recursive_abbrev env ty0 ty = with Cannot_expand -> if !Clflags.recursive_types && (in_current_module p || in_pervasives p || - is_datatype (Env.find_type p env)) + try is_datatype (Env.find_type p env) with Not_found -> false) then () else iter_type_expr (non_recursive_abbrev env ty0) ty end @@ -1790,26 +1808,26 @@ let deep_occur t0 ty = let newtype_level = ref None -let get_newtype_level () = +let get_newtype_level () = match !newtype_level with | None -> assert false | Some x -> x -(* a local constraint can be added only if the rhs +(* a local constraint can be added only if the rhs of the constraint does not contain any Tvars. They need to be removed using this function *) let reify env t = let newtype_level = get_newtype_level () in - let create_fresh_constr lev name = + let create_fresh_constr lev name = let decl = new_declaration (Some (newtype_level, newtype_level)) None in let name = get_new_abstract_name name in - let (id, new_env) = Env.enter_type name decl !env in - let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil)) in + let (id, new_env) = Env.enter_type name decl !env in + let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil)) in env := new_env; t in let visited = ref TypeSet.empty in - let rec iterator ty = + let rec iterator ty = let ty = repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; @@ -1829,16 +1847,18 @@ let reify env t = in iterator t -let is_abstract_newtype env p = - let decl = Env.find_type p env in - not (decl.type_newtype_level = None) && - decl.type_manifest = None && - decl.type_kind = Type_abstract +let is_abstract_newtype env p = + try + let decl = Env.find_type p env in + not (decl.type_newtype_level = None) && + decl.type_manifest = None && + decl.type_kind = Type_abstract + with Not_found -> false -(* mcomp type_pairs subst env t1 t2 does not raise an +(* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually - equal, assuming the types in type_pairs are equal and - that the mapping subst holds. + equal, assuming the types in type_pairs are equal and + that the mapping subst holds. Assumes that both t1 and t2 do not contain any tvars and that both their objects and variants are closed *) @@ -1849,7 +1869,7 @@ let rec mcomp type_pairs subst env t1 t2 = let t2 = repr t2 in if t1 == t2 then () else match (t1.desc, t2.desc) with - | (Tvar _, _) + | (Tvar _, _) | (_, Tvar _) -> fatal_error "types should not include variables" | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> @@ -1949,40 +1969,42 @@ and mcomp_row type_pairs subst env row1 row2 = | _ -> ()) pairs -and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = +and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = let non_aliased p decl = in_pervasives p || in_current_module p && decl.type_newtype_level = None in - let decl = Env.find_type p1 env in - let decl' = Env.find_type p2 env in - if Path.same p1 p2 then - if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2 else () - else match decl.type_kind, decl'.type_kind with - | Type_record (lst,r), Type_record (lst',r') when r = r' -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_record_description type_pairs subst env lst lst' - | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_variant_description type_pairs subst env v1 v2 - | Type_variant _, Type_record _ - | Type_record _, Type_variant _ -> raise (Unify []) - | _ -> - if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl') - || is_datatype decl && non_aliased p2 decl' then raise (Unify []) + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if Path.same p1 p2 then + (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2) + else match decl.type_kind, decl'.type_kind with + | Type_record (lst,r), Type_record (lst',r') when r = r' -> + mcomp_list type_pairs subst env tl1 tl2; + mcomp_record_description type_pairs subst env lst lst' + | Type_variant v1, Type_variant v2 -> + mcomp_list type_pairs subst env tl1 tl2; + mcomp_variant_description type_pairs subst env v1 v2 + | Type_variant _, Type_record _ + | Type_record _, Type_variant _ -> raise (Unify []) + | _ -> + if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl') + || is_datatype decl && non_aliased p2 decl' then raise (Unify []) + with Not_found -> () -and mcomp_type_option type_pairs subst env t t' = +and mcomp_type_option type_pairs subst env t t' = match t, t' with None, None -> () - | Some t, Some t' -> mcomp type_pairs subst env t t' - | _ -> raise (Unify []) + | Some t, Some t' -> mcomp type_pairs subst env t t' + | _ -> raise (Unify []) -and mcomp_variant_description type_pairs subst env = +and mcomp_variant_description type_pairs subst env = let rec iter = fun x y -> match x, y with (name,mflag,t) :: xs, (name', mflag', t') :: ys -> mcomp_type_option type_pairs subst env t t'; - if name = name' && mflag = mflag' + if name = name' && mflag = mflag' then iter xs ys else raise (Unify []) | [],[] -> () @@ -1990,12 +2012,12 @@ and mcomp_variant_description type_pairs subst env = in iter -and mcomp_record_description type_pairs subst env = +and mcomp_record_description type_pairs subst env = let rec iter = fun x y -> - match x, y with + match x, y with (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys -> mcomp type_pairs subst env t t'; - if name = name' && mutable_flag = mutable_flag' + if name = name' && mutable_flag = mutable_flag' then iter xs ys else raise (Unify []) | [], [] -> () @@ -2019,27 +2041,28 @@ let find_lowest_level ty = end in find ty; unmark_type ty; !lowest -let find_newtype_level env path = - match (Env.find_type path env).type_newtype_level with +let find_newtype_level env path = + try match (Env.find_type path env).type_newtype_level with Some x -> x | None -> assert false - + with Not_found -> assert false + let add_gadt_equation env source destination = - let destination = duplicate_type destination in + let destination = duplicate_type destination in let source_lev = find_newtype_level !env (Path.Pident source) in let decl = new_declaration (Some source_lev) (Some destination) in let newtype_level = get_newtype_level () in env := Env.add_local_constraint source decl newtype_level !env; - cleanup_abbrev () + cleanup_abbrev () let unify_eq_set = TypePairs.create 11 let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) -let add_type_equality t1 t2 = +let add_type_equality t1 t2 = TypePairs.add unify_eq_set (order_type_pair t1 t2) () - + let unify_eq env t1 t2 = t1 == t2 || match !umode with @@ -2055,7 +2078,7 @@ let rec unify (env:Env.t ref) t1 t2 = let t2 = repr t2 in if unify_eq !env t1 t2 then () else let reset_tracing = check_trace_gadt_instances !env in - + try type_changed := true; begin match (t1.desc, t2.desc) with @@ -2064,12 +2087,12 @@ let rec unify (env:Env.t ref) t1 t2 = | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 | (Tvar _, _) -> - occur !env t1 t2; + occur !env t1 t2; occur_univar !env t2; link_type t1 t2; update_level !env t1.level t2 | (_, Tvar _) -> - occur !env t2 t1; + occur !env t2 t1; occur_univar !env t1; link_type t2 t1; update_level !env t2.level t1 @@ -2155,14 +2178,15 @@ and unify3 env t1 t1' t2 t2' = | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> - begin match !umode with - | Expression -> - occur !env t1' t2'; - link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' - end; - try match (d1, d2) with + begin match !umode with + | Expression -> + occur !env t1' t2'; + link_type t1' t2 + | Pattern -> + add_type_equality t1' t2' + end; + try + begin match (d1, d2) with (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> unify env t1 t2; unify env u1 u2; @@ -2176,7 +2200,7 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> if !umode = Expression || not !generate_equations || in_current_module p1 || in_pervasives p1 - || is_datatype (Env.find_type p1 !env) + || try is_datatype (Env.find_type p1 !env) with Not_found -> false then unify_list env tl1 tl2 else @@ -2236,20 +2260,20 @@ and unify3 env t1 t1' t2 t2' = unify_list env tl1 tl2 | (_, _) -> raise (Unify []) - with Unify trace -> - t1'.desc <- d1; - raise (Unify trace) - end; - (* XXX Commentaires + changer "create_recursion" *) - if create_recursion then begin - match t2.desc with - Tconstr (p, tl, abbrev) -> - forget_abbrev abbrev p; - let t2'' = expand_head_unif !env t2 in - if not (closed_parameterized_type tl t2'') then - link_type (repr t2) (repr t2') - | _ -> - () (* t2 has already been expanded by update_level *) + end; + (* XXX Commentaires + changer "create_recursion" *) + if create_recursion then + match t2.desc with + Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif !env t2 in + if not (closed_parameterized_type tl t2'') then + link_type (repr t2) (repr t2') + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify trace -> + t1'.desc <- d1; + raise (Unify trace) end and unify_list env tl1 tl2 = @@ -2290,9 +2314,9 @@ and unify_fields env ty1 ty2 = (* Optimization *) List.iter (fun (n, k1, t1, k2, t2) -> unify_kind k1 k2; - try + try if !trace_gadt_instances then update_level !env va.level t1; - unify env t1 t2 + unify env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), newty (Tfield(n, k2, t2, newty Tnil)))::trace))) @@ -2329,11 +2353,12 @@ and unify_row env row1 row2 = with Not_found -> ()) r2 end; + let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in let more = - if row1.row_fixed then rm1 else - if row2.row_fixed then rm2 else + if fixed1 then rm1 else + if fixed2 then rm2 else newty2 (min rm1.level rm2.level) (Tvar None) in - let fixed = row1.row_fixed || row2.row_fixed + let fixed = fixed1 || fixed2 and closed = row1.row_closed || row2.row_closed in let keep switch = List.for_all @@ -2367,8 +2392,8 @@ and unify_row env row1 row2 = if closed then filter_row_fields row.row_closed rest else rest in - if rest <> [] && (row.row_closed || row.row_fixed) - || closed && row.row_fixed && not row.row_closed then begin + if rest <> [] && (row.row_closed || row_fixed row) + || closed && row_fixed row && not row.row_closed then begin let t1 = mkvariant [] true and t2 = mkvariant rest false in raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) end; @@ -2377,7 +2402,7 @@ and unify_row env row1 row2 = if !trace_gadt_instances && rm.desc = Tnil then () else if !trace_gadt_instances then update_level !env rm.level (newgenty (Tvariant row)); - if row.row_fixed then + if row_fixed row then if more == rm then () else if is_Tvar rm then link_type rm more else unify env rm more else @@ -2391,7 +2416,7 @@ and unify_row env row1 row2 = set_more row1 r2; List.iter (fun (l,f1,f2) -> - try unify_row_field env row1.row_fixed row2.row_fixed more l f1 f2 + try unify_row_field env fixed1 fixed2 more l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) @@ -2409,7 +2434,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2 || + (m1 || m2 || fixed1 || fixed2 || !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> @@ -2430,8 +2455,8 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = let f1' = Reither(c1 || c2, tl1', m1 || m2, e) and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 - | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 + | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 + | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 | Rabsent, Rabsent -> () | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; @@ -2485,7 +2510,7 @@ let unify_var env t1 t2 = if reset_tracing then trace_gadt_instances := false; with Unify trace -> if reset_tracing then trace_gadt_instances := false; - let expanded_trace = expand_trace env ((t1,t2)::trace) in + let expanded_trace = expand_trace env ((t1,t2)::trace) in raise (Unify expanded_trace) end | _ -> @@ -2855,7 +2880,7 @@ let rec rigidify_rec vars ty = | Tvariant row -> let row = row_repr row in let more = repr row.row_more in - if is_Tvar more && not row.row_fixed then begin + if is_Tvar more && not (row_fixed row) then begin let more' = newty2 more.level more.desc in let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} in link_type more (newty2 ty.level (Tvariant row')) @@ -3100,16 +3125,16 @@ exception Failure of class_match_failure list let rec moregen_clty trace type_pairs env cty1 cty2 = try match cty1, cty2 with - Tcty_constr (_, _, cty1), _ -> + Cty_constr (_, _, cty1), _ -> moregen_clty true type_pairs env cty1 cty2 - | _, Tcty_constr (_, _, cty2) -> + | _, Cty_constr (_, _, cty2) -> moregen_clty true type_pairs env cty1 cty2 - | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 -> + | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try moregen true type_pairs env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; moregen_clty false type_pairs env cty1' cty2' - | Tcty_signature sign1, Tcty_signature sign2 -> + | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 @@ -3233,18 +3258,18 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let rec equal_clty trace type_pairs subst env cty1 cty2 = try match cty1, cty2 with - Tcty_constr (_, _, cty1), Tcty_constr (_, _, cty2) -> + Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 - | Tcty_constr (_, _, cty1), _ -> + | Cty_constr (_, _, cty1), _ -> equal_clty true type_pairs subst env cty1 cty2 - | _, Tcty_constr (_, _, cty2) -> + | _, Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 - | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 -> + | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; equal_clty false type_pairs subst env cty1' cty2' - | Tcty_signature sign1, Tcty_signature sign2 -> + | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 @@ -3359,14 +3384,16 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = raise (Failure [CM_Type_parameter_mismatch (expand_trace env trace)])) patt_params subj_params; - (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) + (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) equal_clty false type_pairs subst env - (Tcty_signature sign1) (Tcty_signature sign2); + (Cty_signature sign1) (Cty_signature sign2); (* Use moregeneral for class parameters, need to recheck everything to keeps relationships (PR#4824) *) - let clty_params = List.fold_right (fun ty cty -> Tcty_fun ("*",ty,cty)) in + let clty_params = + List.fold_right (fun ty cty -> Cty_fun ("*",ty,cty)) in match_class_types ~trace:false env - (clty_params patt_params patt_type) (clty_params subj_params subj_type) + (clty_params patt_params patt_type) + (clty_params subj_params subj_type) with Failure r -> r end @@ -4029,11 +4056,11 @@ let nondep_type_decl env mid id is_covariant decl = | Type_variant cstrs -> Type_variant (List.map - (fun (c, tl,ret_type_opt) -> - let ret_type_opt = + (fun (c, tl,ret_type_opt) -> + let ret_type_opt = may_map (nondep_type_rec env mid) ret_type_opt in - (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) + (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) cstrs) | Type_record(lbls, rep) -> Type_record @@ -4082,15 +4109,15 @@ let nondep_class_signature env id sign = let rec nondep_class_type env id = function - Tcty_constr (p, _, cty) when Path.isfree id p -> + Cty_constr (p, _, cty) when Path.isfree id p -> nondep_class_type env id cty - | Tcty_constr (p, tyl, cty) -> - Tcty_constr (p, List.map (nondep_type_rec env id) tyl, + | Cty_constr (p, tyl, cty) -> + Cty_constr (p, List.map (nondep_type_rec env id) tyl, nondep_class_type env id cty) - | Tcty_signature sign -> - Tcty_signature (nondep_class_signature env id sign) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty) + | Cty_signature sign -> + Cty_signature (nondep_class_signature env id sign) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty) let nondep_class_declaration env id decl = assert (not (Path.isfree id decl.cty_path)); diff --git a/typing/ctype.mli b/typing/ctype.mli index f835dfc70f..790cd5367e 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -55,7 +55,6 @@ val none: type_expr val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) -val dummy_method: label val object_fields: type_expr -> type_expr val flatten_fields: type_expr -> (string * field_kind * type_expr) list * type_expr @@ -122,6 +121,7 @@ val instance_constructor: constructor_description -> type_expr list * type_expr (* Same, for a constructor *) val instance_parameterized_type: + ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr val instance_parameterized_type_2: type_expr list -> type_expr list -> type_expr -> @@ -155,7 +155,8 @@ val enforce_constraints: Env.t -> type_expr -> unit val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit - (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. *) + (* Unify the two types given and update the environment with the + local constraints. Raise [Unify] if not possible. *) val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) @@ -181,7 +182,7 @@ val rigidify: type_expr -> type_expr list (* "Rigidify" a type and return its type variable *) val all_distinct_vars: Env.t -> type_expr list -> bool (* Check those types are all distinct type variables *) -val matches : Env.t -> type_expr -> type_expr -> bool +val matches: Env.t -> type_expr -> type_expr -> bool (* Same as [moregeneral false], implemented using the two above functions and backtracking. Ignore levels *) @@ -203,7 +204,7 @@ type class_match_failure = | CM_Private_method of string | CM_Virtual_method of string val match_class_types: - ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list + ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list (* Check if the first class type is more general than the second. *) val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool (* [equal env [x1...xn] tau [y1...yn] sigma] @@ -234,7 +235,7 @@ val nondep_class_declaration: Env.t -> Ident.t -> class_declaration -> class_declaration (* Same for class declarations. *) val nondep_cltype_declaration: - Env.t -> Ident.t -> cltype_declaration -> cltype_declaration + Env.t -> Ident.t -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool diff --git a/typing/datarepr.ml b/typing/datarepr.ml index bc05d2a845..ebd4e17da2 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -111,7 +111,7 @@ let label_descrs ty_res lbls repres priv = [] -> [] | (name, mut_flag, ty_arg) :: rest -> let lbl = - { lbl_name = name; + { lbl_name = Ident.name name; lbl_res = ty_res; lbl_arg = ty_arg; lbl_mut = mut_flag; diff --git a/typing/datarepr.mli b/typing/datarepr.mli index bc1190d454..527fecb573 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -19,17 +19,17 @@ open Asttypes open Types val constructor_descrs: - type_expr -> (string * type_expr list * type_expr option) list -> - private_flag -> (string * constructor_description) list + type_expr -> (Ident.t * type_expr list * type_expr option) list -> + private_flag -> (Ident.t * constructor_description) list val exception_descr: Path.t -> exception_declaration -> constructor_description val label_descrs: - type_expr -> (string * mutable_flag * type_expr) list -> + type_expr -> (Ident.t * mutable_flag * type_expr) list -> record_representation -> private_flag -> - (string * label_description) list + (Ident.t * label_description) list exception Constr_not_found val find_constr_by_tag: - constructor_tag -> (string * type_expr list * type_expr option) list -> - string * type_expr list * type_expr option + constructor_tag -> (Ident.t * type_expr list * type_expr option) list -> + Ident.t * type_expr list * type_expr option diff --git a/typing/env.ml b/typing/env.ml index 8d1e43079d..8a4fc81d89 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -14,6 +14,7 @@ (* Environment handling *) +open Cmi_format open Config open Misc open Asttypes @@ -24,26 +25,76 @@ open Btype let add_delayed_check_forward = ref (fun _ -> assert false) -let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16 +let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = + Hashtbl.create 16 (* This table is used to usage of value declarations. A declaration is - identified with its name and location. The callback attached to a declaration - is called whenever the value is used explicitly (lookup_value) or implicitly - (inclusion test between signatures, cf Includemod.value_descriptions). *) + identified with its name and location. The callback attached to a + declaration is called whenever the value is used explicitly + (lookup_value) or implicitly (inclusion test between signatures, + cf Includemod.value_descriptions). *) let type_declarations = Hashtbl.create 16 -let used_constructors : (string * Location.t * string, (unit -> unit)) Hashtbl.t = Hashtbl.create 16 +type constructor_usage = Positive | Pattern | Privatize +type constructor_usages = + { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_privatize: bool; + } +let add_constructor_usage cu = function + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Privatize -> cu.cu_privatize <- true +let constructor_usages () = + {cu_positive = false; cu_pattern = false; cu_privatize = false} + +let used_constructors : + (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t + = Hashtbl.create 16 type error = - Not_an_interface of string - | Wrong_version_interface of string * string - | Corrupted_interface of string | Illegal_renaming of string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string exception Error of error +module EnvLazy : sig + type ('a,'b) t + + val force : ('a -> 'b) -> ('a,'b) t -> 'b + val create : 'a -> ('a,'b) t + +end = struct + + type ('a,'b) t = ('a,'b) eval ref + + and ('a,'b) eval = + Done of 'b + | Raise of exn + | Thunk of 'a + + let force f x = + match !x with + Done x -> x + | Raise e -> raise e + | Thunk e -> + try + let y = f e in + x := Done y; + y + with e -> + x := Raise e; + raise e + + let create x = + let x = ref (Thunk x) in + x + +end + + type summary = Env_empty | Env_value of summary * Ident.t * value_description @@ -52,32 +103,32 @@ type summary = | Env_module of summary * Ident.t * module_type | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration - | Env_cltype of summary * Ident.t * cltype_declaration + | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t module EnvTbl = struct (* A table indexed by identifier, with an extra slot to record usage. *) - type 'a t = 'a Ident.tbl * bool ref Ident.tbl + type 'a t = ('a * bool ref) Ident.tbl - let empty = (Ident.empty, Ident.empty) + let empty = Ident.empty let current_slot = ref (ref true) - let add id x (tbl, slots) = - let slot = !current_slot in - let slots = if !slot then slots else Ident.add id slot slots in - Ident.add id x tbl, slots + let add id x tbl = + Ident.add id (x, !current_slot) tbl - let find_same_not_using id (tbl, _) = - Ident.find_same id tbl + let find_same_not_using id tbl = + fst (Ident.find_same id tbl) - let find_same id (tbl, slots) = - (try Ident.find_same id slots := true with Not_found -> ()); - Ident.find_same id tbl + let find_same id tbl = + let (x, slot) = Ident.find_same id tbl in + slot := true; + x - let find_name s (tbl, slots) = - (try Ident.find_name s slots := true with Not_found -> ()); - Ident.find_name s tbl + let find_name s tbl = + let (x, slot) = Ident.find_name s tbl in + slot := true; + x let with_slot slot f x = let old_slot = !current_slot in @@ -86,33 +137,35 @@ module EnvTbl = (fun () -> f x) (fun () -> current_slot := old_slot) - let keys (tbl, _) = + let keys tbl = Ident.keys tbl - let map f (tbl,slots) = Ident.map f tbl,slots + let map f tbl = Ident.map f tbl end type t = { values: (Path.t * value_description) EnvTbl.t; annotations: (Path.t * Annot.ident) EnvTbl.t; - constrs: constructor_description EnvTbl.t; - labels: label_description EnvTbl.t; + constrs: (Path.t * constructor_description) EnvTbl.t; + labels: (Path.t * label_description) EnvTbl.t; constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t; types: (Path.t * type_declaration) EnvTbl.t; modules: (Path.t * module_type) EnvTbl.t; modtypes: (Path.t * modtype_declaration) EnvTbl.t; components: (Path.t * module_components) EnvTbl.t; classes: (Path.t * class_declaration) EnvTbl.t; - cltypes: (Path.t * cltype_declaration) EnvTbl.t; + cltypes: (Path.t * class_type_declaration) EnvTbl.t; (*> JOCAML *) continuations : (Path.t * continuation_description) EnvTbl.t; (*< JOCAML *) summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; + in_signature: bool; } -and module_components = module_components_repr Lazy.t +and module_components = + (t * Subst.t * Path.t * Types.module_type, module_components_repr) EnvLazy.t and module_components_repr = Structure_comps of structure_components @@ -123,14 +176,15 @@ and structure_components = { mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; - mutable comp_constrs_by_path: + mutable comp_constrs_by_path: (string, (constructor_description list * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; - mutable comp_modules: (string, (module_type Lazy.t * int)) Tbl.t; + mutable comp_modules: + (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t; mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t; mutable comp_components: (string, (module_components * int)) Tbl.t; mutable comp_classes: (string, (class_declaration * int)) Tbl.t; - mutable comp_cltypes: (string, (cltype_declaration * int)) Tbl.t + mutable comp_cltypes: (string, (class_type_declaration * int)) Tbl.t } and functor_components = { @@ -142,24 +196,31 @@ and functor_components = { fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *) } +let subst_modtype_maker (subst, mty) = Subst.modtype subst mty + let empty = { values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty; - labels = EnvTbl.empty; types = EnvTbl.empty; + labels = EnvTbl.empty; types = EnvTbl.empty; constrs_by_path = EnvTbl.empty; modules = EnvTbl.empty; modtypes = EnvTbl.empty; components = EnvTbl.empty; classes = EnvTbl.empty; cltypes = EnvTbl.empty; + summary = Env_empty; local_constraints = false; gadt_instances = []; + in_signature = false; (*> JOCAML *) continuations = EnvTbl.empty; (*<JOCAML *) - summary = Env_empty; local_constraints = false; gadt_instances = [] } + } + +let in_signature env = {env with in_signature = true} let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in List.filter (fun id -> is_local (EnvTbl.find_same_not_using id tbl2) && - try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true) + try ignore (EnvTbl.find_same_not_using id tbl1); false + with Not_found -> true) keys2 let is_ident = function @@ -168,13 +229,9 @@ let is_ident = function let is_local (p, _) = is_ident p -let is_local_exn = function - {cstr_tag = Cstr_exception (p, _)} -> is_ident p - | _ -> false - let diff env1 env2 = diff_keys is_local env1.values env2.values @ - diff_keys is_local_exn env1.constrs env2.constrs @ + diff_keys is_local env1.constrs env2.constrs @ diff_keys is_local env1.modules env2.modules @ diff_keys is_local env1.classes env2.classes @@ -183,6 +240,9 @@ let diff env1 env2 = let components_of_module' = ref ((fun env sub path mty -> assert false) : t -> Subst.t -> Path.t -> module_type -> module_components) +let components_of_module_maker' = + ref ((fun (env, sub, path, mty) -> assert false) : + t * Subst.t * Path.t * module_type -> module_components_repr) let components_of_functor_appl' = ref ((fun f p1 p2 -> assert false) : functor_components -> Path.t -> Path.t -> module_components) @@ -198,8 +258,6 @@ let current_unit = ref "" (* Persistent structure descriptions *) -type pers_flags = Rectypes - type pers_struct = { ps_name: string; ps_sig: signature; @@ -209,7 +267,7 @@ type pers_struct = ps_flags: pers_flags list } let persistent_structures = - (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t) + (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) (* Consistency between persistent structures *) @@ -226,28 +284,15 @@ let check_consistency filename crcs = (* Reading persistent structures from .cmi files *) let read_pers_struct modname filename = - let ic = open_in_bin filename in - try - let buffer = Misc.input_bytes ic (String.length cmi_magic_number) in - if buffer <> cmi_magic_number then begin - close_in ic; - let pre_len = String.length cmi_magic_number - 3 in - if String.sub buffer 0 pre_len = String.sub cmi_magic_number 0 pre_len then - begin - let msg = if buffer < cmi_magic_number then "an older" else "a newer" in - raise (Error (Wrong_version_interface (filename, msg))) - end else begin - raise(Error(Not_an_interface filename)) - end - end; - let (name, sign) = input_value ic in - let crcs = input_value ic in - let flags = input_value ic in - close_in ic; - let comps = + let cmi = read_cmi filename in + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let comps = !components_of_module' empty Subst.identity (Pident(Ident.create_persistent name)) - (Tmty_signature sign) in + (Mty_signature sign) in let ps = { ps_name = name; ps_sig = sign; ps_comps = comps; @@ -262,17 +307,26 @@ let read_pers_struct modname filename = if not !Clflags.recursive_types then raise(Error(Need_recursive_types(ps.ps_name, !current_unit)))) ps.ps_flags; - Hashtbl.add persistent_structures modname ps; + Hashtbl.add persistent_structures modname (Some ps); ps - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface(filename))) let find_pers_struct name = - try - Hashtbl.find persistent_structures name - with Not_found -> - read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi")) + if name = "*predef*" then raise Not_found; + let r = + try Some (Hashtbl.find persistent_structures name) + with Not_found -> None + in + match r with + | Some None -> raise Not_found + | Some (Some sg) -> sg + | None -> + let filename = + try find_in_path_uncap !load_path (name ^ ".cmi") + with Not_found -> + Hashtbl.add persistent_structures name None; + raise Not_found + in + read_pers_struct name filename let reset_cache () = current_unit := ""; @@ -281,6 +335,12 @@ let reset_cache () = Hashtbl.clear value_declarations; Hashtbl.clear type_declarations +let reset_missing_cmis () = + let l = Hashtbl.fold + (fun name r acc -> if r = None then name :: acc else acc) + persistent_structures [] in + List.iter (Hashtbl.remove persistent_structures) l + let set_unit_name name = current_unit := name @@ -298,7 +358,9 @@ let rec find_module_descr path env = else raise Not_found end | Pdot(p, s, pos) -> - begin match Lazy.force(find_module_descr p env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in descr @@ -306,7 +368,9 @@ let rec find_module_descr path env = raise Not_found end | Papply(p1, p2) -> - begin match Lazy.force(find_module_descr p1 env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p1 env) + with Functor_comps f -> !components_of_functor_appl' f p1 p2 | Structure_comps c -> @@ -319,7 +383,9 @@ let find proj1 proj2 path env = let (p, data) = EnvTbl.find_same id (proj1 env) in data | Pdot(p, s, pos) -> - begin match Lazy.force(find_module_descr p env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data | Functor_comps f -> @@ -330,6 +396,8 @@ let find proj1 proj2 path env = let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) +and find_annot = + find (fun env -> env.annotations) (fun sc -> sc.comp_annotations) and find_type = find (fun env -> env.types) (fun sc -> sc.comp_types) and find_constructors = @@ -371,8 +439,8 @@ let find_type_expansion_opt path env = let find_modtype_expansion path env = match find_modtype path env with - Tmodtype_abstract -> raise Not_found - | Tmodtype_manifest mty -> mty + Modtype_abstract -> raise Not_found + | Modtype_manifest mty -> mty let find_module path env = match path with @@ -383,13 +451,16 @@ let find_module path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - Tmty_signature(ps.ps_sig) + Mty_signature(ps.ps_sig) else raise Not_found end | Pdot(p, s, pos) -> - begin match Lazy.force (find_module_descr p env) with + begin match + EnvLazy.force !components_of_module_maker' (find_module_descr p env) + with Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in Lazy.force data + let (data, pos) = Tbl.find s c.comp_modules in + EnvLazy.force subst_modtype_maker data | Functor_comps f -> raise Not_found end @@ -410,7 +481,7 @@ let rec lookup_module_descr lid env = end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in - begin match Lazy.force descr with + begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in (Pdot(p, s, pos), descr) @@ -420,7 +491,7 @@ let rec lookup_module_descr lid env = | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in - begin match Lazy.force desc1 with + begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (Papply(p1, p2), !components_of_functor_appl' f p1 p2) @@ -436,14 +507,14 @@ and lookup_module lid env = with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig) + (Pident(Ident.create_persistent s), Mty_signature ps.ps_sig) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in - begin match Lazy.force descr with + begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in - (Pdot(p, s, pos), Lazy.force data) + (Pdot(p, s, pos), EnvLazy.force subst_modtype_maker data) | Functor_comps f -> raise Not_found end @@ -451,7 +522,7 @@ and lookup_module lid env = let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in let p = Papply(p1, p2) in - begin match Lazy.force desc1 with + begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) @@ -466,7 +537,7 @@ let lookup proj1 proj2 lid env = EnvTbl.find_name s (proj1 env) | Ldot(l, s) -> let (p, desc) = lookup_module_descr l env in - begin match Lazy.force desc with + begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in (Pdot(p, s, pos), data) @@ -482,7 +553,7 @@ let lookup_simple proj1 proj2 lid env = EnvTbl.find_name s (proj1 env) | Ldot(l, s) -> let (p, desc) = lookup_module_descr l env in - begin match Lazy.force desc with + begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data @@ -499,9 +570,9 @@ let lookup_value = let lookup_annot id e = lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = - lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = - lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) + lookup (fun env -> env.labels) (fun sc -> sc.comp_labels) and lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) and lookup_modtype = @@ -524,12 +595,12 @@ let mark_type_used name vd = try Hashtbl.find type_declarations (name, vd.type_loc) () with Not_found -> () -let mark_constructor_used name vd constr = - try Hashtbl.find used_constructors (name, vd.type_loc, constr) () +let mark_constructor_used usage name vd constr = + try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage with Not_found -> () -let mark_exception_used ed constr = - try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) () +let mark_exception_used usage ed constr = + try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage with Not_found -> () let set_value_used_callback name vd callback = @@ -545,7 +616,9 @@ let set_value_used_callback name vd callback = Hashtbl.add value_declarations key callback let set_type_used_callback name td callback = - let old = try Hashtbl.find type_declarations (name, td.type_loc) with Not_found -> assert false in + let old = + try Hashtbl.find type_declarations (name, td.type_loc) + with Not_found -> assert false in Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old) let lookup_value lid env = @@ -558,6 +631,13 @@ let lookup_type lid env = mark_type_used (Longident.last lid) desc; r +(* [path] must be the path to a type, not to a module ! *) +let rec path_subst_last path id = + match path with + Pident _ -> Pident id + | Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos) + | Papply (p1, p2) -> assert false + let mark_type_path env path = let decl = try find_type path env with Not_found -> assert false in mark_type_used (Path.last path) decl @@ -567,27 +647,27 @@ let ty_path = function | _ -> assert false let lookup_constructor lid env = - let desc = lookup_constructor lid env in + let (_,desc) as c = lookup_constructor lid env in mark_type_path env (ty_path desc.cstr_res); - desc + c -let mark_constructor env name desc = +let mark_constructor usage env name desc = match desc.cstr_tag with | Cstr_exception (_, loc) -> begin - try Hashtbl.find used_constructors ("exn", loc, name) () + try Hashtbl.find used_constructors ("exn", loc, name) usage with Not_found -> () end | _ -> let ty_path = ty_path desc.cstr_res in let ty_decl = try find_type ty_path env with Not_found -> assert false in let ty_name = Path.last ty_path in - mark_constructor_used ty_name ty_decl name + mark_constructor_used usage ty_name ty_decl name let lookup_label lid env = - let desc = lookup_label lid env in + let (_,desc) as c = lookup_label lid env in mark_type_path env (ty_path desc.lbl_res); - desc + c let lookup_class lid env = let (_, desc) as r = lookup_class lid env in @@ -652,7 +732,7 @@ let add_gadt_instance_chain env lv t = let rec scrape_modtype mty env = match mty with - Tmty_ident path -> + Mty_ident path -> begin try scrape_modtype (find_modtype_expansion path env) env with Not_found -> @@ -663,7 +743,7 @@ let rec scrape_modtype mty env = (* Compute constructor descriptions *) let constructors_of_type ty_path decl = - let handle_variants cstrs = + let handle_variants cstrs = Datarepr.constructor_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private @@ -687,36 +767,36 @@ let labels_of_type ty_path decl = let rec prefix_idents root pos sub = function [] -> ([], sub) - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) - | Tsig_type(id, decl, _) :: rem -> + | Sig_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Tsig_exception(id, decl) :: rem -> + | Sig_exception(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) sub rem in (p::pl, final_sub) - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) (Subst.add_module id p sub) rem in (p::pl, final_sub) - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos - (Subst.add_modtype id (Tmty_ident p) sub) rem in + (Subst.add_modtype id (Mty_ident p) sub) rem in (p::pl, final_sub) - | Tsig_class(id, decl, _) :: rem -> + | Sig_class(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in (p::pl, final_sub) - | Tsig_cltype(id, decl, _) :: rem -> + | Sig_class_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos sub rem in (p::pl, final_sub) @@ -724,11 +804,14 @@ let rec prefix_idents root pos sub = function (* Compute structure descriptions *) let rec components_of_module env sub path mty = - lazy(match scrape_modtype mty env with - Tmty_signature sg -> + EnvLazy.create (env, sub, path, mty) + +and components_of_module_maker (env, sub, path, mty) = + (match scrape_modtype mty env with + Mty_signature sg -> let c = { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_constrs = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; @@ -739,7 +822,7 @@ let rec components_of_module env sub path mty = let pos = ref 0 in List.iter2 (fun item path -> match item with - Tsig_value(id, decl) -> + Sig_value(id, decl) -> let decl' = Subst.value_description sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; @@ -751,32 +834,34 @@ let rec components_of_module env sub path mty = begin match decl.val_kind with Val_prim _ -> () | _ -> incr pos end - | Tsig_type(id, decl, _) -> + | Sig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in c.comp_types <- Tbl.add (Ident.name id) (decl', nopos) c.comp_types; let constructors = constructors_of_type path decl' in c.comp_constrs_by_path <- - Tbl.add (Ident.name id) + Tbl.add (Ident.name id) (List.map snd constructors, nopos) c.comp_constrs_by_path; List.iter (fun (name, descr) -> - c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs) + c.comp_constrs <- + Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs) constructors; let labels = labels_of_type path decl' in List.iter (fun (name, descr) -> - c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels) + c.comp_labels <- + Tbl.add (Ident.name name) (descr, nopos) c.comp_labels) (labels); env := store_type_infos id path decl !env - | Tsig_exception(id, decl) -> + | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in let cstr = Datarepr.exception_descr path decl' in c.comp_constrs <- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs; incr pos - | Tsig_module(id, mty, _) -> - let mty' = lazy (Subst.modtype sub mty) in + | Sig_module(id, mty, _) -> + let mty' = EnvLazy.create (sub, mty) in c.comp_modules <- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules; let comps = components_of_module !env sub path mty in @@ -784,23 +869,23 @@ let rec components_of_module env sub path mty = Tbl.add (Ident.name id) (comps, !pos) c.comp_components; env := store_module id path mty !env; incr pos - | Tsig_modtype(id, decl) -> + | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; env := store_modtype id path decl !env - | Tsig_class(id, decl, _) -> + | Sig_class(id, decl, _) -> let decl' = Subst.class_declaration sub decl in c.comp_classes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_classes; incr pos - | Tsig_cltype(id, decl, _) -> + | Sig_class_type(id, decl, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) sg pl; Structure_comps c - | Tmty_functor(param, ty_arg, ty_res) -> + | Mty_functor(param, ty_arg, ty_res) -> Functor_comps { fcomp_param = param; (* fcomp_arg must be prefixed eagerly, because it is interpreted @@ -811,11 +896,11 @@ let rec components_of_module env sub path mty = fcomp_env = env; fcomp_subst = sub; fcomp_cache = Hashtbl.create 17 } - | Tmty_ident p -> + | Mty_ident p -> Structure_comps { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -837,7 +922,7 @@ and check_usage loc id warn tbl = end; and store_value ?check id path decl env = - begin match check with Some f -> check_usage decl.val_loc id f value_declarations | None -> () end; + may (fun f -> check_usage decl.val_loc id f value_declarations) check; { env with values = EnvTbl.add id (path, decl) env.values; summary = Env_value(env.summary, id, decl) } @@ -850,41 +935,47 @@ and store_annot id path annot env = and store_type id path info env = let loc = info.type_loc in - check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; + check_usage loc id (fun s -> Warnings.Unused_type_declaration s) + type_declarations; let constructors = constructors_of_type path info in let labels = labels_of_type path info in - if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor "") then begin + if not env.in_signature && not loc.Location.loc_ghost && + Warnings.is_active (Warnings.Unused_constructor ("", false, false)) + then begin let ty = Ident.name id in List.iter - (fun (c, _) -> + begin fun (c, _) -> + let c = Ident.name c in let k = (ty, loc, c) in if not (Hashtbl.mem used_constructors k) then - let used = ref false in - Hashtbl.add used_constructors k (fun () -> used := true); - !add_delayed_check_forward - (fun () -> - if not !used then - Location.prerr_warning loc (Warnings.Unused_constructor c) - ) - ) + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + if not (ty = "" || ty.[0] = '_') + then !add_delayed_check_forward + (fun () -> + if not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_constructor + (c, used.cu_pattern, used.cu_privatize))) + end constructors end; { env with constrs = List.fold_right (fun (name, descr) constrs -> - EnvTbl.add (Ident.create name) descr constrs) - constructors + EnvTbl.add name (path_subst_last path name, descr) constrs) + constructors env.constrs; - constrs_by_path = - EnvTbl.add id + constrs_by_path = + EnvTbl.add id (path,List.map snd constructors) env.constrs_by_path; labels = List.fold_right (fun (name, descr) labels -> - EnvTbl.add (Ident.create name) descr labels) + EnvTbl.add name (path_subst_last path name, descr) labels) labels env.labels; types = EnvTbl.add id (path, info) env.types; @@ -902,22 +993,28 @@ and store_type_infos id path info env = and store_exception id path decl env = let loc = decl.exn_loc in - if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception "") then begin + if not env.in_signature && not loc.Location.loc_ghost && + Warnings.is_active (Warnings.Unused_exception ("", false)) + then begin let ty = "exn" in let c = Ident.name id in let k = (ty, loc, c) in if not (Hashtbl.mem used_constructors k) then begin - let used = ref false in - Hashtbl.add used_constructors k (fun () -> used := true); + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> - if not !used then - Location.prerr_warning loc (Warnings.Unused_exception c) + if not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_exception + (c, used.cu_pattern) + ) ) end; end; { env with - constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs; + constrs = EnvTbl.add id (path_subst_last path id, + Datarepr.exception_descr path decl) env.constrs; summary = Env_exception(env.summary, id, decl) } and store_module id path mty env = @@ -968,7 +1065,8 @@ let components_of_functor_appl f p1 p2 = let _ = components_of_module' := components_of_module; - components_of_functor_appl' := components_of_functor_appl + components_of_functor_appl' := components_of_functor_appl; + components_of_module_maker' := components_of_module_maker (* Insertion of bindings by identifier *) @@ -1004,8 +1102,8 @@ and add_continuation id desc env = and remove_continuations t = {t with continuations = EnvTbl.empty} -let do_purge (path,d as c) = match d.val_kind with - | Val_channel _|Val_alone _ -> path,{ d with val_kind = Val_reg; } +let do_purge ((path,d),sl as c) = match d.val_kind with + | Val_channel _|Val_alone _ -> (path,{ d with val_kind = Val_reg; }),sl | _ -> c let remove_channel_info t = @@ -1038,13 +1136,13 @@ and enter_cltype = enter store_cltype let add_item comp env = match comp with - Tsig_value(id, decl) -> add_value id decl env - | Tsig_type(id, decl, _) -> add_type id decl env - | Tsig_exception(id, decl) -> add_exception id decl env - | Tsig_module(id, mty, _) -> add_module id mty env - | Tsig_modtype(id, decl) -> add_modtype id decl env - | Tsig_class(id, decl, _) -> add_class id decl env - | Tsig_cltype(id, decl, _) -> add_cltype id decl env + Sig_value(id, decl) -> add_value id decl env + | Sig_type(id, decl, _) -> add_type id decl env + | Sig_exception(id, decl) -> add_exception id decl env + | Sig_module(id, mty, _) -> add_module id mty env + | Sig_modtype(id, decl) -> add_modtype id decl env + | Sig_class(id, decl, _) -> add_class id decl env + | Sig_class_type(id, decl, _) -> add_cltype id decl env let rec add_signature sg env = match sg with @@ -1061,25 +1159,25 @@ let open_signature root sg env = List.fold_left2 (fun env item p -> match item with - Tsig_value(id, decl) -> + Sig_value(id, decl) -> let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env in store_annot (Ident.hide id) p (Annot.Iref_external) e1 - | Tsig_type(id, decl, _) -> + | Sig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env - | Tsig_exception(id, decl) -> + | Sig_exception(id, decl) -> store_exception (Ident.hide id) p (Subst.exception_declaration sub decl) env - | Tsig_module(id, mty, _) -> + | Sig_module(id, mty, _) -> store_module (Ident.hide id) p (Subst.modtype sub mty) env - | Tsig_modtype(id, decl) -> + | Sig_modtype(id, decl) -> store_modtype (Ident.hide id) p (Subst.modtype_declaration sub decl) env - | Tsig_class(id, decl, _) -> + | Sig_class(id, decl, _) -> store_class (Ident.hide id) p (Subst.class_declaration sub decl) env - | Tsig_cltype(id, decl, _) -> + | Sig_class_type(id, decl, _) -> store_cltype (Ident.hide id) p (Subst.cltype_declaration sub decl) env) env sg pl in @@ -1091,8 +1189,9 @@ let open_pers_signature name env = let ps = find_pers_struct name in open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env -let open_signature ?(loc = Location.none) root sg env = - if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") then begin +let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env = + if not toplevel && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") + then begin let used = ref false in !add_delayed_check_forward (fun () -> @@ -1100,8 +1199,8 @@ let open_signature ?(loc = Location.none) root sg env = Location.prerr_warning loc (Warnings.Unused_open (Path.name root)) ); EnvTbl.with_slot used (open_signature root sg) env - end else - open_signature root sg env + end + else open_signature root sg env (* Read a signature from a file *) @@ -1130,29 +1229,29 @@ let save_signature_with_imports sg modname filename imports = let sg = Subst.signature (Subst.for_saving Subst.identity) sg in let oc = open_out_bin filename in try - output_string oc cmi_magic_number; - output_value oc (modname, sg); - flush oc; - let crc = Digest.file filename in - let crcs = (modname, crc) :: imports in - output_value oc crcs; - let flags = if !Clflags.recursive_types then [Rectypes] else [] in - output_value oc flags; + let cmi = { + cmi_name = modname; + cmi_sign = sg; + cmi_crcs = imports; + cmi_flags = if !Clflags.recursive_types then [Rectypes] else []; + } in + let crc = output_cmi filename oc cmi in close_out oc; (* Enter signature in persistent table so that imported_unit() will also return its crc *) let comps = components_of_module empty Subst.identity - (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in + (Pident(Ident.create_persistent modname)) (Mty_signature sg) in let ps = { ps_name = modname; ps_sig = sg; ps_comps = comps; - ps_crcs = crcs; + ps_crcs = (cmi.cmi_name, crc) :: imports; ps_filename = filename; - ps_flags = flags } in - Hashtbl.add persistent_structures modname ps; - Consistbl.set crc_units modname crc filename + ps_flags = cmi.cmi_flags } in + Hashtbl.add persistent_structures modname (Some ps); + Consistbl.set crc_units modname crc filename; + sg with exn -> close_out oc; remove_file filename; @@ -1161,6 +1260,78 @@ let save_signature_with_imports sg modname filename imports = let save_signature sg modname filename = save_signature_with_imports sg modname filename (imported_units()) +(* Folding on environments *) +let ident_tbl_fold f t acc = + List.fold_right + (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc) + (EnvTbl.keys t) + acc + +let find_all proj1 proj2 f lid env acc = + match lid with + | None -> + ident_tbl_fold + (fun id (p, data) acc -> f (Ident.name id) p data acc) + (proj1 env) acc + | Some l -> + let p, desc = lookup_module_descr l env in + begin match EnvLazy.force components_of_module_maker desc with + Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) + (proj2 c) acc + | Functor_comps _ -> + raise Not_found + end + +let fold_modules f lid env acc = + match lid with + | None -> + let acc = + ident_tbl_fold + (fun id (p, data) acc -> f (Ident.name id) p data acc) + env.modules + acc + in + Hashtbl.fold + (fun name ps acc -> + match ps with + None -> acc + | Some ps -> + f name (Pident(Ident.create_persistent name)) + (Mty_signature ps.ps_sig) acc) + persistent_structures + acc + | Some l -> + let p, desc = lookup_module_descr l env in + begin match EnvLazy.force components_of_module_maker desc with + Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> + f s (Pdot (p, s, pos)) + (EnvLazy.force subst_modtype_maker data) acc) + c.comp_modules + acc + | Functor_comps _ -> + raise Not_found + end + +let fold_values f = + find_all (fun env -> env.values) (fun sc -> sc.comp_values) f +and fold_constructors f = + find_all (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f +and fold_labels f = + find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f +and fold_types f = + find_all (fun env -> env.types) (fun sc -> sc.comp_types) f +and fold_modtypes f = + find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f +and fold_classs f = + find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f +and fold_cltypes f = + find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f + + (* Make the initial environment *) let initial = Predef.build_initial_env add_type add_exception empty @@ -1168,19 +1339,25 @@ let initial = Predef.build_initial_env add_type add_exception empty (* Return the environment summary *) let summary env = env.summary +let keep_only_summary env = + { empty with + summary = env.summary; + local_constraints = env.local_constraints; + in_signature = env.in_signature; +} + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + { new_env with + local_constraints = env.local_constraints; + in_signature = env.in_signature; + } (* Error report *) open Format let report_error ppf = function - | Not_an_interface filename -> fprintf ppf - "%a@ is not a compiled interface" Location.print_filename filename - | Wrong_version_interface (filename, older_newer) -> fprintf ppf - "%a@ is not a compiled interface for this version of OCaml.@.\ - It seems to be for %s version of OCaml." Location.print_filename filename older_newer - | Corrupted_interface filename -> fprintf ppf - "Corrupted compiled interface@ %a" Location.print_filename filename | Illegal_renaming(modname, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for@ %s" Location.print_filename filename modname diff --git a/typing/env.mli b/typing/env.mli index 14f1177482..9f551fd367 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -16,6 +16,17 @@ open Types +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_exception of summary * Ident.t * exception_declaration + | Env_module of summary * Ident.t * module_type + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + type t val empty: t @@ -25,12 +36,13 @@ val diff: t -> t -> Ident.t list (* Lookup by paths *) val find_value: Path.t -> t -> value_description +val find_annot: Path.t -> t -> Annot.ident val find_type: Path.t -> t -> type_declaration val find_constructors: Path.t -> t -> constructor_description list val find_module: Path.t -> t -> module_type val find_modtype: Path.t -> t -> modtype_declaration val find_class: Path.t -> t -> class_declaration -val find_cltype: Path.t -> t -> cltype_declaration +val find_cltype: Path.t -> t -> class_type_declaration val find_type_expansion: ?level:int -> Path.t -> t -> type_expr list * type_expr * int option @@ -50,27 +62,28 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit val lookup_value: Longident.t -> t -> Path.t * value_description val lookup_annot: Longident.t -> t -> Path.t * Annot.ident -val lookup_constructor: Longident.t -> t -> constructor_description -val lookup_label: Longident.t -> t -> label_description +val lookup_constructor: Longident.t -> t -> Path.t * constructor_description +val lookup_label: Longident.t -> t -> Path.t * label_description val lookup_type: Longident.t -> t -> Path.t * type_declaration val lookup_module: Longident.t -> t -> Path.t * module_type val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration -val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration +val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration (*> JOCAML *) val lookup_continuation: Longident.t -> t -> Path.t * continuation_description (*< JOCAML *) (* Insertion by identifier *) -val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t +val add_value: + ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t val add_annot: Ident.t -> Annot.ident -> t -> t val add_type: Ident.t -> type_declaration -> t -> t val add_exception: Ident.t -> exception_declaration -> t -> t val add_module: Ident.t -> module_type -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t -val add_cltype: Ident.t -> cltype_declaration -> t -> t +val add_cltype: Ident.t -> class_type_declaration -> t -> t val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t (* Insertion of all fields of a signature. *) @@ -88,21 +101,24 @@ val remove_channel_info: t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) -val open_signature: ?loc:Location.t -> Path.t -> signature -> t -> t +val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t val open_pers_signature: string -> t -> t (* Insertion by name *) -val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t +val enter_value: + ?check:(string -> Warnings.t) -> + string -> value_description -> t -> Ident.t * t val enter_type: string -> type_declaration -> t -> Ident.t * t val enter_exception: string -> exception_declaration -> t -> Ident.t * t val enter_module: string -> module_type -> t -> Ident.t * t val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t val enter_class: string -> class_declaration -> t -> Ident.t * t -val enter_cltype: string -> cltype_declaration -> t -> Ident.t * t +val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t (* Initialize the cache of in-core module interfaces. *) val reset_cache: unit -> unit +val reset_missing_cmis: unit -> unit (* Remember the name of the current compilation unit. *) val set_unit_name: string -> unit @@ -111,10 +127,10 @@ val set_unit_name: string -> unit val read_signature: string -> string -> signature (* Arguments: module name, file name. Results: signature. *) -val save_signature: signature -> string -> string -> unit +val save_signature: signature -> string -> string -> signature (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - signature -> string -> string -> (string * Digest.t) list -> unit + signature -> string -> string -> (string * Digest.t) list -> signature (* Arguments: signature, module name, file name, imported units with their CRCs. *) @@ -133,25 +149,19 @@ val crc_units: Consistbl.t (* Summaries -- compact representation of an environment, to be exported in debugging information. *) -type summary = - Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_exception of summary * Ident.t * exception_declaration - | Env_module of summary * Ident.t * module_type - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_class of summary * Ident.t * class_declaration - | Env_cltype of summary * Ident.t * cltype_declaration - | Env_open of summary * Path.t - val summary: t -> summary +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + + (* Error report *) type error = - Not_an_interface of string - | Wrong_version_interface of string * string - | Corrupted_interface of string | Illegal_renaming of string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string @@ -162,17 +172,60 @@ open Format val report_error: formatter -> error -> unit + val mark_value_used: string -> value_description -> unit val mark_type_used: string -> type_declaration -> unit -val mark_constructor_used: string -> type_declaration -> string -> unit -val mark_constructor: t -> string -> constructor_description -> unit -val mark_exception_used: exception_declaration -> string -> unit -val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit -val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit +type constructor_usage = Positive | Pattern | Privatize +val mark_constructor_used: + constructor_usage -> string -> type_declaration -> string -> unit +val mark_constructor: + constructor_usage -> t -> string -> constructor_description -> unit +val mark_exception_used: + constructor_usage -> exception_declaration -> string -> unit + +val in_signature: t -> t + +val set_value_used_callback: + string -> value_description -> (unit -> unit) -> unit +val set_type_used_callback: + string -> type_declaration -> ((unit -> unit) -> unit) -> unit (* Forward declaration to break mutual recursion with Includemod. *) val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref (* Forward declaration to break mutual recursion with Typecore. *) val add_delayed_check_forward: ((unit -> unit) -> unit) ref + +(** Folding over all identifiers (for analysis purpose) *) + +val fold_values: + (string -> Path.t -> Types.value_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_types: + (string -> Path.t -> Types.type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_constructors: + (string -> Path.t -> Types.constructor_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_labels: + (string -> Path.t -> Types.label_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +(** Persistent structures are only traversed if they are already loaded. *) +val fold_modules: + (string -> Path.t -> Types.module_type -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +val fold_modtypes: + (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_classs: + (string -> Path.t -> Types.class_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_cltypes: + (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + + + diff --git a/typing/ident.mli b/typing/ident.mli index 6b0fc10888..715c70a0d8 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -14,7 +14,7 @@ (* Identifiers (unique names) *) -type t +type t = { stamp: int; name: string; mutable flags: int } val create: string -> t val create_persistent: string -> t diff --git a/typing/includeclass.mli b/typing/includeclass.mli index f5bc98a032..27784e9600 100644 --- a/typing/includeclass.mli +++ b/typing/includeclass.mli @@ -15,14 +15,13 @@ (* Inclusion checks for the class language *) open Types -open Typedtree open Ctype open Format val class_types: Env.t -> class_type -> class_type -> class_match_failure list val class_type_declarations: - Env.t -> cltype_declaration -> cltype_declaration -> + Env.t -> class_type_declaration -> class_type_declaration -> class_match_failure list val class_declarations: Env.t -> class_declaration -> class_declaration -> diff --git a/typing/includecore.ml b/typing/includecore.ml index 23c715f4df..e24c89ae79 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -118,11 +118,11 @@ type type_mismatch = | Constraint | Manifest | Variance - | Field_type of string - | Field_mutable of string - | Field_arity of string - | Field_names of int * string * string - | Field_missing of bool * string + | Field_type of Ident.t + | Field_mutable of Ident.t + | Field_arity of Ident.t + | Field_names of int * Ident.t * Ident.t + | Field_missing of bool * Ident.t | Record_representation of bool let nth n = @@ -141,17 +141,17 @@ let report_type_mismatch0 first second decl ppf err = | Manifest -> () | Variance -> pr "Their variances do not agree" | Field_type s -> - pr "The types for field %s are not equal" s + pr "The types for field %s are not equal" (Ident.name s) | Field_mutable s -> - pr "The mutability of field %s is different" s + pr "The mutability of field %s is different" (Ident.name s) | Field_arity s -> - pr "The arities for field %s differ" s + pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> pr "Their %s fields have different names, %s and %s" - (nth n) name1 name2 + (nth n) (Ident.name name1) (Ident.name name2) | Field_missing (b, s) -> pr "The field %s is only present in %s %s" - s (if b then second else first) decl + (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 @@ -169,48 +169,58 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)] | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)] | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 -> - if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else - if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else - match ret1, ret2 with - | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> + if Ident.name cstr1 <> Ident.name cstr2 then + [Field_names (n, cstr1, cstr2)] + else if List.length arg1 <> List.length arg2 then + [Field_arity cstr1] + else match ret1, ret2 with + | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] - | _ -> + | _ -> if Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env true (ty1::decl1.type_params) (ty2::decl2.type_params)) - (arg1) (arg2) - then + (arg1) (arg2) + then compare_variants env decl1 decl2 (n+1) rem1 rem2 else [Field_type cstr1] - - + + let rec compare_records env decl1 decl2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], (lab2,_,_)::_ -> [Field_missing (true, lab2)] | (lab1,_,_)::_, [] -> [Field_missing (false, lab1)] | (lab1, mut1, arg1)::rem1, (lab2, mut2, arg2)::rem2 -> - if lab1 <> lab2 then [Field_names (n, lab1, lab2)] else - if mut1 <> mut2 then [Field_mutable lab1] else + if Ident.name lab1 <> Ident.name lab2 + then [Field_names (n, lab1, lab2)] + else if mut1 <> mut2 then [Field_mutable lab1] else if Ctype.equal env true (arg1::decl1.type_params) (arg2::decl2.type_params) then compare_records env decl1 decl2 (n+1) rem1 rem2 else [Field_type lab1] -let type_declarations env id decl1 decl2 = +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 let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> - let name = Ident.name id in - if decl1.type_private = Private || decl2.type_private = Public then + let mark cstrs usage name decl = List.iter - (fun (c, _, _) -> Env.mark_constructor_used name decl1 c) - cstrs1; + (fun (c, _, _) -> + Env.mark_constructor_used usage name decl (Ident.name c)) + cstrs + in + let usage = + if decl1.type_private = Private || decl2.type_private = Public + then Env.Positive else Env.Privatize + in + mark cstrs1 usage name decl1; + if equality then mark cstrs2 Env.Positive (Ident.name 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 @@ -253,7 +263,8 @@ let type_declarations env id decl1 decl2 = (* Inclusion between exception declarations *) let exception_declarations env ed1 ed2 = - Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1.exn_args ed2.exn_args + Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) + ed1.exn_args ed2.exn_args (* Inclusion between class types *) let encode_val (mut, ty) rem = diff --git a/typing/includecore.mli b/typing/includecore.mli index 66bd04c310..8ddfcb1631 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -14,8 +14,8 @@ (* Inclusion checks for the core language *) -open Types open Typedtree +open Types exception Dont_match @@ -26,18 +26,19 @@ type type_mismatch = | Constraint | Manifest | Variance - | Field_type of string - | Field_mutable of string - | Field_arity of string - | Field_names of int * string * string - | Field_missing of bool * string + | Field_type of Ident.t + | Field_mutable of Ident.t + | Field_arity of Ident.t + | Field_names of int * Ident.t * Ident.t + | Field_missing of bool * Ident.t | Record_representation of bool val value_descriptions: Env.t -> value_description -> value_description -> module_coercion val type_declarations: - Env.t -> Ident.t -> - type_declaration -> type_declaration -> type_mismatch list + ?equality:bool -> + Env.t -> string -> + type_declaration -> Ident.t -> type_declaration -> type_mismatch list val exception_declarations: Env.t -> exception_declaration -> exception_declaration -> bool (* diff --git a/typing/includemod.ml b/typing/includemod.ml index 4cc2904087..367938a920 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -16,8 +16,8 @@ open Misc open Path -open Types open Typedtree +open Types type symptom = Missing_field of Ident.t @@ -31,7 +31,7 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * cltype_declaration * cltype_declaration * + Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * @@ -63,13 +63,13 @@ let value_descriptions env cxt subst id vd1 vd2 = let type_declarations env cxt subst id decl1 decl2 = Env.mark_type_used (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in - let err = Includecore.type_declarations env id decl1 decl2 in + let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between exception declarations *) let exception_declarations env cxt subst id decl1 decl2 = - Env.mark_exception_used decl1 (Ident.name id); + Env.mark_exception_used Env.Positive decl1 (Ident.name id); let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () @@ -112,13 +112,13 @@ type field_desc = | Field_classtype of string let item_ident_name = function - Tsig_value(id, _) -> (id, Field_value(Ident.name id)) - | Tsig_type(id, _, _) -> (id, Field_type(Ident.name id)) - | Tsig_exception(id, _) -> (id, Field_exception(Ident.name id)) - | Tsig_module(id, _, _) -> (id, Field_module(Ident.name id)) - | Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id)) - | Tsig_class(id, _, _) -> (id, Field_class(Ident.name id)) - | Tsig_cltype(id, _, _) -> (id, Field_classtype(Ident.name id)) + Sig_value(id, _) -> (id, Field_value(Ident.name id)) + | Sig_type(id, _, _) -> (id, Field_type(Ident.name id)) + | Sig_exception(id, _) -> (id, Field_exception(Ident.name id)) + | Sig_module(id, _, _) -> (id, Field_module(Ident.name id)) + | Sig_modtype(id, _) -> (id, Field_modtype(Ident.name id)) + | Sig_class(id, _, _) -> (id, Field_class(Ident.name id)) + | Sig_class_type(id, _, _) -> (id, Field_classtype(Ident.name id)) (* Simplify a structure coercion *) @@ -148,13 +148,13 @@ let rec modtypes env cxt subst mty1 mty2 = and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with - (_, Tmty_ident p2) -> + (_, Mty_ident p2) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) - | (Tmty_ident p1, _) -> + | (Mty_ident p1, _) -> try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 - | (Tmty_signature sig1, Tmty_signature sig2) -> + | (Mty_signature sig1, Mty_signature sig2) -> signatures env cxt subst sig1 sig2 - | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) -> + | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) -> let arg2' = Subst.modtype subst arg2 in let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in let cc_res = @@ -170,9 +170,9 @@ and try_modtypes env cxt subst mty1 mty2 = and try_modtypes2 env cxt mty1 mty2 = (* mty2 is an identifier *) match (mty1, mty2) with - (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 -> + (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 -> Tcoerce_none - | (_, Tmty_ident p2) -> + | (_, Mty_ident p2) -> try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2) | (_, _) -> assert false @@ -182,7 +182,7 @@ and try_modtypes2 env cxt mty1 mty2 = and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = - Env.add_signature sig1 env in + Env.add_signature sig1 (Env.in_signature env) in (* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function @@ -191,14 +191,14 @@ and signatures env cxt subst sig1 sig2 = let (id, name) = item_ident_name item in let nextpos = match item with - Tsig_value(_,{val_kind = Val_prim _}) - | Tsig_type(_,_,_) - | Tsig_modtype(_,_) - | Tsig_cltype(_,_,_) -> pos - | Tsig_value(_,_) - | Tsig_exception(_,_) - | Tsig_module(_,_,_) - | Tsig_class(_, _,_) -> pos+1 in + Sig_value(_,{val_kind = Val_prim _}) + | Sig_type(_,_,_) + | Sig_modtype(_,_) + | Sig_class_type(_,_,_) -> pos + | Sig_value(_,_) + | Sig_exception(_,_) + | Sig_module(_,_,_) + | Sig_class(_, _,_) -> pos+1 in build_component_table nextpos (Tbl.add name (id, item, pos) tbl) rem in let comps1 = @@ -218,7 +218,7 @@ and signatures env cxt subst sig1 sig2 = let (id2, name2) = item_ident_name item2 in let name2, report = match item2, name2 with - Tsig_type (_, {type_manifest=None}, _), Field_type s + Sig_type (_, {type_manifest=None}, _), Field_type s when let l = String.length s in l >= 4 && String.sub s (l-4) 4 = "#row" -> (* Do not report in case of failure, @@ -230,13 +230,13 @@ and signatures env cxt subst sig1 sig2 = let (id1, item1, pos1) = Tbl.find name2 comps1 in let new_subst = match item2 with - Tsig_type _ -> + Sig_type _ -> Subst.add_type id2 (Pident id1) subst - | Tsig_module _ -> + | Sig_module _ -> Subst.add_module id2 (Pident id1) subst - | Tsig_modtype _ -> - Subst.add_modtype id2 (Tmty_ident (Pident id1)) subst - | Tsig_value _ | Tsig_exception _ | Tsig_class _ | Tsig_cltype _ -> + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Pident id1)) subst + | Sig_value _ | Sig_exception _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst @@ -253,31 +253,32 @@ and signatures env cxt subst sig1 sig2 = and signature_components env cxt subst = function [] -> [] - | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem -> + | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem -> let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with Val_prim p -> signature_components env cxt subst rem | _ -> (pos, cc) :: signature_components env cxt subst rem end - | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem -> + | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> type_declarations env cxt subst id1 tydecl1 tydecl2; signature_components env cxt subst rem - | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) + | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos) :: rem -> exception_declarations env cxt subst id1 excdecl1 excdecl2; (pos, Tcoerce_none) :: signature_components env cxt subst rem - | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem -> + | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in (pos, cc) :: signature_components env cxt subst rem - | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem -> + | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; signature_components env cxt subst rem - | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem -> + | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem -> class_declarations env cxt subst id1 decl1 decl2; (pos, Tcoerce_none) :: signature_components env cxt subst rem - | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem -> + | (Sig_class_type(id1, info1, _), + Sig_class_type(id2, info2, _), pos) :: rem -> class_type_declarations env cxt subst id1 info1 info2; signature_components env cxt subst rem | _ -> @@ -290,12 +291,12 @@ and modtype_infos env cxt subst id info1 info2 = let cxt' = Modtype id :: cxt in try match (info1, info2) with - (Tmodtype_abstract, Tmodtype_abstract) -> () - | (Tmodtype_manifest mty1, Tmodtype_abstract) -> () - | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) -> + (Modtype_abstract, Modtype_abstract) -> () + | (Modtype_manifest mty1, Modtype_abstract) -> () + | (Modtype_manifest mty1, Modtype_manifest mty2) -> check_modtype_equiv env cxt' mty1 mty2 - | (Tmodtype_abstract, Tmodtype_manifest mty2) -> - check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2 + | (Modtype_abstract, Modtype_manifest mty2) -> + check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2 with Error reasons -> raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) diff --git a/typing/includemod.mli b/typing/includemod.mli index c1c9c1f0c0..c060a580a8 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -14,8 +14,8 @@ (* Inclusion checks for the module language *) -open Types open Typedtree +open Types open Format val modtypes: Env.t -> module_type -> module_type -> module_coercion @@ -36,7 +36,7 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * cltype_declaration * cltype_declaration * + Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * diff --git a/typing/joinmatching.ml b/typing/joinmatching.ml index ccd0e13e08..411f04cfe3 100644 --- a/typing/joinmatching.ml +++ b/typing/joinmatching.ml @@ -23,12 +23,14 @@ open Typedtree -(* Nul process *) +(* Null process *) let null_ex = { exp_desc = Texp_null; exp_loc = Location.none; exp_type = Ctype.none; - exp_env = Env.empty ; } + exp_env = Env.empty ; + exp_extra = []; (* who knows? *) + } (* omega pattern *) let null_pat = Parmatch.omega @@ -124,8 +126,9 @@ let rewrite_simple_one id reac = | None -> reac | Some (rem, found) -> let (jid, pat) = found.jpat_desc in - let xi = Ident.create ("_"^Ident.name jid.jident_desc) in - let xi_pat = {pat with pat_desc = Tpat_var xi} in + let xname = "_"^Ident.name jid.jident_desc in + let xi = Ident.create xname in + let xi_pat = {pat with pat_desc = Tpat_var (xi,mknoloc xname)} in old, (rem, [{found with jpat_desc = (jid, xi_pat)}]::already_done), (xi, pat)::gd @@ -142,8 +145,9 @@ let rewrite_one id dag node2id reac = | None -> reac | Some (rem, found) -> let (jid, pat) = found.jpat_desc in - let xi = Ident.create ("_"^Ident.name jid.jident_desc) in - let xi_pat = {pat with pat_desc = Tpat_var xi} in + let xname = "_"^Ident.name jid.jident_desc in + let xi = Ident.create xname in + let xi_pat = {pat with pat_desc = Tpat_var (xi,mknoloc xname)} in let new_or_jpats = let nodes = Agraph.nodes dag in let has_info n = eq_pat (Agraph.info dag n) pat in diff --git a/typing/mtype.ml b/typing/mtype.ml index 5700b59e0e..cda8186db5 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -21,7 +21,7 @@ open Types let rec scrape env mty = match mty with - Tmty_ident p -> + Mty_ident p -> begin try scrape env (Env.find_modtype_expansion p env) with Not_found -> @@ -34,19 +34,19 @@ let freshen mty = 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) when !Clflags.applicative_functors -> - Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param))) + Mty_signature sg -> + Mty_signature(strengthen_sig env sg p) + | Mty_functor(param, arg, res) when !Clflags.applicative_functors -> + Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty and strengthen_sig env sg p = match sg with [] -> [] - | (Tsig_value(id, desc) as sigelt) :: rem -> + | (Sig_value(id, desc) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Tsig_type(id, decl, rs) :: rem -> + | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with Some _, Public, _ -> decl @@ -60,26 +60,26 @@ and strengthen_sig env sg p = else { decl with type_manifest = manif } in - Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p - | (Tsig_exception(id, d) as sigelt) :: rem -> + Sig_type(id, newdecl, rs) :: strengthen_sig env rem p + | (Sig_exception(id, d) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Tsig_module(id, mty, rs) :: rem -> - Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) + | Sig_module(id, mty, rs) :: rem -> + Sig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) :: strengthen_sig (Env.add_module id mty env) rem p (* Need to add the module in case it defines manifest module types *) - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> let newdecl = match decl with - Tmodtype_abstract -> - Tmodtype_manifest(Tmty_ident(Pdot(p, Ident.name id, nopos))) - | Tmodtype_manifest _ -> + Modtype_abstract -> + Modtype_manifest(Mty_ident(Pdot(p, Ident.name id, nopos))) + | Modtype_manifest _ -> decl in - Tsig_modtype(id, newdecl) :: + Sig_modtype(id, newdecl) :: strengthen_sig (Env.add_modtype id decl env) rem p (* Need to add the module type in case it is manifest *) - | (Tsig_class(id, decl, rs) as sigelt) :: rem -> + | (Sig_class(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | (Tsig_cltype(id, decl, rs) as sigelt) :: rem -> + | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p (* In nondep_supertype, env is only used for the type it assigns to id. @@ -92,16 +92,16 @@ let nondep_supertype env mid mty = let rec nondep_mty env va mty = match mty with - Tmty_ident p -> + Mty_ident p -> if Path.isfree mid p then nondep_mty env va (Env.find_modtype_expansion p env) else mty - | Tmty_signature sg -> - Tmty_signature(nondep_sig env va sg) - | Tmty_functor(param, arg, res) -> + | Mty_signature sg -> + Mty_signature(nondep_sig env va sg) + | Mty_functor(param, arg, res) -> let var_inv = match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Tmty_functor(param, nondep_mty env var_inv arg, + Mty_functor(param, nondep_mty env var_inv arg, nondep_mty (Env.add_module param arg env) va res) and nondep_sig env va = function @@ -109,38 +109,38 @@ let nondep_supertype env mid mty = | item :: rem -> let rem' = nondep_sig env va rem in match item with - Tsig_value(id, d) -> - Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type; + Sig_value(id, d) -> + Sig_value(id, {val_type = Ctype.nondep_type env mid d.val_type; val_kind = d.val_kind; val_loc = d.val_loc; - }) :: rem' - | Tsig_type(id, d, rs) -> - Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) + }) :: rem' + | Sig_type(id, d, rs) -> + Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' - | Tsig_exception(id, d) -> + | Sig_exception(id, d) -> let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args; exn_loc = d.exn_loc} in - Tsig_exception(id, d) :: rem' - | Tsig_module(id, mty, rs) -> - Tsig_module(id, nondep_mty env va mty, rs) :: rem' - | Tsig_modtype(id, d) -> + Sig_exception(id, d) :: rem' + | Sig_module(id, mty, rs) -> + Sig_module(id, nondep_mty env va mty, rs) :: rem' + | Sig_modtype(id, d) -> begin try - Tsig_modtype(id, nondep_modtype_decl env d) :: rem' + Sig_modtype(id, nondep_modtype_decl env d) :: rem' with Not_found -> match va with - Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem' + Co -> Sig_modtype(id, Modtype_abstract) :: rem' | _ -> raise Not_found end - | Tsig_class(id, d, rs) -> - Tsig_class(id, Ctype.nondep_class_declaration env mid d, rs) + | Sig_class(id, d, rs) -> + Sig_class(id, Ctype.nondep_class_declaration env mid d, rs) :: rem' - | Tsig_cltype(id, d, rs) -> - Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d, rs) + | Sig_class_type(id, d, rs) -> + Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) :: rem' and nondep_modtype_decl env = function - Tmodtype_abstract -> Tmodtype_abstract - | Tmodtype_manifest mty -> Tmodtype_manifest(nondep_mty env Strict mty) + Modtype_abstract -> Modtype_abstract + | Modtype_manifest mty -> Modtype_manifest(nondep_mty env Strict mty) in nondep_mty env Co mty @@ -160,62 +160,62 @@ let enrich_typedecl env p decl = let rec enrich_modtype env p mty = match mty with - Tmty_signature sg -> - Tmty_signature(List.map (enrich_item env p) sg) + Mty_signature sg -> + Mty_signature(List.map (enrich_item env p) sg) | _ -> mty and enrich_item env p = function - Tsig_type(id, decl, rs) -> - Tsig_type(id, + Sig_type(id, decl, rs) -> + Sig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Tsig_module(id, mty, rs) -> - Tsig_module(id, + | Sig_module(id, mty, rs) -> + Sig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs) | item -> item let rec type_paths env p mty = match scrape env mty with - Tmty_ident p -> [] - | Tmty_signature sg -> type_paths_sig env p 0 sg - | Tmty_functor(param, arg, res) -> [] + Mty_ident p -> [] + | Mty_signature sg -> type_paths_sig env p 0 sg + | Mty_functor(param, arg, res) -> [] and type_paths_sig env p pos sg = match sg with [] -> [] - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in type_paths_sig env p pos' rem - | Tsig_type(id, decl, _) :: rem -> + | Sig_type(id, decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) mty @ type_paths_sig (Env.add_module id mty env) p (pos+1) rem - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem - | (Tsig_exception _ | Tsig_class _) :: rem -> + | (Sig_exception _ | Sig_class _) :: rem -> type_paths_sig env p (pos+1) rem - | (Tsig_cltype _) :: rem -> + | (Sig_class_type _) :: rem -> type_paths_sig env p pos rem let rec no_code_needed env mty = match scrape env mty with - Tmty_ident p -> false - | Tmty_signature sg -> no_code_needed_sig env sg - | Tmty_functor(_, _, _) -> false + Mty_ident p -> false + | Mty_signature sg -> no_code_needed_sig env sg + | Mty_functor(_, _, _) -> false and no_code_needed_sig env sg = match sg with [] -> true - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> begin match decl.val_kind with | Val_prim _ -> no_code_needed_sig env rem | _ -> false end - | Tsig_module(id, mty, _) :: rem -> + | Sig_module(id, mty, _) :: rem -> no_code_needed env mty && no_code_needed_sig (Env.add_module id mty env) rem - | (Tsig_type _ | Tsig_modtype _ | Tsig_cltype _) :: rem -> + | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem - | (Tsig_exception _ | Tsig_class _) :: rem -> + | (Sig_exception _ | Sig_class _) :: rem -> false diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 0596a01378..e1578b9285 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -24,13 +24,15 @@ open Typedtree (*************************************) let make_pat desc ty tenv = - {pat_desc = desc; pat_loc = Location.none; + {pat_desc = desc; pat_loc = Location.none; pat_extra = []; pat_type = ty ; pat_env = tenv } let omega = make_pat Tpat_any Ctype.none Env.empty let extra_pat = - make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty + make_pat + (Tpat_var (Ident.create "+", mknoloc "+")) + Ctype.none Env.empty let rec omegas i = if i <= 0 then [] else omega :: omegas (i-1) @@ -55,9 +57,9 @@ let records_args l1 l2 = (* Invariant: fields are already sorted by Typecore.type_label_a_list *) let rec combine r1 r2 l1 l2 = match l1,l2 with | [],[] -> List.rev r1, List.rev r2 - | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 - | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] - | (lbl1,p1)::rem1, (lbl2,p2)::rem2 -> + | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 + | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] + | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then combine (p1::r1) (omega::r2) rem1 l2 else if lbl1.lbl_pos > lbl2.lbl_pos then @@ -69,8 +71,8 @@ let records_args l1 l2 = let rec compat p q = match p.pat_desc,q.pat_desc with - | Tpat_alias (p,_),_ -> compat p q - | _,Tpat_alias (q,_) -> compat p q + | Tpat_alias (p,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_) -> compat p q | (Tpat_any|Tpat_var _),_ -> true | _,(Tpat_any|Tpat_var _) -> true | Tpat_or (p1,p2,_),_ -> compat p1 q || compat p2 q @@ -78,7 +80,7 @@ let rec compat p q = | Tpat_constant c1, Tpat_constant c2 -> c1=c2 | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs | Tpat_lazy p, Tpat_lazy q -> compat p q - | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> + | Tpat_construct (_, _, c1,ps1, _), Tpat_construct (_, _, c2,ps2, _) -> c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> l1=l2 && compat p1 p2 @@ -86,7 +88,7 @@ let rec compat p q = l1 = l2 | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false - | Tpat_record l1,Tpat_record l2 -> + | Tpat_record (l1,_),Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in compats ps qs | Tpat_array ps, Tpat_array qs -> @@ -135,7 +137,7 @@ let find_label lbl lbls = try let name,_,_ = List.nth lbls lbl.lbl_pos in name - with Failure "nth" -> "*Unkown label*" + with Failure "nth" -> Ident.create "*Unknown label*" let rec get_record_labels ty tenv = match get_type_descr ty tenv with @@ -156,7 +158,7 @@ let get_constr_name tag ty tenv = match tag with | Cstr_exception (path, _) -> Path.name path | _ -> try - let name,_,_ = get_constr tag ty tenv in name + let name,_,_ = get_constr tag ty tenv in Ident.name name with | Datarepr.Constr_not_found -> "*Unknown constructor*" @@ -165,9 +167,21 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with | _ -> false -let rec pretty_val ppf v = match v.pat_desc with +let rec pretty_val ppf v = + match v.pat_extra with + (cstr,_) :: rem -> + begin match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } + | Tpat_constraint ctyp -> + fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } + end + | [] -> + match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var x -> Ident.print ppf x + | Tpat_var (x,_) -> Ident.print ppf x | Tpat_constant (Const_int i) -> fprintf ppf "%d" i | Tpat_constant (Const_char c) -> fprintf ppf "%C" c | Tpat_constant (Const_string s) -> fprintf ppf "%S" s @@ -177,13 +191,13 @@ let rec pretty_val ppf v = match v.pat_desc with | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct ({cstr_tag=tag},[]) -> + | Tpat_construct (_, _, {cstr_tag=tag},[], _) -> let name = get_constr_name tag v.pat_type v.pat_env in fprintf ppf "%s" name - | Tpat_construct ({cstr_tag=tag},[w]) -> + | Tpat_construct (_, _, {cstr_tag=tag},[w], _) -> let name = get_constr_name tag v.pat_type v.pat_env in fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w - | Tpat_construct ({cstr_tag=tag},vs) -> + | Tpat_construct (_, _, {cstr_tag=tag},vs, _) -> let name = get_constr_name tag v.pat_type v.pat_env in begin match (name, vs) with ("::", [v1;v2]) -> @@ -195,36 +209,36 @@ let rec pretty_val ppf v = match v.pat_desc with fprintf ppf "`%s" l | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w - | Tpat_record lvs -> + | Tpat_record (lvs,_) -> fprintf ppf "@[{%a}@]" (pretty_lvals (get_record_labels v.pat_type v.pat_env)) (List.filter (function - | (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) | _ -> true) lvs) | Tpat_array vs -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v,x) -> + | Tpat_alias (v, x,_) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_or (v,w,_) -> fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w and pretty_car ppf v = match v.pat_desc with -| Tpat_construct ({cstr_tag=tag}, [_ ; _]) +| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _], _) when is_cons tag v -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct ({cstr_tag=tag}, [v1 ; v2]) +| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2], _) when is_cons tag v -> fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 | _ -> pretty_val ppf v and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_::_) -> fprintf ppf "(%a)" pretty_val v +| Tpat_construct (_,_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_or ppf v = match v.pat_desc with @@ -240,12 +254,13 @@ and pretty_vals sep ppf = function and pretty_lvals lbls ppf = function | [] -> () - | [lbl,v] -> + | [_, _,lbl,v] -> let name = find_label lbl lbls in - fprintf ppf "%s=%a" name pretty_val v - | (lbl,v)::rest -> + fprintf ppf "%s=%a" (Ident.name name) pretty_val v + | (_, _, lbl,v)::rest -> let name = find_label lbl lbls in - fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest + fprintf ppf "%s=%a;@ %a" + (Ident.name name) pretty_val v (pretty_lvals lbls) rest let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v @@ -263,7 +278,7 @@ let prerr_pat v = (* Check top matching *) let simple_match p1 p2 = match p1.pat_desc, p2.pat_desc with - | Tpat_construct(c1, _), Tpat_construct(c2, _) -> + | Tpat_construct(_, _, c1, _, _), Tpat_construct(_,_, c2, _, _) -> c1.cstr_tag = c2.cstr_tag | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> l1 = l2 @@ -283,30 +298,32 @@ let simple_match p1 p2 = (* extract record fields as a whole *) let record_arg p = match p.pat_desc with | Tpat_any -> [] -| Tpat_record args -> args +| Tpat_record (args,_) -> args | _ -> fatal_error "Parmatch.as_record" (* Raise Not_found when pos is not present in arg *) let get_field pos arg = - let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in + let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in p let extract_fields omegas arg = List.map - (fun (lbl,_) -> + (fun (_,_,lbl,_) -> try get_field lbl.lbl_pos arg with Not_found -> omega) omegas let all_record_args lbls = match lbls with -| ({lbl_all=lbl_all},_)::_ -> +| (_,_,{lbl_all=lbl_all},_)::_ -> let t = Array.map - (fun lbl -> lbl,omega) lbl_all in + (fun lbl -> Path.Pident (Ident.create "?temp?"), + mknoloc (Longident.Lident "?temp?"), lbl,omega) + lbl_all in List.iter - (fun ((lbl,_) as x) -> t.(lbl.lbl_pos) <- x) + (fun ((_,_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) lbls ; Array.to_list t | _ -> fatal_error "Parmatch.all_record_args" @@ -314,19 +331,19 @@ let all_record_args lbls = match lbls with (* Build argument list when p2 >= p1, where p1 is a simple pattern *) let rec simple_match_args p1 p2 = match p2.pat_desc with -| Tpat_alias (p2,_) -> simple_match_args p1 p2 -| Tpat_construct(cstr, args) -> args +| Tpat_alias (p2,_,_) -> simple_match_args p1 p2 +| Tpat_construct(_,_, cstr, args, _) -> args | Tpat_variant(lab, Some arg, _) -> [arg] | Tpat_tuple(args) -> args -| Tpat_record(args) -> extract_fields (record_arg p1) args +| Tpat_record(args,_) -> extract_fields (record_arg p1) args | Tpat_array(args) -> args | Tpat_lazy arg -> [arg] | (Tpat_any | Tpat_var(_)) -> begin match p1.pat_desc with - Tpat_construct(_, args) -> omega_list args + Tpat_construct(_,_, _,args, _) -> omega_list args | Tpat_variant(_, Some _, _) -> [omega] | Tpat_tuple(args) -> omega_list args - | Tpat_record(args) -> omega_list args + | Tpat_record(args,_) -> omega_list args | Tpat_array(args) -> omega_list args | Tpat_lazy _ -> [omega] | _ -> [] @@ -341,24 +358,27 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with let rec normalize_pat q = match q.pat_desc with | Tpat_any | Tpat_constant _ -> q | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env - | Tpat_alias (p,_) -> normalize_pat p + | Tpat_alias (p,_,_) -> normalize_pat p | Tpat_tuple (args) -> make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env - | Tpat_construct (c,args) -> - make_pat (Tpat_construct (c,omega_list args)) q.pat_type q.pat_env + | Tpat_construct (lid, lid_loc, c,args,explicit_arity) -> + make_pat + (Tpat_construct (lid, lid_loc, c,omega_list args, explicit_arity)) + q.pat_type q.pat_env | Tpat_variant (l, arg, row) -> make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) q.pat_type q.pat_env | Tpat_array (args) -> make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env - | Tpat_record (largs) -> - make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs)) + | Tpat_record (largs, closed) -> + make_pat + (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) -> + lid, lid_loc, lbl,omega) largs, closed)) q.pat_type q.pat_env | Tpat_lazy _ -> make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" - (* Build normalized (cf. supra) discriminating pattern, in the non-data type case @@ -367,7 +387,7 @@ let rec normalize_pat q = match q.pat_desc with let discr_pat q pss = let rec acc_pat acc pss = match pss with - ({pat_desc = Tpat_alias (p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss -> acc_pat acc ((p::ps)::pss) | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss -> acc_pat acc ((p1::ps)::(p2::ps)::pss) @@ -375,19 +395,19 @@ let discr_pat q pss = acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_record largs} as p)::_)::pss -> + | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss -> let new_omegas = List.fold_right - (fun (lbl,_) r -> + (fun (lid, lid_loc, lbl,_) r -> try let _ = get_field lbl.lbl_pos r in r with Not_found -> - (lbl,omega)::r) + (lid, lid_loc, lbl,omega)::r) largs (record_arg acc) in acc_pat - (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env) + (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) pss | _ -> acc in @@ -412,26 +432,27 @@ let do_set_args erase_mutable q r = match q with | {pat_desc = Tpat_tuple omegas} -> let args,rest = read_args omegas r in make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest -| {pat_desc = Tpat_record omegas} -> +| {pat_desc = Tpat_record (omegas,closed)} -> let args,rest = read_args omegas r in make_pat (Tpat_record - (List.map2 (fun (lbl,_) arg -> + (List.map2 (fun (lid, lid_loc, lbl,_) arg -> if erase_mutable && (match lbl.lbl_mut with | Mutable -> true | Immutable -> false) then - lbl, omega + lid, lid_loc, lbl, omega else - lbl,arg) - omegas args)) + lid, lid_loc, lbl, arg) + omegas args, closed)) q.pat_type q.pat_env:: rest -| {pat_desc = Tpat_construct (c,omegas)} -> +| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas, explicit_arity)} -> let args,rest = read_args omegas r in make_pat - (Tpat_construct (c,args)) q.pat_type q.pat_env:: + (Tpat_construct (lid, lid_loc, c,args, explicit_arity)) + q.pat_type q.pat_env:: rest | {pat_desc = Tpat_variant (l, omega, row)} -> let arg, rest = @@ -464,7 +485,7 @@ and set_args_erase_mutable q r = do_set_args true q r (* filter pss acording to pattern q *) let filter_one q pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -482,7 +503,7 @@ let filter_one q pss = *) let filter_extra pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -517,7 +538,7 @@ let filter_all pat0 pss = else c :: insert q qs env in let rec filter_rec env = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_rec env ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec env ((p1::ps)::(p2::ps)::pss) @@ -528,13 +549,14 @@ let filter_all pat0 pss = | _ -> env and filter_omega env = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> filter_omega env ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_omega env ((p1::ps)::(p2::ps)::pss) | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss -> filter_omega - (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) env) + (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) + env) pss | _::pss -> filter_omega env pss | [] -> env in @@ -556,7 +578,7 @@ let rec set_last a = function (* mark constructor lines for failure when they are incomplete *) let rec mark_partial = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> mark_partial ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> mark_partial ((p1::ps)::(p2::ps)::pss) @@ -596,14 +618,14 @@ let row_of_pat pat = not. *) -let generalized_constructor x = - match x with - ({pat_desc = Tpat_construct(c,_);pat_env=env},_) -> +let generalized_constructor x = + match x with + ({pat_desc = Tpat_construct(_,_,c,_, _);pat_env=env},_) -> c.cstr_generalized | _ -> assert false -let clean_env env = - let rec loop = +let clean_env env = + let rec loop = function | [] -> [] | x :: xs -> @@ -612,12 +634,13 @@ let clean_env env = loop env let full_match ignore_generalized closing env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> +| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_,_)},_)::_ -> false -| ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> +| ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ -> if ignore_generalized then - (* remove generalized constructors; those cases will be handled separately *) - let env = clean_env env in + (* remove generalized constructors; + those cases will be handled separately *) + let env = clean_env env in List.length env = c.cstr_normal else List.length env = c.cstr_consts + c.cstr_nonconsts @@ -630,7 +653,7 @@ let full_match ignore_generalized closing env = match env with env in let row = row_of_pat p in - if closing && not row.row_fixed then + if closing && not (Btype.row_fixed row) then (* closing=true, we are considering the variant as closed *) List.for_all (fun (tag,f) -> @@ -656,12 +679,13 @@ let full_match ignore_generalized closing env = match env with | _ -> fatal_error "Parmatch.full_match" let full_match_gadt env = match env with - | ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> + | ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ -> List.length env = c.cstr_consts + c.cstr_nonconsts | _ -> true let extendable_match env = match env with -| ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ -> +| ({pat_desc=Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)} + as p,_) :: _ -> let path = get_type_path p.pat_type p.pat_env in not (Path.same path Predef.path_bool || @@ -673,9 +697,9 @@ let extendable_match env = match env with let should_extend ext env = match ext with | None -> false | Some ext -> match env with - | ({pat_desc = - Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) - :: _ -> + | ({pat_desc = + Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)} + as p, _) :: _ -> let path = get_type_path p.pat_type p.pat_env in Path.same path ext | _ -> false @@ -703,7 +727,10 @@ let complete_tags nconsts nconstrs tags = (* build a pattern from a constructor list *) let pat_of_constr ex_pat cstr = - {ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)} + {ex_pat with pat_desc = + Tpat_construct (Path.Pident (Ident.create "?pat_of_constr?"), + mknoloc (Longident.Lident "?pat_of_constr?"), + cstr,omegas cstr.cstr_arity,false)} let rec pat_of_constrs ex_pat = function | [] -> raise Empty @@ -729,7 +756,7 @@ let rec adt_path env ty = | _ -> raise Not_an_adt ;; -let rec map_filter f = +let rec map_filter f = function [] -> [] | x :: xs -> @@ -738,12 +765,13 @@ let rec map_filter f = | Some y -> y :: map_filter f xs (* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = +let complete_constrs p all_tags = match p.pat_desc with - | Tpat_construct (c,_) -> + | Tpat_construct (_,_,c,_,_) -> begin try let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in - let constrs = Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in + let constrs = + Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in map_filter (fun cnstr -> if List.mem cnstr.cstr_tag not_tags then Some cnstr else None) @@ -771,22 +799,23 @@ let build_other_constant proj make first next p env = *) let build_other ext env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) +| ({pat_desc = + Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_,_)},_) ::_ -> make_pat (Tpat_construct - ({c with + (lid, lid_loc, {c with cstr_tag=(Cstr_exception (Path.Pident (Ident.create "*exception*"), Location.none))}, - [])) + [], false)) Ctype.none Env.empty -| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> +| ({pat_desc = Tpat_construct (_,_, _,_,_)} as p,_) :: _ -> begin match ext with | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> extra_pat | _ -> let get_tag = function - | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag + | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in let all_tags = List.map (fun (p,_) -> get_tag p) env in pat_of_constrs p (complete_constrs p all_tags) @@ -899,11 +928,11 @@ let build_other ext env = match env with | [] -> omega | _ -> omega -let build_other_gadt ext env = +let build_other_gadt ext env = match env with - | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> + | ({pat_desc = Tpat_construct _} as p,_) :: _ -> let get_tag = function - | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag + | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag | _ -> fatal_error "Parmatch.get_tag" in let all_tags = List.map (fun (p,_) -> get_tag p) env in let cnstrs = complete_constrs p all_tags in @@ -912,7 +941,7 @@ let build_other_gadt ext env = Format.eprintf "@.@."; *) pats | _ -> assert false - + (* Core function : Is the last row of pattern matrix pss + qs satisfiable ? @@ -925,11 +954,14 @@ let build_other_gadt ext env = let rec has_instance p = match p.pat_desc with | Tpat_variant (l,_,r) when is_absent l r -> false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 - | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps - | Tpat_record lps -> has_instances (List.map snd lps) - | Tpat_lazy p -> has_instance p + | Tpat_construct (_, _,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps) + | Tpat_lazy p + -> has_instance p + and has_instances = function | [] -> true @@ -942,7 +974,7 @@ let rec satisfiable pss qs = match pss with | [] -> false | {pat_desc = Tpat_or(q1,q2,_)}::qs -> satisfiable pss (q1::qs) || satisfiable pss (q2::qs) - | {pat_desc = Tpat_alias(q,_)}::qs -> + | {pat_desc = Tpat_alias(q,_,_)}::qs -> satisfiable pss (q::qs) | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> let q0 = discr_pat omega pss in @@ -976,14 +1008,14 @@ type 'a result = | Rsome of 'a (* This matching value *) let rec orify_many = - let rec orify x y = - make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env + let rec orify x y = + make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env in function | [] -> assert false | [x] -> x | x :: xs -> orify x (orify_many xs) - + let rec try_many f = function | [] -> Rnone | (p,pss)::rest -> @@ -997,13 +1029,13 @@ let rec try_many_gadt f = function | (p,pss)::rest -> match f (p,pss) with | Rnone -> try_many f rest - | Rsome sofar -> - let others = try_many f rest in + | Rsome sofar -> + let others = try_many f rest in match others with Rnone -> Rsome sofar | Rsome sofar' -> Rsome (sofar @ sofar') - + let rec exhaust ext pss n = match pss with @@ -1053,8 +1085,8 @@ let rec exhaust ext pss n = match pss with | Empty -> fatal_error "Parmatch.exhaust" end -let combinations f lst lst' = - let rec iter2 x = +let combinations f lst lst' = + let rec iter2 x = function [] -> [] | y :: ys -> @@ -1066,10 +1098,33 @@ let combinations f lst lst' = | x :: xs -> iter2 x lst' @ iter xs in iter lst - + +(* +let print_pat pat = + let rec string_of_pat pat = + match pat.pat_desc with + Tpat_var _ -> "v" + | Tpat_any -> "_" + | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) + | Tpat_constant n -> "0" + | Tpat_construct (_, lid, _, _) -> + Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) + | Tpat_lazy p -> + Printf.sprintf "(lazy %s)" (string_of_pat p) + | Tpat_or (p1,p2,_) -> + Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) + | Tpat_tuple list -> + Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) + | Tpat_variant (_, _, _) -> "variant" + | Tpat_record (_, _) -> "record" + | Tpat_array _ -> "array" + in + Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) +*) + (* strictly more powerful than exhaust; however, exhaust was kept for backwards compatibility *) -let rec exhaust_gadt ext pss n = match pss with +let rec exhaust_gadt (ext:Path.t option) pss n = match pss with | [] -> Rsome [omegas n] | []::_ -> Rnone | pss -> @@ -1112,34 +1167,33 @@ let rec exhaust_gadt ext pss n = match pss with | Rsome r -> try let missing_trailing = build_other_gadt ext constrs in - let before = - match before with - Rnone -> [] - | Rsome lst -> lst + let before = + match before with + Rnone -> [] + | Rsome lst -> lst in - let dug = + let dug = combinations - (fun head tail -> - head :: tail) + (fun head tail -> head :: tail) missing_trailing r in - Rsome (dug @ before) + Rsome (dug @ before) with (* cannot occur, since constructors don't make a full signature *) | Empty -> fatal_error "Parmatch.exhaust" end -let exhaust_gadt ext pss n = - let ret = exhaust_gadt ext pss n in +let exhaust_gadt ext pss n = + let ret = exhaust_gadt ext pss n in match ret with Rnone -> Rnone | Rsome lst -> (* The following line is needed to compile stdlib/printf.ml *) if lst = [] then Rsome (omegas n) else - let singletons = - List.map - (function + let singletons = + List.map + (function [x] -> x | _ -> assert false) lst @@ -1185,7 +1239,7 @@ let rec pressure_variants tdefs = function begin match constrs, tdefs with ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> let row = row_of_pat p in - if row.row_fixed + if Btype.row_fixed row || pressure_variants None (filter_extra pss) then () else close_variant env row | _ -> () @@ -1205,7 +1259,7 @@ let rec pressure_variants tdefs = function type answer = | Used (* Useful pattern *) | Unused (* Useless pattern *) - | Upartial of Typedtree.pattern list (* Neither, with list of useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) let pretty_pat p = @@ -1261,7 +1315,7 @@ let make_rows pss = List.map make_row pss (* Useful to detect and expand or pats inside as pats *) let rec unalias p = match p.pat_desc with -| Tpat_alias (p,_) -> unalias p +| Tpat_alias (p,_,_) -> unalias p | _ -> p @@ -1279,7 +1333,7 @@ let is_var_column rs = (* Standard or-args for left-to-right matching *) let rec or_args p = match p.pat_desc with | Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_) -> or_args p +| Tpat_alias (p,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1314,7 +1368,7 @@ let filter_one q rs = | r::rem -> match r.active with | [] -> assert false - | {pat_desc = Tpat_alias(p,_)}::ps -> + | {pat_desc = Tpat_alias(p,_,_)}::ps -> filter_rec ({r with active = p::ps}::rem) | {pat_desc = Tpat_or(p1,p2,_)}::ps -> filter_rec @@ -1467,10 +1521,10 @@ and every_both pss qs q1 q2 = let rec le_pat p q = match (p.pat_desc, q.pat_desc) with | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_), _ -> le_pat p q - | _, Tpat_alias(q,_) -> le_pat p q + | Tpat_alias(p,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2 - | Tpat_construct(c1,ps), Tpat_construct(c2,qs) -> + | Tpat_construct(_,_,c1,ps,_), Tpat_construct(_,_,c2,qs,_) -> c1.cstr_tag = c2.cstr_tag && le_pats ps qs | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> (l1 = l2 && le_pat p1 p2) @@ -1479,7 +1533,7 @@ let rec le_pat p q = | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs | Tpat_lazy p, Tpat_lazy q -> le_pat p q - | Tpat_record l1, Tpat_record l2 -> + | Tpat_record (l1,_), Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in le_pats ps qs | Tpat_array(ps), Tpat_array(qs) -> @@ -1507,8 +1561,8 @@ let get_mins le ps = *) let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_),_ -> lub p q -| _,Tpat_alias (q,_) -> lub p q +| Tpat_alias (p,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_) -> lub p q | (Tpat_any|Tpat_var _),_ -> q | _,(Tpat_any|Tpat_var _) -> p | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q @@ -1520,19 +1574,20 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_lazy p, Tpat_lazy q -> let r = lub p q in make_pat (Tpat_lazy r) p.pat_type p.pat_env -| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) +| Tpat_construct (lid, lid_loc, c1,ps1,_), Tpat_construct (_, _,c2,ps2,_) when c1.cstr_tag = c2.cstr_tag -> let rs = lubs ps1 ps2 in - make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env + make_pat (Tpat_construct (lid, lid_loc, c1,rs, false)) + p.pat_type p.pat_env | Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) when l1=l2 -> let r=lub p1 p2 in make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env | Tpat_variant (l1,None,row), Tpat_variant(l2,None,_) when l1 = l2 -> p -| Tpat_record l1,Tpat_record l2 -> +| Tpat_record (l1,closed),Tpat_record (l2,_) -> let rs = record_lubs l1 l2 in - make_pat (Tpat_record rs) p.pat_type p.pat_env + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> let rs = lubs ps qs in @@ -1554,13 +1609,13 @@ and record_lubs l1 l2 = let rec lub_rec l1 l2 = match l1,l2 with | [],_ -> l2 | _,[] -> l1 - | (lbl1,p1)::rem1, (lbl2,p2)::rem2 -> + | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then - (lbl1,p1)::lub_rec rem1 l2 + (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2 else if lbl2.lbl_pos < lbl1.lbl_pos then - (lbl2,p2)::lub_rec l1 rem2 + (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2 else - (lbl1,lub p1 p2)::lub_rec rem1 rem2 in + (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in lub_rec l1 l2 and lubs ps qs = match ps,qs with @@ -1631,7 +1686,7 @@ let rec do_filter_var = function let do_filter_one q pss = let rec filter_rec = function - | ({pat_desc = Tpat_alias(p,_)}::ps,loc)::pss -> + | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss -> filter_rec ((p::ps,loc)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss -> filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss) @@ -1673,11 +1728,11 @@ let check_partial_all v casel = (************************) - let rec get_first f = + let rec get_first f = function | [] -> None - | x :: xs -> - match f x with + | x :: xs -> + match f x with | None -> get_first f xs | x -> x @@ -1685,11 +1740,11 @@ let check_partial_all v casel = (* conversion from Typedtree.pattern to Parsetree.pattern list *) module Conv = struct open Parsetree - let mkpat desc = + let mkpat desc = {ppat_desc = desc; ppat_loc = Location.none} - let rec select : 'a list list -> 'a list list = + let rec select : 'a list list -> 'a list list = function | xs :: [] -> List.map (fun y -> [y]) xs | (x::xs)::ys -> @@ -1700,48 +1755,49 @@ module Conv = struct select (xs::ys) | _ -> [] - let name_counter = ref 0 - let fresh () = - let current = !name_counter in + let name_counter = ref 0 + let fresh () = + let current = !name_counter in name_counter := !name_counter + 1; "#$%^@*@" ^ string_of_int current - let conv (typed: Typedtree.pattern) : - Parsetree.pattern list * - (string,Types.constructor_description) Hashtbl.t * - (string,Types.label_description) Hashtbl.t - = - let constrs = Hashtbl.create 0 in - let labels = Hashtbl.create 0 in - let rec loop pat = + let conv (typed: Typedtree.pattern) : + Parsetree.pattern list * + (string,Path.t * Types.constructor_description) Hashtbl.t * + (string,Path.t * Types.label_description) Hashtbl.t + = + let constrs = Hashtbl.create 0 in + let labels = Hashtbl.create 0 in + let rec loop pat = match pat.pat_desc with Tpat_or (a,b,_) -> loop a @ loop b | Tpat_any | Tpat_constant _ | Tpat_var _ -> [mkpat Ppat_any] - | Tpat_alias (p,_) -> loop p + | Tpat_alias (p,_,_) -> loop p | Tpat_tuple lst -> - let results = select (List.map loop lst) in + let results = select (List.map loop lst) in List.map (fun lst -> mkpat (Ppat_tuple lst)) results - | Tpat_construct (cstr,lst) -> - let id = fresh () in - Hashtbl.add constrs id cstr; + | Tpat_construct (cstr_path, cstr_lid, cstr,lst,_) -> + let id = fresh () in + let lid = { cstr_lid with txt = Longident.Lident id } in + Hashtbl.add constrs id (cstr_path,cstr); let results = select (List.map loop lst) in begin match lst with [] -> - [mkpat (Ppat_construct(Longident.Lident id, None, false))] + [mkpat (Ppat_construct(lid, None, false))] | _ -> - List.map + List.map (fun lst -> - let arg = + let arg = match lst with [] -> assert false | [x] -> Some x | _ -> Some (mkpat (Ppat_tuple lst)) in - mkpat (Ppat_construct(Longident.Lident id, arg, false))) + mkpat (Ppat_construct(lid, arg, false))) results end | Tpat_variant(label,p_opt,row_desc) -> @@ -1749,38 +1805,40 @@ module Conv = struct | None -> [mkpat (Ppat_variant(label, None))] | Some p -> - let results = loop p in + let results = loop p in List.map (fun p -> mkpat (Ppat_variant(label, Some p))) results end - | Tpat_record subpatterns -> - let pats = + | Tpat_record (subpatterns, _closed_flag) -> + let pats = select - (List.map (fun (_,x) -> (loop x)) subpatterns) + (List.map (fun (_,_,_,x) -> (loop x)) subpatterns) in - let label_idents = - List.map - (fun (lbl,_) -> - let id = fresh () in - Hashtbl.add labels id lbl; - Longident.Lident id) + let label_idents = + List.map + (fun (lbl_path,_,lbl,_) -> + let id = fresh () in + Hashtbl.add labels id (lbl_path, lbl); + Longident.Lident id) subpatterns - in + in List.map (fun lst -> - let lst = List.combine label_idents lst in - mkpat (Ppat_record (lst, Open))) + let lst = List.map2 (fun lid pat -> + (mknoloc lid, pat) + ) label_idents lst in + mkpat (Ppat_record (lst, Open))) pats | Tpat_array lst -> - let results = select (List.map loop lst) in + let results = select (List.map loop lst) in List.map (fun lst -> mkpat (Ppat_array lst)) results | Tpat_lazy p -> - let results = loop p in + let results = loop p in List.map (fun p -> mkpat (Ppat_lazy p)) results in - let ps = loop typed in + let ps = loop typed in (ps, constrs, labels) end @@ -1804,10 +1862,14 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with begin match exhaust None pss (List.length ps) with | Rnone -> Total | Rsome [u] -> - let v = - match pred with + let v = + match pred with | Some pred -> - let (patterns,constrs,labels) = Conv.conv u in + let (patterns,constrs,labels) = Conv.conv u in +(* Hashtbl.iter (fun s (path, _) -> + Printf.fprintf stderr "CONV: %s -> %s \n%!" s (Path.name path)) + constrs + ; *) get_first (pred constrs labels) patterns | None -> Some u in @@ -1838,10 +1900,10 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with fatal_error "Parmatch.check_partial" end -let do_check_partial_normal loc casel pss = +let do_check_partial_normal loc casel pss = do_check_partial exhaust loc casel pss -let do_check_partial_gadt pred loc casel pss = +let do_check_partial_gadt pred loc casel pss = do_check_partial ~pred exhaust_gadt loc casel pss @@ -1866,7 +1928,7 @@ let extendable_path path = Path.same path Predef.path_option) let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},ps) -> +| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) -> let path = get_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat @@ -1874,16 +1936,17 @@ let rec collect_paths_from_pat r p = match p.pat_desc with ps | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r | Tpat_tuple ps | Tpat_array ps -| Tpat_construct ({cstr_tag=Cstr_exception _}, ps)-> +| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps,_)-> List.fold_left collect_paths_from_pat r ps -| Tpat_record lps -> +| Tpat_record (lps,_) -> List.fold_left - (fun r (_,p) -> collect_paths_from_pat r p) + (fun r (_, _, _, p) -> collect_paths_from_pat r p) r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 -| Tpat_lazy p -> +| Tpat_lazy p + -> collect_paths_from_pat r p @@ -1975,16 +2038,19 @@ let useful pats = let rec remove_binders p = match p.pat_desc with | Tpat_any|Tpat_constant _|Tpat_variant (_, None, _) -> p | Tpat_var _ -> { p with pat_desc = Tpat_any } -| Tpat_alias (p, _) -> remove_binders p +| Tpat_alias (p, _, _) -> remove_binders p | Tpat_tuple ps -> { p with pat_desc = Tpat_tuple (remove_binders_list ps) } -| Tpat_construct (c, ps) -> - { p with pat_desc = Tpat_construct (c, remove_binders_list ps) } +| Tpat_construct (path, loc, c, ps, b) -> + { p with pat_desc = Tpat_construct (path, loc, c, remove_binders_list ps, b) } | Tpat_variant (lab, Some p, row) -> { p with pat_desc = Tpat_variant (lab, Some (remove_binders p), row) } -| Tpat_record lblps -> - { p with pat_desc = - Tpat_record (List.map (fun (lbl,p) -> lbl, remove_binders p) lblps) } +| Tpat_record (vrac_ps,fl) -> + let vrac_ps = + List.map + (fun (path,loc,lbl,p) -> path,loc,lbl,remove_binders p) + vrac_ps in + { p with pat_desc = Tpat_record (vrac_ps,fl) } | Tpat_array ps -> { p with pat_desc = Tpat_array (remove_binders_list ps) } | Tpat_or (p1, p2, patho) -> @@ -2012,25 +2078,25 @@ let rec inactive pat = match pat with false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> true -| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps -> +| Tpat_tuple ps | Tpat_construct (_, _, _, ps,_) | Tpat_array ps -> List.for_all (fun p -> inactive p.pat_desc) ps -| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) -> +| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> inactive p.pat_desc -| Tpat_record ldps -> - List.exists (fun (_, p) -> inactive p.pat_desc) ldps +| Tpat_record (ldps,_) -> + List.exists (fun (_, _, _, p) -> inactive p.pat_desc) ldps | Tpat_or (p,q,_) -> inactive p.pat_desc && inactive q.pat_desc - (* A `fluid' pattern is both irrefutable and inactive *) -let fluid pat = irrefutable pat && inactive pat.pat_desc +let fluid pat = irrefutable pat && inactive pat.pat_desc + + - (********************************) (* Exported exhustiveness check *) (********************************) @@ -2040,7 +2106,7 @@ let fluid pat = irrefutable pat && inactive pat.pat_desc on exhaustive matches only. *) -let check_partial_param do_check_partial do_check_fragile loc casel = +let check_partial_param do_check_partial do_check_fragile loc casel = if Warnings.is_active (Warnings.Partial_match "") then begin let pss = initial_matrix casel in let pss = get_mins le_pats pss in @@ -2052,11 +2118,11 @@ let check_partial_param do_check_partial do_check_fragile loc casel = end ; total end else - Partial + Partial -let check_partial = - check_partial_param - do_check_partial_normal +let check_partial = + check_partial_param + do_check_partial_normal do_check_fragile_normal let check_partial_gadt pred loc casel = @@ -2064,7 +2130,7 @@ let check_partial_gadt pred loc casel = let first_check = check_partial loc casel in match first_check with | Partial -> Partial - | Total -> + | Total -> (* checks for missing GADT constructors *) check_partial_param (do_check_partial_gadt pred) do_check_fragile_gadt loc casel diff --git a/typing/parmatch.mli b/typing/parmatch.mli index f3cd2d0876..cd5ca99688 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -13,8 +13,9 @@ (* $Id$ *) (* Detection of partial matches and unused match cases. *) -open Types +open Asttypes open Typedtree +open Types val top_pretty : Format.formatter -> pattern -> unit val pretty_pat : pattern -> unit @@ -26,7 +27,8 @@ val omegas : int -> pattern list val omega_list : 'a list -> pattern list val normalize_pat : pattern -> pattern val all_record_args : - (label_description * pattern) list -> (label_description * pattern) list + (Path.t * Longident.t loc * label_description * pattern) list -> + (Path.t * Longident.t loc * label_description * pattern) list val le_pat : pattern -> pattern -> bool val le_pats : pattern list -> pattern list -> bool @@ -52,10 +54,10 @@ val complete_constrs : val pressure_variants: Env.t -> pattern list -> unit val check_partial: Location.t -> (pattern * expression) list -> partial -val check_partial_gadt: - ((string,constructor_description) Hashtbl.t -> - (string,label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> +val check_partial_gadt: + ((string,Path.t * constructor_description) Hashtbl.t -> + (string,Path.t * label_description) Hashtbl.t -> + Parsetree.pattern -> pattern option) -> Location.t -> (pattern * expression) list -> partial val check_unused: Env.t -> (pattern * expression) list -> unit diff --git a/typing/predef.ml b/typing/predef.ml index 88091f0903..2f06520b7a 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -19,21 +19,31 @@ open Path open Types open Btype -let ident_int = Ident.create "int" -and ident_char = Ident.create "char" -and ident_string = Ident.create "string" -and ident_float = Ident.create "float" -and ident_bool = Ident.create "bool" -and ident_unit = Ident.create "unit" -and ident_exn = Ident.create "exn" -and ident_array = Ident.create "array" -and ident_list = Ident.create "list" -and ident_format6 = Ident.create "format6" -and ident_option = Ident.create "option" -and ident_nativeint = Ident.create "nativeint" -and ident_int32 = Ident.create "int32" -and ident_int64 = Ident.create "int64" -and ident_lazy_t = Ident.create "lazy_t" +let builtin_idents = ref [] + +let wrap create s = + let id = create s in + builtin_idents := (s, id) :: !builtin_idents; + id + +let ident_create = wrap Ident.create +let ident_create_predef_exn = wrap Ident.create_predef_exn + +let ident_int = ident_create "int" +and ident_char = ident_create "char" +and ident_string = ident_create "string" +and ident_float = ident_create "float" +and ident_bool = ident_create "bool" +and ident_unit = ident_create "unit" +and ident_exn = ident_create "exn" +and ident_array = ident_create "array" +and ident_list = ident_create "list" +and ident_format6 = ident_create "format6" +and ident_option = ident_create "option" +and ident_nativeint = ident_create "nativeint" +and ident_int32 = ident_create "int32" +and ident_int64 = ident_create "int64" +and ident_lazy_t = ident_create "lazy_t" let path_int = Pident ident_int and path_char = Pident ident_char @@ -69,24 +79,31 @@ and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) and type_process kids = newgenty (Tproc kids) (*<JOCAML*) -let ident_match_failure = Ident.create_predef_exn "Match_failure" -and ident_out_of_memory = Ident.create_predef_exn "Out_of_memory" -and ident_invalid_argument = Ident.create_predef_exn "Invalid_argument" -and ident_failure = Ident.create_predef_exn "Failure" -and ident_not_found = Ident.create_predef_exn "Not_found" -and ident_sys_error = Ident.create_predef_exn "Sys_error" -and ident_end_of_file = Ident.create_predef_exn "End_of_file" -and ident_division_by_zero = Ident.create_predef_exn "Division_by_zero" -and ident_stack_overflow = Ident.create_predef_exn "Stack_overflow" -and ident_sys_blocked_io = Ident.create_predef_exn "Sys_blocked_io" -and ident_assert_failure = Ident.create_predef_exn "Assert_failure" +let ident_match_failure = ident_create_predef_exn "Match_failure" +and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" +and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" +and ident_failure = ident_create_predef_exn "Failure" +and ident_not_found = ident_create_predef_exn "Not_found" +and ident_sys_error = ident_create_predef_exn "Sys_error" +and ident_end_of_file = ident_create_predef_exn "End_of_file" +and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" +and ident_stack_overflow = ident_create_predef_exn "Stack_overflow" +and ident_sys_blocked_io = ident_create_predef_exn "Sys_blocked_io" +and ident_assert_failure = ident_create_predef_exn "Assert_failure" and ident_undefined_recursive_module = - Ident.create_predef_exn "Undefined_recursive_module" + ident_create_predef_exn "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 ident_false = ident_create "false" +and ident_true = ident_create "true" +and ident_void = ident_create "()" +and ident_nil = ident_create "[]" +and ident_cons = ident_create "::" +and ident_none = ident_create "None" +and ident_some = ident_create "Some" let build_initial_env add_type add_exception empty_env = let decl_abstr = {type_params = []; @@ -100,7 +117,7 @@ let build_initial_env add_type add_exception empty_env = and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false", [], None; "true", [], None]); + type_kind = Type_variant([ident_false, [], None; ident_true, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -109,7 +126,7 @@ let build_initial_env add_type add_exception empty_env = and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant(["()", [], None]); + type_kind = Type_variant([ident_void, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -139,7 +156,8 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", [], None; "::", [tvar; type_list tvar], None]); + Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar], + None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -165,7 +183,7 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant(["None", [], None; "Some", [tvar], None]); + type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]); type_loc = Location.none; type_private = Public; type_manifest = None; @@ -183,7 +201,8 @@ let build_initial_env add_type add_exception empty_env = type_newtype_level = None} in - let add_exception id l = add_exception id { exn_args = l; exn_loc = Location.none } in + let add_exception id l = + add_exception id { exn_args = l; exn_loc = Location.none } in add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_out_of_memory [] ( @@ -232,4 +251,5 @@ let builtin_values = be defined in this file (above!) without breaking .cmi compatibility. *) -let _ = Ident.set_current_time 999 +let _ = Ident.set_current_time 999 +let builtin_idents = List.rev !builtin_idents diff --git a/typing/predef.mli b/typing/predef.mli index bd477ad523..cedcf88915 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -66,3 +66,4 @@ val build_initial_env: (* To initialize linker tables *) val builtin_values: (string * Ident.t) list +val builtin_idents: (string * Ident.t) list diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1f23448db4..6e7184e892 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -453,7 +453,8 @@ let rec tree_of_typexp sch ty = Otyp_var (false, name_of_type ty) | Tproc _ -> Otyp_proc | Tpackage (p, n, tyl) -> - let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in + let n = + List.map (fun li -> String.concat "." (Longident.flatten li)) n in Otyp_module (Path.name p, n, tree_of_typlist sch tyl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; @@ -591,8 +592,8 @@ let rec tree_of_type_decl id decl = begin match decl.type_kind with | Type_abstract -> () | Type_variant cstrs -> - List.iter - (fun (_, args,ret_type_opt) -> + List.iter + (fun (_, args,ret_type_opt) -> List.iter mark_loops args; may mark_loops ret_type_opt) cstrs @@ -651,6 +652,7 @@ let rec tree_of_type_decl id decl = (name, args, ty, priv, constraints) and tree_of_constructor (name, args, ret_type_opt) = + let name = Ident.name name in if ret_type_opt = None then (name, tree_of_typlist false args, None) else let nm = !names in names := []; @@ -658,7 +660,7 @@ and tree_of_constructor (name, args, ret_type_opt) = let args = tree_of_typlist false args in names := nm; (name, args, ret) - + and tree_of_constructor_ret = function @@ -666,7 +668,7 @@ and tree_of_constructor_ret = | Some ret_type -> Some (tree_of_typexp false ret_type) and tree_of_label (name, mut, arg) = - (name, mut = Mutable, tree_of_typexp false arg) + (Ident.name name, mut = Mutable, tree_of_typexp false arg) let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) @@ -723,14 +725,14 @@ let tree_of_metho sch concrete csil (lab, kind, ty) = else csil let rec prepare_class_type params = function - | Tcty_constr (p, tyl, cty) -> + | Cty_constr (p, tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) || List.exists (deep_occur sty) tyl then prepare_class_type params cty else List.iter mark_loops tyl - | Tcty_signature sign -> + | Cty_signature sign -> let sty = repr sign.cty_self in (* Self may have a name *) let px = proxy sty in @@ -741,13 +743,13 @@ let rec prepare_class_type params = function in List.iter (fun met -> mark_loops (fst (method_type met))) fields; Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> mark_loops ty; prepare_class_type params cty let rec tree_of_class_type sch params = function - | Tcty_constr (p', tyl, cty) -> + | Cty_constr (p', tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) @@ -755,7 +757,7 @@ let rec tree_of_class_type sch params = tree_of_class_type sch params cty else Octy_constr (tree_of_path p', tree_of_typlist true tyl) - | Tcty_signature sign -> + | Cty_signature sign -> let sty = repr sign.cty_self in let self_ty = if is_aliased sty then @@ -787,7 +789,7 @@ let rec tree_of_class_type sch params = List.fold_left (tree_of_metho sch sign.cty_concr) csil fields in Octy_signature (self_ty, List.rev csil) - | Tcty_fun (l, ty, cty) -> + | Cty_fun (l, ty, cty) -> let lab = if !print_labels && l <> "" || is_optional l then l else "" in let ty = if is_optional l then @@ -871,33 +873,33 @@ let cltype_declaration id ppf cl = (* Print a module type *) let rec tree_of_modtype = function - | Tmty_ident p -> + | Mty_ident p -> Omty_ident (tree_of_path p) - | Tmty_signature sg -> + | Mty_signature sg -> Omty_signature (tree_of_signature sg) - | Tmty_functor(param, ty_arg, ty_res) -> + | Mty_functor(param, ty_arg, ty_res) -> Omty_functor (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res) and tree_of_signature = function | [] -> [] - | Tsig_value(id, decl) :: rem -> + | Sig_value(id, decl) :: rem -> tree_of_value_description id decl :: tree_of_signature rem - | Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> + | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> tree_of_signature rem - | Tsig_type(id, decl, rs) :: rem -> + | Sig_type(id, decl, rs) :: rem -> Osig_type(tree_of_type_decl id decl, tree_of_rec rs) :: tree_of_signature rem - | Tsig_exception(id, decl) :: rem -> + | Sig_exception(id, decl) :: rem -> tree_of_exception_declaration id decl :: tree_of_signature rem - | Tsig_module(id, mty, rs) :: rem -> + | Sig_module(id, mty, rs) :: rem -> Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) :: tree_of_signature rem - | Tsig_modtype(id, decl) :: rem -> + | Sig_modtype(id, decl) :: rem -> tree_of_modtype_declaration id decl :: tree_of_signature rem - | Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> + | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> tree_of_class_declaration id decl rs :: tree_of_signature rem - | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> tree_of_cltype_declaration id decl rs :: tree_of_signature rem | _ -> assert false @@ -905,8 +907,8 @@ and tree_of_signature = function and tree_of_modtype_declaration id decl = let mty = match decl with - | Tmodtype_abstract -> Omty_abstract - | Tmodtype_manifest mty -> tree_of_modtype mty + | Modtype_abstract -> Omty_abstract + | Modtype_manifest mty -> tree_of_modtype mty in Osig_modtype (Ident.name id, mty) @@ -996,7 +998,7 @@ let rec mismatch unif = function let explanation unif t3 t4 ppf = match t3.desc, t4.desc with - | Tfield _, Tvar _ | Tvar _, Tfield _ -> + | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> fprintf ppf "@,Self type cannot escape its class" | Tconstr (p, tl, _), Tvar _ when unif && t4.level < Path.binding_time p -> diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 5417ebf41f..b546670303 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -38,20 +38,28 @@ val type_scheme_max: ?b_reset_names: bool -> (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit -val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item -val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit +val tree_of_exception_declaration: + Ident.t -> exception_declaration -> out_sig_item +val exception_declaration: + Ident.t -> formatter -> exception_declaration -> unit val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit -val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item +val tree_of_modtype_declaration: + Ident.t -> modtype_declaration -> out_sig_item +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: bool -> type_expr -> out_type val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: Ident.t -> class_declaration -> rec_status -> out_sig_item +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item +val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit diff --git a/typing/printtyped.ml b/typing/printtyped.ml new file mode 100644 index 0000000000..7c280ddcb7 --- /dev/null +++ b/typing/printtyped.ml @@ -0,0 +1,794 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Tublic License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: printast.ml 12414 2012-05-02 14:36:55Z lefessan $ *) + +open Asttypes;; +open Format;; +open Lexing;; +open Location;; +open Typedtree;; + +let fmt_position f l = + if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;; +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; + +let fmt_ident = Ident.print + +let rec fmt_path_aux f x = + match x with + | Path.Pident (s) -> fprintf f "%a" fmt_ident s; + | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s; + | Path.Papply (y, z) -> + fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z; +;; + +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; +let fmt_path_loc f x = fprintf f "\"%a\"" fmt_path_aux x.txt;; + +let fmt_constant f x = + match x with + | Const_int (i) -> fprintf f "Const_int %d" i; + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); + | Const_string (s) -> fprintf f "Const_string %S" s; + | Const_float (s) -> fprintf f "Const_float %s" s; + | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; + | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; + | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; +;; + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; +;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; +;; + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; + | Default -> fprintf f "Default"; +;; + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; +;; + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) +;; + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n"; + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n"; +;; + +let option i f ppf x = + match x with + | None -> line i ppf "None\n"; + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x; +;; + +let longident i ppf li = line i ppf "%a\n" fmt_longident li;; +let path i ppf li = line i ppf "%a\n" fmt_path li;; +let ident i ppf li = line i ppf "%a\n" fmt_ident li;; +let string i ppf s = line i ppf "\"%s\"\n" s;; +let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; +let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; +let label i ppf x = line i ppf "label=\"%s\"\n" x;; + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ctyp_loc; + let i = i+1 in + match x.ctyp_desc with + | Ttyp_any -> line i ppf "Ptyp_any\n"; + | Ttyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ttyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + string i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ttyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ttyp_constr (li, _, l) -> + line i ppf "Ptyp_constr %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed); + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ttyp_object (l) -> + line i ppf "Ptyp_object\n"; + list i core_field_type ppf l; + | Ttyp_class (li, _, l, low) -> + line i ppf "Ptyp_class %a\n" fmt_path li; + list i core_type ppf l; + list i string ppf low + | Ttyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ttyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; + core_type i ppf ct; + | Ttyp_package { pack_name = s; pack_fields = l } -> + line i ppf "Ptyp_package %a\n" fmt_path s; + list i package_with ppf l; + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident s; + core_type i ppf t + +and core_field_type i ppf x = + line i ppf "core_field_type %a\n" fmt_location x.field_loc; + let i = i+1 in + match x.field_desc with + | Tcfield (s, ct) -> + line i ppf "Pfield \"%s\"\n" s; + core_type i ppf ct; + | Tcfield_var -> line i ppf "Pfield_var\n"; + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.pat_loc; + let i = i+1 in + match x.pat_extra with + | (Tpat_unpack, _) :: rem -> + line i ppf "Tpat_unpack\n"; + pattern i ppf { x with pat_extra = rem } + | (Tpat_constraint cty, _) :: rem -> + line i ppf "Tpat_constraint\n"; + core_type i ppf cty; + pattern i ppf { x with pat_extra = rem } + | (Tpat_type (id, _), _) :: rem -> + line i ppf "Tpat_type %a\n" fmt_path id; + pattern i ppf { x with pat_extra = rem } + | [] -> + match x.pat_desc with + | Tpat_any -> line i ppf "Ppat_any\n"; + | Tpat_var (s,_) -> line i ppf "Ppat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_) -> + line i ppf "Ppat_alias \"%a\"\n" fmt_ident s; + pattern i ppf p; + | Tpat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Tpat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Tpat_construct (li, _, _, po, explicity_arity) -> + line i ppf "Ppat_construct %a\n" fmt_path li; + list i pattern ppf po; + bool i ppf explicity_arity; + | Tpat_variant (l, po, _) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Tpat_record (l, c) -> + line i ppf "Ppat_record\n"; + list i longident_x_pattern ppf l; + | Tpat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Tpat_or (p1, p2, _) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Tpat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + +and expression_extra i ppf x = + match x with + | Texp_constraint (cto1, cto2) -> + line i ppf "Pexp_constraint\n"; + option i core_type ppf cto1; + option i core_type ppf cto2; + | Texp_open (m, _, _) -> + line i ppf "Pexp_open \"%a\"\n" fmt_path m; + | Texp_poly cto -> + line i ppf "Pexp_poly\n"; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Pexp_newtype \"%s\"\n" s; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + let i = + List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1) + (i+1) x.exp_extra + in + match x.exp_desc with + | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; + | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; + | Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Texp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + expression i ppf e; + | Texp_function (p, l, _partial) -> + line i ppf "Pexp_function \"%s\"\n" p; +(* option i expression ppf eo; *) + list i pattern_x_expression_case ppf l; + | Texp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Texp_match (e, l, partial) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Texp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Texp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Texp_construct (li, _, _, eo, b) -> + line i ppf "Pexp_construct %a\n" fmt_path li; + list i expression ppf eo; + bool i ppf b; + | Texp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Texp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Texp_field (e, li, _, _) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + path i ppf li; + | Texp_setfield (e1, li, _, _, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + path i ppf li; + expression i ppf e2; + | Texp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Texp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Texp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_for (s, _, e1, e2, df, e3) -> + line i ppf "Pexp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Texp_when (e1, e2) -> + line i ppf "Pexp_when\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_send (e, Tmeth_name s, eo) -> + line i ppf "Pexp_send \"%s\"\n" s; + expression i ppf e; + option i expression ppf eo + | Texp_send (e, Tmeth_val s, eo) -> + line i ppf "Pexp_send \"%a\"\n" fmt_ident s; + expression i ppf e; + option i expression ppf eo + | Texp_new (li, _, _) -> line i ppf "Pexp_new %a\n" fmt_path li; + | Texp_setinstvar (_, s, _, e) -> + line i ppf "Pexp_setinstvar \"%a\"\n" fmt_path s; + expression i ppf e; + | Texp_override (_, l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Texp_letmodule (s, _, me, e) -> + line i ppf "Pexp_letmodule \"%a\"\n" fmt_ident s; + module_expr i ppf me; + expression i ppf e; + | Texp_assert (e) -> + line i ppf "Pexp_assert"; + expression i ppf e; + | Texp_assertfalse -> + line i ppf "Pexp_assertfalse"; + | Texp_lazy (e) -> + line i ppf "Pexp_lazy"; + expression i ppf e; + | Texp_object (s, _) -> + line i ppf "Pexp_object"; + class_structure i ppf s + | Texp_pack me -> + line i ppf "Pexp_pack"; + module_expr i ppf me +(*> JOCAML *) + | Texp_asyncsend (e1, e2) -> + line i ppf "Pexp_asyncsend\n"; + expression i ppf e1 ; + expression i ppf e2 + | Texp_spawn e -> + line i ppf "Pexp_spawn\n"; + expression i ppf e + | Texp_par (e1, e2) -> + line i ppf "Pexp_par\n"; + expression i ppf e1 ; + expression i ppf e2 + | Texp_null -> + line i ppf "Pexp_null\n" + | Texp_reply (e, id) -> + line i ppf "Pexp_reply \"%a\"\n" fmt_ident id; + expression i ppf e + | Texp_def (d,e) -> + line i ppf "Pexp_def\n" ; + list i joinautomaton ppf d ; + expression i ppf e + | Texp_loc (_, _) -> assert false +(*< JOCAML *) +and value_description i ppf x = + line i ppf "value_description\n"; + core_type (i+1) ppf x.val_desc; + list (i+1) string ppf x.val_prim; + +and string_option_underscore i ppf = + function + | Some x -> + string i ppf x.txt + | None -> + string i ppf "_" + +and type_declaration i ppf x = + line i ppf "type_declaration %a\n" fmt_location x.typ_loc; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) string_option_underscore ppf x.typ_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.typ_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.typ_manifest; + +and type_kind i ppf x = + match x with + | Ttype_abstract -> + line i ppf "Ptype_abstract\n" + | Ttype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) string_x_core_type_list_x_location ppf l; + | Ttype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; + +and exception_declaration i ppf x = list i core_type ppf x + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.cltyp_loc; + let i = i+1 in + match x.cltyp_desc with + | Tcty_constr (li, _, l) -> + line i ppf "Pcty_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Tcty_fun (l, co, cl) -> + line i ppf "Pcty_fun \"%s\"\n" l; + core_type i ppf co; + class_type i ppf cl; + +and class_signature i ppf { csig_self = ct; csig_fields = l } = + line i ppf "class_signature\n"; + core_type (i+1) ppf ct; + list (i+1) class_type_field ppf l; + +and class_type_field i ppf x = + let loc = x.ctf_loc in + match x.ctf_desc with + | Tctf_inher (ct) -> + line i ppf "Pctf_inher\n"; + class_type i ppf ct; + | Tctf_val (s, mf, vf, ct) -> + line i ppf + "Pctf_val \"%s\" %a %a %a\n" s + fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_virt (s, pf, ct) -> + line i ppf + "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_meth (s, pf, ct) -> + line i ppf + "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tctf_cstr (ct1, ct2) -> + line i ppf "Pctf_cstr %a\n" fmt_location loc; + core_type i ppf ct1; + core_type i ppf ct2; + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.cl_loc; + let i = i+1 in + match x.cl_desc with + | Tcl_ident (li, _, l) -> + line i ppf "Pcl_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Tcl_fun (l, eo, p, e, _) -> assert false (* TODO *) +(* line i ppf "Pcl_fun\n"; + label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; *) + | Tcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Tcl_let (rf, l1, l2, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l1; + list i ident_x_loc_x_expression_def ppf l2; + class_expr i ppf ce; + | Tcl_constraint (ce, Some ct, _, _, _) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Tcl_constraint (_, None, _, _, _) -> assert false + (* TODO : is it possible ? see parsetree *) + +and class_structure i ppf { cstr_pat = p; cstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = assert false (* TODO *) +(* let loc = x.cf_loc in + match x.cf_desc with + | Tcf_inher (ovf, ce, so) -> + line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; + | Tcf_valvirt (s, mf, ct) -> + line i ppf "Pcf_valvirt \"%s\" %a %a\n" + s.txt fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + | Tcf_val (s, mf, ovf, e) -> + line i ppf "Pcf_val \"%s\" %a %a %a\n" + s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Tcf_virt (s, pf, ct) -> + line i ppf "Pcf_virt \"%s\" %a %a\n" + s.txt fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Tcf_meth (s, pf, ovf, e) -> + line i ppf "Pcf_meth \"%s\" %a %a %a\n" + s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Tcf_constr (ct1, ct2) -> + line i ppf "Pcf_constr %a\n" fmt_location loc; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tcf_init (e) -> + line i ppf "Pcf_init\n"; + expression (i+1) ppf e; +*) + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.ci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.mty_loc; + let i = i+1 in + match x.mty_desc with + | Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li; + | Tmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Tmty_functor (s, _, mt1, mt2) -> + line i ppf "Pmty_functor \"%a\"\n" fmt_ident s; + module_type i ppf mt1; + module_type i ppf mt2; + | Tmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l; + | Tmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + +and signature i ppf x = list i signature_item ppf x.sig_items + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.sig_loc; + let i = i+1 in + match x.sig_desc with + | Tsig_value (s, _, vd) -> + line i ppf "Psig_value \"%a\"\n" fmt_ident s; + value_description i ppf vd; + | Tsig_type (l) -> + line i ppf "Psig_type\n"; + list i string_x_type_declaration ppf l; + | Tsig_exception (s, _, ed) -> + line i ppf "Psig_exception \"%a\"\n" fmt_ident s; + exception_declaration i ppf ed.exn_params; + | Tsig_module (s, _, mt) -> + line i ppf "Psig_module \"%a\"\n" fmt_ident s; + module_type i ppf mt; + | Tsig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i string_x_module_type ppf decls; + | Tsig_modtype (s, _, md) -> + line i ppf "Psig_modtype \"%a\"\n" fmt_ident s; + modtype_declaration i ppf md; + | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li; + | Tsig_include (mt, _) -> + line i ppf "Psig_include\n"; + module_type i ppf mt; + | Tsig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Tsig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + +and modtype_declaration i ppf x = + match x with + | Tmodtype_abstract -> line i ppf "Pmodtype_abstract\n"; + | Tmodtype_manifest (mt) -> + line i ppf "Pmodtype_manifest\n"; + module_type (i+1) ppf mt; + +and with_constraint i ppf x = + match x with + | Twith_type (td) -> + line i ppf "Pwith_type\n"; + type_declaration (i+1) ppf td; + | Twith_typesubst (td) -> + line i ppf "Pwith_typesubst\n"; + type_declaration (i+1) ppf td; + | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li; + | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li; + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.mod_loc; + let i = i+1 in + match x.mod_desc with + | Tmod_ident (li,_) -> line i ppf "Pmod_ident %a\n" fmt_path li; + | Tmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Tmod_functor (s, _, mt, me) -> + line i ppf "Pmod_functor \"%a\"\n" fmt_ident s; + module_type i ppf mt; + module_expr i ppf me; + | Tmod_apply (me1, me2, _) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> assert false (* TODO *) +(* line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; *) + | Tmod_unpack (e, _) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + +and structure i ppf x = list i structure_item ppf x.str_items + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.str_loc; + let i = i+1 in + match x.str_desc with + | Tstr_eval (e) -> + line i ppf "Pstr_eval\n"; + expression i ppf e; + | Tstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + | Tstr_primitive (s, _, vd) -> + line i ppf "Pstr_primitive \"%a\"\n" fmt_ident s; + value_description i ppf vd; + | Tstr_type l -> + line i ppf "Pstr_type\n"; + list i string_x_type_declaration ppf l; + | Tstr_exception (s, _, ed) -> + line i ppf "Pstr_exception \"%a\"\n" fmt_ident s; + exception_declaration i ppf ed.exn_params; + | Tstr_exn_rebind (s, _, li, _) -> + line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li; + | Tstr_module (s, _, me) -> + line i ppf "Pstr_module \"%a\"\n" fmt_ident s; + module_expr i ppf me; + | Tstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i string_x_modtype_x_module ppf bindings; + | Tstr_modtype (s, _, mt) -> + line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s; + module_type i ppf mt; + | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li; + | Tstr_class (l) -> + line i ppf "Pstr_class\n"; + list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); + | Tstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); + | Tstr_include (me, _) -> + line i ppf "Pstr_include"; + module_expr i ppf me +(*> JOCAML *) + | Tstr_def d -> + line i ppf "Pstr_def\n"; + list i joinautomaton ppf d + | Tstr_exn_global (path,_) -> + line i ppf "Pstr_exn_glocal %a\n" fmt_path path + | Tstr_loc _ -> assert false +(*< JOCAML *) + +and string_x_type_declaration i ppf (s, _, td) = + ident i ppf s; + type_declaration (i+1) ppf td; + +and string_x_module_type i ppf (s, _, mty) = + ident i ppf s; + module_type (i+1) ppf mty; + +and string_x_modtype_x_module i ppf (s, _, mty, modl) = + ident 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_path li; + with_constraint (i+1) ppf wc; + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf "<constraint> %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) = + line i ppf "\"%a\"\n" fmt_ident s; + list (i+1) core_type ppf l; +(* option (i+1) core_type ppf r_opt; *) + +and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) = + line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + +and string_list_x_location i ppf (l, loc) = + line i ppf "<params> %a\n" fmt_location loc; + list (i+1) string_loc ppf l; + +and longident_x_pattern i ppf (li, _, _, p) = + line i ppf "%a\n" fmt_path li; + pattern (i+1) ppf p; + +and pattern_x_expression_case i ppf (p, e) = + line i ppf "<case>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and pattern_x_expression_def i ppf (p, e) = + line i ppf "<def>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and string_x_expression i ppf (s, _, e) = + line i ppf "<override> \"%a\"\n" fmt_path s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, _, _, e) = + line i ppf "%a\n" fmt_path li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l, e, _) = + line i ppf "<label> \"%s\"\n" l; + (match e with None -> () | Some e -> expression (i+1) ppf e) + +and ident_x_loc_x_expression_def i ppf (l,_, e) = + line i ppf "<def> \"%a\"\n" fmt_ident l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x with + Ttag (l, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + list (i+1) core_type ppf ctl + | Tinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct +(*> JOCAML *) +and joinautomaton i ppf d = () +(*< JOCAML *) +;; + +let interface ppf x = list 0 signature_item ppf x.sig_items;; + +let implementation ppf x = list 0 structure_item ppf x.str_items;; diff --git a/typing/printtyped.mli b/typing/printtyped.mli new file mode 100644 index 0000000000..7bb594aaae --- /dev/null +++ b/typing/printtyped.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: printast.mli 12404 2012-04-26 13:20:09Z lefessan $ *) + +open Typedtree;; +open Format;; + +val interface : formatter -> signature -> unit;; +val implementation : formatter -> structure -> unit;; diff --git a/typing/stypes.ml b/typing/stypes.ml index 1d2c0efde3..158062f21e 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -157,7 +157,10 @@ let get_info () = let dump filename = if !Clflags.annotations then begin let info = get_info () in - let pp = formatter_of_out_channel (open_out filename) in + let pp = + match filename with + None -> std_formatter + | Some filename -> formatter_of_out_channel (open_out filename) in sort_filter_phrases (); ignore (List.fold_left (print_info pp) Location.none info); phrases := []; diff --git a/typing/stypes.mli b/typing/stypes.mli index 02cccd800d..c51c45e252 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -29,7 +29,7 @@ type annotation = val record : annotation -> unit;; val record_phrase : Location.t -> unit;; -val dump : string -> unit;; +val dump : string option -> unit;; val get_location : annotation -> Location.t;; val get_info : unit -> annotation list;; diff --git a/typing/subst.ml b/typing/subst.ml index 4a84a4e285..0a1f18016b 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -49,7 +49,7 @@ let rec modtype_path s = function Pident id as p -> begin try match Tbl.find id s.modtypes with - | Tmty_ident p -> p + | Mty_ident p -> p | _ -> fatal_error "Subst.modtype_path" with Not_found -> p end | Pdot(p, n, pos) -> @@ -110,6 +110,10 @@ let rec typexp s ty = None -> None | Some (p, tl) -> Some (type_path s p, List.map (typexp s) tl))) + | Tfield (m, k, t1, t2) + when s == identity && ty.level < generic_level && m = dummy_method -> + (* not allowed to lower the level of the dummy method *) + Tfield (m, k, t1, typexp s t2) | Tvariant row -> let row = row_repr row in let more = repr row.row_more in @@ -171,7 +175,7 @@ let type_declaration s decl = | Type_variant cstrs -> Type_variant (List.map - (fun (n, args, ret_type) -> + (fun (n, args, ret_type) -> (n, List.map (typexp s) args, may_map (typexp s) ret_type)) cstrs) | Type_record(lbls, rep) -> @@ -180,7 +184,7 @@ let type_declaration s decl = rep) end; type_manifest = - begin + begin match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) @@ -206,12 +210,12 @@ let class_signature s sign = let rec class_type s = function - Tcty_constr (p, tyl, cty) -> - Tcty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) - | Tcty_signature sign -> - Tcty_signature (class_signature s sign) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, typexp s ty, class_type s cty) + Cty_constr (p, tyl, cty) -> + Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) + | Cty_signature sign -> + Cty_signature (class_signature s sign) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, typexp s ty, class_type s cty) let class_declaration s decl = let decl = @@ -258,36 +262,36 @@ let exception_declaration s descr = let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) - | Tsig_type(id, d, _) :: sg -> + | Sig_type(id, d, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Tsig_module(id, mty, _) :: sg -> + | Sig_module(id, mty, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg - | Tsig_modtype(id, d) :: sg -> + | Sig_modtype(id, d) :: sg -> let id' = Ident.rename id in - rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s) + rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) (id' :: idents) sg - | (Tsig_value(id, _) | Tsig_exception(id, _) | - Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg -> + | (Sig_value(id, _) | Sig_exception(id, _) | + Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg let rec modtype s = function - Tmty_ident p as mty -> + Mty_ident p as mty -> begin match p with Pident id -> begin try Tbl.find id s.modtypes with Not_found -> mty end | Pdot(p, n, pos) -> - Tmty_ident(Pdot(module_path s p, n, pos)) + Mty_ident(Pdot(module_path s p, n, pos)) | Papply(p1, p2) -> fatal_error "Subst.modtype" end - | Tmty_signature sg -> - Tmty_signature(signature s sg) - | Tmty_functor(id, arg, res) -> + | Mty_signature sg -> + Mty_signature(signature s sg) + | Mty_functor(id, arg, res) -> let id' = Ident.rename id in - Tmty_functor(id', modtype s arg, + Mty_functor(id', modtype s arg, modtype (add_module id (Pident id') s) res) and signature s sg = @@ -300,26 +304,26 @@ and signature s sg = and signature_component s comp newid = match comp with - Tsig_value(id, d) -> - Tsig_value(newid, value_description s d) - | Tsig_type(id, d, rs) -> - Tsig_type(newid, type_declaration s d, rs) - | Tsig_exception(id, d) -> - Tsig_exception(newid, exception_declaration s d) - | Tsig_module(id, mty, rs) -> - Tsig_module(newid, modtype s mty, rs) - | Tsig_modtype(id, d) -> - Tsig_modtype(newid, modtype_declaration s d) - | Tsig_class(id, d, rs) -> - Tsig_class(newid, class_declaration s d, rs) - | Tsig_cltype(id, d, rs) -> - Tsig_cltype(newid, cltype_declaration s d, rs) + Sig_value(id, d) -> + Sig_value(newid, value_description s d) + | Sig_type(id, d, rs) -> + Sig_type(newid, type_declaration s d, rs) + | Sig_exception(id, d) -> + Sig_exception(newid, exception_declaration s d) + | Sig_module(id, mty, rs) -> + Sig_module(newid, modtype s mty, rs) + | Sig_modtype(id, d) -> + Sig_modtype(newid, modtype_declaration s d) + | Sig_class(id, d, rs) -> + Sig_class(newid, class_declaration s d, rs) + | Sig_class_type(id, d, rs) -> + Sig_class_type(newid, cltype_declaration s d, rs) and modtype_declaration s = function - Tmodtype_abstract -> Tmodtype_abstract - | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty) + Modtype_abstract -> Modtype_abstract + | Modtype_manifest mty -> Modtype_manifest(modtype s mty) -(* For every binding k |-> d of m1, add k |-> f d to m2 +(* For every binding k |-> d of m1, add k |-> f d to m2 and return resulting merged map. *) let merge_tbls f m1 m2 = diff --git a/typing/subst.mli b/typing/subst.mli index cf97788541..b5e2008293 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -48,7 +48,7 @@ val type_declaration: t -> type_declaration -> type_declaration val exception_declaration: t -> exception_declaration -> exception_declaration val class_declaration: t -> class_declaration -> class_declaration -val cltype_declaration: t -> cltype_declaration -> cltype_declaration +val cltype_declaration: t -> class_type_declaration -> class_type_declaration val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 5610c3e94e..cb106c8577 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -17,7 +17,6 @@ open Parsetree open Asttypes open Path open Types -open Typedtree open Typecore open Typetexp open Format @@ -50,6 +49,16 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string +open Typedtree + +let ctyp desc typ env loc = + { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env } +let cltyp desc typ env loc = + { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env } +let mkcf desc loc = { cf_desc = desc; cf_loc = loc } +let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc } + + exception Error of Location.t * error @@ -62,7 +71,7 @@ exception Error of Location.t * error Self type have a dummy private method, thus preventing it to become closed. *) -let dummy_method = Ctype.dummy_method +let dummy_method = Btype.dummy_method (* Path associated to the temporary class type of a class being typed @@ -79,20 +88,20 @@ let unbound_class = Path.Pident (Ident.create "") (* Fully expand the head of a class type *) let rec scrape_class_type = function - Tcty_constr (_, _, cty) -> scrape_class_type cty + Cty_constr (_, _, cty) -> scrape_class_type cty | cty -> cty (* Generalize a class type *) let rec generalize_class_type = function - Tcty_constr (_, params, cty) -> + Cty_constr (_, params, cty) -> List.iter Ctype.generalize params; generalize_class_type cty - | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> + | Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> Ctype.generalize sty; Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.generalize ty; generalize_class_type cty @@ -109,20 +118,20 @@ let virtual_methods sign = (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with - Tcty_constr (_, _, cty) -> + Cty_constr (_, _, cty) -> constructor_type constr cty - | Tcty_signature sign -> + | Cty_signature sign -> constr - | Tcty_fun (l, ty, cty) -> + | Cty_fun (l, ty, cty) -> Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) let rec class_body cty = match cty with - Tcty_constr (_, _, cty') -> + Cty_constr (_, _, cty') -> cty (* Only class bodies can be abbreviated *) - | Tcty_signature sign -> + | Cty_signature sign -> cty - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> class_body cty let rec extract_constraints cty = @@ -140,22 +149,22 @@ let rec extract_constraints cty = let rec abbreviate_class_type path params cty = match cty with - Tcty_constr (_, _, _) | Tcty_signature _ -> - Tcty_constr (path, params, cty) - | Tcty_fun (l, ty, cty) -> - Tcty_fun (l, ty, abbreviate_class_type path params cty) + Cty_constr (_, _, _) | Cty_signature _ -> + Cty_constr (path, params, cty) + | Cty_fun (l, ty, cty) -> + Cty_fun (l, ty, abbreviate_class_type path params cty) let rec closed_class_type = function - Tcty_constr (_, params, _) -> + Cty_constr (_, params, _) -> List.for_all Ctype.closed_schema params - | Tcty_signature sign -> + | Cty_signature sign -> Ctype.closed_schema sign.cty_self && Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) sign.cty_vars true - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.closed_schema ty && closed_class_type cty @@ -167,22 +176,23 @@ let closed_class cty = let rec limited_generalize rv = function - Tcty_constr (path, params, cty) -> + Cty_constr (path, params, cty) -> List.iter (Ctype.limited_generalize rv) params; limited_generalize rv cty - | Tcty_signature sign -> + | Cty_signature sign -> Ctype.limited_generalize rv sign.cty_self; Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) sign.cty_vars; List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) sign.cty_inher - | Tcty_fun (_, ty, cty) -> + | Cty_fun (_, ty, cty) -> Ctype.limited_generalize rv ty; limited_generalize rv cty (* Record a class type *) let rc node = - Stypes.record (Stypes.Ti_class node); + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + Stypes.record (Stypes.Ti_class node); (* moved to genannot *) node @@ -194,11 +204,14 @@ let rc node = (* Enter a value in the method environment only *) let enter_met_env ?check loc lab kind ty val_env met_env par_env = let (id, val_env) = - Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = loc} val_env + Env.enter_value lab {val_type = ty; val_kind = Val_unbound; + Types.val_loc = loc} val_env in (id, val_env, - Env.add_value ?check id {val_type = ty; val_kind = kind; val_loc = loc} met_env, - Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = loc} par_env) + Env.add_value ?check id {val_type = ty; val_kind = kind; + Types.val_loc = loc} met_env, + Env.add_value id {val_type = ty; val_kind = Val_unbound; + Types.val_loc = loc} par_env) (* Enter an instance variable in the environment *) let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = @@ -218,7 +231,8 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = let (id, _, _, _) as result = match id with Some id -> (id, val_env, met_env, par_env) | None -> - enter_met_env Location.none lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env + enter_met_env Location.none lab (Val_ivar (mut, cl_num)) + ty val_env met_env par_env in vars := Vars.add lab (id, mut, virt, ty) !vars; result @@ -230,7 +244,7 @@ let concr_vals vars = let inheritance self_type env ovf concr_meths warn_vals loc parent = match scrape_class_type parent with - Tcty_signature cl_sig -> + Cty_signature cl_sig -> (* Methods *) begin try @@ -251,7 +265,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = Some Fresh -> let cname = match parent with - Tcty_constr (p, _, _) -> Path.name p + Cty_constr (p, _, _) -> Path.name p | _ -> "inherited" in if not (Concr.is_empty over_meths) then @@ -279,9 +293,13 @@ let virtual_method val_env meths self_type lab priv sty loc = let (_, ty') = Ctype.filter_self_method val_env lab priv meths self_type in - let ty = transl_simple_type val_env false sty in - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> + raise(Error(loc, Field_type_mismatch ("method", lab, trace))); + end; + cty let delayed_meth_specs = ref [] @@ -294,24 +312,44 @@ let declare_method val_env meths self_type lab priv sty loc = raise(Error(loc, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with - Ptyp_poly ([],sty), Public -> + Ptyp_poly ([],sty'), Public -> +(* TODO: we moved the [transl_simple_type_univars] outside of the lazy, +so that we can get an immediate value. Is that correct ? Ask Jacques. *) + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in delayed_meth_specs := - lazy (unif (transl_simple_type_univars val_env sty)) :: - !delayed_meth_specs - | _ -> unif (transl_simple_type val_env false sty) + lazy ( + let cty = transl_simple_type_univars val_env sty' in + let ty = cty.ctyp_type in + unif ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: + !delayed_meth_specs; + returned_cty + | _ -> + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + unif ty; + cty let type_constraint val_env sty sty' loc = - let ty = transl_simple_type val_env false sty in - let ty' = transl_simple_type val_env false sty' in - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Unconsistent_constraint trace)) + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify trace -> + raise(Error(loc, Unconsistent_constraint trace)); + end; + (cty, cty') -let mkpat d = { ppat_desc = d; ppat_loc = Location.none } -let make_method cl_num expr = +let make_method self_loc cl_num expr = + let mkpat d = { ppat_desc = d; ppat_loc = self_loc } in + let mkid s = mkloc s self_loc in { pexp_desc = Pexp_function ("", None, - [mkpat (Ppat_alias (mkpat(Ppat_var "self-*"), - "self-" ^ cl_num)), + [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")), + mkid ("self-" ^ cl_num))), expr]); pexp_loc = expr.pexp_loc } @@ -326,42 +364,56 @@ let add_val env loc lab (mut, virt, ty) val_sig = in Vars.add lab (mut, virt, ty) val_sig -let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = - function +let rec class_type_field env self_type meths + (fields, val_sig, concr_meths, inher) ctf = + let loc = ctf.pctf_loc in + match ctf.pctf_desc with Pctf_inher sparent -> let parent = class_type env sparent in let inher = - match parent with - Tcty_constr (p, tl, _) -> (p, tl) :: inher + match parent.cltyp_type with + Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, _) = inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc - parent + parent.cltyp_type in let val_sig = Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in - (val_sig, concr_meths, inher) - - | Pctf_val (lab, mut, virt, sty, loc) -> - let ty = transl_simple_type env false sty in - (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher) - - | Pctf_virt (lab, priv, sty, loc) -> - declare_method env meths self_type lab priv sty loc; - (val_sig, concr_meths, inher) - - | Pctf_meth (lab, priv, sty, loc) -> - declare_method env meths self_type lab priv sty loc; - (val_sig, Concr.add lab concr_meths, inher) - - | Pctf_cstr (sty, sty', loc) -> - type_constraint env sty sty' loc; - (val_sig, concr_meths, inher) - -and class_signature env sty sign = + (mkctf (Tctf_inher parent) loc :: fields, + val_sig, concr_meths, inher) + + | Pctf_val (lab, mut, virt, sty) -> + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + (mkctf (Tctf_val (lab, mut, virt, cty)) loc :: fields, + add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher) + + | Pctf_virt (lab, priv, sty) -> + let cty = + declare_method env meths self_type lab priv sty ctf.pctf_loc + in + (mkctf (Tctf_virt (lab, priv, cty)) loc :: fields, + val_sig, concr_meths, inher) + + | Pctf_meth (lab, priv, sty) -> + let cty = + declare_method env meths self_type lab priv sty ctf.pctf_loc in + (mkctf (Tctf_meth (lab, priv, cty)) loc :: fields, + val_sig, Concr.add lab concr_meths, inher) + + | Pctf_cstr (sty, sty') -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + (mkctf (Tctf_cstr (cty, cty')) loc :: fields, + val_sig, concr_meths, inher) + +and class_signature env sty sign loc = let meths = ref Meths.empty in - let self_type = Ctype.expand_head env (transl_simple_type env false sty) in + let self_cty = transl_simple_type env false sty in + let self_cty = { self_cty with + ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in + let self_type = self_cty.ctyp_type in (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) @@ -375,45 +427,62 @@ and class_signature env sty sign = end; (* Class type fields *) - let (val_sig, concr_meths, inher) = + let (fields, val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) - (Vars.empty, Concr.empty, []) + ([], Vars.empty, Concr.empty, []) sign in - - {cty_self = self_type; + let cty = {cty_self = self_type; cty_vars = val_sig; cty_concr = concr_meths; cty_inher = inher} + in + { csig_self = self_cty; + csig_fields = fields; + csig_type = cty; + csig_loc = loc; + } and class_type env scty = + let loc = scty.pcty_loc in match scty.pcty_desc with Pcty_constr (lid, styl) -> - let (path, decl) = Typetexp.find_cltype env scty.pcty_loc lid in + let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in if Path.same decl.clty_path unbound_class then - raise(Error(scty.pcty_loc, Unbound_class_type_2 lid)); + raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in if List.length params <> List.length styl then raise(Error(scty.pcty_loc, - Parameter_arity_mismatch (lid, List.length params, + Parameter_arity_mismatch (lid.txt, List.length params, List.length styl))); - List.iter2 + let ctys = List.map2 (fun sty ty -> - let ty' = transl_simple_type env false sty in + let cty' = transl_simple_type env false sty in + let ty' = cty'.ctyp_type in + begin try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, Parameter_mismatch trace))) - styl params; - Tcty_constr (path, params, clty) + raise(Error(sty.ptyp_loc, Parameter_mismatch trace)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + cltyp (Tcty_constr ( path, lid , ctys)) typ env loc - | Pcty_signature (sty, sign) -> - Tcty_signature (class_signature env sty sign) + | Pcty_signature pcsig -> + let clsig = class_signature env + pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in + let typ = Cty_signature clsig.csig_type in + cltyp (Tcty_signature clsig) typ env loc | Pcty_fun (l, sty, scty) -> - let ty = transl_simple_type env false sty in - let cty = class_type env scty in - Tcty_fun (l, ty, cty) + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + let clty = class_type env scty in + let typ = Cty_fun (l, ty, clty.cltyp_type) in + cltyp (Tcty_fun (l, cty, clty)) typ env loc let class_type env scty = delayed_meth_specs := []; @@ -424,14 +493,16 @@ let class_type env scty = (*******************************) -let rec class_field cl_num self_type meths vars - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) = - function +let rec class_field self_loc cl_num self_type meths vars + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + cf = + let loc = cf.pcf_loc in + match cf.pcf_desc with Pcf_inher (ovf, sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in let inher = match parent.cl_type with - Tcty_constr (p, tl, _) -> (p, tl) :: inher + Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, warn_vals) = @@ -469,31 +540,36 @@ let rec class_field cl_num self_type meths vars (val_env, met_env, par_env) in (val_env, met_env, par_env, - lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, + lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc) + :: fields, concr_meths, warn_vals, inher) - | Pcf_valvirt (lab, mut, styp, loc) -> + | Pcf_valvirt (lab, mut, styp) -> if !Clflags.principal then Ctype.begin_def (); - let ty = Typetexp.transl_simple_type val_env false styp in + let cty = Typetexp.transl_simple_type val_env false styp in + let ty = cty.ctyp_type in if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure ty end; let (id, val_env, met_env', par_env) = - enter_val cl_num vars false lab mut Virtual ty + enter_val cl_num vars false lab.txt mut Virtual ty val_env met_env par_env loc in (val_env, met_env', par_env, - lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields, + lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty, + met_env' == met_env)) loc) + :: fields, concr_meths, warn_vals, inher) - | Pcf_val (lab, mut, ovf, sexp, loc) -> - if Concr.mem lab warn_vals then begin + | Pcf_val (lab, mut, ovf, sexp) -> + if Concr.mem lab.txt warn_vals then begin if ovf = Fresh then - Location.prerr_warning loc (Warnings.Instance_variable_override[lab]) + Location.prerr_warning lab.loc + (Warnings.Instance_variable_override[lab.txt]) end else begin if ovf = Override then - raise(Error(loc, No_overriding ("instance variable", lab))) + raise(Error(loc, No_overriding ("instance variable", lab.txt))) end; if !Clflags.principal then Ctype.begin_def (); let exp = @@ -503,35 +579,42 @@ let rec class_field cl_num self_type meths vars if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure exp.exp_type - end; + end; let (id, val_env, met_env', par_env) = - enter_val cl_num vars false lab mut Concrete exp.exp_type + enter_val cl_num vars false lab.txt mut Concrete exp.exp_type val_env met_env par_env loc in (val_env, met_env', par_env, - lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields, - concr_meths, Concr.add lab warn_vals, inher) + lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, + Tcfk_concrete exp, met_env' == met_env)) loc) + :: fields, + concr_meths, Concr.add lab.txt warn_vals, inher) - | Pcf_virt (lab, priv, sty, loc) -> - virtual_method val_env meths self_type lab priv sty loc; - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + | Pcf_virt (lab, priv, sty) -> + let cty = virtual_method val_env meths self_type lab.txt priv sty loc in + (val_env, met_env, par_env, + lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc) + ::fields, + concr_meths, warn_vals, inher) - | Pcf_meth (lab, priv, ovf, expr, loc) -> - if Concr.mem lab concr_meths then begin + | Pcf_meth (lab, priv, ovf, expr) -> + if Concr.mem lab.txt concr_meths then begin if ovf = Fresh then - Location.prerr_warning loc (Warnings.Method_override [lab]) + Location.prerr_warning loc (Warnings.Method_override [lab.txt]) end else begin - if ovf = Override then raise(Error(loc, No_overriding("method", lab))) + if ovf = Override then + raise(Error(loc, No_overriding("method", lab.txt))) end; let (_, ty) = - Ctype.filter_self_method val_env lab priv meths self_type + Ctype.filter_self_method val_env lab.txt priv meths self_type in begin try match expr.pexp_desc with Pexp_poly (sbody, sty) -> begin match sty with None -> () - | Some sty -> - Ctype.unify val_env - (Typetexp.transl_simple_type val_env false sty) ty + | Some sty -> + let cty' = Typetexp.transl_simple_type val_env false sty in + let ty' = cty'.ctyp_type in + Ctype.unify val_env ty' ty end; begin match (Ctype.repr ty).desc with Tvar _ -> @@ -546,9 +629,9 @@ let rec class_field cl_num self_type meths vars end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace))) end; - let meth_expr = make_method cl_num expr in + let meth_expr = make_method self_loc cl_num expr in (* backup variables for Pexp_override *) let vars_local = !vars in @@ -560,17 +643,22 @@ let rec class_field cl_num self_type meths vars vars := vars_local; let texp = type_expect met_env meth_expr meth_type in Ctype.end_def (); - Cf_meth (lab, texp) + mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp, + match ovf with + Override -> true + | Fresh -> false)) loc end in (val_env, met_env, par_env, field::fields, - Concr.add lab concr_meths, warn_vals, inher) + Concr.add lab.txt concr_meths, warn_vals, inher) - | Pcf_cstr (sty, sty', loc) -> - type_constraint val_env sty sty' loc; - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + | Pcf_constr (sty, sty') -> + let (cty, cty') = type_constraint val_env sty sty' loc in + (val_env, met_env, par_env, + lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields, + concr_meths, warn_vals, inher) | Pcf_init expr -> - let expr = make_method cl_num expr in + let expr = make_method self_loc cl_num expr in let vars_local = !vars in let field = lazy begin @@ -582,14 +670,18 @@ let rec class_field cl_num self_type meths vars vars := vars_local; let texp = type_expect met_env expr meth_type in Ctype.end_def (); - Cf_init texp + mkcf (Tcf_init texp) loc end in (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher) -and class_structure cl_num final val_env met_env loc (spat, str) = +and class_structure cl_num final val_env met_env loc + { pcstr_pat = spat; pcstr_fields = str } = (* Environment for substructures *) let par_env = met_env in + (* Location of self. Used for locations of self arguments *) + let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in + (* Self type, with a dummy method preventing it from being closed/escaped. *) let self_type = Ctype.newvar () in Ctype.unify val_env @@ -630,7 +722,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) = (* Typing of class fields *) let (_, _, _, fields, concr_meths, _, inher) = - List.fold_left (class_field cl_num self_type meths vars) + List.fold_left (class_field self_loc cl_num self_type meths vars) (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, []) str in @@ -639,7 +731,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) = {cty_self = public_self; cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; cty_concr = concr_meths; - cty_inher = inher} in + cty_inher = inher} in let methods = get_methods self_type in let priv_meths = List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) @@ -692,18 +784,22 @@ and class_structure cl_num final val_env met_env loc (spat, str) = let added = List.filter (fun x -> List.mem x l1) l2 in if added <> [] then Location.prerr_warning loc (Warnings.Implicit_public_methods added); - {cl_field = fields; cl_meths = meths}, - if final then sign else - {sign with cty_self = Ctype.expand_head val_env public_self} + let sign = if final then sign else + {sign with cty_self = Ctype.expand_head val_env public_self} in + { + cstr_pat = pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths}, sign (* redondant, since already in cstr_type *) and class_expr cl_num val_env met_env scl = match scl.pcl_desc with Pcl_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid in + let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in if Path.same decl.cty_path unbound_class then - raise(Error(scl.pcl_loc, Unbound_class_2 lid)); + raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt)); let tyl = List.map - (fun sty -> transl_simple_type val_env false sty, sty.ptyp_loc) + (fun sty -> transl_simple_type val_env false sty) styl in let (params, clty) = @@ -712,51 +808,54 @@ and class_expr cl_num val_env met_env scl = let clty' = abbreviate_class_type path params clty in if List.length params <> List.length tyl then raise(Error(scl.pcl_loc, - Parameter_arity_mismatch (lid, List.length params, + Parameter_arity_mismatch (lid.txt, List.length params, List.length tyl))); List.iter2 - (fun (ty',loc) ty -> + (fun cty' ty -> + let ty' = cty'.ctyp_type in try Ctype.unify val_env ty' ty with Ctype.Unify trace -> - raise(Error(loc, Parameter_mismatch trace))) + raise(Error(cty'.ctyp_loc, Parameter_mismatch trace))) tyl params; let cl = - rc {cl_desc = Tclass_ident path; + rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} in let (vals, meths, concrs) = extract_constraints clty in - rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs); + rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} | Pcl_structure cl_str -> let (desc, ty) = class_structure cl_num false val_env met_env scl.pcl_loc cl_str in - rc {cl_desc = Tclass_structure desc; + rc {cl_desc = Tcl_structure desc; cl_loc = scl.pcl_loc; - cl_type = Tcty_signature ty; + cl_type = Cty_signature ty; cl_env = val_env} | Pcl_fun (l, Some default, spat, sbody) -> let loc = default.pexp_loc in let scases = - [{ppat_loc = loc; ppat_desc = - Ppat_construct(Longident.(Ldot (Lident"*predef*", "Some")), - Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"}, - false)}, - {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")}; + [{ppat_loc = loc; ppat_desc = Ppat_construct ( + mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))), + Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")}, + false)}, + {pexp_loc = loc; pexp_desc = + Pexp_ident(mknoloc (Longident.Lident"*sth*"))}; {ppat_loc = loc; ppat_desc = - Ppat_construct(Longident.(Ldot (Lident"*predef*", "None")), + Ppat_construct(mknoloc (Longident.(Ldot (Lident"*predef*", "None"))), None, false)}, default] in let smatch = {pexp_loc = loc; pexp_desc = Pexp_match({pexp_loc = loc; pexp_desc = - Pexp_ident(Longident.Lident"*opt*")}, + Pexp_ident(mknoloc (Longident.Lident"*opt*"))}, scases)} in let sfun = {pcl_loc = scl.pcl_loc; pcl_desc = - Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, + Pcl_fun(l, None, + {ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*opt*")}, {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_let(Default, [spat, smatch], sbody)})} in @@ -772,30 +871,30 @@ and class_expr cl_num val_env met_env scl = end; let pv = List.map - (function (id, id', ty) -> + begin fun (id, id_loc, id', ty) -> let path = Pident id' in - let vd = Env.find_value path val_env' (* do not mark the value as being used *) in - (id, - { - exp_desc = Texp_ident(path, vd); - exp_loc = Location.none; + (* do not mark the value as being used *) + let vd = Env.find_value path val_env' in + (id, id_loc, + {exp_desc = + Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env' vd.val_type; - exp_env = val_env' - }) - ) + exp_env = val_env'}) + end pv in let rec not_function = function - Tcty_fun _ -> false + Cty_fun _ -> false | _ -> true in let partial = Parmatch.check_partial pat.pat_loc [pat, (* Dummy expression *) {exp_desc = Texp_constant (Asttypes.Const_int 1); - exp_loc = Location.none; + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.none; - exp_env = Env.empty }] + exp_env = Env.empty }] in Ctype.raise_nongen_level (); let cl = class_expr cl_num val_env' met_env scl' in @@ -803,16 +902,16 @@ and class_expr cl_num val_env met_env scl = if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc Warnings.Unerasable_optional_argument; - rc {cl_desc = Tclass_fun (pat, pv, cl, partial); + rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); cl_loc = scl.pcl_loc; - cl_type = Tcty_fun + cl_type = Cty_fun (l, Ctype.instance_def pat.pat_type, cl.cl_type); cl_env = val_env} | Pcl_apply (scl', sargs) -> let cl = class_expr cl_num val_env met_env scl' in let rec nonopt_labels ls ty_fun = match ty_fun with - | Tcty_fun (l, _, ty_res) -> + | Cty_fun (l, _, ty_res) -> if Btype.is_optional l then nonopt_labels ls ty_res else nonopt_labels (l::ls) ty_res | _ -> ls @@ -830,7 +929,7 @@ and class_expr cl_num val_env met_env scl = in let rec type_args args omitted ty_fun sargs more_sargs = match ty_fun with - | Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> + | Cty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> let name = Btype.label_name l and optional = if Btype.is_optional l then Optional else Required in @@ -873,7 +972,7 @@ and class_expr cl_num val_env met_env scl = else None in let omitted = if arg = None then (l,ty) :: omitted else omitted in - type_args ((arg,optional)::args) omitted ty_fun sargs more_sargs + type_args ((l,arg,optional)::args) omitted ty_fun sargs more_sargs | _ -> match sargs @ more_sargs with (l, sarg0)::_ -> @@ -884,7 +983,7 @@ and class_expr cl_num val_env met_env scl = | [] -> (List.rev args, List.fold_left - (fun ty_fun (l,ty) -> Tcty_fun(l,ty,ty_fun)) + (fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun)) ty_fun omitted) in let (args, cty) = @@ -893,7 +992,7 @@ and class_expr cl_num val_env met_env scl = else type_args [] [] cl.cl_type sargs [] in - rc {cl_desc = Tclass_apply (cl, args); + rc {cl_desc = Tcl_apply (cl, args); cl_loc = scl.pcl_loc; cl_type = cty; cl_env = val_env} @@ -906,14 +1005,15 @@ and class_expr cl_num val_env met_env scl = in let (vals, met_env) = List.fold_right - (fun id (vals, met_env) -> + (fun (id, id_loc) (vals, met_env) -> let path = Pident id in - let vd = Env.find_value path val_env in (* do not mark the value as used *) + (* do not mark the value as used *) + let vd = Env.find_value path val_env in Ctype.begin_def (); let expr = - { - exp_desc = Texp_ident(path, vd); - exp_loc = Location.none; + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env vd.val_type; exp_env = val_env; } @@ -923,18 +1023,18 @@ and class_expr cl_num val_env met_env scl = let desc = {val_type = expr.exp_type; val_kind = Val_ivar (Immutable, cl_num); - val_loc = vd.val_loc; + Types.val_loc = vd.Types.val_loc; } in let id' = Ident.create (Ident.name id) in - ((id', expr) + ((id', id_loc, expr) :: vals, Env.add_value id' desc met_env)) - (let_bound_idents defs) + (let_bound_idents_with_loc defs) ([], met_env) in let cl = class_expr cl_num val_env met_env scl' in - rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl); + rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env} @@ -950,16 +1050,19 @@ and class_expr cl_num val_env met_env scl = limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) cl.cl_type; - limited_generalize (Ctype.row_variable (Ctype.self_type clty)) clty; + limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) + clty.cltyp_type; - begin match Includeclass.class_types val_env cl.cl_type clty with + begin match + Includeclass.class_types val_env cl.cl_type clty.cltyp_type + with [] -> () | error -> raise(Error(cl.cl_loc, Class_match_failure error)) end; - let (vals, meths, concrs) = extract_constraints clty in - rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs); + let (vals, meths, concrs) = extract_constraints clty.cltyp_type in + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); cl_loc = scl.pcl_loc; - cl_type = snd (Ctype.instance_class [] clty); + cl_type = snd (Ctype.instance_class [] clty.cltyp_type); cl_env = val_env} (*******************************) @@ -1025,7 +1128,7 @@ let rec initial_env define_class approx let constr_type = approx cl.pci_expr in if !Clflags.principal then Ctype.generalize_spine constr_type; let dummy_cty = - Tcty_signature + Cty_signature { cty_self = Ctype.newvar (); cty_vars = Vars.empty; cty_concr = Concr.empty; @@ -1072,7 +1175,7 @@ let class_infos define_class kind let params = try let params, loc = cl.pci_params in - List.map (enter_type_variable true loc) params + List.map (fun x -> enter_type_variable true loc x.txt) params with Already_bound -> raise(Error(snd cl.pci_params, Repeated_parameter)) in @@ -1156,7 +1259,7 @@ let class_infos define_class kind (Ctype.instance env constr_type) with Ctype.Unify trace -> raise(Error(cl.pci_loc, - Constructor_type_mismatch (cl.pci_name, trace))) + Constructor_type_mismatch (cl.pci_name.txt, trace))) end; (* Class and class type temporary definitions *) @@ -1287,23 +1390,38 @@ let final_decl env define_class raise(Error(cl.pci_loc, Unbound_type_var(printer, reason))) end; - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, (cl.pci_variance, cl.pci_loc)) + (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, + { ci_variance = cl.pci_variance; + ci_loc = cl.pci_loc; + ci_virt = cl.pci_virt; + ci_params = cl.pci_params; +(* TODO : check that we have the correct use of identifiers *) + ci_id_name = cl.pci_name; + ci_id_class = id; + ci_id_class_type = ty_id; + ci_id_object = obj_id; + ci_id_typesharp = cl_id; + ci_expr = expr; + ci_decl = clty; + ci_type_decl = cltydef; + }) +(* (cl.pci_variance, cl.pci_loc)) *) let extract_type_decls - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, required) decls = (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls let merge_type_decls - (id, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, + (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr) + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, req) let final_env define_class env - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr) = + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coe, expr, req) = (* Add definitions after cleaning them *) Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) ( Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) ( @@ -1314,8 +1432,8 @@ let final_env define_class env (* Check that #c is coercible to c if there is a self-coercion *) let check_coercions env - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coercion_locs, expr) = + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, coercion_locs, expr, req) = begin match coercion_locs with [] -> () | loc :: _ -> let cl_ty, obj_ty = @@ -1337,8 +1455,8 @@ let check_coercions env if not (Ctype.opened_object cl_ty) then raise(Error(loc, Cannot_coerce_self obj_ty)) end; - (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, expr) + (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + arity, pub_meths, req) (*******************************) @@ -1347,8 +1465,8 @@ let type_classes define_class approx kind env cls = List.map (function cl -> (cl, - Ident.create cl.pci_name, Ident.create cl.pci_name, - Ident.create cl.pci_name, Ident.create ("#" ^ cl.pci_name))) + Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, + Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) cls in Ctype.init_def (Ident.current_time ()); @@ -1376,7 +1494,7 @@ let class_declaration env sexpr = let class_description env sexpr = let expr = class_type env sexpr in - (expr, expr) + (expr, expr.cltyp_type) let class_declarations env cls = type_classes true approx_declaration class_declaration env cls @@ -1390,14 +1508,15 @@ let class_type_declarations env cls = in (List.map (function - (_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) -> - (ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr)) + (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + _, _, ci) -> + (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci)) decl, env) let rec unify_parents env ty cl = match cl.cl_desc with - Tclass_ident p -> + Tcl_ident (p, _, _) -> begin try let decl = Env.find_class p env in let _, body = Ctype.find_cltype_for_path env decl.cty_path in @@ -1406,16 +1525,16 @@ let rec unify_parents env ty cl = Not_found -> () | exn -> assert false end - | Tclass_structure st -> unify_parents_struct env ty st - | Tclass_fun (_, _, cl, _) - | Tclass_apply (cl, _) - | Tclass_let (_, _, _, cl) - | Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl + | Tcl_structure st -> unify_parents_struct env ty st + | Tcl_fun (_, _, _, cl, _) + | Tcl_apply (cl, _) + | Tcl_let (_, _, _, cl) + | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl and unify_parents_struct env ty st = List.iter - (function Cf_inher (cl, _, _) -> unify_parents env ty cl + (function {cf_desc = Tcf_inher (_, cl, _, _, _)} -> unify_parents env ty cl | _ -> ()) - st.cl_field + st.cstr_fields let type_object env loc s = incr class_num; @@ -1438,7 +1557,8 @@ let approx_class sdecl = let self' = { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in let clty' = - { pcty_desc = Pcty_signature(self', []); + { pcty_desc = Pcty_signature { pcsig_self = self'; + pcsig_fields = []; pcsig_loc = Location.none }; pcty_loc = sdecl.pci_expr.pcty_loc } in { sdecl with pci_expr = clty' } @@ -1602,4 +1722,4 @@ let report_error ppf = function "instance variable" | No_overriding (kind, name) -> fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name - + diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 9841ed4010..3329a8206f 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -14,39 +14,70 @@ open Asttypes open Types -open Typedtree open Format val class_declarations: Env.t -> Parsetree.class_declaration list -> - (Ident.t * class_declaration * - Ident.t * cltype_declaration * + (Ident.t * string loc * class_declaration * + Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * - int * string list * class_expr) list * Env.t + int * string list * Typedtree.class_declaration) list * Env.t + +(* +and class_declaration = + (class_expr, Types.class_declaration) class_infos +*) val class_descriptions: Env.t -> Parsetree.class_description list -> - (Ident.t * class_declaration * - Ident.t * cltype_declaration * + (Ident.t * string loc * class_declaration * + Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * - int * string list * class_type) list * Env.t + int * string list * Typedtree.class_description) list * Env.t + +(* +and class_description = + (class_type, unit) class_infos +*) val class_type_declarations: Env.t -> Parsetree.class_description list -> - (Ident.t * cltype_declaration * + (Ident.t * string loc * class_type_declaration * + Ident.t * type_declaration * Ident.t * type_declaration * - Ident.t * type_declaration) list * Env.t + Typedtree.class_type_declaration) list * Env.t + +(* +and class_type_declaration = + (class_type, Types.class_type_declaration) class_infos +*) val approx_class_declarations: Env.t -> Parsetree.class_description list -> - (Ident.t * cltype_declaration * + (Ident.t * string loc * class_type_declaration * + Ident.t * type_declaration * Ident.t * type_declaration * - Ident.t * type_declaration) list + Typedtree.class_type_declaration) list val virtual_methods: Types.class_signature -> label list +(* +val type_classes : + bool -> + ('a -> Types.type_expr) -> + (Env.t -> 'a -> 'b * Types.class_type) -> + Env.t -> + 'a Parsetree.class_infos list -> + ( Ident.t * Types.class_declaration * + Ident.t * Types.class_type_declaration * + Ident.t * Types.type_declaration * + Ident.t * Types.type_declaration * + int * string list * 'b * 'b Typedtree.class_infos) + list * Env.t +*) + type error = Unconsistent_constraint of (type_expr * type_expr) list | Field_type_mismatch of string * string * (type_expr * type_expr) list diff --git a/typing/typecore.ml b/typing/typecore.ml index 0ca812b984..957eb01df6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -33,7 +33,7 @@ type error = | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t - | Label_missing of string list + | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char @@ -96,7 +96,7 @@ let type_package = let type_object = ref (fun env s -> assert false : Env.t -> Location.t -> Parsetree.class_structure -> - class_structure * class_signature * string list) + Typedtree.class_structure * Types.class_signature * string list) (* Saving and outputting type information. @@ -105,14 +105,20 @@ let type_object = or [Typedtree.pattern] that will end up in the typed AST. *) let re node = + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); Stypes.record (Stypes.Ti_expr node); node ;; let rp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); Stypes.record (Stypes.Ti_pat node); node ;; + +let snd3 (_,x,_) = x +let thd4 (_,_, x,_) = x + (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = @@ -153,7 +159,7 @@ let iter_expression f e = | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3 | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel | Pexp_letmodule (_, me, e) -> expr e; module_expr me - | Pexp_object (_, cs) -> List.iter class_field cs + | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs | Pexp_pack me -> module_expr me (*>JOCAML *) | Pexp_spawn e -> expr e @@ -204,7 +210,7 @@ let iter_expression f e = and class_expr ce = match ce.pcl_desc with | Pcl_constr _ -> () - | Pcl_structure (_, cfl) -> List.iter class_field cfl + | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs | Pcl_fun (_, eo, _, ce) -> may expr eo; class_expr ce | Pcl_apply (ce, lel) -> class_expr ce; List.iter (fun (_, e) -> expr e) lel @@ -212,10 +218,11 @@ let iter_expression f e = List.iter (fun (_, e) -> expr e) pel; class_expr ce | Pcl_constraint (ce, _) -> class_expr ce - and class_field = function + and class_field cf = + match cf.pcf_desc with | Pcf_inher (_, ce, _) -> class_expr ce - | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () - | Pcf_val (_,_,_, e, _) | Pcf_meth (_,_,_, e, _) -> expr e + | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> () + | Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e | Pcf_init e -> expr e in @@ -225,7 +232,7 @@ let iter_expression f e = let all_idents el = let idents = Hashtbl.create 8 in let f = function - | {pexp_desc=Pexp_ident (Longident.Lident id); _} -> + | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> Hashtbl.replace idents id () | _ -> () in @@ -249,15 +256,20 @@ let type_constant = function let type_option ty = newty (Tconstr(Predef.path_option,[ty], ref Mnil)) +let mkexp exp_desc exp_type exp_loc exp_env = + { exp_desc; exp_type; exp_loc; exp_env; exp_extra = [] } + let option_none ty loc = - let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in - { exp_desc = Texp_construct(cnone, []); - exp_type = ty; exp_loc = loc; exp_env = Env.initial } + let lid = Longident.Lident "None" in + let (path, cnone) = Env.lookup_constructor lid Env.initial in + mkexp (Texp_construct( path, mknoloc lid, cnone, [], false)) + ty loc Env.initial let option_some texp = - let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in - { exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc; - exp_type = type_option texp.exp_type; exp_env = texp.exp_env } + let lid = Longident.Lident "Some" in + let (path, csome) = Env.lookup_constructor lid Env.initial in + mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) ) + (type_option texp.exp_type) texp.exp_loc texp.exp_env let extract_option_type env ty = match expand_head env ty with {desc = Tconstr(path, [ty], _)} @@ -328,6 +340,7 @@ let unify_pat_types_gadt loc env ty ty' = (* Creating new conjunctive types is not allowed when typing patterns *) + let unify_pat env pat expected_ty = unify_pat_types pat.pat_loc env pat.pat_type expected_ty @@ -349,7 +362,7 @@ let finalize_variant pat = begin match opat with None -> assert false | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end - | Reither (c, l, true, e) when not row.row_fixed -> + | Reither (c, l, true, e) when not (row_fixed row) -> set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; @@ -373,11 +386,12 @@ let has_variants p = (* pattern environment *) -let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * bool (* as-variable *)) list) +let pattern_variables = ref ([] : + (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list) let pattern_force = ref ([] : (unit -> unit) list) let pattern_scope = ref (None : Annot.ident option);; let allow_modules = ref false -let module_variables = ref ([] : (string * Location.t) list) +let module_variables = ref ([] : (string loc * Location.t) list) let reset_pattern scope allow = pattern_variables := []; pattern_force := []; @@ -387,24 +401,26 @@ let reset_pattern scope allow = ;; let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = - if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables - then raise(Error(loc, Multiply_bound_variable name)); - let id = Ident.create name in - pattern_variables := (id, ty, loc, is_as_variable) :: !pattern_variables; + if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) + !pattern_variables + then raise(Error(loc, Multiply_bound_variable name.txt)); + let id = Ident.create name.txt in + pattern_variables := + (id, ty, name, loc, is_as_variable) :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Modules_not_allowed)); module_variables := (name, loc) :: !module_variables - end else begin - match !pattern_scope with - | None -> () - | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); - end; + end else + (* moved to genannot *) + may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) + !pattern_scope; id let sort_pattern_variables vs = List.sort - (fun (x,_,_,_) (y,_,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y)) + (fun (x,_,_,_,_) (y,_,_,_,_) -> + Pervasives.compare (Ident.name x) (Ident.name y)) vs let enter_orpat_variables loc env p1_vs p2_vs = @@ -414,7 +430,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = and p2_vs = sort_pattern_variables p2_vs in let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with - | (x1,t1,l1,a1)::rem1, (x2,t2,l2,a2)::rem2 when Ident.equal x1 x2 -> + | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 else begin @@ -427,9 +443,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) - | [],(x,_,_,_)::_ -> raise (Error (loc, Orpat_vars x)) - | (x,_,_,_)::_, (y,_,_,_)::_ -> + | (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) + | [],(x,_,_,_,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in @@ -438,11 +454,11 @@ let enter_orpat_variables loc env p1_vs p2_vs = let rec build_as_type env p = match p.pat_desc with - Tpat_alias(p1, _) -> build_as_type env p1 + Tpat_alias(p1,_, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) - | Tpat_construct(cstr, pl) -> + | Tpat_construct(_, _, cstr, pl,_) -> let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in if keep then p.pat_type else let tyl = List.map (build_as_type env) pl in @@ -455,11 +471,11 @@ let rec build_as_type env p = newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); row_bound=(); row_name=None; row_fixed=false; row_closed=false}) - | Tpat_record lpl -> - let lbl = fst(List.hd lpl) in + | Tpat_record (lpl,_) -> + let lbl = thd4 (List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else let ty = newvar () in - let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in + let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; @@ -508,7 +524,7 @@ let build_or_pat env loc lid = (l, Reither(true,[], true, ref None)) :: fields | Rpresent (Some ty) -> (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; - pat_type=ty}) + pat_type=ty; pat_extra=[];}) :: pats, (l, Reither(false, [ty], true, ref None)) :: fields | _ -> pats, fields) @@ -522,7 +538,7 @@ let build_or_pat env loc lid = let row' = ref {row with row_more=newvar()} in let pats = List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; - pat_env=env; pat_type=ty}) + pat_env=env; pat_type=ty; pat_extra=[];}) pats in match pats with @@ -530,38 +546,41 @@ let build_or_pat env loc lid = | pat :: pats -> let r = List.fold_left - (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); + (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; pat_loc=gloc; pat_env=env; pat_type=ty}) pat pats in - (rp { r with pat_loc = loc },ty) + (path, rp { r with pat_loc = loc },ty) (* Records *) let rec find_record_qual = function | [] -> None - | (Longident.Ldot (modname, _), _) :: _ -> Some modname + | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest -let type_label_a_list ?labels env loc type_lbl_a lid_a_list = +let type_label_a_list ?labels env type_lbl_a lid_a_list = let record_qual = find_record_qual lid_a_list in let lbl_a_list = List.map (fun (lid, a) -> - match lid, labels, record_qual with - Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> - Hashtbl.find labels s, a - | Longident.Lident s, _, Some modname -> - Typetexp.find_label env loc (Longident.Ldot (modname, s)), a - | _ -> - Typetexp.find_label env loc lid, a) - lid_a_list in + let path, label = + match lid.txt, labels, record_qual with + Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> + (Hashtbl.find labels s : Path.t * Types.label_description) + | Longident.Lident s, _, Some modname -> + Typetexp.find_label env lid.loc (Longident.Ldot (modname, s)) + | _ -> + Typetexp.find_label env lid.loc lid.txt + in (path, lid, label, a) + ) lid_a_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort - (fun (lbl1,_) (lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + (fun ( _, _, lbl1,_) ( _,_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in List.map type_lbl_a lbl_a_list +;; let lid_of_label label = match repr label.lbl_res with @@ -575,10 +594,10 @@ let lid_of_label label = let check_recordpat_labels loc lbl_pat_list closed = match lbl_pat_list with | [] -> () (* should not happen *) - | (label1, _) :: _ -> + | (_, _, label1, _) :: _ -> let all = label1.lbl_all in let defined = Array.make (Array.length all) false in - let check_defined (label, _) = + let check_defined (_, _, label, _) = if defined.(label.lbl_pos) then raise(Error(loc, Label_multiply_defined (Longident.Lident label.lbl_name))) @@ -626,28 +645,30 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = Ppat_any -> rp { pat_desc = Tpat_any; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_var name -> let id = enter_variable loc name expected_ty in rp { - pat_desc = Tpat_var id; - pat_loc = loc; + pat_desc = Tpat_var (id, name); + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_unpack name -> let id = enter_variable loc name expected_ty ~is_module:true in rp { - pat_desc = Tpat_var id; - pat_loc = loc; + pat_desc = Tpat_var (id, name); + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, loc]; pat_type = expected_ty; pat_env = !env } - | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc}, + | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, ({ptyp_desc=Ptyp_poly _} as sty)) -> (* explicitly polymorphic type *) - let ty, force = Typetexp.transl_simple_type_delayed !env sty in - unify_pat_types loc !env ty expected_ty; + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + unify_pat_types lloc !env ty expected_ty; pattern_force := force :: !pattern_force; begin match ty.desc with | Tpoly (body, tyl) -> @@ -655,11 +676,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let _, ty' = instance_poly ~keep_names:true false tyl body in end_def (); generalize ty'; - let id = enter_variable loc name ty' in - rp { pat_desc = Tpat_var id; - pat_loc = loc; - pat_type = ty; - pat_env = !env } + let id = enter_variable lloc name ty' in + rp { + pat_desc = Tpat_var (id, name); + pat_loc = lloc; + pat_extra = [Tpat_constraint cty, loc]; + pat_type = ty; + pat_env = !env + } | _ -> assert false end | Ppat_alias(sq, name) -> @@ -670,15 +694,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = generalize ty_var; let id = enter_variable ~is_as_variable:true loc name ty_var in rp { - pat_desc = Tpat_alias(q, id); - pat_loc = loc; + pat_desc = Tpat_alias(q, id, name); + pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_env = !env } | Ppat_constant cst -> unify_pat_types loc !env (type_constant cst) expected_ty; rp { pat_desc = Tpat_constant cst; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_tuple spl -> @@ -688,16 +712,17 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in rp { pat_desc = Tpat_tuple pl; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_construct(lid, sarg, explicit_arity) -> - let constr = - match lid, constrs with + let (constr_path, constr) = + match lid.txt, constrs with Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> Hashtbl.find constrs s - | _ -> Typetexp.find_constructor !env loc lid + | _ -> Typetexp.find_constructor !env loc lid.txt in + Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; if no_existentials && constr.cstr_existentials <> [] then raise (Error (loc, Unexpected_existential)); (* if constructor is gadt, we must verify that the expected type has the @@ -716,7 +741,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then - raise(Error(loc, Constructor_arity_mismatch(lid, + raise(Error(loc, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = instance_constructor ~in_pattern:(env, get_newtype_level ()) constr @@ -727,8 +752,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types loc !env ty_res expected_ty; let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in rp { - pat_desc = Tpat_construct(constr, args); - pat_loc = loc; + pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity); + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_variant(l, sarg) -> @@ -744,11 +769,11 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types loc !env (newty (Tvariant row)) expected_ty; rp { pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_record(lid_sp_list, closed) -> - let type_label_pat (label, sarg) = + let type_label_pat (label_path, label_lid, label, sarg) = begin_def (); let (vars, ty_arg, ty_res) = instance_label false label in if vars = [] then end_def (); @@ -768,14 +793,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = if List.exists instantiated vars then raise (Error(loc, Polymorphic_label (lid_of_label label))) end; - (label, arg) + (label_path, label_lid, label, arg) in let lbl_pat_list = - type_label_a_list ?labels !env loc type_label_pat lid_sp_list in + type_label_a_list ?labels !env type_label_pat lid_sp_list in check_recordpat_labels loc lbl_pat_list closed; rp { - pat_desc = Tpat_record lbl_pat_list; - pat_loc = loc; + pat_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_array spl -> @@ -786,7 +811,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in rp { pat_desc = Tpat_array pl; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_or(sp1, sp2) -> @@ -801,23 +826,25 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pattern_variables := p1_variables; rp { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None); - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_lazy sp1 -> let nv = newvar () in - unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty; + unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) + expected_ty; let p1 = type_pat sp1 nv in rp { pat_desc = Tpat_lazy p1; - pat_loc = loc; + pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_constraint(sp, sty) -> (* Separate when not already separated by !principal *) let separate = true in if separate then begin_def(); - let ty, force = Typetexp.transl_simple_type_delayed !env sty in + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in let ty, expected_ty' = if separate then begin end_def(); @@ -833,15 +860,18 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pattern_force := force :: !pattern_force; if separate then match p.pat_desc with - Tpat_var id -> + Tpat_var (id,s) -> {p with pat_type = ty; - pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id)} - | _ -> {p with pat_type = ty} + pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s); + pat_extra = [Tpat_constraint cty, loc]; + } + | _ -> {p with pat_type = ty; + pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra} else p | Ppat_type lid -> - let (r,ty) = build_or_pat !env loc lid in + let (path, p,ty) = build_or_pat !env loc lid.txt in unify_pat_types loc !env ty expected_ty; - r + { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra } let type_pat ?(allow_existentials=false) ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty = @@ -888,10 +918,10 @@ let rec iter3 f lst1 lst2 lst3 = let add_pattern_variables ?check ?check_as env = let pv = get_ref pattern_variables in (List.fold_right - (fun (id, ty, loc, as_var) env -> + (fun (id, ty, name, loc, as_var) env -> let check = if as_var then check_as else check in let e1 = Env.add_value ?check id - {val_type = ty; val_kind = Val_reg; val_loc = loc} env in + {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in Env.add_annot id (Annot.Iref_internal loc) e1) pv env, get_ref module_variables) @@ -925,15 +955,15 @@ let type_class_arg_pattern cl_num val_env met_env l spat = if is_optional l then unify_pat val_env pat (type_option (newvar ())); let (pv, met_env) = List.fold_right - (fun (id, ty, loc, as_var) (pv, env) -> + (fun (id, ty, name, loc, as_var) (pv, env) -> let check s = if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in let id' = Ident.create (Ident.name id) in - ((id', id, ty)::pv, + ((id', name, id, ty)::pv, Env.add_value id' {val_type = ty; val_kind = Val_ivar (Immutable, cl_num); - val_loc = loc; + Types.val_loc = loc; } ~check env)) !pattern_variables ([], met_env) @@ -945,8 +975,8 @@ let mkpat d = { ppat_desc = d; ppat_loc = Location.none } let type_self_pattern cl_num privty val_env met_env par_env spat = let spat = - mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")), - "selfpat-" ^ cl_num)) + mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")), + mknoloc ("selfpat-" ^ cl_num))) in reset_pattern None false; let nv = newvar() in @@ -958,20 +988,20 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = pattern_variables := []; let (val_env, met_env, par_env) = List.fold_right - (fun (id, ty, loc, as_var) (val_env, met_env, par_env) -> + (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound; - val_loc = loc; + Types.val_loc = loc; } val_env, Env.add_value id {val_type = ty; val_kind = Val_self (meths, vars, cl_num, privty); - val_loc = loc; + Types.val_loc = loc; } ~check:(fun s -> if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s) met_env, Env.add_value id {val_type = ty; val_kind = Val_unbound; - val_loc = loc; + Types.val_loc = loc; } par_env)) pv (val_env, met_env, par_env) in @@ -987,6 +1017,9 @@ let force_delayed_checks () = reset_delayed_checks (); Btype.backtrack snap +let fst3 (x, _, _) = x +let snd3 (_, x, _) = x + (*> JOCAML *) (**************************) (* Collecting port names *) @@ -1016,21 +1049,20 @@ let reset_reaction scp = (* get or create channel identifier *) let create_channel chan = - let name = chan.pjident_desc in + let name = chan.txt in let rec do_rec = function | [] -> (* add a new channel *) (* Channels must differ from other ids in set of join definitions *) let p id = Ident.name id = name in if List.exists p !def_ids then - raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; - let id = Ident.create chan.pjident_desc + raise (Error (chan.loc, Multiply_bound_variable name)) ; + let id = Ident.create name and ty = newvar() - and loc = chan.pjident_loc + and loc = chan.loc and ty_arg = newvar() in def_ids := id :: !def_ids ; auto_chans := (id, ty, loc, ty_arg) :: !auto_chans ; begin - let name = chan.pjident_desc in match !def_scope with | None -> () | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); @@ -1045,10 +1077,10 @@ let create_channel chan = let enter_channel chan = (* Channels must differ from other channels in reaction rule *) - let name = chan.pjident_desc in + let name = chan.txt in let p id = id = name in if List.exists p !reaction_chans then - raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; + raise (Error (chan.loc, Multiply_bound_variable name)) ; reaction_chans := name :: !reaction_chans ; create_channel chan @@ -1079,7 +1111,7 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (fun sjpat -> let schan, sarg = sjpat.pjpat_desc in let (id, ty, ty_arg) = enter_channel schan in - let chan = mk_jident id schan.pjident_loc ty tenv + let chan = mk_jident id schan.loc ty tenv and arg = let rtenv = ref tenv and ty_pat = newvar () in @@ -1170,45 +1202,51 @@ let type_autos_lhs env autos scope = let rec is_nonexpansive exp = match exp.exp_desc with - Texp_ident(_,_) -> true + Texp_ident(_,_,_) -> true | Texp_constant _ -> true | Texp_let(rec_flag, pat_exp_list, body) -> List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list && is_nonexpansive body | Texp_function _ -> true - | Texp_apply(e, (None,_)::el) -> - is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el) + | Texp_apply(e, (_,None,_)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) | Texp_tuple el -> List.for_all is_nonexpansive el - | Texp_construct(_, el) -> + | Texp_construct(_, _, _, el,_) -> List.for_all is_nonexpansive el | Texp_variant(_, arg) -> is_nonexpansive_opt arg | Texp_record(lbl_exp_list, opt_init_exp) -> List.for_all - (fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) + (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) lbl_exp_list && is_nonexpansive_opt opt_init_exp - | Texp_field(exp, lbl) -> is_nonexpansive exp + | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp | Texp_array [] -> true | Texp_ifthenelse(cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> + | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e - | Texp_object ({cl_field=fields}, {cty_vars=vars}, _) -> + | Texp_object ({cstr_fields=fields; cstr_type = { cty_vars=vars}}, _) -> let count = ref 0 in List.for_all - (function - Cf_meth _ -> true - | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e - | Cf_init e -> is_nonexpansive e - | Cf_inher _ -> false) + (fun field -> match field.cf_desc with + Tcf_meth _ -> true + | Tcf_val (_,_, _, _, Tcfk_concrete e,_) -> + incr count; is_nonexpansive e + | Tcf_val (_,_, _, _, Tcfk_virtual _,_) -> + incr count; true + | Tcf_init e -> is_nonexpansive e + | Tcf_constr _ -> true + | Tcf_inher _ -> false) fields && Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 + | Texp_letmodule (_, _, mexp, e) -> + is_nonexpansive_mod mexp && is_nonexpansive e | Texp_pack mexp -> is_nonexpansive_mod mexp | _ -> false @@ -1218,17 +1256,18 @@ and is_nonexpansive_mod mexp = | Tmod_ident _ -> true | Tmod_functor _ -> true | Tmod_unpack (e, _) -> is_nonexpansive e - | Tmod_constraint (m, _, _) -> is_nonexpansive_mod m - | Tmod_structure items -> + | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m + | Tmod_structure str -> List.for_all - (function + (fun item -> match item.str_desc with | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ - | Tstr_open _ | Tstr_cltype _ | Tstr_exn_rebind _ -> true + | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list - | Tstr_module (_, m) | Tstr_include (m, _) -> is_nonexpansive_mod m + | Tstr_module (_, _, m) | Tstr_include (m, _) -> is_nonexpansive_mod m | Tstr_recmodule id_mod_list -> - List.for_all (fun (_, m) -> is_nonexpansive_mod m) id_mod_list + List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m) + id_mod_list | Tstr_exception _ -> false (* true would be unsound *) | Tstr_class _ -> false (* could be more precise *) (*>JOCAML*) @@ -1236,7 +1275,7 @@ and is_nonexpansive_mod mexp = | Tstr_exn_global (_, _)|Tstr_loc _|Tstr_def _ -> false (*<JOCAML*) ) - items + str.str_items | Tmod_apply _ -> false and is_nonexpansive_opt = function @@ -1459,7 +1498,7 @@ let rec approx_type env sty = newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> begin try - let (path, decl) = Env.lookup_type lid env in + let (path, decl) = Env.lookup_type lid.txt env in if List.length ctl <> decl.type_arity then raise Not_found; let tyl = List.map (approx_type env) ctl in newconstr path tyl @@ -1560,26 +1599,30 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* Helpers for packaged modules. *) let create_package_type loc env (p, l) = let s = !Typetexp.transl_modtype_longident loc env p in - newty (Tpackage (s, - List.map fst l, - List.map (Typetexp.transl_simple_type env false) - (List.map snd l))) + let fields = List.map (fun (name, ct) -> + name, Typetexp.transl_simple_type env false ct) l in + let ty = newty (Tpackage (s, + List.map fst l, + List.map (fun (_, cty) -> cty.ctyp_type) fields)) + in + (s, fields, ty) -let wrap_unpacks sexp unpacks = - List.fold_left - (fun sexp (name, loc) -> - {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule ( - name, - {pmod_loc = loc; pmod_desc = Pmod_unpack - {pexp_desc=Pexp_ident(Longident.Lident name); pexp_loc=loc}}, + let wrap_unpacks sexp unpacks = + List.fold_left + (fun sexp (name, loc) -> + {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule ( + name, + {pmod_loc = loc; pmod_desc = Pmod_unpack + {pexp_desc=Pexp_ident(mkloc (Longident.Lident name.txt) name.loc); + pexp_loc=name.loc}}, sexp)}) sexp unpacks (* Helpers for type_cases *) -let iter_ppat f p = +let iter_ppat f p = match p.ppat_desc with - | Ppat_any | Ppat_var _ | Ppat_constant _ - | Ppat_type _ | Ppat_unpack _ -> () + | Ppat_any | Ppat_var _ | Ppat_constant _ + | Ppat_type _ | Ppat_unpack _ -> () | Ppat_array pats -> List.iter f pats | Ppat_or (p1,p2) -> f p1; f p2 | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg @@ -1600,7 +1643,8 @@ let contains_gadt env p = match p.ppat_desc with Ppat_construct (lid, _, _) -> begin try - if (Env.lookup_constructor lid env).cstr_generalized then raise Exit + let (_path, cstr) = Env.lookup_constructor lid.txt env in + if cstr.cstr_generalized then raise Exit with Not_found -> () end; iter_ppat loop p | _ -> iter_ppat loop p @@ -1687,6 +1731,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = + Cmt_format.add_saved_type (Cmt_format.Partial_expression exp); Stypes.record (Stypes.Ti_expr exp); unify_exp env exp (instance env ty_expected); exp @@ -1696,13 +1741,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = check_expression ctx sexp ; begin if !Clflags.annotations then begin - try let (path, annot) = Env.lookup_annot lid env in + try let (path, annot) = Env.lookup_annot lid.txt env in Stypes.record (Stypes.An_ident ( loc, Path.name ~paren:Oprint.parenthesized_ident path, annot)) with _ -> () end; - let (path, desc) = Typetexp.find_value env loc lid in + let (path, desc) = Typetexp.find_value env loc lid.txt in rue { exp_desc = begin match desc.val_kind with @@ -1710,45 +1755,48 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let (self_path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in - Texp_instvar(self_path, path) + Texp_instvar(self_path, path, + match lid.txt with + Longident.Lident txt -> { txt; loc = lid.loc } + | _ -> assert false) | Val_self (_, _, cl_num, _) -> let (path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in - Texp_ident(path, desc) + Texp_ident(path, lid, desc) | Val_unbound -> - raise(Error(loc, Masked_instance_variable lid)) + raise(Error(loc, Masked_instance_variable lid.txt)) | _ -> - Texp_ident(path, desc) + Texp_ident(path, lid, desc) end; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env desc.val_type; exp_env = env } end | Pexp_constant(Const_int 0) when ctx=P -> rue { - exp_desc = Texp_null; - exp_loc = sexp.pexp_loc; - exp_type = Predef.type_process []; - exp_env = env; } + exp_desc = Texp_null; + exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = Predef.type_process []; + exp_env = env; } | Pexp_constant(Const_string s as cst) -> check_expression ctx sexp ; rue { - exp_desc = Texp_constant cst; - exp_loc = loc; - exp_type = - (* Terrible hack for format strings *) - begin match (repr (expand_head env ty_expected)).desc with - Tconstr(path, _, _) when Path.same path Predef.path_format6 -> - type_format loc s - | _ -> instance_def Predef.type_string - end; - exp_env = env } + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = + (* Terrible hack for format strings *) + begin match (repr (expand_head env ty_expected)).desc with + Tconstr(path, _, _) when Path.same path Predef.path_format6 -> + type_format loc s + | _ -> instance_def Predef.type_string + end; + exp_env = env } | Pexp_constant cst -> check_expression ctx sexp ; rue { exp_desc = Texp_constant cst; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = type_constant cst; exp_env = env } | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat -> @@ -1767,10 +1815,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let body = do_type_expect ctx new_env (wrap_unpacks sbody unpacks) ty_expected in re { - exp_desc = Texp_let(rec_flag, pat_exp_list, body); - exp_loc = loc; - exp_type = body.exp_type; - exp_env = env } + exp_desc = Texp_let(rec_flag, pat_exp_list, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_env = env } | Pexp_function (l, Some default, [spat, sbody]) -> check_expression ctx sexp ; let default_loc = default.pexp_loc in @@ -1778,14 +1826,16 @@ and do_type_expect ?in_function ctx env sexp ty_expected = {ppat_loc = default_loc; ppat_desc = Ppat_construct - (Longident.(Ldot (Lident "*predef*", "Some")), - Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"}, + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))), + Some {ppat_loc = default_loc; + ppat_desc = Ppat_var (mknoloc "*sth*")}, false)}, {pexp_loc = default_loc; - pexp_desc = Pexp_ident(Longident.Lident "*sth*")}; + pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))}; {ppat_loc = default_loc; ppat_desc = Ppat_construct - (Longident.(Ldot (Lident "*predef*", "None")), None, false)}, + (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))), + None, false)}, default; ] in let smatch = { @@ -1793,7 +1843,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = pexp_desc = Pexp_match ({ pexp_loc = loc; - pexp_desc = Pexp_ident(Longident.Lident "*opt*") + pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*")) }, scases ) @@ -1804,7 +1854,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Pexp_function ( l, None, [ {ppat_loc = loc; - ppat_desc = Ppat_var "*opt*"}, + ppat_desc = Ppat_var (mknoloc "*opt*")}, {pexp_loc = loc; pexp_desc = Pexp_let(Default, [spat, smatch], sbody); } @@ -1856,8 +1906,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Location.prerr_warning (fst (List.hd cases)).pat_loc Warnings.Unerasable_optional_argument; re { - exp_desc = Texp_function(cases, partial); - exp_loc = loc; + exp_desc = Texp_function(l,cases, partial); + exp_loc = loc; exp_extra = []; exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); exp_env = env } | Pexp_apply(sfunct, sargs) -> @@ -1888,7 +1938,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = unify_var env (newvar()) funct.exp_type; rue { exp_desc = Texp_apply(funct, args); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } | P -> @@ -1918,9 +1968,9 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (sarg.pexp_loc, Garrigue_illegal "message"))) ty in rue { exp_desc = Texp_asyncsend (funct, arg); - exp_loc = sexp.pexp_loc; - exp_type = Predef.type_process [] ; - exp_env = env } + exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = Predef.type_process [] ; + exp_env = env } end | Pexp_match(sarg, caselist) -> begin_def (); @@ -1932,13 +1982,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = type_cases ctx env arg.exp_type ty_expected true loc caselist in re { - exp_desc = Texp_match(arg, cases, partial); - exp_loc = loc; - exp_type = - (match ctx with - | E -> instance env ty_expected - | P -> Predef.type_process reps); - exp_env = env } + exp_desc = Texp_match(arg, cases, partial); + exp_loc = loc; exp_extra = []; + exp_type = + (match ctx with + | E -> instance env ty_expected + | P -> Predef.type_process reps); + exp_env = env } | Pexp_try(sbody, caselist) -> check_expression ctx sexp ; let body = do_type_expect ctx env sbody ty_expected in @@ -1946,7 +1996,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = type_cases ctx env Predef.type_exn ty_expected false loc caselist in re { exp_desc = Texp_try(body, cases); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_tuple sexpl -> @@ -1959,7 +2009,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = in re { exp_desc = Texp_tuple expl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; (* Keep sharing *) exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); exp_env = env } @@ -1979,7 +2029,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Rpresent (Some ty), Rpresent (Some ty0) -> let arg = type_argument env sarg ty ty0 in re { exp_desc = Texp_variant(l, Some arg); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ty_expected0; exp_env = env } | _ -> raise Not_found @@ -1990,7 +2040,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let arg_type = may_map (fun arg -> arg.exp_type) arg in rue { exp_desc = Texp_variant(l, arg); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; row_more = newvar (); row_bound = (); @@ -2002,24 +2052,25 @@ and do_type_expect ?in_function ctx env sexp ty_expected = | Pexp_record(lid_sexp_list, opt_sexp) -> check_expression ctx sexp ; let lbl_exp_list = - type_label_a_list env loc (type_label_exp true env loc ty_expected) + type_label_a_list env (type_label_exp true env loc ty_expected) lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with - ((lid, _) :: rem1, (lbl, _) :: rem2) -> + ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) -> if List.mem lbl.lbl_pos seen_pos - then raise(Error(loc, Label_multiply_defined lid)) + then raise(Error(loc, Label_multiply_defined lid.txt)) else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2 | (_, _) -> () in check_duplicates [] lid_sexp_list lbl_exp_list; let opt_exp = match opt_sexp, lbl_exp_list with None, _ -> None - | Some sexp, (lbl, _) :: _ -> + | Some sexp, (_, _, lbl, _) :: _ -> if !Clflags.principal then begin_def (); let ty_exp = newvar () in let unify_kept lbl = - if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos) + if List.for_all + (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos) lbl_exp_list then begin let _, ty_arg1, ty_res1 = instance_label false lbl @@ -2038,10 +2089,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = in let num_fields = match lbl_exp_list with [] -> assert false - | (lbl,_)::_ -> Array.length lbl.lbl_all in + | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin let present_indices = - List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in + List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in let label_names = extract_label_names sexp env ty_expected in let rec missing_labels n = function [] -> [] @@ -2056,31 +2107,32 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Location.prerr_warning loc Warnings.Useless_record_with; re { exp_desc = Texp_record(lbl_exp_list, opt_exp); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_field(sarg, lid) -> check_expression ctx sexp ; let arg = do_type_exp ctx env sarg in - let label = Typetexp.find_label env loc lid in + let (label_path,label) = Typetexp.find_label env loc lid.txt in let (_, ty_arg, ty_res) = instance_label false label in unify_exp env arg ty_res; rue { - exp_desc = Texp_field(arg, label); - exp_loc = loc; + exp_desc = Texp_field(arg, label_path, lid, label); + exp_loc = loc; exp_extra = []; exp_type = ty_arg; exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> check_expression ctx sexp ; let record = do_type_exp ctx env srecord in - let label = Typetexp.find_label env loc lid in - let (label, newval) = - type_label_exp false env loc record.exp_type (label, snewval) in + let (label_path, label) = Typetexp.find_label env loc lid.txt in + let (label_path, label_loc, label, newval) = + type_label_exp false env loc record.exp_type + (label_path, lid, label, snewval) in if label.lbl_mut = Immutable then - raise(Error(loc, Label_not_mutable lid)); + raise(Error(loc, Label_not_mutable lid.txt)); rue { - exp_desc = Texp_setfield(record, label, newval); - exp_loc = loc; + exp_desc = Texp_setfield(record, label_path, label_loc, label, newval); + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_array(sargl) -> @@ -2091,7 +2143,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let argl = List.map (fun sarg -> do_type_expect ctx env sarg ty) sargl in re { exp_desc = Texp_array argl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> @@ -2103,7 +2155,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let ifso = do_type_expect ctx env sifso Predef.type_unit in rue { exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } | Some sifnot -> @@ -2112,8 +2164,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (* Keep sharing *) unify_exp env ifnot ifso.exp_type; re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = loc; + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } end @@ -2125,10 +2177,10 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let rep1 = Typejoin.get_replies ifso in re { exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = - Predef.type_process - (Typejoin.inter sexp.pexp_loc rep1 []); + Predef.type_process + (Typejoin.inter sexp.pexp_loc rep1 []); exp_env = env } with Typejoin.MissingRight id -> raise (Error (sifso.pexp_loc, ExtraReply id)) @@ -2140,12 +2192,12 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let repso = Typejoin.get_replies ifso and repnot = Typejoin.get_replies ifnot in re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = sexp.pexp_loc; - exp_type = - Predef.type_process - (Typejoin.inter sexp.pexp_loc repso repnot) ; - exp_env = env } + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = sexp.pexp_loc; exp_extra=[]; + exp_type = + Predef.type_process + (Typejoin.inter sexp.pexp_loc repso repnot) ; + exp_env = env } with | Typejoin.MissingRight id -> raise (Error (sifnot.pexp_loc, MissingReply id)) @@ -2161,69 +2213,70 @@ and do_type_expect ?in_function ctx env sexp ty_expected = | P -> do_type_expect E env sexp1 Predef.type_unit in let exp2 = do_type_expect ctx env sexp2 ty_expected in re { - exp_desc = Texp_sequence(exp1, exp2); - exp_loc = loc; - exp_type = exp2.exp_type; - exp_env = env } + exp_desc = Texp_sequence(exp1, exp2); + exp_loc = loc; exp_extra = []; + exp_type = exp2.exp_type; + exp_env = env } | Pexp_while(scond, sbody) -> check_expression ctx sexp; let cond = do_type_expect E env scond Predef.type_bool in let body = type_statement env sbody in rue { exp_desc = Texp_while(cond, body); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_for(param, slow, shigh, dir, sbody) -> let low = do_type_expect E env slow Predef.type_int in let high = do_type_expect E env shigh Predef.type_int in let (id, new_env) = - Env.enter_value param {val_type = instance_def Predef.type_int; - val_kind = Val_reg; - val_loc = loc; - } env + Env.enter_value param.txt {val_type = instance_def Predef.type_int; + val_kind = Val_reg; Types.val_loc = loc; } env ~check:(fun s -> Warnings.Unused_for_index s) in begin match ctx with | E -> let body = type_statement new_env sbody in rue { - exp_desc = Texp_for(id, low, high, dir, body); - exp_loc = loc; - exp_type = instance_def Predef.type_unit; - exp_env = env } + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_env = env } | P -> (* Remove continuation, so as to statically enforce unique replies *) let new_env = Env.remove_continuations new_env in let body = do_type_exp ctx new_env sbody in re { - exp_desc = Texp_for(id, low, high, dir, body); - exp_loc = loc; - exp_type = Predef.type_process [] ; - exp_env = env } + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = Predef.type_process [] ; + exp_env = env } end | Pexp_constraint(sarg, sty, sty') -> check_expression ctx sexp; let separate = true (* always separate, 1% slowdown for lablgtk *) (* !Clflags.principal || Env.has_local_constraints env *) in - let (arg, ty') = + let (arg, ty',cty,cty') = match (sty, sty') with (None, None) -> (* Case actually unused *) let arg = do_type_exp ctx env sarg in - (arg, arg.exp_type) + (arg, arg.exp_type,None,None) | (Some sty, None) -> if separate then begin_def (); - let ty = Typetexp.transl_simple_type env false sty in + let cty = Typetexp.transl_simple_type env false sty in + let ty = cty.ctyp_type in if separate then begin end_def (); generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty) + (type_argument env sarg ty (instance env ty), + instance env ty, Some cty, None) end else - (type_argument env sarg ty ty, ty) + (type_argument env sarg ty ty, ty, Some cty, None) | (None, Some sty') -> - let (ty', force) = + let (cty', force) = Typetexp.transl_simple_type_delayed env sty' in + let ty' = cty'.ctyp_type in if separate then begin_def (); let arg = do_type_exp ctx env sarg in let gen = @@ -2236,7 +2289,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end else true in begin match arg.exp_desc, !self_coercion, (repr ty').desc with - Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, + Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> (* prerr_endline "self coercion"; *) r := loc :: !r; @@ -2269,14 +2322,16 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Coercion_failure(ty', full_expand env ty', trace, b))) end end; - (arg, ty') + (arg, ty', None, Some cty') | (Some sty, Some sty') -> if separate then begin_def (); - let (ty, force) = + let (cty, force) = Typetexp.transl_simple_type_delayed env sty - and (ty', force') = + and (cty', force') = Typetexp.transl_simple_type_delayed env sty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in begin try let force'' = subtype env ty ty' in force (); force' (); force'' () @@ -2287,40 +2342,43 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end_def (); generalize_structure ty; generalize_structure ty'; - (type_argument env sarg ty (instance env ty), instance env ty') + (type_argument env sarg ty (instance env ty), + instance env ty', Some cty, Some cty') end else - (type_argument env sarg ty ty, ty') + (type_argument env sarg ty ty, ty', Some cty, Some cty') in rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; exp_type = ty'; - exp_env = env } + exp_env = env; + exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra; + } | Pexp_when(scond, sbody) -> check_expression ctx sexp; let cond = do_type_expect E env scond Predef.type_bool in let body = do_type_expect ctx env sbody ty_expected in re { - exp_desc = Texp_when(cond, body); - exp_loc = loc; - exp_type = body.exp_type; - exp_env = env } + exp_desc = Texp_when(cond, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_env = env } | Pexp_send (e, met) -> check_expression ctx sexp ; if !Clflags.principal then begin_def (); let obj = do_type_exp E env e in begin try - let (exp, typ) = + let (meth, exp, typ) = match obj.exp_desc with - Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) -> + Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) -> let (id, typ) = filter_self_method env met Private meths privty in if is_Tvar (repr typ) then Location.prerr_warning loc (Warnings.Undeclared_virtual_method met); - (Texp_send(obj, Tmeth_val id), typ) - | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) -> + (Tmeth_val id, None, typ) + | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> raise(Error(e.pexp_loc, Undefined_inherited_method met)) @@ -2339,25 +2397,31 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let (obj_ty, res_ty) = filter_arrow env method_type "" in unify env obj_ty desc.val_type; unify env res_ty (instance env typ); - (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id, - {val_type = method_type; - val_kind = Val_reg; - val_loc = Location.none; - }); - exp_loc = loc; + let exp = + Texp_apply({exp_desc = + Texp_ident(Path.Pident method_id, lid, + {val_type = method_type; + val_kind = Val_reg; + Types.val_loc = Location.none}); + exp_loc = loc; exp_extra = []; exp_type = method_type; - exp_env = env }, - [Some {exp_desc = Texp_ident(path, desc); - exp_loc = obj.exp_loc; - exp_type = desc.val_type; - exp_env = env }, - Required]), - typ) + exp_env = env}, + ["", + Some {exp_desc = Texp_ident(path, lid, desc); + exp_loc = obj.exp_loc; exp_extra = []; + exp_type = desc.val_type; + exp_env = env}, + Required]) + in + (Tmeth_name met, Some (re {exp_desc = exp; + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_env = env}), typ) | _ -> assert false end | _ -> - (Texp_send(obj, Tmeth_name met), + (Tmeth_name met, None, filter_method env met Public obj.exp_type) in if !Clflags.principal then begin @@ -2383,57 +2447,58 @@ and do_type_expect ?in_function ctx env sexp ty_expected = assert false in rue { - exp_desc = exp; - exp_loc = loc; - exp_type = typ; - exp_env = env } + exp_desc = Texp_send(obj, meth, exp); + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_env = env } with Unify _ -> raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> check_expression ctx sexp ; - let (cl_path, cl_decl) = Typetexp.find_class env loc cl in + let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in begin match cl_decl.cty_new with None -> - raise(Error(loc, Virtual_class cl)) + raise(Error(loc, Virtual_class cl.txt)) | Some ty -> rue { - exp_desc = Texp_new (cl_path, cl_decl); - exp_loc = loc; + exp_desc = Texp_new (cl_path, cl, cl_decl); + exp_loc = loc; exp_extra = []; exp_type = instance_def ty; exp_env = env } end | Pexp_setinstvar (lab, snewval) -> check_expression ctx sexp ; begin try - let (path, desc) = Env.lookup_value (Longident.Lident lab) env in + let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in match desc.val_kind with Val_ivar (Mutable, cl_num) -> - let newval = do_type_expect E env snewval (instance env desc.val_type) in + let newval = + do_type_expect ctx env snewval (instance env desc.val_type) in let (path_self, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in rue { - exp_desc = Texp_setinstvar(path_self, path, newval); - exp_loc = loc; + exp_desc = Texp_setinstvar(path_self, path, lab, newval); + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Val_ivar _ -> - raise(Error(loc,Instance_variable_not_mutable(true,lab))) + raise(Error(loc,Instance_variable_not_mutable(true,lab.txt))) | _ -> - raise(Error(loc,Instance_variable_not_mutable(false,lab))) + raise(Error(loc,Instance_variable_not_mutable(false,lab.txt))) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab)) + raise(Error(loc, Unbound_instance_variable lab.txt)) end | Pexp_override lst -> check_expression ctx sexp ; let _ = List.fold_right (fun (lab, _) l -> - if List.exists ((=) lab) l then + if List.exists (fun l -> l.txt = lab.txt) l then raise(Error(loc, - Value_multiply_overridden lab)); + Value_multiply_overridden lab.txt)); lab::l) lst [] in @@ -2448,17 +2513,17 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, _, ty) = Vars.find lab !vars in - (Path.Pident id, do_type_expect E env snewval (instance env ty)) + let (id, _, _, ty) = Vars.find lab.txt !vars in + (Path.Pident id, lab, do_type_expect ctx env snewval (instance env ty)) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab)) + raise(Error(loc, Unbound_instance_variable lab.txt)) end in let modifs = List.map type_override lst in rue { exp_desc = Texp_override(path_self, modifs); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = self_ty; exp_env = env } | _ -> @@ -2471,7 +2536,7 @@ and do_type_expect ?in_function ctx env sexp ty_expected = Ident.set_current_time ty.level; let context = Typetexp.narrow () in let modl = !type_module env smodl in - let (id, new_env) = Env.enter_module name modl.mod_type env in + let (id, new_env) = Env.enter_module name.txt modl.mod_type env in Ctype.init_def(Ident.current_time()); Typetexp.widen context; let body = do_type_expect ctx new_env sbody ty_expected in @@ -2485,30 +2550,30 @@ and do_type_expect ?in_function ctx env sexp ty_expected = begin try Ctype.unify_var new_env ty body.exp_type with Unify _ -> - raise(Error(loc, Scoping_let_module(name, body.exp_type))) + raise(Error(loc, Scoping_let_module(name.txt, body.exp_type))) end; re { - exp_desc = Texp_letmodule(id, modl, body); - exp_loc = loc; - exp_type = ty; - exp_env = env } + exp_desc = Texp_letmodule(id, name, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = ty; + exp_env = env } | Pexp_assert (e) -> check_expression ctx sexp ; let cond = do_type_expect ctx env e Predef.type_bool in rue { - exp_desc = Texp_assert (cond); - exp_loc = loc; - exp_type = instance_def Predef.type_unit; - exp_env = env; - } + exp_desc = Texp_assert (cond); + exp_loc = loc; exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_env = env; + } | Pexp_assertfalse -> check_expression ctx sexp ; re { - exp_desc = Texp_assertfalse; - exp_loc = loc; - exp_type = instance env ty_expected; - exp_env = env; - } + exp_desc = Texp_assertfalse; + exp_loc = loc; exp_extra = []; + exp_type = instance env ty_expected; + exp_env = env; + } | Pexp_lazy e -> check_expression ctx sexp ; let ty = newgenvar () in @@ -2516,28 +2581,28 @@ and do_type_expect ?in_function ctx env sexp ty_expected = unify_exp_types loc env to_unify ty_expected; let arg = do_type_expect ctx env e ty in re { - exp_desc = Texp_lazy arg; - exp_loc = loc; - exp_type = instance env ty_expected; - exp_env = env; - } + exp_desc = Texp_lazy arg; + exp_loc = loc; exp_extra = []; + exp_type = instance env ty_expected; + exp_env = env; + } | Pexp_object s -> check_expression ctx sexp ; let desc, sign, meths = !type_object env loc s in rue { - exp_desc = Texp_object (desc, sign, meths); - exp_loc = loc; - exp_type = sign.cty_self; - exp_env = env; - } + exp_desc = Texp_object (desc, (*sign,*) meths); + exp_loc = loc; exp_extra = []; + exp_type = sign.cty_self; + exp_env = env; + } | Pexp_poly(sbody, sty) -> check_expression ctx sexp ; if !Clflags.principal then begin_def (); - let ty = - match sty with None -> repr ty_expected + let ty, cty = + match sty with None -> repr ty_expected, None | Some sty -> - let ty = Typetexp.transl_simple_type env false sty in - repr ty + let cty = Typetexp.transl_simple_type env false sty in + repr cty.ctyp_type, Some cty in if !Clflags.principal then begin end_def (); @@ -2545,11 +2610,11 @@ and do_type_expect ?in_function ctx env sexp ty_expected = end; if sty <> None then unify_exp_types loc env (instance env ty) (instance env ty_expected); - begin + let exp = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = do_type_expect ctx env sbody ty' in - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); @@ -2562,16 +2627,20 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let exp = do_type_expect ctx env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tvar _ -> let exp = do_type_exp ctx env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; - re exp + exp | _ -> assert false - end + in + re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> check_expression ctx sexp ; + let ty = newvar () in + (* remember original level *) + begin_def (); (* Create a fake abstract type declaration for name. *) let level = get_current_level () in let decl = { @@ -2585,9 +2654,6 @@ and do_type_expect ?in_function ctx env sexp ty_expected = type_loc = loc; } in - let ty = newvar () in - (* remember original level *) - begin_def (); Ident.set_current_time ty.level; let (id, new_env) = Env.enter_type name decl env in Ctype.init_def(Ident.current_time()); @@ -2614,7 +2680,8 @@ and do_type_expect ?in_function ctx env sexp ty_expected = (* non-expansive if the body is non-expansive, so we don't introduce any new extra node in the typed AST. *) - rue { body with exp_loc = sexp.pexp_loc; exp_type = ety } + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = (Texp_newtype name, loc) :: body.exp_extra } | Pexp_pack m -> check_expression ctx sexp ; let (p, nl, tl) = @@ -2633,30 +2700,35 @@ and do_type_expect ?in_function ctx env sexp ty_expected = in let (modl, tl') = !type_package env m p nl tl in rue { - exp_desc = Texp_pack modl; - exp_loc = loc; - exp_type = newty (Tpackage (p, nl, tl')); - exp_env = env } + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage (p, nl, tl')); + exp_env = env } | Pexp_open (lid, e) -> - do_type_expect ctx (!type_open env sexp.pexp_loc lid) e ty_expected + let (path, newenv) = !type_open env sexp.pexp_loc lid in + let exp = do_type_expect ctx newenv e ty_expected in + { exp with + exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; + } (*>JOCAML *) (* Continuation scope is restricted to P in - P & P, let D in P, match E (| p -> P)+, if e then P (else P)? - def D in P. - To achieve this it suffices to remove continuations from typing env - for typing D in def D in _ and for P in spawn P only. - Also for P in for .. do P done. -*) + P & P, let D in P, match E (| p -> P)+, if e then P (else P)? + def D in P. + To achieve this it suffices to remove continuations from typing env + for typing D in def D in _ and for P in spawn P only. + Also for P in for .. do P done. + *) | Pexp_spawn sarg -> check_expression ctx sexp ; let arg = do_type_exp P (Env.remove_continuations env) sarg in rue { exp_desc = Texp_spawn arg; - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env; } | Pexp_par (se1,se2) -> + check_process ctx sexp ; let e1 = do_type_exp P env se1 and e2 = do_type_exp P env se2 in begin try @@ -2664,27 +2736,27 @@ and do_type_expect ?in_function ctx env sexp ty_expected = and konts2 = Typejoin.get_replies e2 in re { exp_desc = Texp_par (e1, e2); - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = Predef.type_process (Typejoin.delta konts1 konts2) ; exp_env = env; } with Typejoin.Double (id, loc1, loc2) -> raise (Error (sexp.pexp_loc, DoubleReply (id, loc1, loc2))) end -|Pexp_reply (sres,jid) -> - check_process ctx sexp ; - let lid = Longident.parse jid.pjident_desc in + |Pexp_reply (sres,jid) -> + check_process ctx sexp ; + let lid = Longident.parse jid.txt in let path,ty = try let path,desc = Env.lookup_continuation lid env in desc.continuation_kind <- true ; path, desc.continuation_type with Not_found -> - raise(Error(jid.pjident_loc, Unbound_continuation lid)) in + raise(Error(jid.loc, Unbound_continuation lid)) in let res = do_type_expect E env sres ty in let kid = match path with Path.Pident r -> r | _ -> assert false in re { exp_desc = Texp_reply (res, kid) ; - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = Predef.type_process [kid, sexp.pexp_loc]; exp_env = env; } | Pexp_def (sautos, sbody) -> @@ -2694,12 +2766,13 @@ and do_type_expect ?in_function ctx env sexp ty_expected = let body = do_type_exp ctx new_env sbody in rue { exp_desc = Texp_def (autos, body); - exp_loc = sexp.pexp_loc; + exp_loc = sexp.pexp_loc; exp_extra=[]; exp_type = body.exp_type; exp_env = env } (*<JOCAML *) -and type_label_exp create env loc ty_expected (label, sarg) = +and type_label_exp create env loc ty_expected + (label_path, lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = !Clflags.principal || Env.has_local_constraints env in @@ -2714,7 +2787,7 @@ and type_label_exp create env loc ty_expected (label, sarg) = begin try unify env (instance_def ty_res) (instance env ty_expected) with Unify trace -> - raise(Error(loc , Label_mismatch(lid_of_label label, trace))) + raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in @@ -2724,8 +2797,10 @@ and type_label_exp create env loc ty_expected (label, sarg) = generalize_structure ty_arg end; if label.lbl_private = Private then - raise(Error(loc, if create then Private_type ty_expected - else Private_label (lid_of_label label, ty_expected))); + if create then + raise (Error(loc, Private_type ty_expected)) + else + raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance env ty_arg) in @@ -2746,7 +2821,7 @@ and type_label_exp create env loc ty_expected (label, sarg) = with Error (_, Less_general _) as e -> raise e | _ -> raise exn (* In case of failure return the first error *) in - (label, {arg with exp_type = instance env arg.exp_type}) + (label_path, lid, label, {arg with exp_type = instance env arg.exp_type}) and type_argument env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -2754,11 +2829,14 @@ and type_argument env sarg ty_expected' ty_expected = let ls, tvar = list_labels env ty in not tvar && List.for_all ((=) "") ls in - (* let ty_expected = instance ty_expected' in *) - match expand_head env ty_expected', sarg with - | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) -> - do_type_expect E env sarg ty_expected' - | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ -> + let rec is_inferred sexp = + match sexp.pexp_desc with + Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true + | Pexp_open (_, e) -> is_inferred e + | _ -> false + in + match expand_head env ty_expected' with + {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg -> (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) if !Clflags.principal then begin_def (); @@ -2793,17 +2871,23 @@ and type_argument env sarg ty_expected' ty_expected = (* eta-expand to avoid side effects *) let var_pair name ty = let id = Ident.create name in - {pat_desc = Tpat_var id; pat_type = ty; + {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; pat_loc = Location.none; pat_env = env}, - {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc = - Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg; val_loc = Location.none})} + {exp_type = ty; exp_loc = Location.none; exp_env = env; + exp_extra = []; + exp_desc = + Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), + {val_type = ty; val_kind = Val_reg; + Types.val_loc = Location.none})} in let eta_pat, eta_var = var_pair "eta" ty_arg in let func texp = { texp with exp_type = ty_fun; exp_desc = - Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc = - Texp_apply (texp, args@ - [Some eta_var, Required])}], + Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc = + Texp_apply (texp, + (List.map (fun (label, exp) -> + ("", label, exp)) args)@ + ["", Some eta_var, Required])}], Total) } in if warn then Location.prerr_warning texp.exp_loc (Warnings.Without_principality "eliminated optional argument"); @@ -2830,53 +2914,58 @@ and type_application env funct sargs = tvar || List.mem l ls in let ignored = ref [] in - let rec type_unknown_args args omitted ty_fun = function - [] -> - (List.map - (function None, x -> None, x | Some f, x -> Some (f ()), x) - (List.rev args), - instance env (result_type omitted ty_fun)) - | (l1, sarg1) :: sargl -> - let (ty1, ty2) = - let ty_fun = expand_head env ty_fun in - match ty_fun.desc with - Tvar _ -> - let t1 = newvar () and t2 = newvar () in - let not_identity = function - Texp_ident(_,{val_kind=Val_prim - {Primitive.prim_name="%identity"}}) -> - false - | _ -> true - in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); - (t1, t2) - | Tarrow (l,t1,t2,_) when l = l1 - || !Clflags.classic && l1 = "" && not (is_optional l) -> - (t1, t2) - | td -> - let ty_fun = - match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - Tarrow _ -> - if (!Clflags.classic || not (has_label l1 ty_fun)) then - raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) - else - raise(Error(funct.exp_loc, Incoherent_label_order)) - | _ -> - raise(Error(funct.exp_loc, Apply_non_function - (expand_head env funct.exp_type))) - in - let optional = if is_optional l1 then Optional else Required in - let arg1 () = - let arg1 = do_type_expect E env sarg1 ty1 in - if optional = Optional then - unify_exp env arg1 (type_option(newvar())); - arg1 - in - type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl + let rec type_unknown_args + (args : + (Asttypes.label * (unit -> Typedtree.expression) option * + Typedtree.optional) list) + omitted ty_fun = function + [] -> + (List.map + (function l, None, x -> l, None, x + | l, Some f, x -> l, Some (f ()), x) + (List.rev args), + instance env (result_type omitted ty_fun)) + | (l1, sarg1) :: sargl -> + let (ty1, ty2) = + let ty_fun = expand_head env ty_fun in + match ty_fun.desc with + Tvar _ -> + let t1 = newvar () and t2 = newvar () in + let not_identity = function + Texp_ident(_,_,{val_kind=Val_prim + {Primitive.prim_name="%identity"}}) -> + false + | _ -> true + in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); + (t1, t2) + | Tarrow (l,t1,t2,_) when l = l1 + || !Clflags.classic && l1 = "" && not (is_optional l) -> + (t1, t2) + | td -> + let ty_fun = + match td with Tarrow _ -> newty td | _ -> ty_fun in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + Tarrow _ -> + if (!Clflags.classic || not (has_label l1 ty_fun)) then + raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) + else + raise(Error(funct.exp_loc, Incoherent_label_order)) + | _ -> + raise(Error(funct.exp_loc, Apply_non_function + (expand_head env funct.exp_type))) + in + let optional = if is_optional l1 then Optional else Required in + let arg1 () = + let arg1 = do_type_expect E env sarg1 ty1 in + if optional = Optional then + unify_exp env arg1 (type_option(newvar())); + arg1 + in + type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl in let ignore_labels = !Clflags.classic || @@ -2964,7 +3053,7 @@ and type_application env funct sargs = let omitted = if arg = None then (l,ty,lv) :: omitted else omitted in let ty_old = if sargs = [] then ty_fun else ty_old in - type_args ((arg,optional)::args) omitted ty_fun ty_fun0 + type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 ty_old sargs more_sargs | _ -> match sargs with @@ -2976,7 +3065,7 @@ and type_application env funct sargs = in match funct.exp_desc, sargs with (* Special case for ignore: avoid discarding warning *) - Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}), + Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}), ["", sarg] -> let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in let exp = do_type_expect E env sarg ty_arg in @@ -2987,7 +3076,7 @@ and type_application env funct sargs = add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; - ([Some exp, Required], ty_res) + (["", Some exp, Required], ty_res) | _ -> let ty = funct.exp_type in if ignore_labels then @@ -2996,8 +3085,8 @@ and type_application env funct sargs = type_args [] [] ty (instance env ty) ty sargs [] and type_construct env loc lid sarg explicit_arity ty_expected = - let constr = Typetexp.find_constructor env loc lid in - Env.mark_constructor env (Longident.last lid) constr; + let (path,constr) = Typetexp.find_constructor env loc lid.txt in + Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; let sargs = match sarg with None -> [] @@ -3006,14 +3095,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected = | Some se -> [se] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, Constructor_arity_mismatch - (lid, constr.cstr_arity, List.length sargs))); + (lid.txt, constr.cstr_arity, List.length sargs))); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); let (ty_args, ty_res) = instance_constructor constr in let texp = re { - exp_desc = Texp_construct(constr, []); - exp_loc = loc; + exp_desc = Texp_construct(path, lid, constr, [],explicit_arity); + exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } in if separate then begin @@ -3036,7 +3125,8 @@ and type_construct env loc lid sarg explicit_arity ty_expected = (List.combine ty_args ty_args0) in if constr.cstr_private = Private then raise(Error(loc, Private_type ty_res)); - { texp with exp_desc = Texp_construct(constr, args)} + { texp with + exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) } (* Typing of statements (expressions whose values are discarded) *) @@ -3066,17 +3156,17 @@ and type_statement env sexp = (* Typing of match cases *) (* - Argument ty_res is unused when ctx is P, - instead the list of names replied to is returned, - as an additional 'reps' in typed_cases, partial, reps -*) + Argument ty_res is unused when ctx is P, + instead the list of names replied to is returned, + as an additional 'reps' in typed_cases, partial, reps + *) and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = (* ty_arg is _fully_ generalized *) let dont_propagate, has_gadts = let patterns = List.map fst caselist in List.exists contains_polymorphic_variant patterns, List.exists (contains_gadt env) patterns in - (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) +(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) let ty_arg, ty_res, env = if has_gadts && not !Clflags.principal then correct_levels ty_arg, correct_levels ty_res, @@ -3086,17 +3176,19 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = if has_gadts then begin (* raise level for existentials *) begin_def (); - Ident.set_current_time (get_current_level ()); + Ident.set_current_time (get_current_level ()); let lev = Ident.current_time () in Ctype.init_def (lev+1000); (* up to 1000 existentials *) (lev, Env.add_gadt_instance_level lev env) end else (get_current_level (), env) in +(* if has_gadts then + Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) begin_def (); (* propagation of the argument *) let ty_arg' = newvar () in let pattern_force = ref [] in - (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_arg; *) +(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) let pat_env_list = List.map (fun (spat, sexp) -> @@ -3153,15 +3245,11 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = end else if contains_gadt env spat then correct_levels ty_res else ty_res in -(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_res'; *) - let exp = do_type_expect ?in_function ctx ext_env sexp ty_res' in +(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_res'; *) + let exp = do_type_expect E ?in_function ext_env sexp ty_res' in (pat, {exp with exp_type = instance env ty_res'})) pat_env_list caselist in - if !Clflags.principal || has_gadts then begin - let ty_res' = instance env ty_res in - List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases - end; cases,[] | P -> (* No GADT ?? *) let cases = @@ -3176,10 +3264,10 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_flag loc caselist = | (_,fst)::rem -> let reps = Typejoin.get_replies fst in (* - Printf.eprintf "Replies: [%s]\n%!" - (String.concat "; " - (List.map (fun (id,_) -> Ident.name id) reps)) ; -*) + Printf.eprintf "Replies: [%s]\n%!" + (String.concat "; " + (List.map (fun (id,_) -> Ident.name id) reps)) ; + *) List.iter (fun (_, exp) -> try @@ -3221,7 +3309,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let is_fake_let = match spat_sexp_list with | [_, {pexp_desc=Pexp_match( - {pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] -> + {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] -> true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) | _ -> false @@ -3237,9 +3325,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal -> (* propagate type annotation to pattern, to allow it to be generalized in -principal mode *) - {ppat_desc = Ppat_constraint - (spat, {ptyp_desc=Ptyp_poly([],sty); - ptyp_loc={sty.ptyp_loc with Location.loc_ghost=true}}); + {ppat_desc = Ppat_constraint (spat, sty); ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}} | _ -> spat) spat_sexp_list in @@ -3283,7 +3369,11 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) if is_recursive then new_env else env in let current_slot = ref None in - let warn_unused = Warnings.is_active (check "") || Warnings.is_active (check_strict "") in + let rec_needed = ref false in + let warn_unused = + Warnings.is_active (check "") || Warnings.is_active (check_strict "") || + (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)) + in let pat_slot_list = (* Algorithm to detect unused declarations in recursive bindings: - During type checking of the definitions, we capture the 'value_used' @@ -3291,7 +3381,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) to the current definition (!current_slot). In effect, this creates a dependency graph between definitions. - - After type checking the definition (!current_slot = Mone), + - After type checking the definition (!current_slot = None), when one of the bound identifier is effectively used, we trigger again all the events recorded in the corresponding slot. The effect is to traverse the transitive closure of the graph created @@ -3309,7 +3399,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) (* has one of the identifier of this pattern been used? *) let slot = ref [] in List.iter - (fun id -> + (fun (id,_) -> let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *) let name = Ident.name id in @@ -3318,14 +3408,15 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) add_delayed_check (fun () -> if not !used then - Location.prerr_warning vd.val_loc + Location.prerr_warning vd.Types.val_loc ((if !some_used then check_strict else check) name) ); Env.set_value_used_callback name vd (fun () -> match !current_slot with - | Some slot -> slot := (name, vd) :: !slot + | Some slot -> + slot := (name, vd) :: !slot; rec_needed := true | None -> List.iter (fun (name, vd) -> Env.mark_value_used name vd) @@ -3361,6 +3452,10 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) | _ -> do_type_expect E exp_env sexp pat.pat_type) spat_sexp_list pat_slot_list in current_slot := None; + if is_recursive && not !rec_needed + && Warnings.is_active Warnings.Unused_rec_flag then + Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc + Warnings.Unused_rec_flag; List.iter2 (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp])) pat_list exp_list; @@ -3389,8 +3484,8 @@ and type_dispatcher names disp = Disp (d_id, chan, cls, par) and type_clause env names reac = - let g_id,(old,(actual_pats, gd)) = reac in - let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in + let g_id,(old,(actual_pats, gd)) = reac in + let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in (* First build environment for guarded process *) let conts = ref [] in @@ -3403,14 +3498,14 @@ and type_clause env names reac = conts := kdesc :: !conts; Env.add_continuation kid kdesc env - and add_pat_var (id, ty, loc, as_var) env = + and add_pat_var (id, ty, _name, loc, as_var) env = (* _name info forgotten *) let check = if as_var then fun s -> Warnings.Unused_var s else fun s -> Warnings.Unused_var_strict s in let e1 = Env.add_value ~check - id {val_type = ty; val_kind = Val_reg; val_loc = loc; } + id {val_type = ty; val_kind = Val_reg; Types.val_loc = loc; } env in Env.add_annot id (Annot.Iref_internal loc) e1 in @@ -3464,9 +3559,9 @@ and type_reac env names reac = Reac (type_clause env names reac) and type_fwd env names reac = Fwd (type_clause env names reac) and type_auto env - (my_loc, my_names, - (nchans, original, def_names), - (disps,reacs,fwds)) = + (my_loc, my_names, + (nchans, original, def_names), + (disps,reacs,fwds)) = let env = Env.remove_continuations env in let reacs = List.map (type_reac env def_names) reacs and fwds = List.map (type_fwd env def_names) fwds in @@ -3521,23 +3616,23 @@ and generalize_auto env auto = auto.jauto_names and add_auto_names p env names = - List.fold_left - (fun env (id,(ty,nat)) -> - if p id then - let kind = match nat with - | Chan (name,num)-> Val_channel (name,num) - | Alone g -> Val_alone g in - Env.add_value id - {val_type = ty; val_kind = kind; val_loc = Location.none; } env - else env) - env names + List.fold_left + (fun env (id,(ty,nat)) -> + if p id then + let kind = match nat with + | Chan (name,num)-> Val_channel (name,num) + | Alone g -> Val_alone g in + Env.add_value id + {val_type = ty; val_kind = kind; Types.val_loc = Location.none; } env + else env) + env names and add_auto_names_as_regular p env names = List.fold_left (fun env (id,(ty,_)) -> if p id then Env.add_value id - {val_type = ty; val_kind = Val_reg; val_loc = Location.none} env + {val_type = ty; val_kind = Val_reg; Types.val_loc = Location.none} env else env) env names @@ -3566,13 +3661,13 @@ and type_def toplevel env sautos scope = (fun env (_ , _, (_,original,names), _) -> let p id = List.mem id original in add_auto_names_as_regular p env names) - env names_lhs_list + env names_lhs_list else List.fold_left (fun env (_ , _, (_,original,names), _) -> let p id = List.mem id original in add_auto_names p env names) - env names_lhs_list in + env names_lhs_list in autos, final_env (* Got to export those *) @@ -3609,7 +3704,7 @@ let type_expression env sexp = match sexp.pexp_desc with Pexp_ident lid -> (* Special case for keeping type variables when looking-up a variable *) - let (path, desc) = Env.lookup_value lid env in + let (path, desc) = Env.lookup_value lid.txt env in {exp with exp_type = desc.val_type} | _ -> exp @@ -3644,9 +3739,9 @@ let report_error ppf = function | Pattern_type_clash trace -> report_unification_error ppf trace (function ppf -> - fprintf ppf "This pattern matches values of type") + fprintf ppf "This pattern matches values of type") (function ppf -> - fprintf ppf "but a pattern was expected which matches values of type") + fprintf ppf "but a pattern was expected which matches values of type") | Multiply_bound_variable name -> fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> @@ -3682,7 +3777,8 @@ let report_error ppf = function fprintf ppf "The record field label %a is defined several times" longident lid | Label_missing labels -> - let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + let print_labels ppf = + List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in fprintf ppf "@[<hov>Some record field labels are undefined:%a@]" print_labels labels | Label_not_mutable lid -> @@ -3823,3 +3919,4 @@ let report_error ppf = function (*<JOCAML *) let () = Env.add_delayed_check_forward := add_delayed_check + diff --git a/typing/typecore.mli b/typing/typecore.mli index c4b9b5b368..bc22d4c1be 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -41,7 +41,7 @@ val type_joindefinition: val type_class_arg_pattern: string -> Env.t -> Env.t -> label -> Parsetree.pattern -> - Typedtree.pattern * (Ident.t * Ident.t * type_expr) list * + Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list * Env.t * Env.t val type_self_pattern: string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> @@ -82,7 +82,7 @@ type error = | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t - | Label_missing of string list + | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char @@ -130,13 +130,15 @@ val report_error: formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref +val type_open: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> - Typedtree.class_structure * class_signature * string list) ref + Typedtree.class_structure * Types.class_signature * string list) ref val type_package: - (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> type_expr list -> - Typedtree.module_expr * type_expr list) ref + (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> + type_expr list -> Typedtree.module_expr * type_expr list) ref -val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr +val create_package_type : Location.t -> Env.t -> + Longident.t * (Longident.t * Parsetree.core_type) list -> + Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 3f59be0926..2890d0cac1 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -19,7 +19,6 @@ open Asttypes open Parsetree open Primitive open Types -open Typedtree open Typetexp type error = @@ -44,6 +43,8 @@ type error = | Unbound_type_var_exc of type_expr * type_expr | Varying_anonymous +open Typedtree + exception Error of Location.t * error (* Enter all declared types in the environment as abstract types *) @@ -125,11 +126,11 @@ module StringSet = end) let make_params sdecl = - try - List.map + try + List.map (function None -> Ctype.new_global_var ~name:"_" () - | Some x -> enter_type_variable true sdecl.ptype_loc x) + | Some x -> enter_type_variable true sdecl.ptype_loc x.txt) sdecl.ptype_params with Already_bound -> raise(Error(sdecl.ptype_loc, Repeated_parameter)) @@ -140,106 +141,132 @@ let transl_declaration env (name, sdecl) id = Ctype.begin_def (); let params = make_params sdecl in let cstrs = List.map - (fun (sty, sty', loc) -> - transl_simple_type env false sty, - transl_simple_type env false sty', loc) - sdecl.ptype_cstrs + (fun (sty, sty', loc) -> + transl_simple_type env false sty, + transl_simple_type env false sty', loc) + sdecl.ptype_cstrs in - let decl = - { type_params = params; - type_arity = List.length params; - type_kind = - begin match sdecl.ptype_kind with - Ptype_abstract -> Type_abstract - | Ptype_variant cstrs -> - let all_constrs = ref StringSet.empty in - List.iter - (fun (name, _, _, loc) -> - if StringSet.mem name !all_constrs then - raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); - all_constrs := StringSet.add name !all_constrs) - cstrs; - if List.length - (List.filter (fun (_, args, _, _) -> args <> []) cstrs) - > (Config.max_tag + 1) then - raise(Error(sdecl.ptype_loc, Too_many_constructors)); - let make_cstr (name, args, ret_type, loc) = - match ret_type with - | None -> - (name, List.map (transl_simple_type env true) args, None) - | Some sty -> - (* if it's a generalized constructor we must first narrow and - then widen so as to not introduce any new constraints *) - let z = narrow () in - reset_type_variables (); - let args = List.map (transl_simple_type env false) args in - let ret_type = - let ty = transl_simple_type env false sty in - let p = Path.Pident id in - match (Ctype.repr ty).desc with - Tconstr (p', _, _) when Path.same p p' -> ty - | _ -> raise(Error(sty.ptyp_loc, - Constraint_failed (ty, Ctype.newconstr p params))) - in - widen z; - (name, args, Some ret_type) - in - Type_variant (List.map make_cstr cstrs) - - | Ptype_record lbls -> - let all_labels = ref StringSet.empty in - List.iter - (fun (name, mut, arg, loc) -> - if StringSet.mem name !all_labels then - raise(Error(sdecl.ptype_loc, Duplicate_label name)); - all_labels := StringSet.add name !all_labels) - lbls; - let lbls' = - List.map - (fun (name, mut, arg, loc) -> - let ty = transl_simple_type env true arg in - name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) - lbls in - let rep = - if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' - then Record_float - else Record_regular in - Type_record(lbls', rep) - end; - type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with - None -> None - | Some sty -> - let no_row = not (is_fixed_type sdecl) in - Some (transl_simple_type env no_row sty) - end; - type_variance = List.map (fun _ -> true, true, true) params; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - } in + let (tkind, kind) = + match sdecl.ptype_kind with + Ptype_abstract -> Ttype_abstract, Type_abstract + | Ptype_variant cstrs -> + let all_constrs = ref StringSet.empty in + List.iter + (fun ({ txt = name}, _, _, loc) -> + if StringSet.mem name !all_constrs then + raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); + all_constrs := StringSet.add name !all_constrs) + cstrs; + if List.length + (List.filter (fun (_, args, _, _) -> args <> []) cstrs) + > (Config.max_tag + 1) then + raise(Error(sdecl.ptype_loc, Too_many_constructors)); + let make_cstr (lid, args, ret_type, loc) = + let name = Ident.create lid.txt in + match ret_type with + | None -> + (name, lid, List.map (transl_simple_type env true) args, None, loc) + | Some sty -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + let z = narrow () in + reset_type_variables (); + let args = List.map (transl_simple_type env false) args in + let ret_type = + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + let p = Path.Pident id in + match (Ctype.repr ty).desc with + Tconstr (p', _, _) when Path.same p p' -> ty + | _ -> + raise (Error (sty.ptyp_loc, Constraint_failed + (ty, Ctype.newconstr p params))) + in + widen z; + (name, lid, args, Some ret_type, loc) + in + let cstrs = List.map make_cstr cstrs in + Ttype_variant (List.map (fun (name, lid, ctys, _, loc) -> + name, lid, ctys, loc + ) cstrs), + Type_variant (List.map (fun (name, name_loc, ctys, option, loc) -> + name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs) + + | Ptype_record lbls -> + let all_labels = ref StringSet.empty in + List.iter + (fun ({ txt = name }, mut, arg, loc) -> + if StringSet.mem name !all_labels then + raise(Error(sdecl.ptype_loc, Duplicate_label name)); + all_labels := StringSet.add name !all_labels) + lbls; + let lbls = List.map (fun (name, mut, arg, loc) -> + let cty = transl_simple_type env true arg in + (Ident.create name.txt, name, mut, cty, loc) + ) lbls in + let lbls' = + List.map + (fun (name, name_loc, mut, cty, loc) -> + let ty = cty.ctyp_type in + name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) + lbls in + let rep = + if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' + then Record_float + else Record_regular in + Ttype_record lbls, Type_record(lbls', rep) + in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env no_row sty in + Some cty, Some cty.ctyp_type + in + let decl = + { type_params = params; + type_arity = List.length params; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + type_variance = List.map (fun _ -> true, true, true) params; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + } in (* Check constraints *) - List.iter - (fun (ty, ty', loc) -> - try Ctype.unify env ty ty' with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint tr))) - cstrs; - Ctype.end_def (); + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' with Ctype.Unify tr -> + raise(Error(loc, Inconsistent_constraint tr))) + cstrs; + Ctype.end_def (); (* Add abstract row *) - if is_fixed_type sdecl then begin - let (p, _) = - try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env - with Not_found -> assert false in - set_fixed_row env sdecl.ptype_loc p decl - end; + if is_fixed_type sdecl then begin + let (p, _) = + try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env + with Not_found -> assert false in + set_fixed_row env sdecl.ptype_loc p decl + end; (* Check for cyclic abbreviations *) - begin match decl.type_manifest with None -> () - | Some ty -> - if Ctype.cyclic_abbrev env id ty then - raise(Error(sdecl.ptype_loc, Recursive_abbrev name)); - end; - (id, decl) + begin match decl.type_manifest with None -> () + | Some ty -> + if Ctype.cyclic_abbrev env id ty then + raise(Error(sdecl.ptype_loc, Recursive_abbrev name.txt)); + end; + let tdecl = { + typ_params = sdecl.ptype_params; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_variance = sdecl.ptype_variance; + typ_private = sdecl.ptype_private; + } in + (id, name, tdecl) (* Generalize a type declaration *) @@ -303,7 +330,7 @@ let check_constraints env (_, sdecl) (_, decl) = let (styl, sret_type) = try let (_, sty, sret_type, _) = - List.find (fun (n,_,_,_) -> n = name) pl + List.find (fun (n,_,_,_) -> n.txt = Ident.name name) pl in (sty, sret_type) with Not_found -> assert false in List.iter2 @@ -325,11 +352,11 @@ let check_constraints env (_, sdecl) (_, decl) = let rec get_loc name = function [] -> assert false | (name', _, sty, _) :: tl -> - if name = name' then sty.ptyp_loc else get_loc name tl + if name = name'.txt then sty.ptyp_loc else get_loc name tl in List.iter (fun (name, _, ty) -> - check_constraints_rec env (get_loc name pl) visited ty) + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l end; begin match decl.type_manifest with @@ -359,8 +386,10 @@ let check_abbrev env (_, sdecl) (id, decl) = else if not (Ctype.equal env false args decl.type_params) then [Includecore.Constraint] else - Includecore.type_declarations env id + Includecore.type_declarations ~equality:true env + (Path.last path) decl' + id (Subst.type_declaration (Subst.add_type id path Subst.identity) decl) in @@ -373,12 +402,25 @@ let check_abbrev env (_, sdecl) (id, decl) = end | _ -> () +(* Check that recursion is well-founded *) + +let check_well_founded env loc path decl = + Misc.may + (fun body -> + try Ctype.correct_abbrev env path decl.type_params body with + | Ctype.Recursive_abbrev -> + raise(Error(loc, Recursive_abbrev (Path.name path))) + | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))) + decl.type_manifest + (* Check for ill-defined abbrevs *) let check_recursion env loc path decl to_check = (* to_check is true for potentially mutually recursive paths. (path, decl) is the type declaration to be checked. *) + if decl.type_params = [] then () else + let visited = ref [] in let rec check_regular cpath args prev_exp ty = @@ -415,29 +457,22 @@ let check_recursion env loc path decl to_check = end; List.iter (check_regular cpath args prev_exp) args' | Tpoly (ty, tl) -> - let (_, ty) = Ctype.instance_poly false tl ty in + let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in check_regular cpath args prev_exp ty | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty end in - match decl.type_manifest with - | None -> () - | Some body -> - (* Check that recursion is well-founded *) - begin try - Ctype.correct_abbrev env path decl.type_params body - with Ctype.Recursive_abbrev -> - raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)) - end; - (* Check that recursion is regular *) - if decl.type_params = [] then () else + Misc.may + (fun body -> let (args, body) = - Ctype.instance_parameterized_type decl.type_params body in - check_regular path args [] body + Ctype.instance_parameterized_type + ~keep_names:true decl.type_params body in + check_regular path args [] body) + decl.type_manifest -let check_abbrev_recursion env id_loc_list (id, decl) = +let check_abbrev_recursion env id_loc_list (id, _, tdecl) = + let decl = tdecl.typ_type in check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false) @@ -519,7 +554,7 @@ let whole_type decl = match decl.type_kind with Type_variant tll -> Btype.newgenty - (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) + (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) @@ -600,7 +635,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl {decl with type_params = tyl; type_private = Private} (add_false tl) | _ -> assert false - + let compute_variance_decl env check decl (required, loc as rloc) = if decl.type_kind = Type_abstract && decl.type_manifest = None then List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true)) @@ -664,8 +699,8 @@ let init_variance (id, decl) = let compute_variance_decls env cldecls = let decls, required = List.fold_right - (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) (decls, req) -> - (obj_id, obj_abbr) :: decls, required :: req) + (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) -> + (obj_id, obj_abbr) :: decls, (ci.ci_variance, ci.ci_loc) :: req) cldecls ([],[]) in let variances = List.map init_variance decls in @@ -688,20 +723,21 @@ let check_duplicates name_sdecl_list = List.iter (fun (cname, _, _, loc) -> try - let name' = Hashtbl.find constrs cname in + let name' = Hashtbl.find constrs cname.txt in Location.prerr_warning loc (Warnings.Duplicate_definitions - ("constructor", cname, name', name)) - with Not_found -> Hashtbl.add constrs cname name) + ("constructor", cname.txt, name', name.txt)) + with Not_found -> Hashtbl.add constrs cname.txt name.txt) cl | Ptype_record fl -> List.iter (fun (cname, _, _, loc) -> try - let name' = Hashtbl.find labels cname in + let name' = Hashtbl.find labels cname.txt in Location.prerr_warning loc - (Warnings.Duplicate_definitions ("label", cname, name', name)) - with Not_found -> Hashtbl.add labels cname name) + (Warnings.Duplicate_definitions + ("label", cname.txt, name', name.txt)) + with Not_found -> Hashtbl.add labels cname.txt name.txt) fl | Ptype_abstract -> ()) name_sdecl_list @@ -729,15 +765,15 @@ let transl_type_decl env name_sdecl_list = in let name_sdecl_list = List.map - (fun (name,sdecl) -> - name^"#row", + (fun (name, sdecl) -> + mkloc (name.txt ^"#row") name.loc, {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None}) fixed_types @ name_sdecl_list in (* Create identifiers. *) let id_list = - List.map (fun (name, _) -> Ident.create name) name_sdecl_list + List.map (fun (name, _) -> Ident.create name.txt) name_sdecl_list in (* Since we've introduced fresh idents, make sure the definition @@ -765,12 +801,19 @@ let transl_type_decl env name_sdecl_list = (fun old_callback -> match !current_slot with | Some slot -> slot := (name, td) :: !slot - | None -> List.iter (fun (name, d) -> Env.mark_type_used name d) (get_ref slot); old_callback () + | None -> + List.iter (fun (name, d) -> Env.mark_type_used name d) + (get_ref slot); + old_callback () ); id, Some slot in - let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in - let decls = List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in + let transl_declaration name_sdecl (id, slot) = + current_slot := slot; transl_declaration temp_env name_sdecl id in + let tdecls = + List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in + let decls = + List.map (fun (id, name_loc, tdecl) -> (id, tdecl.typ_type)) tdecls in current_slot := None; (* Check for duplicates *) check_duplicates name_sdecl_list; @@ -792,21 +835,26 @@ let transl_type_decl env name_sdecl_list = List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc)) id_list name_sdecl_list in - List.iter (check_abbrev_recursion newenv id_loc_list) decls; + List.iter (fun (id, decl) -> + check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) + decls; + List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; (* Check that all type variable are closed *) List.iter2 - (fun (_, sdecl) (id, decl) -> + (fun (_, sdecl) (id, _, tdecl) -> + let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) | None -> ()) - name_sdecl_list decls; + name_sdecl_list tdecls; (* Check re-exportation *) List.iter2 (check_abbrev newenv) name_sdecl_list decls; (* Check that constraints are enforced *) List.iter2 (check_constraints newenv) name_sdecl_list decls; (* Name recursion *) let decls = - List.map2 (fun (_, sdecl) (id, decl) -> id, name_recursion sdecl id decl) + List.map2 (fun (_, sdecl) (id, decl) -> + id, name_recursion sdecl id decl) name_sdecl_list decls in (* Add variances to the environment *) @@ -817,41 +865,49 @@ let transl_type_decl env name_sdecl_list = let final_decls, final_env = compute_variance_fixpoint env decls required (List.map init_variance decls) in + let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) -> + (id, name_loc, { tdecl with typ_type = decl }) + ) tdecls final_decls in (* Done *) (final_decls, final_env) (* Translate an exception declaration *) let transl_closed_type env sty = - let ty = transl_simple_type env true sty in + let cty = transl_simple_type env true sty in + let ty = cty.ctyp_type in + let ty = match Ctype.free_variables ty with | [] -> ty | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty))) + in + { cty with ctyp_type = ty } let transl_exception env loc excdecl = reset_type_variables(); Ctype.begin_def(); - let types = List.map (transl_closed_type env) excdecl in + let ttypes = List.map (transl_closed_type env) excdecl in Ctype.end_def(); + let types = List.map (fun cty -> cty.ctyp_type) ttypes in List.iter Ctype.generalize types; - { exn_args = types; - exn_loc = loc } + let exn_decl = { exn_args = types; Types.exn_loc = loc } in + { exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc } (* Translate an exception rebinding *) let transl_exn_rebind env loc lid = - let cdescr = + let (path, cdescr) = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in - Env.mark_constructor env (Longident.last lid) cdescr; + 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_loc = loc}) + (path, {exn_args = cdescr.cstr_args; Types.exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception lid)) (* exception globalization, just check lid is an exception constructor *) let transl_exn_global env loc lid = - let cdescr = + let _,cdescr = try Env.lookup_constructor lid env with Not_found -> @@ -862,10 +918,12 @@ let transl_exn_global env loc lid = (* Translate a value declaration *) let transl_value_decl env loc valdecl = - let ty = Typetexp.transl_type_scheme env valdecl.pval_type in + let cty = Typetexp.transl_type_scheme env valdecl.pval_type in + let ty = cty.ctyp_type in + let v = match valdecl.pval_prim with [] -> - { val_type = ty; val_kind = Val_reg; val_loc = loc } + { val_type = ty; val_kind = Val_reg; Types.val_loc = loc } | decl -> let arity = Ctype.arity ty in if arity = 0 then @@ -875,11 +933,16 @@ let transl_value_decl env loc valdecl = && prim.prim_arity > 5 && prim.prim_native_name = "" then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external)); - { val_type = ty; val_kind = Val_prim prim; val_loc = loc } + { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc } + in + { val_desc = cty; val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; } (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = + Env.mark_type_used (Ident.name id) orig_decl; reset_type_variables(); Ctype.begin_def(); let params = make_params sdecl in @@ -887,30 +950,32 @@ let transl_with_constraint env id row_path orig_decl sdecl = let arity_ok = List.length params = orig_decl.type_arity in if arity_ok then List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - let orig_decl = Ctype.instance_declaration orig_decl in - let arity_ok = List.length params = orig_decl.type_arity in - if arity_ok then - List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - List.iter + let constraints = List.map (function (ty, ty', loc) -> try - Ctype.unify env (transl_simple_type env false ty) - (transl_simple_type env false ty') + let cty = transl_simple_type env false ty in + let cty' = transl_simple_type env false ty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + Ctype.unify env ty ty'; + (cty, cty', loc) with Ctype.Unify tr -> raise(Error(loc, Inconsistent_constraint tr))) - sdecl.ptype_cstrs; + sdecl.ptype_cstrs + in let no_row = not (is_fixed_type sdecl) in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let cty = transl_simple_type env no_row sty in + Some cty, Some cty.ctyp_type + in let decl = { type_params = params; type_arity = List.length params; type_kind = if arity_ok then orig_decl.type_kind else Type_abstract; type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with - None -> None - | Some sty -> - Some(transl_simple_type env no_row sty) - end; + type_manifest = man; type_variance = []; type_newtype_level = None; type_loc = sdecl.ptype_loc; @@ -929,7 +994,16 @@ let transl_with_constraint env id row_path orig_decl sdecl = (sdecl.ptype_variance, sdecl.ptype_loc)} in Ctype.end_def(); generalize_decl decl; - decl + { + typ_params = sdecl.ptype_params; + typ_type = decl; + typ_cstrs = constraints; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = Ttype_abstract; + typ_variance = sdecl.ptype_variance; + typ_private = sdecl.ptype_private; + } (* Approximate a type declaration: just make all types abstract *) @@ -954,7 +1028,7 @@ let abstract_type_decl arity = let approx_type_decl env name_sdecl_list = List.map (fun (name, sdecl) -> - (Ident.create name, + (Ident.create name.txt, abstract_type_decl (List.length sdecl.ptype_params))) name_sdecl_list @@ -964,6 +1038,7 @@ let approx_type_decl env name_sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) + check_well_founded env loc path decl; check_recursion env loc path decl (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) @@ -1058,12 +1133,12 @@ let report_error ppf = function let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> - explain_unbound ppf ty tl (fun (_,tl,_) -> - Btype.newgenty (Ttuple tl)) - "case" (fun (lab,_,_) -> lab ^ " of ") + explain_unbound ppf ty tl (fun (_,tl,_) -> + Btype.newgenty (Ttuple tl)) + "case" (fun (lab,_,_) -> Ident.name lab ^ " of ") | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun (_,_,t) -> t) - "field" (fun (lab,_,_) -> lab ^ ": ") + "field" (fun (lab,_,_) -> Ident.name lab ^ ": ") | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 9a3e543851..16cf7b9043 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -14,14 +14,17 @@ (* Typing of type definitions and primitive definitions *) +open Asttypes open Types open Format val transl_type_decl: - Env.t -> (string * Parsetree.type_declaration) list -> - (Ident.t * type_declaration) list * Env.t + Env.t -> (string loc * Parsetree.type_declaration) list -> + (Ident.t * string Asttypes.loc * Typedtree.type_declaration) list * Env.t + val transl_exception: - Env.t -> Location.t -> Parsetree.exception_declaration -> exception_declaration + Env.t -> Location.t -> + Parsetree.exception_declaration -> Typedtree.exception_declaration val transl_exn_rebind: Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration @@ -32,15 +35,16 @@ val transl_exn_global: (*<JOCAML*) val transl_value_decl: - Env.t -> Location.t -> Parsetree.value_description -> value_description + Env.t -> Location.t -> + Parsetree.value_description -> Typedtree.value_description val transl_with_constraint: - Env.t -> Ident.t -> Path.t option -> type_declaration -> - Parsetree.type_declaration -> type_declaration + Env.t -> Ident.t -> Path.t option -> Types.type_declaration -> + Parsetree.type_declaration -> Typedtree.type_declaration val abstract_type_decl: int -> type_declaration val approx_type_decl: - Env.t -> (string * Parsetree.type_declaration) list -> + Env.t -> (string loc * Parsetree.type_declaration) list -> (Ident.t * type_declaration) list val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit @@ -51,10 +55,11 @@ val is_fixed_type : Parsetree.type_declaration -> bool (* for typeclass.ml *) val compute_variance_decls: Env.t -> - (Ident.t * type_declaration * type_declaration * class_declaration * - cltype_declaration * ((bool * bool) list * Location.t)) list -> - (type_declaration * type_declaration * class_declaration * - cltype_declaration) list + (Ident.t * Types.type_declaration * Types.type_declaration * + Types.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Types.type_declaration * Types.type_declaration * + Types.class_declaration * Types.class_type_declaration) list type error = Repeated_parameter diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6aea460b78..3620a33421 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -20,65 +20,87 @@ open Types (* Value expressions for the core language *) +type partial = Partial | Total +type optional = Required | Optional + type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; + pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_unpack + and pattern_desc = Tpat_any - | Tpat_var of Ident.t - | Tpat_alias of pattern * Ident.t + | Tpat_var of Ident.t * string loc + | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list - | Tpat_construct of constructor_description * pattern list + | Tpat_construct of + Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref - | Tpat_record of (label_description * pattern) list + | Tpat_record of + (Path.t * Longident.t loc * label_description * pattern) list * + closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern -type partial = Partial | Total -type optional = Required | Optional - -type expression = +and expression = { exp_desc: expression_desc; exp_loc: Location.t; + exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } +and exp_extra = + | Texp_constraint of core_type option * core_type option + | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string + and expression_desc = - Texp_ident of Path.t * value_description + Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list * partial - | Texp_apply of expression * (expression option * optional) list + | Texp_function of label * (pattern * expression) list * partial + | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list - | Texp_construct of constructor_description * expression list + | Texp_construct of + Path.t * Longident.t loc * constructor_description * expression list * + bool | Texp_variant of label * expression option - | Texp_record of (label_description * expression) list * expression option - | Texp_field of expression * label_description - | Texp_setfield of expression * label_description * expression + | Texp_record of + (Path.t * Longident.t loc * label_description * expression) list * + expression option + | Texp_field of expression * Path.t * Longident.t loc * label_description + | Texp_setfield of + expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * expression * expression * direction_flag * expression + Ident.t * string loc * expression * expression * direction_flag * + expression | Texp_when of expression * expression - | Texp_send of expression * meth - | Texp_new of Path.t * class_declaration - | Texp_instvar of Path.t * Path.t - | Texp_setinstvar of Path.t * Path.t * expression - | Texp_override of Path.t * (Path.t * expression) list - | Texp_letmodule of Ident.t * module_expr * expression + | Texp_send of expression * meth * expression option + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_object of class_structure * class_signature * string list + | Texp_object of class_structure * string list | Texp_pack of module_expr (*> JOCAML *) | Texp_asyncsend of expression * expression @@ -155,65 +177,103 @@ and meth = and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; - cl_type: class_type; + cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = - Tclass_ident of Path.t - | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial - | Tclass_apply of class_expr * (expression option * optional) list - | Tclass_let of rec_flag * (pattern * expression) list * - (Ident.t * expression) list * class_expr - | Tclass_constraint of class_expr * string list * string list * Concr.t + Tcl_ident of Path.t * Longident.t loc * core_type list (* Pcl_constr *) + | Tcl_structure of class_structure + | Tcl_fun of + label * pattern * (Ident.t * string loc * expression) list * class_expr * + partial + | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * Concr.t + (* Visible instance variables, methods and concretes methods *) and class_structure = - { cl_field: class_field list; - cl_meths: Ident.t Meths.t } + { cstr_pat : pattern; + cstr_fields: class_field list; + cstr_type : Types.class_signature; + cstr_meths: Ident.t Meths.t } and class_field = - Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list - | Cf_val of string * Ident.t * expression option * bool - | Cf_meth of string * expression - | Cf_init of expression + { + cf_desc : class_field_desc; + cf_loc : Location.t; + } + +and class_field_kind = + Tcfk_virtual of core_type +| Tcfk_concrete of expression + +and class_field_desc = + Tcf_inher of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of + string * string loc * mutable_flag * Ident.t * class_field_kind * bool + (* None = virtual, true = override *) + | Tcf_meth of string * string loc * private_flag * class_field_kind * bool + | Tcf_constr of core_type * core_type +(* | Tcf_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list *) + | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; - mod_type: module_type; + mod_type: Types.module_type; mod_env: Env.t } +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + and module_expr_desc = - Tmod_ident of Path.t + Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure - | Tmod_functor of Ident.t * module_type * module_expr + | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of module_expr * module_type * module_coercion - | Tmod_unpack of expression * module_type + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type -and structure = structure_item list +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list - | Tstr_primitive of Ident.t * value_description - | Tstr_type of (Ident.t * type_declaration) list - | 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 * virtual_flag) list - | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_primitive of Ident.t * string loc * value_description + | Tstr_type of (Ident.t * string loc * type_declaration) list + | Tstr_exception of Ident.t * string loc * exception_declaration + | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc + | Tstr_module of Ident.t * string loc * module_expr + | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list + | Tstr_modtype of Ident.t * string loc * module_type + | Tstr_open of Path.t * Longident.t loc + | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_loc of joinlocation list - | Tstr_exn_global of Location.t * Path.t + | Tstr_exn_global of Path.t * Longident.t loc (*< JOCAML *) and module_coercion = @@ -222,15 +282,181 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; (* BINANNOT ADDED *) + mty_loc: Location.t } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of Ident.t * string loc * value_description + | Tsig_type of (Ident.t * string loc * type_declaration) list + | Tsig_exception of Ident.t * string loc * exception_declaration + | Tsig_module of Ident.t * string loc * module_type + | Tsig_recmodule of (Ident.t * string loc * module_type) list + | Tsig_modtype of Ident.t * string loc * modtype_declaration + | Tsig_open of Path.t * Longident.t loc + | Tsig_include of module_type * Types.signature + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + +and modtype_declaration = + Tmodtype_abstract + | Tmodtype_manifest of module_type + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of core_field_type list + | Ttyp_class of Path.t * Longident.t loc * core_type list * label list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * bool * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_name : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and core_field_type = + { field_desc: core_field_desc; + field_loc: Location.t } + +and core_field_desc = + Tcfield of string * core_type + | Tcfield_var + +and row_field = + Ttag of label * bool * core_type list + | Tinherit of core_type + +and value_description = + { val_desc : core_type; + val_val : Types.value_description; + val_prim : string list; + val_loc : Location.t; + } + +and type_declaration = + { typ_params: string loc option list; + typ_type : Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_variance: (bool * bool) list; + typ_loc: Location.t } + +and type_kind = + Ttype_abstract + | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list + | Ttype_record of + (Ident.t * string loc * mutable_flag * core_type * Location.t) list + +and exception_declaration = + { exn_params : core_type list; + exn_exn : Types.exception_declaration; + exn_loc : Location.t } + +and class_type = + { cltyp_desc: class_type_desc; + cltyp_type : Types.class_type; + cltyp_env : Env.t; (* BINANNOT ADDED *) + cltyp_loc: Location.t } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_fun of label * core_type * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + csig_loc : Location.t; + } + +and class_type_field = { + ctf_desc : class_type_field_desc; + ctf_loc : Location.t; + } + +and class_type_field_desc = + Tctf_inher of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_virt of (string * private_flag * core_type) + | Tctf_meth of (string * private_flag * core_type) + | Tctf_cstr of (core_type * core_type) + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: string loc list * Location.t; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_id_typesharp : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_variance: (bool * bool) list; + ci_loc: Location.t } + (* Auxiliary functions over the a.s.t. *) let iter_pattern_desc f = function - | Tpat_alias(p, id) -> f p + | Tpat_alias(p, _, _) -> f p | Tpat_tuple patl -> List.iter f patl - | Tpat_construct(cstr, patl) -> List.iter f patl + | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl | Tpat_variant(_, pat, _) -> may f pat - | Tpat_record lbl_pat_list -> - List.iter (fun (lbl, pat) -> f pat) lbl_pat_list + | Tpat_record (lbl_pat_list, _) -> + List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 | Tpat_lazy p -> f p @@ -240,14 +466,15 @@ let iter_pattern_desc f = function let map_pattern_desc f d = match d with - | Tpat_alias (p1, id) -> - Tpat_alias (f p1, id) + | Tpat_alias (p1, id, s) -> + Tpat_alias (f p1, id, s) | Tpat_tuple pats -> Tpat_tuple (List.map f pats) - | Tpat_record lpats -> - Tpat_record (List.map (fun (l,p) -> l, f p) lpats) - | Tpat_construct (c,pats) -> - Tpat_construct (c, List.map f pats) + | Tpat_record (lpats, closed) -> + Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p) + lpats, closed) + | Tpat_construct (lid, lid_loc, c,pats, arity) -> + Tpat_construct (lid, lid_loc, c, List.map f pats, arity) | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_lazy p1 -> Tpat_lazy (f p1) @@ -262,12 +489,13 @@ let map_pattern_desc f d = (* List the identifiers bound by a pattern or a let *) -let idents = ref([]: Ident.t list) +let idents = ref([]: (Ident.t * string loc) list) let rec bound_idents pat = match pat.pat_desc with - | Tpat_var id -> idents := id :: !idents - | Tpat_alias(p, id) -> bound_idents p; idents := id :: !idents + | Tpat_var (id,s) -> idents := (id,s) :: !idents + | Tpat_alias(p, id, s ) -> + bound_idents p; idents := (id,s) :: !idents | Tpat_or(p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 @@ -276,13 +504,16 @@ let rec bound_idents pat = let pat_bound_idents pat = idents := []; bound_idents pat; let res = !idents in idents := []; res -let rev_let_bound_idents pat_expr_list = +let rev_let_bound_idents_with_loc pat_expr_list = idents := []; List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list; let res = !idents in idents := []; res -let let_bound_idents pat_expr_list = - List.rev(rev_let_bound_idents pat_expr_list) +let let_bound_idents_with_loc pat_expr_list = + List.rev(rev_let_bound_idents_with_loc pat_expr_list) + +let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) +let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) (*> JOCAML *) let do_def_bound_idents autos r = @@ -307,16 +538,19 @@ let rev_loc_bound_idents d = List.rev (loc_bound_idents d) let alpha_var env id = List.assoc id env let rec alpha_pat env p = match p.pat_desc with -| Tpat_var id -> (* note the ``Not_found'' case *) +| Tpat_var (id, s) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id) with + try Tpat_var (alpha_var env id, s) with | Not_found -> Tpat_any} -| Tpat_alias (p1, id) -> +| Tpat_alias (p1, id, s) -> let new_p = alpha_pat env p1 in begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} with | Not_found -> new_p end | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 949774222d..5133377435 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -19,65 +19,87 @@ open Types (* Value expressions for the core language *) +type partial = Partial | Total +type optional = Required | Optional + type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; + pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_unpack + and pattern_desc = Tpat_any - | Tpat_var of Ident.t - | Tpat_alias of pattern * Ident.t + | Tpat_var of Ident.t * string loc + | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list - | Tpat_construct of constructor_description * pattern list + | Tpat_construct of + Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref - | Tpat_record of (label_description * pattern) list + | Tpat_record of + (Path.t * Longident.t loc * label_description * pattern) list * + closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern -type partial = Partial | Total -type optional = Required | Optional - -type expression = +and expression = { exp_desc: expression_desc; exp_loc: Location.t; + exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } +and exp_extra = + | Texp_constraint of core_type option * core_type option + | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string + and expression_desc = - Texp_ident of Path.t * value_description + Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list * partial - | Texp_apply of expression * (expression option * optional) list + | Texp_function of label * (pattern * expression) list * partial + | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list - | Texp_construct of constructor_description * expression list + | Texp_construct of + Path.t * Longident.t loc * constructor_description * expression list * + bool | Texp_variant of label * expression option - | Texp_record of (label_description * expression) list * expression option - | Texp_field of expression * label_description - | Texp_setfield of expression * label_description * expression + | Texp_record of + (Path.t * Longident.t loc * label_description * expression) list * + expression option + | Texp_field of expression * Path.t * Longident.t loc * label_description + | Texp_setfield of + expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * expression * expression * direction_flag * expression + Ident.t * string loc * expression * expression * direction_flag * + expression | Texp_when of expression * expression - | Texp_send of expression * meth - | Texp_new of Path.t * class_declaration - | Texp_instvar of Path.t * Path.t - | Texp_setinstvar of Path.t * Path.t * expression - | Texp_override of Path.t * (Path.t * expression) list - | Texp_letmodule of Ident.t * module_expr * expression + | Texp_send of expression * meth * expression option + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_object of class_structure * class_signature * string list + | Texp_object of class_structure * string list | Texp_pack of module_expr (*> JOCAML *) | Texp_asyncsend of expression * expression @@ -148,68 +170,103 @@ and meth = and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; - cl_type: class_type; + cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = - Tclass_ident of Path.t - | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial - | Tclass_apply of class_expr * (expression option * optional) list - | Tclass_let of rec_flag * (pattern * expression) list * - (Ident.t * expression) list * class_expr - | Tclass_constraint of class_expr * string list * string list * Concr.t + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + label * pattern * (Ident.t * string loc * expression) list * class_expr * + partial + | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concretes methods *) and class_structure = - { cl_field: class_field list; - cl_meths: Ident.t Meths.t } + { cstr_pat : pattern; + cstr_fields: class_field list; + cstr_type : Types.class_signature; + cstr_meths: Ident.t Meths.t } and class_field = - Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list + { + cf_desc : class_field_desc; + cf_loc : Location.t; + } + +and class_field_kind = + Tcfk_virtual of core_type +| Tcfk_concrete of expression + +and class_field_desc = + Tcf_inher of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list (* Inherited instance variables and concrete methods *) - | Cf_val of string * Ident.t * expression option * bool + | Tcf_val of + string * string loc * mutable_flag * Ident.t * class_field_kind * bool (* None = virtual, true = override *) - | Cf_meth of string * expression - | Cf_init of expression + | Tcf_meth of string * string loc * private_flag * class_field_kind * bool + | Tcf_constr of core_type * core_type +(* | Tcf_let of rec_flag * (pattern * expression) list * + (Ident.t * string loc * expression) list *) + | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; - mod_type: module_type; + mod_type: Types.module_type; mod_env: Env.t } +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + and module_expr_desc = - Tmod_ident of Path.t + Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure - | Tmod_functor of Ident.t * module_type * module_expr + | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of module_expr * module_type * module_coercion - | Tmod_unpack of expression * module_type + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type -and structure = structure_item list +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list - | Tstr_primitive of Ident.t * value_description - | Tstr_type of (Ident.t * type_declaration) list - | 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 * virtual_flag) list - | Tstr_cltype of (Ident.t * cltype_declaration) list + | Tstr_primitive of Ident.t * string loc * value_description + | Tstr_type of (Ident.t * string loc * type_declaration) list + | Tstr_exception of Ident.t * string loc * exception_declaration + | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc + | Tstr_module of Ident.t * string loc * module_expr + | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list + | Tstr_modtype of Ident.t * string loc * module_type + | Tstr_open of Path.t * Longident.t loc + | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_loc of joinlocation list - | Tstr_exn_global of Location.t * Path.t + | Tstr_exn_global of Path.t * Longident.t loc (*< JOCAML *) and module_coercion = @@ -218,10 +275,176 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of Ident.t * string loc * value_description + | Tsig_type of (Ident.t * string loc * type_declaration) list + | Tsig_exception of Ident.t * string loc * exception_declaration + | Tsig_module of Ident.t * string loc * module_type + | Tsig_recmodule of (Ident.t * string loc * module_type) list + | Tsig_modtype of Ident.t * string loc * modtype_declaration + | Tsig_open of Path.t * Longident.t loc + | Tsig_include of module_type * Types.signature + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + +and modtype_declaration = + Tmodtype_abstract + | Tmodtype_manifest of module_type + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of core_field_type list + | Ttyp_class of Path.t * Longident.t loc * core_type list * label list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * bool * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_name : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and core_field_type = + { field_desc: core_field_desc; + field_loc: Location.t } + +and core_field_desc = + Tcfield of string * core_type + | Tcfield_var + +and row_field = + Ttag of label * bool * core_type list + | Tinherit of core_type + +and value_description = + { val_desc : core_type; + val_val : Types.value_description; + val_prim : string list; + val_loc : Location.t; + } + +and type_declaration = + { typ_params: string loc option list; + typ_type : Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_variance: (bool * bool) list; + typ_loc: Location.t } + +and type_kind = + Ttype_abstract + | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list + | Ttype_record of + (Ident.t * string loc * mutable_flag * core_type * Location.t) list + +and exception_declaration = + { exn_params : core_type list; + exn_exn : Types.exception_declaration; + exn_loc : Location.t } + +and class_type = + { cltyp_desc: class_type_desc; + cltyp_type : Types.class_type; + cltyp_env : Env.t; (* BINANNOT ADDED *) + cltyp_loc: Location.t } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_fun of label * core_type * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + csig_loc : Location.t; + } + +and class_type_field = { + ctf_desc : class_type_field_desc; + ctf_loc : Location.t; + } + +and class_type_field_desc = + Tctf_inher of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_virt of (string * private_flag * core_type) + | Tctf_meth of (string * private_flag * core_type) + | Tctf_cstr of (core_type * core_type) + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: string loc list * Location.t; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_id_typesharp : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_variance: (bool * bool) list; + ci_loc: Location.t } + (* Auxiliary functions over the a.s.t. *) -val iter_pattern_desc : (pattern -> unit) -> pattern_desc -> unit -val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc +val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit +val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc val let_bound_idents: (pattern * expression) list -> Ident.t list val rev_let_bound_idents: (pattern * expression) list -> Ident.t list @@ -233,5 +456,15 @@ val rev_def_bound_idents: joinautomaton list -> Ident.t list val rev_loc_bound_idents: joinlocation list -> Ident.t list (*< JOCAML *) +val let_bound_idents_with_loc: + (pattern * expression) list -> (Ident.t * string loc) list +val rev_let_bound_idents_with_loc: + (pattern * expression) list -> (Ident.t * string loc) list + (* Alpha conversion of patterns *) -val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern +val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern + +val mknoloc: 'a -> 'a Asttypes.loc +val mkloc: 'a -> Location.t -> 'a Asttypes.loc + +val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list diff --git a/typing/typemod.ml b/typing/typemod.ml index 2f5fab2520..669bd0f34b 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -12,15 +12,12 @@ (* $Id$ *) -(* Type-checking of the module language *) - open Misc open Longident open Path open Asttypes open Parsetree open Types -open Typedtree open Format type error = @@ -45,24 +42,34 @@ type error = exception Error of Location.t * error +open Typedtree + +let fst3 (x,_,_) = x + +let rec path_concat head p = + match p with + Pident tail -> Pdot (Pident head, Ident.name tail, 0) + | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) + | Papply _ -> assert false + (* Extract a signature from a module type *) let extract_sig env loc mty = match Mtype.scrape env mty with - Tmty_signature sg -> sg + Mty_signature sg -> sg | _ -> raise(Error(loc, Signature_expected)) let extract_sig_open env loc mty = match Mtype.scrape env mty with - Tmty_signature sg -> sg + Mty_signature sg -> sg | _ -> raise(Error(loc, Structure_expected mty)) (* Compute the environment after opening a module *) -let type_open env loc lid = - let (path, mty) = Typetexp.find_module env loc lid in +let type_open ?toplevel env loc lid = + let (path, mty) = Typetexp.find_module env loc lid.txt in let sg = extract_sig_open env loc mty in - Env.open_signature ~loc path sg env + path, Env.open_signature ~loc ?toplevel path sg env (* Record a module type *) let rm node = @@ -70,14 +77,15 @@ let rm node = node (* Forward declaration, to be filled in by type_module_type_of *) -let type_module_type_of_fwd - : (Env.t -> Parsetree.module_expr -> module_type) ref +let type_module_type_of_fwd : + (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) ref = ref (fun env m -> assert false) (* Merge one "with" constraint in a signature *) let rec add_rec_types env = function - Tsig_type(id, decl, Trec_next) :: rem -> + Sig_type(id, decl, Trec_next) :: rem -> add_rec_types (Env.add_type id decl env) rem | _ -> env @@ -97,20 +105,24 @@ let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none} let make_next_first rs rem = if rs = Trec_first then match rem with - Tsig_type (id, decl, Trec_next) :: rem -> - Tsig_type (id, decl, Trec_first) :: rem - | Tsig_module (id, mty, Trec_next) :: rem -> - Tsig_module (id, mty, Trec_first) :: rem + Sig_type (id, decl, Trec_next) :: rem -> + Sig_type (id, decl, Trec_first) :: rem + | Sig_module (id, mty, Trec_next) :: rem -> + Sig_module (id, mty, Trec_first) :: rem | _ -> rem else rem -let merge_constraint initial_env loc sg lid constr = +let sig_item desc typ env loc = { + Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env +} + +let merge_constraint initial_env loc sg lid constr = let real_id = ref None in let rec merge env sg namelist row_id = match (sg, namelist, constr) with ([], _, _) -> - raise(Error(loc, With_no_component lid)) - | (Tsig_type(id, decl, rs) :: rem, [s], + raise(Error(loc, With_no_component lid.txt)) + | (Sig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = @@ -127,83 +139,102 @@ let merge_constraint initial_env loc sg lid constr = type_newtype_level = None } and id_row = Ident.create (s^"#row") in let initial_env = Env.add_type id_row decl_row initial_env in - let newdecl = Typedecl.transl_with_constraint + let tdecl = Typedecl.transl_with_constraint initial_env id (Some(Pident id_row)) decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; let decl_row = {decl_row with type_params = newdecl.type_params} in let rs' = if rs = Trec_first then Trec_not else rs in - Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem - | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl) + (Pident id, lid, Twith_type tdecl), + Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem + | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type sdecl) when Ident.name id = s -> - let newdecl = + let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; - Tsig_type(id, newdecl, rs) :: rem - | (Tsig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) + (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem + | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) when Ident.name id = s ^ "#row" -> merge env rem namelist (Some id) - | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) + | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) when Ident.name id = s -> (* Check as for a normal with constraint, but discard definition *) - let newdecl = + let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in + let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; real_id := Some id; + (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid) + | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid in + let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); - Tsig_module(id, newmty, rs) :: rem - | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_modsubst lid) + (Pident id, lid, Twith_module (path, lid)), + Sig_module(id, newmty, rs) :: rem + | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (lid)) when Ident.name id = s -> - let (path, mty') = Typetexp.find_module initial_env loc lid in + let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); real_id := Some id; + (Pident id, lid, Twith_modsubst (path, lid)), make_next_first rs rem - | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _) + | (Sig_module(id, mty, rs) :: rem, s :: namelist, _) when Ident.name id = s -> - let newsg = merge env (extract_sig env loc mty) namelist None in - Tsig_module(id, Tmty_signature newsg, rs) :: rem + let ((path, path_loc, tcstr), newsg) = + merge env (extract_sig env loc mty) namelist None in + (path_concat id path, lid, tcstr), + Sig_module(id, Mty_signature newsg, rs) :: rem | (item :: rem, _, _) -> - item :: merge (Env.add_item item env) rem namelist row_id in + let (cstr, items) = merge (Env.add_item item env) rem namelist row_id + in + cstr, item :: items + in try - let names = Longident.flatten lid in - let sg = merge initial_env sg names None in + let names = Longident.flatten lid.txt in + let (tcstr, sg) = merge initial_env sg names None in + let sg = match names, constr with [s], Pwith_typesubst sdecl -> let id = match !real_id with None -> assert false | Some id -> id in let lid = try match sdecl.ptype_manifest with - | Some {ptyp_desc = Ptyp_constr (lid, stl)} -> + | Some {ptyp_desc = Ptyp_constr (lid, stl)} + when List.length stl = List.length sdecl.ptype_params -> let params = List.map (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit) stl in - if List.map (fun x -> Some x) params <> sdecl.ptype_params - then raise Exit; + List.iter2 (fun x ox -> + match ox with + Some y when x = y.txt -> () + | _ -> raise Exit + ) params sdecl.ptype_params; lid | _ -> raise Exit with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr)) in let (path, _) = - try Env.lookup_type lid initial_env with Not_found -> assert false + try Env.lookup_type lid.txt initial_env with Not_found -> assert false in let sub = Subst.add_type id path Subst.identity in Subst.signature sub sg - | [s], Pwith_modsubst lid -> + | [s], Pwith_modsubst (lid) -> let id = match !real_id with None -> assert false | Some id -> id in - let (path, _) = Typetexp.find_module initial_env loc lid in + let (path, _) = Typetexp.find_module initial_env loc lid.txt in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg | _ -> - sg + sg + in + (tcstr, sg) with Includemod.Error explanation -> - raise(Error(loc, With_mismatch(lid, explanation))) + raise(Error(loc, With_mismatch(lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -219,6 +250,12 @@ let rec map_rec' fn decls rem = fn Trec_not d1 :: map_rec' fn dl rem | _ -> map_rec fn decls rem +let rec map_rec'' fn decls rem = + match decls with + | (id, _,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> + fn Trec_not d1 :: map_rec'' fn dl rem + | _ -> map_rec fn decls rem + (* 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 @@ -228,19 +265,20 @@ let rec map_rec' fn decls rem = let rec approx_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> - let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid in - Tmty_ident path + let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in + Mty_ident path | Pmty_signature ssg -> - Tmty_signature(approx_sig env ssg) + Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> let arg = approx_modtype env sarg in - let (id, newenv) = Env.enter_module param arg env in + let (id, newenv) = Env.enter_module param.txt arg env in let res = approx_modtype newenv sres in - Tmty_functor(id, arg, res) + Mty_functor(id, arg, res) | Pmty_with(sbody, constraints) -> approx_modtype env sbody | Pmty_typeof smod -> - !type_module_type_of_fwd env smod + let (_, mty) = !type_module_type_of_fwd env smod in + mty and approx_sig env ssg = match ssg with @@ -250,28 +288,29 @@ and approx_sig env ssg = | Psig_type sdecls -> let decls = Typedecl.approx_type_decl env sdecls in let rem = approx_sig env srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem | Psig_module(name, smty) -> let mty = approx_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in - Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem + let (id, newenv) = Env.enter_module name.txt mty env in + Sig_module(id, mty, Trec_not) :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype env smty)) + (Ident.create name.txt, approx_modtype env smty)) sdecls in let newenv = List.fold_left (fun env (id, mty) -> Env.add_module id mty env) env decls in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls + map_rec (fun rs (id, mty) -> Sig_module(id, mty, rs)) decls (approx_sig newenv srem) | Psig_modtype(name, sinfo) -> let info = approx_modtype_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - Tsig_modtype(id, info) :: approx_sig newenv srem + let (id, newenv) = Env.enter_modtype name.txt info env in + Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open lid -> - approx_sig (type_open env item.psig_loc lid) srem + let (path, mty) = type_open env item.psig_loc lid in + approx_sig mty srem | Psig_include smty -> let mty = approx_modtype env smty in let sg = Subst.signature Subst.identity @@ -283,10 +322,10 @@ and approx_sig env ssg = let rem = approx_sig env srem in List.flatten (map_rec - (fun rs (i1, d1, i2, d2, i3, d3) -> - [Tsig_cltype(i1, d1, rs); - Tsig_type(i2, d2, rs); - Tsig_type(i3, d3, rs)]) + (fun rs (i1, _, d1, i2, d2, i3, d3, _) -> + [Sig_class_type(i1, d1, rs); + Sig_type(i2, d2, rs); + Sig_type(i3, d3, rs)]) decls [rem]) | _ -> approx_sig env srem @@ -294,17 +333,18 @@ and approx_sig env ssg = and approx_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> - Tmodtype_abstract + Modtype_abstract | Pmodtype_manifest smty -> - Tmodtype_manifest(approx_modtype env smty) + Modtype_manifest(approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) let check_recmod_typedecls env sdecls decls = - let recmod_ids = List.map fst decls in + let recmod_ids = List.map fst3 decls in List.iter2 - (fun (_, smty) (id, mty) -> + (fun (_, smty) (id, _, mty) -> + let mty = mty.mty_type in List.iter (fun path -> Typedecl.check_recmod_typedecl env smty.pmty_loc recmod_ids @@ -322,23 +362,23 @@ let check cl loc set_ref name = else set_ref := StringSet.add name !set_ref let check_sig_item type_names module_names modtype_names loc = function - Tsig_type(id, _, _) -> + Sig_type(id, _, _) -> check "type" loc type_names (Ident.name id) - | Tsig_module(id, _, _) -> + | Sig_module(id, _, _) -> check "module" loc module_names (Ident.name id) - | Tsig_modtype(id, _) -> + | Sig_modtype(id, _) -> check "module type" loc modtype_names (Ident.name id) | _ -> () let rec remove_values ids = function [] -> [] - | Tsig_value (id, _) :: rem + | Sig_value (id, _) :: rem when List.exists (Ident.equal id) ids -> remove_values ids rem | f :: rem -> f :: remove_values ids rem let rec get_values = function [] -> [] - | Tsig_value (id, _) :: rem -> id :: get_values rem + | Sig_value (id, _) :: rem -> id :: get_values rem | f :: rem -> get_values rem (* Check and translate a module type expression *) @@ -347,28 +387,55 @@ let transl_modtype_longident loc env lid = let (path, info) = Typetexp.find_modtype env loc lid in path +let mkmty desc typ env loc = + let mty = { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + } in + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + mty + +let mksig desc env loc = + let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + sg + +(* let signature sg = List.map (fun item -> item.sig_type) sg *) + let rec transl_modtype env smty = + let loc = smty.pmty_loc in match smty.pmty_desc with Pmty_ident lid -> - Tmty_ident (transl_modtype_longident smty.pmty_loc env lid) + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc | Pmty_signature ssg -> - Tmty_signature(transl_signature env ssg) + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc | Pmty_functor(param, sarg, sres) -> let arg = transl_modtype env sarg in - let (id, newenv) = Env.enter_module param arg env in + let (id, newenv) = Env.enter_module param.txt arg.mty_type env in let res = transl_modtype newenv sres in - Tmty_functor(id, arg, res) + mkmty (Tmty_functor (id, param, arg, res)) + (Mty_functor(id, arg.mty_type, res.mty_type)) env loc | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in - let init_sg = extract_sig env sbody.pmty_loc body in - let final_sg = + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let (tcstrs, final_sg) = List.fold_left - (fun sg (lid, sdecl) -> - merge_constraint env smty.pmty_loc sg lid sdecl) - init_sg constraints in - Mtype.freshen (Tmty_signature final_sg) + (fun (tcstrs,sg) (lid, sdecl) -> + let (tcstr, sg) = merge_constraint env smty.pmty_loc sg lid sdecl + in + (tcstr :: tcstrs, sg) + ) + ([],init_sg) constraints in + mkmty (Tmty_with ( body, tcstrs)) + (Mtype.freshen (Mty_signature final_sg)) env loc | Pmty_typeof smod -> - !type_module_type_of_fwd env smod + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc + and transl_signature env sg = let type_names = ref StringSet.empty @@ -377,52 +444,75 @@ and transl_signature env sg = let rec transl_sig env sg = Ctype.init_def(Ident.current_time()); match sg with - [] -> [] + [] -> [], [], env | item :: srem -> + let loc = item.psig_loc in match item.psig_desc with | Psig_value(name, sdesc) -> - let desc = Typedecl.transl_value_decl env item.psig_loc sdesc in - let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in - let rem = transl_sig newenv srem in - if List.exists (Ident.equal id) (get_values rem) then rem - else Tsig_value(id, desc) :: rem + let tdesc = Typedecl.transl_value_decl env item.psig_loc sdesc in + let desc = tdesc.val_val in + let (id, newenv) = + Env.enter_value name.txt desc env + ~check:(fun s -> Warnings.Unused_value_declaration s) in + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_value (id, name, tdesc)) env loc :: trem, + (if List.exists (Ident.equal id) (get_values rem) then rem + else Sig_value(id, desc) :: rem), + final_env | Psig_type sdecls -> List.iter - (fun (name, decl) -> check "type" item.psig_loc type_names name) + (fun (name, decl) -> + check "type" item.psig_loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in - let rem = transl_sig newenv srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_type decls) env loc :: trem, + map_rec'' (fun rs (id, _, info) -> + Sig_type(id, info.typ_type, rs)) decls rem, + final_env | Psig_exception(name, sarg) -> let arg = Typedecl.transl_exception env item.psig_loc sarg in - let (id, newenv) = Env.enter_exception name arg env in - let rem = transl_sig newenv srem in - Tsig_exception(id, arg) :: rem + let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_exception (id, name, arg)) env loc :: trem, + Sig_exception(id, arg.exn_exn) :: rem, + final_env | Psig_module(name, smty) -> - check "module" item.psig_loc module_names name; - let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in - let rem = transl_sig newenv srem in - Tsig_module(id, mty, Trec_not) :: rem + check "module" item.psig_loc module_names name.txt; + let tmty = transl_modtype env smty in + let mty = tmty.mty_type in + let (id, newenv) = Env.enter_module name.txt mty env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_module (id, name, tmty)) env loc :: trem, + Sig_module(id, mty, Trec_not) :: rem, + final_env | Psig_recmodule sdecls -> List.iter (fun (name, smty) -> - check "module" item.psig_loc module_names name) + check "module" item.psig_loc module_names name.txt) sdecls; let (decls, newenv) = transl_recmodule_modtypes item.psig_loc env sdecls in - let rem = transl_sig newenv srem in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule decls) env loc :: trem, + map_rec (fun rs (id, _, tmty) -> Sig_module(id, tmty.mty_type, rs)) + decls rem, + final_env | Psig_modtype(name, sinfo) -> - check "module type" item.psig_loc modtype_names name; - let info = transl_modtype_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - let rem = transl_sig newenv srem in - Tsig_modtype(id, info) :: rem + check "module type" item.psig_loc modtype_names name.txt; + let (tinfo, info) = transl_modtype_info env sinfo in + let (id, newenv) = Env.enter_modtype name.txt info env in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem, + Sig_modtype(id, info) :: rem, + final_env | Psig_open lid -> - transl_sig (type_open env item.psig_loc lid) srem + let (path, newenv) = type_open env item.psig_loc lid in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env | Psig_include smty -> - let mty = transl_modtype env smty in + let tmty = transl_modtype env smty in + let mty = tmty.mty_type in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in List.iter @@ -430,63 +520,88 @@ and transl_signature env sg = item.psig_loc) sg; let newenv = Env.add_signature sg env in - let rem = transl_sig newenv srem in - remove_values (get_values rem) sg @ rem + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_include (tmty, sg)) env loc :: trem, + remove_values (get_values rem) sg @ rem, final_env | Psig_class cl -> List.iter (fun {pci_name = name} -> - check "type" item.psig_loc type_names name) + check "type" item.psig_loc type_names name.txt ) cl; let (classes, newenv) = Typeclass.class_descriptions env cl in - let rem = transl_sig newenv srem in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_class + (List.map2 + (fun pcl tcl -> + let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in + tcl) + cl classes)) env loc + :: trem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) -> - [Tsig_class(i, d, rs); - Tsig_cltype(i', d', rs); - Tsig_type(i'', d'', rs); - Tsig_type(i''', d''', rs)]) - classes [rem]) + (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> + [Sig_class(i, d, rs); + Sig_class_type(i', d', rs); + Sig_type(i'', d'', rs); + Sig_type(i''', d''', rs)]) + classes [rem]), + final_env | Psig_class_type cl -> List.iter (fun {pci_name = name} -> - check "type" item.psig_loc type_names name) + check "type" item.psig_loc type_names name.txt) cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in - let rem = transl_sig newenv srem in + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_class_type (List.map2 (fun pcl tcl -> + let (_, _, _, _, _, _, _, tcl) = tcl in + tcl + ) cl classes)) env loc :: trem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'') -> - [Tsig_cltype(i, d, rs); - Tsig_type(i', d', rs); - Tsig_type(i'', d'', rs)]) - classes [rem]) - in transl_sig env sg + (fun rs (i, _, d, i', d', i'', d'', _) -> + [Sig_class_type(i, d, rs); + Sig_type(i', d', rs); + Sig_type(i'', d'', rs)]) + classes [rem]), + final_env + in + let previous_saved_types = Cmt_format.get_saved_types () in + let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in + let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in + Cmt_format.set_saved_types + ((Cmt_format.Partial_signature sg) :: previous_saved_types); + sg and transl_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> - Tmodtype_abstract + Tmodtype_abstract, Modtype_abstract | Pmodtype_manifest smty -> - Tmodtype_manifest(transl_modtype env smty) + let tmty = transl_modtype env smty in + Tmodtype_manifest tmty, Modtype_manifest tmty.mty_type and transl_recmodule_modtypes loc env sdecls = let make_env curr = List.fold_left - (fun env (id, mty) -> Env.add_module id mty env) + (fun env (id, _, mty) -> Env.add_module id mty env) + env curr in + let make_env2 curr = + List.fold_left + (fun env (id, _, mty) -> Env.add_module id mty.mty_type env) env curr in let transition env_c curr = List.map2 - (fun (_, smty) (id, mty) -> (id, transl_modtype env_c smty)) + (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty)) sdecls curr in let init = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype env smty)) + (Ident.create name.txt, name, approx_modtype env smty)) sdecls in let env0 = make_env init in let dcl1 = transition env0 init in - let env1 = make_env dcl1 in + let env1 = make_env2 dcl1 in check_recmod_typedecls env1 sdecls dcl1; let dcl2 = transition env1 dcl1 in (* @@ -495,7 +610,7 @@ and transl_recmodule_modtypes loc env sdecls = Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) dcl2; *) - let env2 = make_env dcl2 in + let env2 = make_env2 dcl2 in check_recmod_typedecls env2 sdecls dcl2; (dcl2, env2) @@ -505,7 +620,7 @@ exception Not_a_path let rec path_of_module mexp = match mexp.mod_desc with - Tmod_ident p -> p + Tmod_ident (p,_) -> p | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors -> Papply(path_of_module funct, path_of_module arg) | _ -> raise Not_a_path @@ -513,23 +628,24 @@ let rec path_of_module mexp = (* Check that all core type schemes in a structure are closed *) let rec closed_modtype = function - Tmty_ident p -> true - | Tmty_signature sg -> List.for_all closed_signature_item sg - | Tmty_functor(id, param, body) -> closed_modtype body + Mty_ident p -> true + | Mty_signature sg -> List.for_all closed_signature_item sg + | Mty_functor(id, param, body) -> closed_modtype body and closed_signature_item = function - Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type - | Tsig_module(id, mty, _) -> closed_modtype mty + Sig_value(id, desc) -> Ctype.closed_schema desc.val_type + | Sig_module(id, mty, _) -> closed_modtype mty | _ -> true -let check_nongen_scheme env = function +let check_nongen_scheme env str = + match str.str_desc with Tstr_value(rec_flag, pat_exp_list) -> List.iter (fun (pat, exp) -> if not (Ctype.closed_schema exp.exp_type) then raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) pat_exp_list - | Tstr_module(id, md) -> + | Tstr_module(id, _, md) -> if not (closed_modtype md.mod_type) then raise(Error(md.mod_loc, Non_generalizable_module md.mod_type)) | _ -> () @@ -544,21 +660,19 @@ let check_nongen_schemes env str = let rec bound_value_identifiers = function [] -> [] - | Tsig_value(id, {val_kind = Val_reg}) :: rem -> + | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem - | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem -(* Type a module value expression *) - (*> JOCAML *) (* Channels appear as regular values in signatures *) let make_sig_channel_value env id = try let desc = Env.find_value (Pident id) env in - Tsig_value(id, {desc with val_kind=Val_reg}) + Sig_value(id, {desc with val_kind=Val_reg}) with Not_found -> assert false (*< JOCAML *) @@ -574,9 +688,10 @@ let enrich_type_decls anchor decls oldenv newenv = None -> newenv | Some p -> List.fold_left - (fun e (id, info) -> + (fun e (id, _, info) -> let info' = - Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info + Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) + info.typ_type in Env.add_type id info' e) oldenv decls @@ -616,7 +731,7 @@ let check_recmodule_inclusion env bindings = (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map - (fun (id, mty_decl, modl, mty_actual) -> + (fun (id, _, mty_decl, modl, mty_actual) -> (id, Ident.rename id, mty_actual)) bindings in (* Enter the Y_i in the environment with their actual types substituted @@ -641,8 +756,8 @@ let check_recmodule_inclusion env bindings = end else begin (* Base case: check inclusion of s(mty_actual) in s(mty_decl) and insert coercion if needed *) - let check_inclusion (id, mty_decl, modl, mty_actual) = - let mty_decl' = Subst.modtype s mty_decl + let check_inclusion (id, id_loc, mty_decl, modl, mty_actual) = + let mty_decl' = Subst.modtype s mty_decl.mty_type and mty_actual' = subst_and_strengthen env s id mty_actual in let coercion = try @@ -650,11 +765,12 @@ let check_recmodule_inclusion env bindings = with Includemod.Error msg -> raise(Error(modl.mod_loc, Not_included msg)) in let modl' = - { mod_desc = Tmod_constraint(modl, mty_decl, coercion); - mod_type = mty_decl; + { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, + Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; mod_env = env; mod_loc = modl.mod_loc } in - (id, modl') in + (id, id_loc, mty_decl, modl') in List.map check_inclusion bindings end in check_incl true (List.length bindings) env Subst.identity @@ -667,50 +783,58 @@ let rec package_constraints env loc mty constrs = let sg' = List.map (function - | Tsig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs -> + | Sig_type (id, ({type_params=[]} as td), rs) + when List.mem_assoc [Ident.name id] constrs -> let ty = List.assoc [Ident.name id] constrs in - Tsig_type (id, {td with type_manifest = Some ty}, rs) - | Tsig_module (id, mty, rs) -> + Sig_type (id, {td with type_manifest = Some ty}, rs) + | Sig_module (id, mty, rs) -> let rec aux = function - | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest + | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> + (l, t) :: aux rest | _ :: rest -> aux rest | [] -> [] in - Tsig_module (id, package_constraints env loc mty (aux constrs), rs) + Sig_module (id, package_constraints env loc mty (aux constrs), rs) | item -> item ) sg in - Tmty_signature sg' + Mty_signature sg' let modtype_of_package env loc p nl tl = try match Env.find_modtype p env with - | Tmodtype_manifest mty when nl <> [] -> - package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl) + | Modtype_manifest mty when nl <> [] -> + package_constraints env loc mty + (List.combine (List.map Longident.flatten nl) tl) | _ -> - if nl = [] then Tmty_ident p + if nl = [] then Mty_ident p else raise(Error(loc, Signature_expected)) with Not_found -> raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p))) -let wrap_constraint env arg mty = +let wrap_constraint env arg mty explicit = let coercion = try Includemod.modtypes env arg.mod_type mty with Includemod.Error msg -> raise(Error(arg.mod_loc, Not_included msg)) in - { mod_desc = Tmod_constraint(arg, mty, coercion); + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); mod_type = mty; mod_env = env; mod_loc = arg.mod_loc } (* Type a module value expression *) +let mkstr desc loc env = + let str = { str_desc = desc; str_loc = loc; str_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str); + str + let rec type_module sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let (path, mty) = Typetexp.find_module env smod.pmod_loc lid in - rm { mod_desc = Tmod_ident path; + let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + rm { mod_desc = Tmod_ident (path, lid); mod_type = if sttn then Mtype.strengthen env mty path else mty; mod_env = env; mod_loc = smod.pmod_loc } @@ -718,15 +842,15 @@ let rec type_module sttn funct_body anchor env smod = let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in rm { mod_desc = Tmod_structure str; - mod_type = Tmty_signature sg; + mod_type = Mty_signature sg; mod_env = env; mod_loc = smod.pmod_loc } | Pmod_functor(name, smty, sbody) -> let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_module name mty env in + let (id, newenv) = Env.enter_module name.txt mty.mty_type env in let body = type_module sttn true None newenv sbody in - rm { mod_desc = Tmod_functor(id, mty, body); - mod_type = Tmty_functor(id, mty, body.mod_type); + rm { mod_desc = Tmod_functor(id, name, mty, body); + mod_type = Mty_functor(id, mty.mty_type, body.mod_type); mod_env = env; mod_loc = smod.pmod_loc } | Pmod_apply(sfunct, sarg) -> @@ -735,7 +859,7 @@ let rec type_module sttn funct_body anchor env smod = let funct = type_module (sttn && path <> None) funct_body None env sfunct in begin match Mtype.scrape env funct.mod_type with - Tmty_functor(param, mty_param, mty_res) as mty_functor -> + Mty_functor(param, mty_param, mty_res) as mty_functor -> let coercion = try Includemod.modtypes env arg.mod_type mty_param @@ -764,7 +888,8 @@ let rec type_module sttn funct_body anchor env smod = | Pmod_constraint(sarg, smty) -> let arg = type_module true funct_body anchor env sarg in let mty = transl_modtype env smty in - rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc} + rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with + mod_loc = smod.pmod_loc} | Pmod_unpack sexp -> if funct_body then @@ -798,20 +923,24 @@ let rec type_module sttn funct_body anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } -and type_structure funct_body anchor env sstr scope = +and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in let rec type_struct env sstr = + let mkstr desc loc = mkstr desc loc env in Ctype.init_def(Ident.current_time()); match sstr with [] -> ([], [], env) - | {pstr_desc = Pstr_eval sexpr} :: srem -> - let expr = Typecore.type_expression env sexpr in - let (str_rem, sig_rem, final_env) = type_struct env srem in - (Tstr_eval expr :: str_rem, sig_rem, final_env) - | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem -> + | pstr :: srem -> + let loc = pstr.pstr_loc in + match pstr.pstr_desc with + | Pstr_eval sexpr -> + let expr = Typecore.type_expression env sexpr in + let (str_rem, sig_rem, final_env) = type_struct env srem in + (mkstr (Tstr_eval expr) loc :: str_rem, sig_rem, final_env) + | Pstr_value(rec_flag, sdefs) -> let scope = match rec_flag with | Recursive -> Some (Annot.Idef {scope with @@ -830,157 +959,145 @@ and type_structure funct_body anchor env sstr scope = (* Note: Env.find_value does not trigger the value_used event. Values will be marked as being used during the signature inclusion test. *) let make_sig_value id = - Tsig_value(id, Env.find_value (Pident id) newenv) in - (Tstr_value(rec_flag, defs) :: str_rem, + Sig_value(id, Env.find_value (Pident id) newenv) in + (mkstr (Tstr_value(rec_flag, defs)) loc :: str_rem, map_end make_sig_value bound_idents sig_rem, final_env) -(*> JOCAML *) - | {pstr_desc = Pstr_def (sdefs) ; pstr_loc = loc} :: srem -> - let scope = - let start = match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in - Some (Annot.Idef {scope with Location.loc_start = start}) in - let (defs, newenv) = - Typecore.type_joindefinition env sdefs scope in - let (str_rem, sig_rem, final_env) = type_struct newenv srem in - let bound_idents = Typedtree.def_bound_idents defs in - (Tstr_def (defs) :: str_rem, - map_end (make_sig_channel_value newenv) bound_idents sig_rem, - final_env) - | {pstr_desc = Pstr_exn_global(longid); pstr_loc = loc} :: srem -> - let path = Typedecl.transl_exn_global env loc longid in - let (str_rem, sig_rem, final_env) = type_struct env srem in - (Tstr_exn_global (loc,path) :: str_rem, - sig_rem, - final_env) -(*< JOCAML *) - | {pstr_desc = Pstr_primitive(name, sdesc); pstr_loc = loc} :: srem -> + | Pstr_primitive(name, sdesc) -> let desc = Typedecl.transl_value_decl env loc sdesc in - let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in + let (id, newenv) = Env.enter_value name.txt desc.val_val env + ~check:(fun s -> Warnings.Unused_value_declaration s) in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_primitive(id, desc) :: str_rem, - Tsig_value(id, desc) :: sig_rem, + (mkstr (Tstr_primitive(id, name, desc)) loc :: str_rem, + Sig_value(id, desc.val_val) :: sig_rem, final_env) - | {pstr_desc = Pstr_type sdecls; pstr_loc = loc} :: srem -> + | Pstr_type sdecls -> List.iter - (fun (name, decl) -> check "type" loc type_names name) + (fun (name, decl) -> check "type" loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls 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_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem, + (mkstr (Tstr_type decls) loc :: str_rem, + map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs)) + decls sig_rem, final_env) - | {pstr_desc = Pstr_exception(name, sarg); pstr_loc = loc} :: srem -> + | Pstr_exception(name, sarg) -> let arg = Typedecl.transl_exception env loc sarg in - let (id, newenv) = Env.enter_exception name arg env in + let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_exception(id, arg) :: str_rem, - Tsig_exception(id, arg) :: sig_rem, + (mkstr (Tstr_exception(id, name, arg)) loc :: str_rem, + Sig_exception(id, arg.exn_exn) :: sig_rem, final_env) - | {pstr_desc = Pstr_exn_rebind(name, longid); pstr_loc = loc} :: srem -> - let (path, arg) = Typedecl.transl_exn_rebind env loc longid in - let (id, newenv) = Env.enter_exception name arg env in + | Pstr_exn_rebind(name, longid) -> + let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in + let (id, newenv) = Env.enter_exception name.txt arg env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_exn_rebind(id, path) :: str_rem, - Tsig_exception(id, arg) :: sig_rem, + (mkstr (Tstr_exn_rebind(id, name, path, longid)) loc :: str_rem, + Sig_exception(id, arg) :: sig_rem, final_env) - | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem -> - check "module" loc module_names name; + | Pstr_module(name, smodl) -> + check "module" loc module_names name.txt; let modl = - type_module true funct_body (anchor_submodule name anchor) env + type_module true funct_body (anchor_submodule name.txt 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 mty = enrich_module_type anchor name.txt modl.mod_type env in + let (id, newenv) = Env.enter_module name.txt 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, Trec_not) :: sig_rem, + (mkstr (Tstr_module(id, name, modl)) loc :: str_rem, + Sig_module(id, modl.mod_type, Trec_not) :: sig_rem, final_env) - | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem -> + | Pstr_recmodule sbind -> List.iter - (fun (name, _, _) -> check "module" loc module_names name) + (fun (name, _, _) -> check "module" loc module_names name.txt) sbind; let (decls, newenv) = transl_recmodule_modtypes loc env (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in let bindings1 = List.map2 - (fun (id, mty) (name, smty, smodl) -> + (fun (id, _, mty) (name, _, smodl) -> let modl = type_module true funct_body (anchor_recmodule id anchor) newenv smodl in let mty' = enrich_module_type anchor (Ident.name id) modl.mod_type newenv in - (id, mty, modl, mty')) + (id, name, mty, modl, mty')) decls sbind in let bindings2 = check_recmodule_inclusion newenv bindings1 in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_recmodule bindings2 :: str_rem, - map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs)) + (mkstr (Tstr_recmodule bindings2) loc :: str_rem, + map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs)) bindings2 sig_rem, final_env) - | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem -> - check "module type" loc modtype_names name; + | Pstr_modtype(name, smty) -> + check "module type" loc modtype_names name.txt; let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in + let (id, newenv) = + Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_modtype(id, mty) :: str_rem, - Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem, + (mkstr (Tstr_modtype(id, name, mty)) loc :: str_rem, + Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem, final_env) - | {pstr_desc = Pstr_open lid; pstr_loc = loc} :: srem -> - type_struct (type_open env loc lid) srem - | {pstr_desc = Pstr_class cl; pstr_loc = loc} :: srem -> + | Pstr_open (lid) -> + let (path, newenv) = type_open ~toplevel env loc lid in + let (str_rem, sig_rem, final_env) = type_struct newenv srem in + (mkstr (Tstr_open (path, lid)) loc :: str_rem, sig_rem, final_env) + | Pstr_class cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name) + (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_class - (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) -> + (mkstr (Tstr_class + (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) -> let vf = if d.cty_new = None then Virtual else Concrete in - (i, s, m, c, vf)) classes) :: - Tstr_cltype - (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) :: + (* (i, s, m, c, vf) *) (c, m, vf)) classes)) loc :: +(* TODO: check with Jacques why this is here + Tstr_class_type + (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: Tstr_type (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: Tstr_type (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: +*) str_rem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) -> - [Tsig_class(i, d, rs); - Tsig_cltype(i', d', rs); - Tsig_type(i'', d'', rs); - Tsig_type(i''', d''', rs)]) + (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> + [Sig_class(i, d, rs); + Sig_class_type(i', d', rs); + Sig_type(i'', d'', rs); + Sig_type(i''', d''', rs)]) classes [sig_rem]), final_env) - | {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem -> + | Pstr_class_type cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name) + (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_cltype - (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes) :: - Tstr_type + (mkstr (Tstr_class_type + (List.map (fun (i, i_loc, d, _, _, _, _, c) -> + (i, i_loc, c)) classes)) loc :: +(* TODO: check with Jacques why this is here + Tstr_type (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: + (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) str_rem, List.flatten (map_rec - (fun rs (i, d, i', d', i'', d'') -> - [Tsig_cltype(i, d, rs); - Tsig_type(i', d', rs); - Tsig_type(i'', d'', rs)]) + (fun rs (i, _, d, i', d', i'', d'', _) -> + [Sig_class_type(i, d, rs); + Sig_type(i', d', rs); + Sig_type(i'', d'', rs)]) classes [sig_rem]), final_env) - | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem -> + | Pstr_include smodl -> let modl = type_module true funct_body None env smodl in (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity @@ -989,29 +1106,58 @@ and type_structure funct_body anchor env sstr scope = (check_sig_item type_names module_names modtype_names loc) sg; let new_env = Env.add_signature sg env in let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (Tstr_include (modl, bound_value_identifiers sg) :: str_rem, + (mkstr (Tstr_include (modl, bound_value_identifiers sg)) loc :: str_rem, sg @ sig_rem, final_env) +(*>JOCAML *) + | Pstr_def sdefs -> + let scope = +(* scope is non-recursive (recursive calls use optimised bindings?) *) + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in + Some (Annot.Idef {scope with Location.loc_start = start}) in + let (defs, newenv) = + Typecore.type_joindefinition env sdefs scope in + let (str_rem, sig_rem, final_env) = type_struct newenv srem in + let bound_idents = Typedtree.def_bound_idents defs in + (mkstr (Tstr_def defs) loc :: str_rem, + map_end (make_sig_channel_value newenv) bound_idents sig_rem, + final_env) + | Pstr_exn_global longid -> + let path = Typedecl.transl_exn_global env loc longid.txt in + let (str_rem, sig_rem, final_env) = type_struct env srem in + (mkstr (Tstr_exn_global (path,longid)) loc:: str_rem, + sig_rem, + final_env) +(*<JOCAML *) in - if !Clflags.annotations - then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; - type_struct env sstr - + if !Clflags.annotations then + (* moved to genannot *) + List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; + let previous_saved_types = Cmt_format.get_saved_types () in + let (items, sg, final_env) = type_struct env sstr in + let str = { str_items = items; str_type = sg; str_final_env = final_env } in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure str :: previous_saved_types); + str, sg, final_env + +let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none let type_module = type_module true false None let type_structure = type_structure false None (* Normalize types in a signature *) let rec normalize_modtype env = function - Tmty_ident p -> () - | Tmty_signature sg -> normalize_signature env sg - | Tmty_functor(id, param, body) -> normalize_modtype env body + Mty_ident p -> () + | Mty_signature sg -> normalize_signature env sg + | Mty_functor(id, param, body) -> normalize_modtype env body and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function - Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type - | Tsig_module(id, mty, _) -> normalize_modtype env mty + Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type + | Sig_module(id, mty, _) -> normalize_modtype env mty | _ -> () (* Simplify multiple specifications of a value or an exception in a signature. @@ -1021,26 +1167,26 @@ and normalize_signature_item env = function let rec simplify_modtype mty = match mty with - Tmty_ident path -> mty - | Tmty_functor(id, arg, res) -> Tmty_functor(id, arg, simplify_modtype res) - | Tmty_signature sg -> Tmty_signature(simplify_signature sg) + Mty_ident path -> mty + | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) + | Mty_signature sg -> Mty_signature(simplify_signature sg) and simplify_signature sg = let rec simplif val_names exn_names res = function [] -> res - | (Tsig_value(id, descr) as component) :: sg -> + | (Sig_value(id, descr) as component) :: sg -> let name = Ident.name id in simplif (StringSet.add name val_names) exn_names (if StringSet.mem name val_names then res else component :: res) sg - | (Tsig_exception(id, decl) as component) :: sg -> + | (Sig_exception(id, decl) as component) :: sg -> let name = Ident.name id in simplif val_names (StringSet.add name exn_names) (if StringSet.mem name exn_names then res else component :: res) sg - | Tsig_module(id, mty, rs) :: sg -> + | Sig_module(id, mty, rs) :: sg -> simplif val_names exn_names - (Tsig_module(id, simplify_modtype mty, rs) :: res) sg + (Sig_module(id, simplify_modtype mty, rs) :: res) sg | component :: sg -> simplif val_names exn_names (component :: res) sg in @@ -1049,23 +1195,28 @@ and simplify_signature sg = (* Extract the module type of a module expression *) let type_module_type_of env smod = - let mty = + let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) - let (path, mty) = Typetexp.find_module env smod.pmod_loc lid in mty - | _ -> (type_module env smod).mod_type in + let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in + rm { mod_desc = Tmod_ident (path, lid); + mod_type = mty; + mod_env = env; + mod_loc = smod.pmod_loc } + | _ -> type_module env smod in + let mty = tmty.mod_type in (* PR#5037: clean up inferred signature to remove duplicate specs *) let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then raise(Error(smod.pmod_loc, Non_generalizable_module mty)); - mty + tmty, mty (* For Typecore *) let rec get_manifest_types = function [] -> [] - | Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem -> + | Sig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem -> (Ident.name id, ty) :: get_manifest_types rem | _ :: rem -> get_manifest_types rem @@ -1081,7 +1232,7 @@ let type_package env m p nl tl = Typetexp.widen context; let (mp, env) = match modl.mod_desc with - Tmod_ident mp -> (mp, env) + Tmod_ident (mp,_) -> (mp, env) | _ -> let (id, new_env) = Env.enter_module "%M" modl.mod_type env in (Pident id, new_env) @@ -1095,14 +1246,15 @@ let type_package env m p nl tl = List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in (* go back to original level *) Ctype.end_def (); - if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else - let mty = modtype_of_package env modl.mod_loc p nl tl' in + if nl = [] then + (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) + else let mty = modtype_of_package env modl.mod_loc p nl tl' in List.iter2 (fun n ty -> try Ctype.unify env ty (Ctype.newvar ()) with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty)))) nl tl'; - (wrap_constraint env modl mty, tl') + (wrap_constraint env modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) let () = @@ -1116,6 +1268,8 @@ let () = (* Typecheck an implementation file *) let type_implementation sourcefile outputprefix modulename initial_env ast = + Cmt_format.set_saved_types []; + try Typecore.reset_delayed_checks (); let (str, sg, finalenv) = type_structure initial_env ast Location.none in let simple_sg = simplify_signature sg in @@ -1137,9 +1291,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; (str, coercion) end else begin - check_nongen_schemes finalenv str; + check_nongen_schemes finalenv str.str_items; normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg @@ -1149,11 +1305,27 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then - Env.save_signature simple_sg modulename (outputprefix ^ ".cmi"); + if not !Clflags.dont_write_files then begin + let sg = + Env.save_signature simple_sg modulename (outputprefix ^ ".cmi") in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) + (Some sourcefile) initial_env (Some sg); + end; (str, coercion) end - end + end + with e -> + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e + + +let save_signature modname tsg outputprefix source_file initial_env cmi = + Cmt_format.save_cmt (outputprefix ^ ".cmti") modname + (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) (* "Packaging" of several compilation units into one unit having them as sub-modules. *) @@ -1164,7 +1336,7 @@ let rec package_signatures subst = function let sg' = Subst.signature subst sg in let oldid = Ident.create_persistent name and newid = Ident.create name in - Tsig_module(newid, Tmty_signature sg', Trec_not) :: + Sig_module(newid, Mty_signature sg', Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem let package_units objfiles cmifile modulename = @@ -1184,13 +1356,15 @@ let package_units objfiles cmifile modulename = Ident.reinit(); let sg = package_signatures Subst.identity units in (* See if explicit interface is provided *) - let mlifile = - chop_extension_if_any cmifile ^ !Config.interface_suffix in + let prefix = chop_extension_if_any cmifile in + let mlifile = prefix ^ !Config.interface_suffix in if Sys.file_exists mlifile then begin if not (Sys.file_exists cmifile) then begin raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None Env.initial None ; Includemod.compunit "(obtained by packing)" sg mlifile dclsig end else begin (* Determine imports *) @@ -1200,7 +1374,13 @@ let package_units objfiles cmifile modulename = (fun (name, crc) -> not (List.mem name unit_names)) (Env.imported_units()) in (* Write packaged signature *) - Env.save_signature_with_imports sg modulename cmifile imports; + if not !Clflags.dont_write_files then begin + let sg = + Env.save_signature_with_imports sg modulename + (prefix ^ ".cmi") imports in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None Env.initial (Some sg) + end; Tcoerce_none end diff --git a/typing/typemod.mli b/typing/typemod.mli index a2c03aaa83..c339825d99 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -21,20 +21,28 @@ val type_module: Env.t -> Parsetree.module_expr -> Typedtree.module_expr val type_structure: Env.t -> Parsetree.structure -> Location.t -> - Typedtree.structure * signature * Env.t + Typedtree.structure * Types.signature * Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Env.t val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion + string -> string -> string -> Env.t -> Parsetree.structure -> + Typedtree.structure * Typedtree.module_coercion val transl_signature: - Env.t -> Parsetree.signature -> signature + Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: - Env.t -> Typedtree.structure -> unit + Env.t -> Typedtree.structure_item list -> unit val simplify_signature: signature -> signature +val save_signature : string -> Typedtree.signature -> string -> string -> + Env.t -> Types.signature_item list -> unit + val package_units: string list -> string -> string -> Typedtree.module_coercion +val bound_value_identifiers : Types.signature_item list -> Ident.t list + type error = Cannot_apply of module_type | Not_included of Includemod.error list diff --git a/typing/types.ml b/typing/types.ml index a50901cb06..00d8396f74 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -174,8 +174,8 @@ type type_declaration = and type_kind = Type_abstract | Type_record of - (string * mutable_flag * type_expr) list * record_representation - | Type_variant of (string * type_expr list * type_expr option) list + (Ident.t * mutable_flag * type_expr) list * record_representation + | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; @@ -186,9 +186,9 @@ type exception_declaration = module Concr = Set.Make(OrderedString) type class_type = - Tcty_constr of Path.t * type_expr list * class_type - | Tcty_signature of class_signature - | Tcty_fun of label * type_expr * class_type + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; @@ -204,7 +204,7 @@ type class_declaration = cty_new: type_expr option; cty_variance: (bool * bool) list } -type cltype_declaration = +type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; @@ -213,24 +213,24 @@ type cltype_declaration = (* Type expressions for the module language *) type module_type = - Tmty_ident of Path.t - | Tmty_signature of signature - | Tmty_functor of Ident.t * module_type * module_type + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = - Tsig_value of Ident.t * value_description - | Tsig_type of Ident.t * type_declaration * rec_status - | Tsig_exception of Ident.t * exception_declaration - | Tsig_module of Ident.t * module_type * rec_status - | Tsig_modtype of Ident.t * modtype_declaration - | Tsig_class of Ident.t * class_declaration * rec_status - | Tsig_cltype of Ident.t * cltype_declaration * rec_status + Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_exception of Ident.t * exception_declaration + | Sig_module of Ident.t * module_type * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of Ident.t * class_declaration * rec_status + | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = - Tmodtype_abstract - | Tmodtype_manifest of module_type + Modtype_abstract + | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) diff --git a/typing/types.mli b/typing/types.mli index 1138eb4aae..96b9710083 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -173,8 +173,8 @@ type type_declaration = and type_kind = Type_abstract | Type_record of - (string * mutable_flag * type_expr) list * record_representation - | Type_variant of (string * type_expr list * type_expr option) list + (Ident.t * mutable_flag * type_expr) list * record_representation + | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; @@ -185,9 +185,9 @@ type exception_declaration = module Concr : Set.S with type elt = string type class_type = - Tcty_constr of Path.t * type_expr list * class_type - | Tcty_signature of class_signature - | Tcty_fun of label * type_expr * class_type + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; @@ -202,7 +202,7 @@ type class_declaration = cty_new: type_expr option; cty_variance: (bool * bool) list } -type cltype_declaration = +type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; @@ -211,24 +211,24 @@ type cltype_declaration = (* Type expressions for the module language *) type module_type = - Tmty_ident of Path.t - | Tmty_signature of signature - | Tmty_functor of Ident.t * module_type * module_type + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = - Tsig_value of Ident.t * value_description - | Tsig_type of Ident.t * type_declaration * rec_status - | Tsig_exception of Ident.t * exception_declaration - | Tsig_module of Ident.t * module_type * rec_status - | Tsig_modtype of Ident.t * modtype_declaration - | Tsig_class of Ident.t * class_declaration * rec_status - | Tsig_cltype of Ident.t * cltype_declaration * rec_status + Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_exception of Ident.t * exception_declaration + | Sig_module of Ident.t * module_type * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of Ident.t * class_declaration * rec_status + | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = - Tmodtype_abstract - | Tmodtype_manifest of module_type + Modtype_abstract + | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 131b12a793..5f9c6caf52 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -14,8 +14,10 @@ (* Typechecking of type expressions for the core language *) +open Asttypes open Misc open Parsetree +open Typedtree open Types open Ctype @@ -101,7 +103,7 @@ let find_module = find_component Env.lookup_module (fun lid -> Unbound_module lid) let find_modtype = find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) -let find_cltype = +let find_class_type = find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) (* Support for first-class modules. *) @@ -113,7 +115,8 @@ let create_package_mty fake loc env (p, l) = let l = List.sort (fun (s1, t1) (s2, t2) -> - if s1 = s2 then raise (Error (loc, Multiple_constraints_on_type s1)); + if s1.txt = s2.txt then + raise (Error (loc, Multiple_constraints_on_type s1.txt)); compare s1 s2) l in @@ -127,7 +130,7 @@ let create_package_mty fake loc env (p, l) = ptype_manifest = if fake then None else Some t; ptype_variance = []; ptype_loc = loc} in - {pmty_desc=Pmty_with (mty, [ s, Pwith_type d ]); + {pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]); pmty_loc=loc} ) {pmty_desc=Pmty_ident p; pmty_loc=loc} @@ -195,14 +198,22 @@ let rec swap_list = function type policy = Fixed | Extensible | Univars +let ctyp ctyp_desc ctyp_type ctyp_env ctyp_loc = + { ctyp_desc; ctyp_type; ctyp_env; ctyp_loc } + let rec transl_type env policy styp = + let loc = styp.ptyp_loc in match styp.ptyp_desc with Ptyp_any -> - if policy = Univars then new_pre_univar () else - if policy = Fixed then - raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) - else newvar () + let ty = + if policy = Univars then new_pre_univar () else + if policy = Fixed then + raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) + else newvar () + in + ctyp Ttyp_any ty env loc | Ptyp_var name -> + let ty = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name))); begin try @@ -216,16 +227,21 @@ let rec transl_type env policy styp = used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; v end + in + ctyp (Ttyp_var name) ty env loc | Ptyp_arrow(l, st1, st2) -> - let ty1 = transl_type env policy st1 in - let ty2 = transl_type env policy st2 in - newty (Tarrow(l, ty1, ty2, Cok)) + let cty1 = transl_type env policy st1 in + let cty2 = transl_type env policy st2 in + let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc | Ptyp_tuple stl -> - newty (Ttuple(List.map (transl_type env policy) stl)) + let ctys = List.map (transl_type env policy) stl in + let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in + ctyp (Ttyp_tuple ctys) ty env loc | Ptyp_constr(lid, stl) -> - let (path, decl) = find_type env styp.ptyp_loc lid in + let (path, decl) = find_type env styp.ptyp_loc lid.txt in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, + raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in @@ -236,23 +252,36 @@ let rec transl_type env policy styp = if (repr ty).level = Btype.generic_level then unify_var else unify in List.iter2 - (fun (sty, ty) ty' -> - try unify_param env ty' ty with Unify trace -> + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; - let constr = newconstr path args in + let constr = + newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in begin try Ctype.enforce_constraints env constr with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) end; - constr + ctyp (Ttyp_constr (path, lid, args)) constr env loc | Ptyp_object fields -> - newobj (transl_fields env policy [] fields) + let fields = List.map + (fun pf -> + let desc = + match pf.pfield_desc with + | Pfield_var -> Tcfield_var + | Pfield (s,e) -> + let ty1 = transl_type env policy e in + Tcfield (s, ty1) + in + { field_desc = desc; field_loc = pf.pfield_loc }) + fields in + let ty = newobj (transl_fields env policy [] fields) in + ctyp (Ttyp_object fields) ty env loc | Ptyp_class(lid, stl, present) -> let (path, decl, is_variant) = try - let (path, decl) = Env.lookup_type lid env in + let (path, decl) = Env.lookup_type lid.txt env in let rec check decl = match decl.type_manifest with None -> raise Not_found @@ -268,7 +297,7 @@ let rec transl_type env policy styp = with Not_found -> try if present <> [] then raise Not_found; let lid2 = - match lid with + match lid.txt with Longident.Lident s -> Longident.Lident ("#" ^ s) | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" @@ -276,24 +305,25 @@ let rec transl_type env policy styp = let (path, decl) = Env.lookup_type lid2 env in (path, decl, false) with Not_found -> - raise(Error(styp.ptyp_loc, Unbound_class lid)) + raise(Error(styp.ptyp_loc, Unbound_class lid.txt)) in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, + raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in List.iter2 - (fun (sty, ty) ty' -> - try unify_var env ty' ty with Unify trace -> + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in let ty = - try Ctype.expand_head env (newconstr path args) + try Ctype.expand_head env (newconstr path ty_args) with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) in - begin match ty.desc with + let ty = match ty.desc with Tvariant row -> let row = Btype.row_repr row in List.iter @@ -313,7 +343,7 @@ let rec transl_type env policy styp = row.row_fields in let row = { row_closed = true; row_fields = fields; - row_bound = (); row_name = Some (path, args); + row_bound = (); row_name = Some (path, ty_args); row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = @@ -328,9 +358,10 @@ let rec transl_type env policy styp = ty | _ -> assert false - end + in + ctyp (Ttyp_class (path, lid, args, present)) ty env loc | Ptyp_alias(st, alias) -> - begin + let cty = try let t = try List.assoc alias !univars @@ -338,7 +369,7 @@ let rec transl_type env policy styp = instance env (fst(Tbl.find alias !used_variables)) in let ty = transl_type env policy st in - begin try unify_var env t ty with Unify trace -> + begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; @@ -348,7 +379,7 @@ let rec transl_type env policy styp = let t = newvar () in used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; let ty = transl_type env policy st in - begin try unify_var env t ty with Unify trace -> + begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; @@ -363,8 +394,9 @@ let rec transl_type env policy styp = | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) | _ -> () end; - t - end + { ty with ctyp_type = t } + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type env loc | Ptyp_variant(fields, closed, present) -> let name = ref None in let mkfield l f = @@ -388,21 +420,25 @@ let rec transl_type env policy styp = let rec add_field = function Rtag (l, c, stl) -> name := None; + let tl = List.map (transl_type env policy) stl in let f = match present with Some present when not (List.mem l present) -> - let tl = List.map (transl_type env policy) stl in - Reither(c, tl, false, ref None) + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + Reither(c, ty_tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then raise(Error(styp.ptyp_loc, Present_has_conjunction l)); - match stl with [] -> Rpresent None - | st :: _ -> Rpresent (Some(transl_type env policy st)) + match tl with [] -> Rpresent None + | st :: _ -> + Rpresent (Some st.ctyp_type) in - add_typed_field styp.ptyp_loc l f + add_typed_field styp.ptyp_loc l f; + Ttag (l,c,tl) | Rinherit sty -> - let ty = transl_type env policy sty in + let cty = transl_type env policy sty in + let ty = cty.ctyp_type in let nm = - match repr ty with + match repr cty.ctyp_type with {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in @@ -414,7 +450,7 @@ let rec transl_type env policy styp = (* Unset it otherwise *) name := None end; - let fl = match expand_head env ty, nm with + let fl = match expand_head env cty.ctyp_type, nm with {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in row.row_fields @@ -438,9 +474,10 @@ let rec transl_type env policy styp = | _ -> f in add_typed_field sty.ptyp_loc l f) - fl + fl; + Tinherit cty in - List.iter add_field fields; + let tfields = List.map add_field fields in let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in begin match present with None -> () | Some present -> @@ -459,13 +496,15 @@ let rec transl_type env policy styp = else if policy <> Univars then row else { row with row_more = new_pre_univar () } in - newty (Tvariant row) - | Ptyp_poly(vars, st) -> + let ty = newty (Tvariant row) in + ctyp (Ttyp_variant (tfields, closed, present)) ty env loc + | Ptyp_poly(vars, st) -> begin_def(); let new_univars = List.map (fun name -> name, newvar ~name ()) vars in let old_univars = !univars in univars := new_univars @ !univars; - let ty = transl_type env policy st in + let cty = transl_type env policy st in + let ty = cty.ctyp_type in univars := old_univars; end_def(); generalize ty; @@ -485,28 +524,37 @@ let rec transl_type env policy styp = in let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in unify_var env (newvar()) ty'; - ty' + ctyp (Ttyp_poly (vars, cty)) ty' env loc | Ptyp_package (p, l) -> let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in let z = narrow () in - ignore (!transl_modtype env mty); + let mty = !transl_modtype env mty in widen z; - newty (Tpackage (!transl_modtype_longident styp.ptyp_loc env p, - List.map fst l, - List.map (transl_type env policy) (List.map snd l))) + let ptys = List.map (fun (s, pty) -> + s, transl_type env policy pty + ) l in + let path = !transl_modtype_longident styp.ptyp_loc env p.txt in + let ty = newty (Tpackage (path, + List.map (fun (s, pty) -> s.txt) l, + List.map (fun (_,cty) -> cty.ctyp_type) ptys)) + in + ctyp (Ttyp_package { + pack_name = path; + pack_type = mty.mty_type; + pack_fields = ptys; + pack_txt = p; + }) ty env loc and transl_fields env policy seen = function [] -> newty Tnil - | {pfield_desc = Pfield_var}::_ -> + | {field_desc = Tcfield_var}::_ -> if policy = Univars then new_pre_univar () else newvar () - | {pfield_desc = Pfield(s, e); pfield_loc = loc}::l -> + | {field_desc = Tcfield(s, ty1); field_loc = loc}::l -> if List.mem s seen then raise (Error (loc, Repeated_method_label s)); - let ty1 = transl_type env policy e in let ty2 = transl_fields env policy (s::seen) l in - newty (Tfield (s, Fpresent, ty1, ty2)) - + newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2)) (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = @@ -563,7 +611,7 @@ let transl_simple_type env fixed styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in globalize_used_variables env fixed (); - make_fixed_univars typ; + make_fixed_univars typ.ctyp_type; typ let transl_simple_type_univars env styp = @@ -580,7 +628,7 @@ let transl_simple_type_univars env styp = new_variables; globalize_used_variables env false (); end_def (); - generalize typ; + generalize typ.ctyp_type; let univs = List.fold_left (fun acc v -> @@ -591,13 +639,14 @@ let transl_simple_type_univars env styp = | _ -> acc) [] !pre_univars in - make_fixed_univars typ; - instance env (Btype.newgenty (Tpoly (typ, univs))) + make_fixed_univars typ.ctyp_type; + { typ with ctyp_type = + instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } let transl_simple_type_delayed env styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env Extensible styp in - make_fixed_univars typ; + make_fixed_univars typ.ctyp_type; (typ, globalize_used_variables env false) let transl_type_scheme env styp = @@ -605,7 +654,7 @@ let transl_type_scheme env styp = begin_def(); let typ = transl_simple_type env false styp in end_def(); - generalize typ; + generalize typ.ctyp_type; typ diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 79082d5f5e..0b6d09d30f 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -17,15 +17,15 @@ open Format;; val transl_simple_type: - Env.t -> bool -> Parsetree.core_type -> Types.type_expr + Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_univars: - Env.t -> Parsetree.core_type -> Types.type_expr + Env.t -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_delayed: - Env.t -> Parsetree.core_type -> Types.type_expr * (unit -> unit) + Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) (* Translate a type, but leave type variables unbound. Returns the type and a function that binds the type variable. *) val transl_type_scheme: - Env.t -> Parsetree.core_type -> Types.type_expr + Env.t -> Parsetree.core_type -> Typedtree.core_type val reset_type_variables: unit -> unit val enter_type_variable: bool -> Location.t -> string -> Types.type_expr val type_variable: Location.t -> string -> Types.type_expr @@ -69,15 +69,28 @@ exception Error of Location.t * error val report_error: formatter -> error -> unit (* Support for first-class modules. *) -val transl_modtype_longident: (Location.t -> Env.t -> Longident.t -> Path.t) ref (* from Typemod *) -val transl_modtype: (Env.t -> Parsetree.module_type -> Types.module_type) ref (* from Typemod *) -val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t * Parsetree.core_type) list * Parsetree.module_type +val transl_modtype_longident: (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype: (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref +val create_package_mty: + Location.t -> Env.t -> Parsetree.package_type -> + (Longident.t Asttypes.loc * Parsetree.core_type) list * + Parsetree.module_type -val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration -val find_constructor: Env.t -> Location.t -> Longident.t -> Types.constructor_description -val find_label: Env.t -> Location.t -> Longident.t -> Types.label_description -val find_value: Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description -val find_class: Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration -val find_module: Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type -val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration -val find_cltype: Env.t -> Location.t -> Longident.t -> Path.t * Types.cltype_declaration +val find_type: + Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration +val find_constructor: + Env.t -> Location.t -> Longident.t -> Path.t * Types.constructor_description +val find_label: + Env.t -> Location.t -> Longident.t -> Path.t * Types.label_description +val find_value: + Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description +val find_class: + Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration +val find_module: + Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type +val find_modtype: + Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration +val find_class_type: + Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration |