Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Starting to keep attributes in the typedtree. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13440 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-03-25 14:16:07 +00:00
parent f85f1e2759
commit 5c98dd91fe
19 changed files with 361 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
bytecomp/translmod.ml
View File

@ -298,7 +298,7 @@ and transl_structure fields cc rootpath = function
| Tstr_exception( id, _, decl) ->
Llet(Strict, id, transl_exception id (field_path rootpath id) decl,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_exn_rebind( id, _, path, _) ->
| Tstr_exn_rebind( id, _, path, _, _) ->
Llet(Strict, id, transl_path path,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_module( id, _, modl) ->
@ -312,10 +312,6 @@ and transl_structure fields cc rootpath = function
transl_module Tcoerce_none (field_path rootpath id) modl)
bindings
(transl_structure ext_fields cc rootpath rem)
| Tstr_modtype(id, _, decl) ->
transl_structure fields cc rootpath rem
| Tstr_open (path, _) ->
transl_structure fields cc rootpath rem
| Tstr_class cl_list ->
let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in
Lletrec(List.map
@ -325,9 +321,7 @@ and transl_structure fields cc rootpath = function
(id, transl_class ids id meths cl vf ))
cl_list,
transl_structure (List.rev ids @ fields) cc rootpath rem)
| Tstr_class_type cl_list ->
transl_structure fields cc rootpath rem
| Tstr_include(modl, ids) ->
| Tstr_include(modl, ids, _) ->
let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function
[] ->
@ -338,6 +332,12 @@ and transl_structure fields cc rootpath = function
Llet(Strict, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids)
| Tstr_modtype _
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_structure fields cc rootpath rem
(* Update forward declaration in Translcore *)
let _ =
Translcore.transl_module := transl_module
@ -366,16 +366,17 @@ let rec defined_idents = function
| Tstr_primitive(id, _, descr) -> defined_idents rem
| Tstr_type decls -> defined_idents rem
| Tstr_exception(id, _, decl) -> id :: defined_idents rem
| Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem
| Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem
| Tstr_module(id, _, modl) -> id :: defined_idents rem
| Tstr_recmodule decls ->
List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem
| Tstr_modtype(id, _, decl) -> defined_idents rem
| Tstr_open (path, _) -> defined_idents rem
| Tstr_open (path, _, _) -> defined_idents rem
| Tstr_class cl_list ->
List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
| Tstr_class_type cl_list -> defined_idents rem
| Tstr_include(modl, ids) -> ids @ defined_idents rem
| Tstr_include(modl, ids, _) -> ids @ defined_idents rem
| Tstr_attribute _ -> []
(* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *)
let rec more_idents = function
@ -387,16 +388,17 @@ let rec more_idents = function
| Tstr_primitive(id, _, descr) -> more_idents rem
| Tstr_type decls -> more_idents rem
| Tstr_exception(id, _, decl) -> more_idents rem
| Tstr_exn_rebind(id, _, path, _) -> more_idents rem
| Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem
| Tstr_recmodule decls -> more_idents rem
| Tstr_modtype(id, _, decl) -> more_idents rem
| Tstr_open (path, _) -> more_idents rem
| Tstr_open (path, _, _) -> more_idents rem
| Tstr_class cl_list -> more_idents rem
| Tstr_class_type cl_list -> more_idents rem
| Tstr_include(modl, ids) -> more_idents rem
| Tstr_include(modl, ids, _) -> more_idents rem
| Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
all_idents str.str_items @ more_idents rem
| Tstr_module(id, _, _) -> more_idents rem
| Tstr_attribute _ -> []
and all_idents = function
[] -> []
@ -408,18 +410,19 @@ and all_idents = function
| Tstr_primitive(id, _, descr) -> all_idents rem
| Tstr_type decls -> all_idents rem
| Tstr_exception(id, _, decl) -> id :: all_idents rem
| Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem
| Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem
| Tstr_recmodule decls ->
List.map (fun (id, _, _, _) -> id) decls @ all_idents rem
| Tstr_modtype(id, _, decl) -> all_idents rem
| Tstr_open (path, _) -> all_idents rem
| Tstr_open (path, _, _) -> all_idents rem
| Tstr_class cl_list ->
List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem
| Tstr_class_type cl_list -> all_idents rem
| Tstr_include(modl, ids) -> ids @ all_idents rem
| Tstr_include(modl, ids, _) -> ids @ all_idents rem
| Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
id :: all_idents str.str_items @ all_idents rem
| Tstr_module(id, _, _) -> id :: all_idents rem
| Tstr_attribute _ -> []
(* A variant of transl_structure used to compile toplevel structure definitions
@ -466,7 +469,7 @@ let transl_store_structure glob map prims str =
let lam = transl_exception id (field_path rootpath id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_exn_rebind( id, _, path, _) ->
| Tstr_exn_rebind( id, _, path, _, _) ->
let lam = subst_lambda subst (transl_path path) in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
@ -500,10 +503,6 @@ let transl_store_structure glob map prims str =
bindings
(Lsequence(store_idents ids,
transl_store rootpath (add_idents true ids subst) rem))
| Tstr_modtype(id, _, decl) ->
transl_store rootpath subst rem
| Tstr_open (path, _) ->
transl_store rootpath subst rem
| Tstr_class cl_list ->
let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in
let lam =
@ -516,9 +515,7 @@ let transl_store_structure glob map prims str =
store_idents ids) in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
| Tstr_class_type cl_list ->
transl_store rootpath subst rem
| Tstr_include(modl, ids) ->
| Tstr_include(modl, ids, _attrs) ->
let mid = Ident.create "include" in
let rec store_idents pos = function
[] -> transl_store rootpath (add_idents true ids subst) rem
@ -528,6 +525,11 @@ let transl_store_structure glob map prims str =
Llet(Strict, mid,
subst_lambda subst (transl_module Tcoerce_none None modl),
store_idents 0 ids)
| Tstr_modtype _
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_store rootpath subst rem
and store_ident id =
try
@ -669,13 +671,9 @@ let transl_toplevel_item item =
let idents = let_bound_idents pat_expr_list in
transl_let rec_flag pat_expr_list
(make_sequence toploop_setvalue_id idents)
| Tstr_primitive(id, _, descr) ->
lambda_unit
| Tstr_type(decls) ->
lambda_unit
| Tstr_exception(id, _, decl) ->
toploop_setvalue id (transl_exception id None decl)
| Tstr_exn_rebind(id, _, path, _) ->
| Tstr_exn_rebind(id, _, path, _, _) ->
toploop_setvalue id (transl_path path)
| Tstr_module(id, _, modl) ->
(* we need to use the unique name for the module because of issues
@ -689,10 +687,6 @@ let transl_toplevel_item item =
(fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)
bindings
(make_sequence toploop_setvalue_id idents)
| Tstr_modtype(id, _, decl) ->
lambda_unit
| Tstr_open (path, _) ->
lambda_unit
| Tstr_class cl_list ->
(* we need to use unique names for the classes because there might
be a value named identically *)
@ -707,9 +701,7 @@ let transl_toplevel_item item =
make_sequence
(fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class)
cl_list)
| Tstr_class_type cl_list ->
lambda_unit
| Tstr_include(modl, ids) ->
| Tstr_include(modl, ids, _attrs) ->
let mid = Ident.create "include" in
let rec set_idents pos = function
[] ->
@ -718,6 +710,13 @@ let transl_toplevel_item item =
Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
set_idents (pos + 1) ids) in
Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids)
| Tstr_modtype _
| Tstr_open _
| Tstr_primitive _
| Tstr_type _
| Tstr_class_type _
| Tstr_attribute _ ->
lambda_unit
let transl_toplevel_item_and_close itm =
close_toplevel_term (transl_label_init (transl_toplevel_item itm))

7
ocamldoc/odoc_ast.ml
View File

@ -77,7 +77,7 @@ module Typedtree_search =
Hashtbl.add table (MT (Name.from_ident ident)) tt
| Typedtree.Tstr_exception (ident, _, _) ->
Hashtbl.add table (E (Name.from_ident ident)) tt
| Typedtree.Tstr_exn_rebind (ident, _, _, _) ->
| Typedtree.Tstr_exn_rebind (ident, _, _, _, _) ->
Hashtbl.add table (ER (Name.from_ident ident)) tt
| Typedtree.Tstr_type ident_type_decl_list ->
List.iter
@ -111,6 +111,7 @@ module Typedtree_search =
| Typedtree.Tstr_open _ -> ()
| Typedtree.Tstr_include _ -> ()
| Typedtree.Tstr_eval _ -> ()
| Typedtree.Tstr_attribute _ -> ()
let tables typedtree =
let t = Hashtbl.create 13 in
@ -135,7 +136,7 @@ module Typedtree_search =
let search_exception_rebind table name =
match Hashtbl.find table (ER name) with
| (Typedtree.Tstr_exn_rebind (_, _, p, _)) -> p
| (Typedtree.Tstr_exn_rebind (_, _, p, _, _)) -> p
| _ -> assert false
let search_type_declaration table name =
@ -885,7 +886,7 @@ module Analyser =
let tt_get_included_module_list tt_structure =
let f acc item =
match item.str_desc with
Typedtree.Tstr_include (mod_expr, _) ->
Typedtree.Tstr_include (mod_expr, _, _) ->
acc @ [
{ (* A VOIR : chercher dans les modules et les module types, avec quel env ? *)
im_name = tt_name_from_module_expr mod_expr ;

18
otherlibs/labltk/browser/searchpos.ml
View File

@ -673,19 +673,21 @@ let rec search_pos_structure ~pos str =
search_pos_pat pat ~pos ~env;
search_pos_expr exp ~pos
end
| Tstr_primitive (_, _, vd) ->()
| Tstr_type _ -> ()
| Tstr_exception _ -> ()
| Tstr_exn_rebind(_, _, _, _) -> ()
| Tstr_module (_, _, m) -> search_pos_module_expr m ~pos
| Tstr_recmodule bindings ->
List.iter bindings ~f:(fun (_, _, _, m) -> search_pos_module_expr m ~pos)
| Tstr_modtype _ -> ()
| Tstr_open _ -> ()
| Tstr_class l ->
List.iter l ~f:(fun (cl, _, _) -> search_pos_class_expr cl.ci_expr ~pos)
| Tstr_class_type _ -> ()
| Tstr_include (m, _) -> search_pos_module_expr m ~pos
| Tstr_include (m, _, _) -> search_pos_module_expr m ~pos
| Tstr_primitive _
| Tstr_type _
| Tstr_exception _
| Tstr_modtype _
| Tstr_open _
| Tstr_class_type _
| Tstr_exn_rebind _
| Tstr_attribute _
-> ()
end
and search_pos_class_structure ~pos cls =

3
parsing/printast.ml
View File

@ -378,10 +378,11 @@ and type_declaration i ppf x =
option (i+1) core_type ppf x.ptype_manifest
and attributes i ppf l =
let i = i + 1 in
List.iter
(fun (s, arg) ->
line i ppf "attribute \"%s\"\n" s;
expression i ppf arg;
expression (i + 1) ppf arg;
)
l

2
parsing/printast.mli
View File

@ -16,3 +16,5 @@ open Format;;
val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> unit;;
val expression: int -> formatter -> expression -> unit

12
tools/tast_iter.ml
View File

@ -26,7 +26,7 @@ let structure_item sub x =
| Tstr_type list ->
List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
| Tstr_exception (_id, _, decl) -> sub # exception_declaration decl
| Tstr_exn_rebind (_id, _, _p, _) -> ()
| Tstr_exn_rebind (_id, _, _p, _, _) -> ()
| Tstr_module (_id, _, mexpr) -> sub # module_expr mexpr
| Tstr_recmodule list ->
List.iter
@ -41,7 +41,8 @@ let structure_item sub x =
List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
| Tstr_class_type list ->
List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list
| Tstr_include (mexpr, _) -> sub # module_expr mexpr
| Tstr_include (mexpr, _, _) -> sub # module_expr mexpr
| Tstr_attribute _ -> ()
let value_description sub x =
sub # core_type x.val_desc
@ -68,7 +69,7 @@ let pattern sub pat =
| Tpat_unpack -> ()
| Tpat_constraint ct -> sub # core_type ct
in
List.iter (fun (c, _) -> extra c) pat.pat_extra;
List.iter (fun (c, _, _) -> extra c) pat.pat_extra;
match pat.pat_desc with
| Tpat_any
| Tpat_var _
@ -90,7 +91,7 @@ let expression sub exp =
| Texp_newtype _ -> ()
| Texp_poly cto -> opt (sub # core_type) cto
in
List.iter (function (c, _) -> extra c) exp.exp_extra;
List.iter (fun (c, _, _) -> extra c) exp.exp_extra;
match exp.exp_desc with
| Texp_ident _
| Texp_constant _ -> ()
@ -183,11 +184,12 @@ let signature_item sub item =
| Tsig_modtype (_id, _, mdecl) ->
sub # modtype_declaration mdecl
| Tsig_open _ -> ()
| Tsig_include (mty,_) -> sub # module_type mty
| Tsig_include (mty,_,_) -> sub # module_type mty
| Tsig_class list ->
List.iter (sub # class_description) list
| Tsig_class_type list ->
List.iter (sub # class_type_declaration) list
| Tsig_attribute _ -> ()
let modtype_declaration sub mdecl =
match mdecl with

46
tools/untypeast.ml
View File

@ -55,8 +55,8 @@ and untype_structure_item item =
untype_type_declaration name decl) list)
| Tstr_exception (_id, name, decl) ->
Pstr_exception (untype_exception_declaration name decl)
| Tstr_exn_rebind (_id, name, _p, lid) ->
Pstr_exn_rebind (name, lid, [])
| Tstr_exn_rebind (_id, name, _p, lid, attrs) ->
Pstr_exn_rebind (name, lid, attrs)
| Tstr_module (_id, name, mexpr) ->
Pstr_module (Mb.mk name (untype_module_expr mexpr))
| Tstr_recmodule list ->
@ -73,7 +73,7 @@ and untype_structure_item item =
| Tstr_modtype (_id, name, mtype) ->
Pstr_modtype {pmtb_name=name; pmtb_type=untype_module_type mtype;
pmtb_attributes=[]}
| Tstr_open (_path, lid) -> Pstr_open (lid, [])
| Tstr_open (_path, lid, attrs) -> Pstr_open (lid, attrs)
| Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt;
@ -82,7 +82,7 @@ and untype_structure_item item =
pci_expr = untype_class_expr ci.ci_expr;
pci_variance = ci.ci_variance;
pci_loc = ci.ci_loc;
pci_attributes = [];
pci_attributes = ci.ci_attributes;
}
) list)
| Tstr_class_type list ->
@ -94,11 +94,13 @@ and untype_structure_item item =
pci_expr = untype_class_type ct.ci_expr;
pci_variance = ct.ci_variance;
pci_loc = ct.ci_loc;
pci_attributes = [];
pci_attributes = ct.ci_attributes;
}
) list)
| Tstr_include (mexpr, _) ->
Pstr_include (untype_module_expr mexpr, [])
| Tstr_include (mexpr, _, attrs) ->
Pstr_include (untype_module_expr mexpr, attrs)
| Tstr_attribute x ->
Pstr_attribute x
in
{ pstr_desc = desc; pstr_loc = item.str_loc; }
@ -108,7 +110,7 @@ and untype_value_description name v =
pval_prim = v.val_prim;
pval_type = untype_core_type v.val_desc;
pval_loc = v.val_loc;
pval_attributes = [];
pval_attributes = v.val_attributes;
}
and untype_type_declaration name decl =
@ -138,7 +140,7 @@ and untype_type_declaration name decl =
None -> None
| Some ct -> Some (untype_core_type ct));
ptype_variance = decl.typ_variance;
ptype_attributes = []; (* TODO *)
ptype_attributes = decl.typ_attributes;
ptype_loc = decl.typ_loc;
}
@ -146,15 +148,15 @@ and untype_exception_declaration name decl =
{
ped_name = name;
ped_args = List.map untype_core_type decl.exn_params;
ped_attributes = [];
ped_attributes = decl.exn_attributes;
}
and untype_pattern pat =
let desc =
match pat with
{ pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name
| { pat_extra=[Tpat_type (_path, lid), _]; _ } -> Ppat_type lid
| { pat_extra= (Tpat_constraint ct, _) :: rem; _ } ->
{ pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name
| { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type lid
| { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct)
| _ ->
match pat.pat_desc with
@ -193,11 +195,11 @@ and untype_pattern pat =
| Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
| Tpat_lazy p -> Ppat_lazy (untype_pattern p)
in
Pat.mk ~loc:pat.pat_loc desc
Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *)
and option f x = match x with None -> None | Some e -> Some (f e)
and untype_extra (extra, loc) sexp =
and untype_extra (extra, loc, attrs) sexp =
let desc =
match extra with
Texp_constraint (cty1, cty2) ->
@ -208,7 +210,7 @@ and untype_extra (extra, loc) sexp =
| Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
| Texp_newtype s -> Pexp_newtype (s, sexp)
in
Exp.mk ~loc desc
Exp.mk ~loc ~attrs desc
and untype_expression exp =
let desc =
@ -309,7 +311,7 @@ and untype_expression exp =
Pexp_pack (untype_module_expr mexpr)
in
List.fold_right untype_extra exp.exp_extra
(Exp.mk ~loc:exp.exp_loc desc)
(Exp.mk ~loc:exp.exp_loc ~attrs:exp.exp_attributes desc)
and untype_package_type pack =
(pack.pack_txt,
@ -338,12 +340,14 @@ and untype_signature_item item =
pmd_attributes = []}) list)
| Tsig_modtype (_id, name, mdecl) ->
Psig_modtype {pmtd_name=name; pmtd_type=untype_modtype_declaration mdecl; pmtd_attributes=[]}
| Tsig_open (_path, lid) -> Psig_open (lid, [])
| Tsig_include (mty, _lid) -> Psig_include (untype_module_type mty, [])
| Tsig_open (_path, lid, attrs) -> Psig_open (lid, attrs)
| Tsig_include (mty, _lid, attrs) -> Psig_include (untype_module_type mty, attrs)
| Tsig_class list ->
Psig_class (List.map untype_class_description list)
| Tsig_class_type list ->
Psig_class_type (List.map untype_class_type_declaration list)
| Tsig_attribute x ->
Psig_attribute x
in
{ psig_desc = desc;
psig_loc = item.sig_loc;
@ -362,7 +366,7 @@ and untype_class_description cd =
pci_expr = untype_class_type cd.ci_expr;
pci_variance = cd.ci_variance;
pci_loc = cd.ci_loc;
pci_attributes = [];
pci_attributes = cd.ci_attributes;
}
and untype_class_type_declaration cd =
@ -373,7 +377,7 @@ and untype_class_type_declaration cd =
pci_expr = untype_class_type cd.ci_expr;
pci_variance = cd.ci_variance;
pci_loc = cd.ci_loc;
pci_attributes = [];
pci_attributes = cd.ci_attributes;
}
and untype_module_type mty =

4
typing/cmt_format.ml
View File

@ -75,8 +75,8 @@ module ClearEnv = TypedtreeMap.MakeMap (struct
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)
(Texp_open (path, lloc, env), loc, attrs) ->
(Texp_open (path, lloc, keep_only_summary env), loc, attrs)
| exp_extra -> exp_extra) e.exp_extra in
{ e with
exp_env = keep_only_summary e.exp_env;

6
typing/parmatch.ml
View File

@ -23,7 +23,9 @@ open Typedtree
let make_pat desc ty tenv =
{pat_desc = desc; pat_loc = Location.none; pat_extra = [];
pat_type = ty ; pat_env = tenv }
pat_type = ty ; pat_env = tenv;
pat_attributes = [];
}
let omega = make_pat Tpat_any Ctype.none Env.empty
@ -181,7 +183,7 @@ let pretty_const c = match c with
let rec pretty_val ppf v =
match v.pat_extra with
(cstr,_) :: rem ->
(cstr, _loc, _attrs) :: rem ->
begin match cstr with
| Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }

53
typing/printtyped.ml
View File

@ -130,6 +130,15 @@ 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 attributes i ppf l =
let i = i + 1 in
List.iter
(fun (s, arg) ->
line i ppf "attribute \"%s\"\n" s;
Printast.expression (i + 1) ppf arg;
)
l
let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
let i = i+1 in
@ -184,17 +193,21 @@ and core_field_type i ppf x =
and pattern i ppf x =
line i ppf "pattern %a\n" fmt_location x.pat_loc;
attributes i ppf x.pat_attributes;
let i = i+1 in
match x.pat_extra with
| (Tpat_unpack, _) :: rem ->
| (Tpat_unpack, _, attrs) :: rem ->
line i ppf "Tpat_unpack\n";
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem }
| (Tpat_constraint cty, _) :: rem ->
| (Tpat_constraint cty, _, attrs) :: rem ->
line i ppf "Tpat_constraint\n";
attributes i ppf attrs;
core_type i ppf cty;
pattern i ppf { x with pat_extra = rem }
| (Tpat_type (id, _), _) :: rem ->
| (Tpat_type (id, _), _, attrs) :: rem ->
line i ppf "Tpat_type %a\n" fmt_path id;
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem }
| [] ->
match x.pat_desc with
@ -228,24 +241,29 @@ and pattern i ppf x =
line i ppf "Ppat_lazy\n";
pattern i ppf p;
and expression_extra i ppf x =
and expression_extra i ppf x attrs =
match x with
| Texp_constraint (cto1, cto2) ->
line i ppf "Pexp_constraint\n";
attributes i ppf attrs;
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;
attributes i ppf attrs;
| Texp_poly cto ->
line i ppf "Pexp_poly\n";
attributes i ppf attrs;
option i core_type ppf cto;
| Texp_newtype s ->
line i ppf "Pexp_newtype \"%s\"\n" s;
attributes i ppf attrs;
and expression i ppf x =
line i ppf "expression %a\n" fmt_location x.exp_loc;
attributes i ppf x.exp_attributes;
let i =
List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1)
List.fold_left (fun i (extra,_,attrs) -> expression_extra i ppf extra attrs; i+1)
(i+1) x.exp_extra
in
match x.exp_desc with
@ -579,16 +597,22 @@ and signature_item i ppf x =
| 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, _) ->
| Tsig_open (li,_,attrs) ->
line i ppf "Psig_open %a\n" fmt_path li;
attributes i ppf attrs
| Tsig_include (mt, _, attrs) ->
line i ppf "Psig_include\n";
module_type i ppf mt;
attributes i ppf attrs
| 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;
| Tsig_attribute (s, arg) ->
line i ppf "Psig_attribute \"%s\"\n" s;
Printast.expression i ppf arg
and modtype_declaration i ppf x =
match x with
@ -657,8 +681,9 @@ and structure_item i ppf x =
| 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, _) ->
| Tstr_exn_rebind (s, _, li, _, attrs) ->
line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
attributes i ppf attrs
| Tstr_module (s, _, me) ->
line i ppf "Pstr_module \"%a\"\n" fmt_ident s;
module_expr i ppf me;
@ -668,16 +693,22 @@ and structure_item i ppf x =
| 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_open (li, _, attrs) ->
line i ppf "Pstr_open %a\n" fmt_path li;
attributes i ppf attrs
| 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, _) ->
| Tstr_include (me, _, attrs) ->
line i ppf "Pstr_include";
module_expr i ppf me
module_expr i ppf me;
attributes i ppf attrs
| Tstr_attribute (s, arg) ->
line i ppf "Pstr_attribute \"%s\"\n" s;
Printast.expression i ppf arg
and string_x_type_declaration i ppf (s, _, td) =
ident i ppf s;

18
typing/typeclass.ml
View File

@ -51,7 +51,7 @@ exception Error of Location.t * Env.t * error
open Typedtree
let ctyp desc typ env loc =
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env }
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] }
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 }
@ -883,6 +883,7 @@ and class_expr cl_num val_env met_env scl =
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_attributes = []; (* check *)
exp_env = val_env'})
end
pv
@ -897,6 +898,7 @@ and class_expr cl_num val_env met_env scl =
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.none;
exp_attributes = [];
exp_env = Env.empty }]
in
Ctype.raise_nongen_level ();
@ -1022,6 +1024,7 @@ and class_expr cl_num val_env met_env scl =
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_attributes = [];
exp_env = val_env;
}
in
@ -1402,16 +1405,17 @@ let final_decl env define_class
{ ci_variance = cl.pci_variance;
ci_loc = cl.pci_loc;
ci_virt = cl.pci_virt;
ci_params = cl.pci_params;
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_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;
ci_attributes = cl.pci_attributes;
})
(* (cl.pci_variance, cl.pci_loc)) *)

88
typing/typecore.ml
View File

@ -232,7 +232,7 @@ 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 = [] }
{ exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
let option_none ty loc =
let lid = Longident.Lident "None" in
@ -503,7 +503,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_extra=[];})
pat_type=ty; pat_extra=[]; pat_attributes=[]})
:: pats,
(l, Reither(false, [ty], true, ref None)) :: fields
| _ -> pats, fields)
@ -517,7 +517,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_extra=[];})
pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
pats
in
match pats with
@ -526,7 +526,7 @@ let build_or_pat env loc lid =
let r =
List.fold_left
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
pat_loc=gloc; pat_env=env; pat_type=ty})
pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
pat pats in
(path, rp { r with pat_loc = loc },ty)
@ -852,6 +852,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_any;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_var name ->
let id = enter_variable loc name expected_ty in
@ -859,14 +860,16 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_var (id, name);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_unpack name ->
let id = enter_variable loc name expected_ty ~is_module:true in
rp {
pat_desc = Tpat_var (id, name);
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, loc];
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
pat_type = expected_ty;
pat_attributes = [];
pat_env = !env }
| Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
({ptyp_desc=Ptyp_poly _} as sty)) ->
@ -885,8 +888,9 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
rp {
pat_desc = Tpat_var (id, name);
pat_loc = lloc;
pat_extra = [Tpat_constraint cty, loc];
pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
pat_type = ty;
pat_attributes = [];
pat_env = !env
}
| _ -> assert false
@ -902,6 +906,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_alias(q, id, name);
pat_loc = loc; pat_extra=[];
pat_type = q.pat_type;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_constant cst ->
unify_pat_types loc !env (type_constant cst) expected_ty;
@ -909,6 +914,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_constant cst;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_tuple spl ->
let spl_ann = List.map (fun p -> (p,newvar ())) spl in
@ -919,6 +925,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_tuple pl;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_construct(lid, sarg, explicit_arity) ->
let opath =
@ -973,6 +980,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_variant(l, sarg) ->
let arg = may_map (fun p -> type_pat p (newvar())) sarg in
@ -989,6 +997,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_record(lid_sp_list, closed) ->
let opath, record_ty =
@ -1029,6 +1038,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_array spl ->
let ty_elt = newvar() in
@ -1040,6 +1050,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_array pl;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in
@ -1055,6 +1066,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_lazy sp1 ->
let nv = newvar () in
@ -1065,6 +1077,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_desc = Tpat_lazy p1;
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_constraint(sp, sty) ->
(* Separate when not already separated by !principal *)
@ -1085,20 +1098,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
Printtyp.raw_type_expr ty
Printtyp.raw_type_expr p.pat_type;*)
pattern_force := force :: !pattern_force;
let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
if separate then
match p.pat_desc with
Tpat_var (id,s) ->
{p with pat_type = ty;
pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s);
pat_extra = [Tpat_constraint cty, loc];
pat_desc = Tpat_alias ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
pat_extra = [extra];
}
| _ -> {p with pat_type = ty;
pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra}
pat_extra = extra :: p.pat_extra}
else p
| Ppat_type lid ->
let (path, p,ty) = build_or_pat !env loc lid.txt in
unify_pat_types loc !env ty expected_ty;
{ p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
{ p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
| Ppat_extension (s, _arg) ->
raise (Error (loc, !env, Extension s))
@ -1324,12 +1338,13 @@ and is_nonexpansive_mod mexp =
| 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
| Tstr_exception _ -> false (* true would be unsound *)
| Tstr_class _ -> false (* could be more precise *)
| Tstr_attribute _ -> true
)
str.str_items
| Tmod_apply _ -> false
@ -1838,6 +1853,7 @@ and type_expect_ ?in_function env sexp ty_expected =
end;
exp_loc = loc; exp_extra = [];
exp_type = instance env desc.val_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_constant(Const_string s as cst) ->
@ -1851,12 +1867,14 @@ and type_expect_ ?in_function env sexp ty_expected =
type_format loc s
| _ -> instance_def Predef.type_string
end;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_constant cst ->
rue {
exp_desc = Texp_constant cst;
exp_loc = loc; exp_extra = [];
exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
type_expect ?in_function env
@ -1877,6 +1895,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_function (l, Some default, [spat, sbody]) ->
let default_loc = default.pexp_loc in
@ -1954,6 +1973,7 @@ and type_expect_ ?in_function env sexp ty_expected =
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_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_apply(sfunct, sargs) ->
begin_def (); (* one more level for non-returning functions *)
@ -1983,6 +2003,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_apply(funct, args);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_match(sarg, caselist) ->
begin_def ();
@ -1997,6 +2018,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_try(sbody, caselist) ->
let body = type_expect env sbody ty_expected in
@ -2006,6 +2028,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_try(body, cases);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_tuple sexpl ->
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
@ -2019,9 +2042,10 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_loc = loc; exp_extra = [];
(* Keep sharing *)
exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_construct(lid, sarg, explicit_arity) ->
type_construct env loc lid sarg explicit_arity ty_expected
type_construct env loc lid sarg explicit_arity ty_expected sexp.pexp_attributes
| Pexp_variant(l, sarg) ->
(* Keep sharing *)
let ty_expected0 = instance env ty_expected in
@ -2036,6 +2060,7 @@ and type_expect_ ?in_function env sexp ty_expected =
re { exp_desc = Texp_variant(l, Some arg);
exp_loc = loc; exp_extra = [];
exp_type = ty_expected0;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| _ -> raise Not_found
end
@ -2052,6 +2077,7 @@ and type_expect_ ?in_function env sexp ty_expected =
row_closed = false;
row_fixed = false;
row_name = None});
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_record(lid_sexp_list, opt_sexp) ->
@ -2146,6 +2172,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_field(srecord, lid) ->
let (record, label, _) = type_label_access env loc srecord lid in
@ -2155,6 +2182,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_field(record, lid, label);
exp_loc = loc; exp_extra = [];
exp_type = ty_arg;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
let (record, label, opath) = type_label_access env loc srecord lid in
@ -2168,6 +2196,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_array(sargl) ->
let ty = newgenvar() in
@ -2178,6 +2207,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_array argl;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_ifthenelse(scond, sifso, sifnot) ->
let cond = type_expect env scond Predef.type_bool in
@ -2188,6 +2218,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_ifthenelse(cond, ifso, None);
exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Some sifnot ->
let ifso = type_expect env sifso ty_expected in
@ -2198,6 +2229,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_sequence(sexp1, sexp2) ->
@ -2207,6 +2239,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_sequence(exp1, exp2);
exp_loc = loc; exp_extra = [];
exp_type = exp2.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_while(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in
@ -2215,6 +2248,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_while(cond, body);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_for(param, slow, shigh, dir, sbody) ->
let low = type_expect env slow Predef.type_int in
@ -2229,6 +2263,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_for(id, param, low, high, dir, body);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_constraint(sarg, sty, sty') ->
let separate = true (* always separate, 1% slowdown for lablgtk *)
@ -2328,8 +2363,9 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = arg.exp_desc;
exp_loc = arg.exp_loc;
exp_type = ty';
exp_attributes = arg.exp_attributes;
exp_env = env;
exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
exp_extra = (Texp_constraint (cty, cty'), loc, sexp.pexp_attributes) :: arg.exp_extra;
}
| Pexp_when(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in
@ -2338,6 +2374,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_when(cond, body);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_send (e, met) ->
if !Clflags.principal then begin_def ();
@ -2380,17 +2417,20 @@ and type_expect_ ?in_function env sexp ty_expected =
Types.val_loc = Location.none});
exp_loc = loc; exp_extra = [];
exp_type = method_type;
exp_attributes = []; (* check *)
exp_env = env},
["",
Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type;
exp_attributes = []; (* check *)
exp_env = env},
Required])
in
(Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = [];
exp_type = typ;
exp_attributes = []; (* check *)
exp_env = env}), typ)
| _ ->
assert false
@ -2425,6 +2465,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_send(obj, meth, exp);
exp_loc = loc; exp_extra = [];
exp_type = typ;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
with Unify _ ->
raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met)))
@ -2439,6 +2480,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_new (cl_path, cl, cl_decl);
exp_loc = loc; exp_extra = [];
exp_type = instance_def ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_setinstvar (lab, snewval) ->
@ -2455,6 +2497,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_setinstvar(path_self, path, lab, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Val_ivar _ ->
raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
@ -2497,6 +2540,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_override(path_self, modifs);
exp_loc = loc; exp_extra = [];
exp_type = self_ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| _ ->
assert false
@ -2528,6 +2572,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_letmodule(id, name, modl, body);
exp_loc = loc; exp_extra = [];
exp_type = ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_assert (e) ->
let cond = type_expect env e Predef.type_bool in
@ -2535,6 +2580,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_assert (cond);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_assertfalse ->
@ -2542,6 +2588,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_assertfalse;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_lazy e ->
@ -2553,6 +2600,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_lazy arg;
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_object s ->
@ -2561,6 +2609,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_object (desc, (*sign,*) meths);
exp_loc = loc; exp_extra = [];
exp_type = sign.cty_self;
exp_attributes = sexp.pexp_attributes;
exp_env = env;
}
| Pexp_poly(sbody, sty) ->
@ -2602,7 +2651,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp
| _ -> assert false
in
re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra }
re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
| Pexp_newtype(name, sbody) ->
let ty = newvar () in
(* remember original level *)
@ -2647,7 +2696,7 @@ and type_expect_ ?in_function 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 = loc; exp_type = ety;
exp_extra = (Texp_newtype name, loc) :: body.exp_extra }
exp_extra = (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
| Pexp_pack m ->
let (p, nl, tl) =
match Ctype.expand_head env (instance env ty_expected) with
@ -2668,12 +2717,13 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_pack modl;
exp_loc = loc; exp_extra = [];
exp_type = newty (Tpackage (p, nl, tl'));
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_open (lid, e) ->
let (path, newenv) = !type_open env sexp.pexp_loc lid in
let exp = type_expect newenv e ty_expected in
{ exp with
exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
exp_extra = (Texp_open (path, lid, newenv), loc, sexp.pexp_attributes) :: exp.exp_extra;
}
| Pexp_extension (s, _arg) ->
raise (Error (loc, env, Extension s))
@ -2795,9 +2845,10 @@ and type_argument env sarg ty_expected' ty_expected =
let var_pair name ty =
let id = Ident.create name in
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
pat_attributes = [];
pat_loc = Location.none; pat_env = env},
{exp_type = ty; exp_loc = Location.none; exp_env = env;
exp_extra = [];
exp_extra = []; exp_attributes = [];
exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
{val_type = ty; val_kind = Val_reg;
@ -3012,7 +3063,7 @@ and type_application env funct sargs =
else
type_args [] [] ty (instance env ty) ty sargs []
and type_construct env loc lid sarg explicit_arity ty_expected =
and type_construct env loc lid sarg explicit_arity ty_expected attrs =
let opath =
try
let (p0, p,_) = extract_concrete_variant env ty_expected in
@ -3039,6 +3090,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
exp_desc = Texp_construct(lid, constr, [],explicit_arity);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
exp_attributes = attrs;
exp_env = env } in
if separate then begin
end_def ();

8
typing/typedecl.ml
View File

@ -263,6 +263,7 @@ let transl_declaration env sdecl id =
typ_kind = tkind;
typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
} in
(id, sdecl.ptype_name, tdecl)
@ -883,7 +884,7 @@ let transl_exception env loc excdecl =
let types = List.map (fun cty -> cty.ctyp_type) ttypes in
List.iter Ctype.generalize types;
let exn_decl = { exn_args = types; Types.exn_loc = loc } in
{ exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc }
{ exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc; exn_attributes = excdecl.ped_attributes }
(* Translate an exception rebinding *)
let transl_exn_rebind env loc lid =
@ -919,7 +920,9 @@ let transl_value_decl env loc valdecl =
in
{ val_desc = cty; val_val = v;
val_prim = valdecl.pval_prim;
val_loc = valdecl.pval_loc; }
val_loc = valdecl.pval_loc;
val_attributes = valdecl.pval_attributes;
}
(* Translate a "with" constraint -- much simplified version of
transl_type_decl. *)
@ -985,6 +988,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
typ_kind = Ttype_abstract;
typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
}
(* Approximate a type declaration: just make all types abstract *)

51
typing/typedtree.ml
View File

@ -21,12 +21,16 @@ open Types
type partial = Partial | Total
type optional = Required | Optional
type attribute = string * Parsetree.expression
type pattern =
{ pat_desc: pattern_desc;
pat_loc: Location.t;
pat_extra : (pat_extra * Location.t) list;
pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr;
mutable pat_env: Env.t }
mutable pat_env: Env.t;
pat_attributes: attribute list;
}
and pat_extra =
| Tpat_constraint of core_type
@ -52,9 +56,11 @@ and pattern_desc =
and expression =
{ exp_desc: expression_desc;
exp_loc: Location.t;
exp_extra : (exp_extra * Location.t) list;
exp_extra: (exp_extra * Location.t * attribute list) list;
exp_type: type_expr;
exp_env: Env.t }
exp_env: Env.t;
exp_attributes: attribute list;
}
and exp_extra =
| Texp_constraint of core_type option * core_type option
@ -114,7 +120,7 @@ and class_expr =
cl_env: Env.t }
and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list (* Pcl_constr *)
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 *
@ -195,14 +201,15 @@ and structure_item_desc =
| 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_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attribute list
| 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_open of Path.t * Longident.t loc * attribute list
| 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
| Tstr_include of module_expr * Ident.t list * attribute list
| Tstr_attribute of attribute
and module_coercion =
Tcoerce_none
@ -213,8 +220,10 @@ and module_coercion =
and module_type =
{ mty_desc: module_type_desc;
mty_type : Types.module_type;
mty_env : Env.t; (* BINANNOT ADDED *)
mty_loc: Location.t }
mty_env : Env.t;
mty_loc: Location.t;
mty_attributes: attribute list;
}
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
@ -241,10 +250,11 @@ and signature_item_desc =
| 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_open of Path.t * Longident.t loc * attribute list
| Tsig_include of module_type * Types.signature * attribute list
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
and modtype_declaration =
Tmodtype_abstract
@ -261,7 +271,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *)
ctyp_loc : Location.t }
ctyp_loc : Location.t;
ctyp_attributes: attribute list;
}
and core_type_desc =
Ttyp_any
@ -300,6 +312,7 @@ and value_description =
val_val : Types.value_description;
val_prim : string list;
val_loc : Location.t;
val_attributes: attribute list;
}
and type_declaration =
@ -310,7 +323,9 @@ and type_declaration =
typ_private: private_flag;
typ_manifest: core_type option;
typ_variance: (bool * bool) list;
typ_loc: Location.t }
typ_loc: Location.t;
typ_attributes: attribute list;
}
and type_kind =
Ttype_abstract
@ -321,7 +336,9 @@ and type_kind =
and exception_declaration =
{ exn_params : core_type list;
exn_exn : Types.exception_declaration;
exn_loc : Location.t }
exn_loc : Location.t;
exn_attributes: attribute list;
}
and class_type =
{ cltyp_desc: class_type_desc;
@ -374,7 +391,9 @@ and 'a class_infos =
ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration;
ci_variance: (bool * bool) list;
ci_loc: Location.t }
ci_loc: Location.t;
ci_attributes: attribute list;
}
(* Auxiliary functions over the a.s.t. *)

47
typing/typedtree.mli
View File

@ -20,12 +20,16 @@ open Types
type partial = Partial | Total
type optional = Required | Optional
type attribute = string * Parsetree.expression
type pattern =
{ pat_desc: pattern_desc;
pat_loc: Location.t;
pat_extra : (pat_extra * Location.t) list;
pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr;
mutable pat_env: Env.t }
mutable pat_env: Env.t;
pat_attributes: attribute list;
}
and pat_extra =
| Tpat_constraint of core_type
@ -51,9 +55,11 @@ and pattern_desc =
and expression =
{ exp_desc: expression_desc;
exp_loc: Location.t;
exp_extra : (exp_extra * Location.t) list;
exp_extra: (exp_extra * Location.t * attribute list) list;
exp_type: type_expr;
exp_env: Env.t }
exp_env: Env.t;
exp_attributes: attribute list;
}
and exp_extra =
| Texp_constraint of core_type option * core_type option
@ -194,14 +200,15 @@ and structure_item_desc =
| 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_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attribute list
| 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_open of Path.t * Longident.t loc * attribute list
| 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
| Tstr_include of module_expr * Ident.t list * attribute list
| Tstr_attribute of attribute
and module_coercion =
Tcoerce_none
@ -213,7 +220,9 @@ and module_type =
{ mty_desc: module_type_desc;
mty_type : Types.module_type;
mty_env : Env.t;
mty_loc: Location.t }
mty_loc: Location.t;
mty_attributes: attribute list;
}
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
@ -240,10 +249,11 @@ and signature_item_desc =
| 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_open of Path.t * Longident.t loc * attribute list
| Tsig_include of module_type * Types.signature * attribute list
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
and modtype_declaration =
Tmodtype_abstract
@ -260,7 +270,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *)
ctyp_loc : Location.t }
ctyp_loc : Location.t;
ctyp_attributes: attribute list;
}
and core_type_desc =
Ttyp_any
@ -299,6 +311,7 @@ and value_description =
val_val : Types.value_description;
val_prim : string list;
val_loc : Location.t;
val_attributes: attribute list;
}
and type_declaration =
@ -309,7 +322,9 @@ and type_declaration =
typ_private: private_flag;
typ_manifest: core_type option;
typ_variance: (bool * bool) list;
typ_loc: Location.t }
typ_loc: Location.t;
typ_attributes: attribute list;
}
and type_kind =
Ttype_abstract
@ -320,7 +335,9 @@ and type_kind =
and exception_declaration =
{ exn_params : core_type list;
exn_exn : Types.exception_declaration;
exn_loc : Location.t }
exn_loc : Location.t;
exn_attributes: attribute list;
}
and class_type =
{ cltyp_desc: class_type_desc;
@ -373,7 +390,9 @@ and 'a class_infos =
ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration;
ci_variance: (bool * bool) list;
ci_loc: Location.t }
ci_loc: Location.t;
ci_attributes: attribute list;
}
(* Auxiliary functions over the a.s.t. *)

13
typing/typedtreeIter.ml
View File

@ -132,7 +132,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tstr_type list ->
List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
| Tstr_exception (id, _, decl) -> iter_exception_declaration decl
| Tstr_exn_rebind (id, _, p, _) -> ()
| Tstr_exn_rebind _ -> ()
| Tstr_module (id, _, mexpr) ->
iter_module_expr mexpr
| Tstr_recmodule list ->
@ -154,8 +154,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_class_type ct.ci_expr;
Iter.leave_class_type_declaration ct;
) list
| Tstr_include (mexpr, _) ->
| Tstr_include (mexpr, _, _attrs) ->
iter_module_expr mexpr
| Tstr_attribute _ ->
()
end;
Iter.leave_structure_item item
@ -194,7 +196,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
and iter_pattern pat =
Iter.enter_pattern pat;
List.iter (fun (cstr, _) -> match cstr with
List.iter (fun (cstr, _, _attrs) -> match cstr with
| Tpat_type _ -> ()
| Tpat_unpack -> ()
| Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
@ -225,7 +227,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
and iter_expression exp =
Iter.enter_expression exp;
List.iter (function (cstr, _) ->
List.iter (function (cstr, _, _attrs) ->
match cstr with
Texp_constraint (cty1, cty2) ->
option iter_core_type cty1; option iter_core_type cty2
@ -354,11 +356,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tsig_modtype (id, _, mdecl) ->
iter_modtype_declaration mdecl
| Tsig_open _ -> ()
| Tsig_include (mty,_) -> iter_module_type mty
| Tsig_include (mty, _, _attrs) -> iter_module_type mty
| Tsig_class list ->
List.iter iter_class_description list
| Tsig_class_type list ->
List.iter iter_class_type_declaration list
| Tsig_attribute _ -> ()
end;
Iter.leave_signature_item item;

39
typing/typedtreeMap.ml
View File

@ -108,8 +108,8 @@ module MakeMap(Map : MapArgument) = struct
(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_exn_rebind (id, name, path, lid, attrs) ->
Tstr_exn_rebind (id, name, path, lid, attrs)
| Tstr_module (id, name, mexpr) ->
Tstr_module (id, name, map_module_expr mexpr)
| Tstr_recmodule list ->
@ -121,7 +121,7 @@ module MakeMap(Map : MapArgument) = struct
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_open (path, lid, attrs) -> Tstr_open (path, lid, attrs)
| Tstr_class list ->
let list =
List.map (fun (ci, string_list, virtual_flag) ->
@ -139,8 +139,9 @@ module MakeMap(Map : MapArgument) = struct
(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)
| Tstr_include (mexpr, idents, attrs) ->
Tstr_include (map_module_expr mexpr, idents, attrs)
| Tstr_attribute x -> Tstr_attribute x
in
Map.leave_structure_item { item with str_desc = str_desc}
@ -183,7 +184,9 @@ module MakeMap(Map : MapArgument) = struct
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
exn_loc = decl.exn_loc;
exn_attributes = decl.exn_attributes;
} in
Map.leave_exception_declaration decl;
and map_pattern pat =
@ -220,8 +223,8 @@ module MakeMap(Map : MapArgument) = struct
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
| Tpat_constraint ct, loc, attrs -> (Tpat_constraint (map_core_type ct), loc, attrs)
| (Tpat_type _ | Tpat_unpack), _, _ -> pat_extra
and map_expression exp =
let exp = Map.enter_expression exp in
@ -349,20 +352,19 @@ module MakeMap(Map : MapArgument) = struct
Map.leave_expression {
exp with
exp_desc = exp_desc;
exp_extra = exp_extra }
exp_extra = exp_extra; }
and map_exp_extra exp_extra =
let loc = snd exp_extra in
match fst exp_extra with
and map_exp_extra ((desc, loc, attrs) as exp_extra) =
match desc with
| Texp_constraint (Some ct, None) ->
Texp_constraint (Some (map_core_type ct), None), loc
Texp_constraint (Some (map_core_type ct), None), loc, attrs
| Texp_constraint (None, Some ct) ->
Texp_constraint (None, Some (map_core_type ct)), loc
Texp_constraint (None, Some (map_core_type ct)), loc, attrs
| Texp_constraint (Some ct1, Some ct2) ->
Texp_constraint (Some (map_core_type ct1),
Some (map_core_type ct2)), loc
Some (map_core_type ct2)), loc, attrs
| Texp_poly (Some ct) ->
Texp_poly (Some ( map_core_type ct )), loc
Texp_poly (Some ( map_core_type ct )), loc, attrs
| Texp_newtype _
| Texp_constraint (None, None)
| Texp_open _
@ -401,11 +403,12 @@ module MakeMap(Map : MapArgument) = struct
(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_open (path, lid, _attrs) -> item.sig_desc
| Tsig_include (mty, lid, attrs) -> Tsig_include (map_module_type mty, lid, attrs)
| 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)
| Tsig_attribute _ as x -> x
in
Map.leave_signature_item { item with sig_desc = sig_desc }

41
typing/typemod.ml
View File

@ -391,12 +391,13 @@ 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 mkmty desc typ env loc attrs =
let mty = {
mty_desc = desc;
mty_type = typ;
mty_loc = loc;
mty_env = env;
mty_attributes = attrs;
} in
Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
mty
@ -414,15 +415,18 @@ let rec transl_modtype env smty =
Pmty_ident lid ->
let path = transl_modtype_longident loc env lid.txt in
mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
smty.pmty_attributes
| Pmty_signature ssg ->
let sg = transl_signature env ssg in
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
smty.pmty_attributes
| Pmty_functor(param, sarg, sres) ->
let arg = transl_modtype env sarg in
let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, arg.mty_type, res.mty_type)) env loc
smty.pmty_attributes
| Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in
let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
@ -435,10 +439,11 @@ let rec transl_modtype env smty =
)
([],init_sg) constraints in
mkmty (Tmty_with ( body, tcstrs))
(Mtype.freshen (Mty_signature final_sg)) env loc
(Mtype.freshen (Mty_signature final_sg)) env loc
smty.pmty_attributes
| Pmty_typeof smod ->
let tmty, mty = !type_module_type_of_fwd env smod in
mkmty (Tmty_typeof tmty) mty env loc
mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
| Pmty_extension (s, _arg) ->
raise (Error (smty.pmty_loc, env, Extension s))
@ -512,11 +517,11 @@ and transl_signature env sg =
mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem,
Sig_modtype(id, info) :: rem,
final_env
| Psig_open (lid, _attrs) ->
| Psig_open (lid, attrs) ->
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, _attrs) ->
mksig (Tsig_open (path,lid,attrs)) env loc :: trem, rem, final_env
| Psig_include (smty, attrs) ->
let tmty = transl_modtype env smty in
let mty = tmty.mty_type in
let sg = Subst.signature Subst.identity
@ -527,7 +532,7 @@ and transl_signature env sg =
sg;
let newenv = Env.add_signature sg env in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_include (tmty, sg)) env loc :: trem,
mksig (Tsig_include (tmty, sg, attrs)) env loc :: trem,
remove_values (get_values rem) sg @ rem, final_env
| Psig_class cl ->
List.iter
@ -571,8 +576,9 @@ and transl_signature env sg =
Sig_type(i'', d'', rs)])
classes [rem]),
final_env
| Psig_attribute _ ->
transl_sig env srem
| Psig_attribute x ->
let (trem,rem, final_env) = transl_sig env srem in
mksig (Tsig_attribute x) env loc :: trem, rem, final_env
| Psig_extension ((s, _), _) ->
raise (Error (loc, env, Extension s))
in
@ -997,10 +1003,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
Sig_exception(id, arg.exn_exn) :: sig_rem,
final_env)
| Pstr_exn_rebind(name, longid, _attrs) ->
| Pstr_exn_rebind(name, longid, attrs) ->
let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
let (id, newenv) = Env.enter_exception name.txt arg env in
let item = mk (Tstr_exn_rebind(id, name, path, longid)) in
let item = mk (Tstr_exn_rebind(id, name, path, longid, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem,
Sig_exception(id, arg) :: sig_rem,
@ -1063,9 +1069,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
final_env)
| Pstr_open (lid, _attrs) ->
| Pstr_open (lid, attrs) ->
let (path, newenv) = type_open ~toplevel env loc lid in
let item = mk (Tstr_open (path, lid)) in
let item = mk (Tstr_open (path, lid, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem, sig_rem, final_env)
| Pstr_class cl ->
@ -1125,7 +1131,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_type(i'', d'', rs)])
classes [sig_rem]),
final_env)
| Pstr_include (smodl, _attrs) ->
| Pstr_include (smodl, attrs) ->
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
@ -1133,15 +1139,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
List.iter
(check_sig_item type_names module_names modtype_names loc) sg;
let new_env = Env.add_signature sg env in
let item = mk (Tstr_include (modl, bound_value_identifiers sg)) in
let item = mk (Tstr_include (modl, bound_value_identifiers sg, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct new_env srem in
(item :: str_rem,
sg @ sig_rem,
final_env)
| Pstr_extension ((s, _), _) ->
raise (Error (loc, env, Extension s))
| Pstr_attribute _ ->
type_struct env srem
| Pstr_attribute x ->
let (str_rem, sig_rem, final_env) = type_struct env srem in
mk (Tstr_attribute x) :: str_rem, sig_rem, final_env
in
if !Clflags.annotations then
(* moved to genannot *)

38
typing/typetexp.ml
View File

@ -212,11 +212,11 @@ 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
let ctyp ctyp_desc ctyp_type =
{ ctyp_desc; ctyp_type; ctyp_env = env; ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes }
in
match styp.ptyp_desc with
Ptyp_any ->
let ty =
@ -225,7 +225,7 @@ let rec transl_type env policy styp =
raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
else newvar ()
in
ctyp Ttyp_any ty env loc
ctyp Ttyp_any ty
| Ptyp_var name ->
let ty =
if name <> "" && name.[0] = '_' then
@ -242,16 +242,16 @@ let rec transl_type env policy styp =
v
end
in
ctyp (Ttyp_var name) ty env loc
ctyp (Ttyp_var name) ty
| Ptyp_arrow(l, st1, st2) ->
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
ctyp (Ttyp_arrow (l, cty1, cty2)) ty
| Ptyp_tuple 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
ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
let (path, decl) = find_type env styp.ptyp_loc lid.txt in
if List.length stl <> decl.type_arity then
@ -278,7 +278,7 @@ let rec transl_type env policy styp =
with Unify trace ->
raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
end;
ctyp (Ttyp_constr (path, lid, args)) constr env loc
ctyp (Ttyp_constr (path, lid, args)) constr
| Ptyp_object fields ->
let fields = List.map
(fun pf ->
@ -292,7 +292,7 @@ let rec transl_type env policy styp =
{ 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
ctyp (Ttyp_object fields) ty
| Ptyp_class(lid, stl, present) ->
let (path, decl, is_variant) =
try
@ -375,7 +375,7 @@ let rec transl_type env policy styp =
| _ ->
assert false
in
ctyp (Ttyp_class (path, lid, args, present)) ty env loc
ctyp (Ttyp_class (path, lid, args, present)) ty
| Ptyp_alias(st, alias) ->
let cty =
try
@ -412,7 +412,7 @@ let rec transl_type env policy styp =
end;
{ ty with ctyp_type = t }
in
ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type env loc
ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type
| Ptyp_variant(fields, closed, present) ->
let name = ref None in
let mkfield l f =
@ -514,7 +514,7 @@ let rec transl_type env policy styp =
else { row with row_more = new_pre_univar () }
in
let ty = newty (Tvariant row) in
ctyp (Ttyp_variant (tfields, closed, present)) ty env loc
ctyp (Ttyp_variant (tfields, closed, present)) ty
| Ptyp_poly(vars, st) ->
begin_def();
let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
@ -541,7 +541,7 @@ let rec transl_type env policy styp =
in
let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
unify_var env (newvar()) ty';
ctyp (Ttyp_poly (vars, cty)) ty' env loc
ctyp (Ttyp_poly (vars, cty)) ty'
| Ptyp_package (p, l) ->
let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
let z = narrow () in
@ -555,12 +555,12 @@ let rec transl_type env policy styp =
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
ctyp (Ttyp_package {
pack_name = path;
pack_type = mty.mty_type;
pack_fields = ptys;
pack_txt = p;
}) ty
| Ptyp_extension (s, _arg) ->
raise (Error (loc, env, Extension s))