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) -> | Tstr_exception( id, _, decl) ->
Llet(Strict, id, transl_exception id (field_path rootpath id) decl, Llet(Strict, id, transl_exception id (field_path rootpath id) decl,
transl_structure (id :: fields) cc rootpath rem) transl_structure (id :: fields) cc rootpath rem)
| Tstr_exn_rebind( id, _, path, _) -> | Tstr_exn_rebind( id, _, path, _, _) ->
Llet(Strict, id, transl_path path, Llet(Strict, id, transl_path path,
transl_structure (id :: fields) cc rootpath rem) transl_structure (id :: fields) cc rootpath rem)
| Tstr_module( id, _, modl) -> | Tstr_module( id, _, modl) ->
@ -312,10 +312,6 @@ and transl_structure fields cc rootpath = function
transl_module Tcoerce_none (field_path rootpath id) modl) transl_module Tcoerce_none (field_path rootpath id) modl)
bindings bindings
(transl_structure ext_fields cc rootpath rem) (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 -> | Tstr_class cl_list ->
let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in
Lletrec(List.map Lletrec(List.map
@ -325,9 +321,7 @@ and transl_structure fields cc rootpath = function
(id, transl_class ids id meths cl vf )) (id, transl_class ids id meths cl vf ))
cl_list, cl_list,
transl_structure (List.rev ids @ fields) cc rootpath rem) transl_structure (List.rev ids @ fields) cc rootpath rem)
| Tstr_class_type cl_list -> | Tstr_include(modl, ids, _) ->
transl_structure fields cc rootpath rem
| Tstr_include(modl, ids) ->
let mid = Ident.create "include" in let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function 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, Llet(Strict, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids) 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 *) (* Update forward declaration in Translcore *)
let _ = let _ =
Translcore.transl_module := transl_module Translcore.transl_module := transl_module
@ -366,16 +366,17 @@ let rec defined_idents = function
| Tstr_primitive(id, _, descr) -> defined_idents rem | Tstr_primitive(id, _, descr) -> defined_idents rem
| Tstr_type decls -> defined_idents rem | Tstr_type decls -> defined_idents rem
| Tstr_exception(id, _, decl) -> id :: 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_module(id, _, modl) -> id :: defined_idents rem
| Tstr_recmodule decls -> | Tstr_recmodule decls ->
List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem
| Tstr_modtype(id, _, decl) -> 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 -> | Tstr_class cl_list ->
List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
| Tstr_class_type 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 *) (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *)
let rec more_idents = function let rec more_idents = function
@ -387,16 +388,17 @@ let rec more_idents = function
| Tstr_primitive(id, _, descr) -> more_idents rem | Tstr_primitive(id, _, descr) -> more_idents rem
| Tstr_type decls -> more_idents rem | Tstr_type decls -> more_idents rem
| Tstr_exception(id, _, decl) -> 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_recmodule decls -> more_idents rem
| Tstr_modtype(id, _, decl) -> 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 cl_list -> more_idents rem
| Tstr_class_type 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 }) -> | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
all_idents str.str_items @ more_idents rem all_idents str.str_items @ more_idents rem
| Tstr_module(id, _, _) -> more_idents rem | Tstr_module(id, _, _) -> more_idents rem
| Tstr_attribute _ -> []
and all_idents = function and all_idents = function
[] -> [] [] -> []
@ -408,18 +410,19 @@ and all_idents = function
| Tstr_primitive(id, _, descr) -> all_idents rem | Tstr_primitive(id, _, descr) -> all_idents rem
| Tstr_type decls -> all_idents rem | Tstr_type decls -> all_idents rem
| Tstr_exception(id, _, decl) -> id :: 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 -> | Tstr_recmodule decls ->
List.map (fun (id, _, _, _) -> id) decls @ all_idents rem List.map (fun (id, _, _, _) -> id) decls @ all_idents rem
| Tstr_modtype(id, _, decl) -> 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 -> | Tstr_class cl_list ->
List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem
| Tstr_class_type 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 }) -> | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
id :: all_idents str.str_items @ all_idents rem id :: all_idents str.str_items @ all_idents rem
| Tstr_module(id, _, _) -> id :: all_idents rem | Tstr_module(id, _, _) -> id :: all_idents rem
| Tstr_attribute _ -> []
(* A variant of transl_structure used to compile toplevel structure definitions (* 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 let lam = transl_exception id (field_path rootpath id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id), Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem) 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 let lam = subst_lambda subst (transl_path path) in
Lsequence(Llet(Strict, id, lam, store_ident id), Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem) transl_store rootpath (add_ident false id subst) rem)
@ -500,10 +503,6 @@ let transl_store_structure glob map prims str =
bindings bindings
(Lsequence(store_idents ids, (Lsequence(store_idents ids,
transl_store rootpath (add_idents true ids subst) rem)) 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 -> | Tstr_class cl_list ->
let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in
let lam = let lam =
@ -516,9 +515,7 @@ let transl_store_structure glob map prims str =
store_idents ids) in store_idents ids) in
Lsequence(subst_lambda subst lam, Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem) transl_store rootpath (add_idents false ids subst) rem)
| Tstr_class_type cl_list -> | Tstr_include(modl, ids, _attrs) ->
transl_store rootpath subst rem
| Tstr_include(modl, ids) ->
let mid = Ident.create "include" in let mid = Ident.create "include" in
let rec store_idents pos = function let rec store_idents pos = function
[] -> transl_store rootpath (add_idents true ids subst) rem [] -> transl_store rootpath (add_idents true ids subst) rem
@ -528,6 +525,11 @@ let transl_store_structure glob map prims str =
Llet(Strict, mid, Llet(Strict, mid,
subst_lambda subst (transl_module Tcoerce_none None modl), subst_lambda subst (transl_module Tcoerce_none None modl),
store_idents 0 ids) store_idents 0 ids)
| Tstr_modtype _
| Tstr_open _
| Tstr_class_type _
| Tstr_attribute _ ->
transl_store rootpath subst rem
and store_ident id = and store_ident id =
try try
@ -669,13 +671,9 @@ let transl_toplevel_item item =
let idents = let_bound_idents pat_expr_list in let idents = let_bound_idents pat_expr_list in
transl_let rec_flag pat_expr_list transl_let rec_flag pat_expr_list
(make_sequence toploop_setvalue_id idents) (make_sequence toploop_setvalue_id idents)
| Tstr_primitive(id, _, descr) ->
lambda_unit
| Tstr_type(decls) ->
lambda_unit
| Tstr_exception(id, _, decl) -> | Tstr_exception(id, _, decl) ->
toploop_setvalue id (transl_exception id None 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) toploop_setvalue id (transl_path path)
| Tstr_module(id, _, modl) -> | Tstr_module(id, _, modl) ->
(* we need to use the unique name for the module because of issues (* 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) (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)
bindings bindings
(make_sequence toploop_setvalue_id idents) (make_sequence toploop_setvalue_id idents)
| Tstr_modtype(id, _, decl) ->
lambda_unit
| Tstr_open (path, _) ->
lambda_unit
| Tstr_class cl_list -> | Tstr_class cl_list ->
(* we need to use unique names for the classes because there might (* we need to use unique names for the classes because there might
be a value named identically *) be a value named identically *)
@ -707,9 +701,7 @@ let transl_toplevel_item item =
make_sequence make_sequence
(fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class)
cl_list) cl_list)
| Tstr_class_type cl_list -> | Tstr_include(modl, ids, _attrs) ->
lambda_unit
| Tstr_include(modl, ids) ->
let mid = Ident.create "include" in let mid = Ident.create "include" in
let rec set_idents pos = function let rec set_idents pos = function
[] -> [] ->
@ -718,6 +710,13 @@ let transl_toplevel_item item =
Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
set_idents (pos + 1) ids) in set_idents (pos + 1) ids) in
Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) 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 = let transl_toplevel_item_and_close itm =
close_toplevel_term (transl_label_init (transl_toplevel_item 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 Hashtbl.add table (MT (Name.from_ident ident)) tt
| Typedtree.Tstr_exception (ident, _, _) -> | Typedtree.Tstr_exception (ident, _, _) ->
Hashtbl.add table (E (Name.from_ident ident)) tt 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 Hashtbl.add table (ER (Name.from_ident ident)) tt
| Typedtree.Tstr_type ident_type_decl_list -> | Typedtree.Tstr_type ident_type_decl_list ->
List.iter List.iter
@ -111,6 +111,7 @@ module Typedtree_search =
| Typedtree.Tstr_open _ -> () | Typedtree.Tstr_open _ -> ()
| Typedtree.Tstr_include _ -> () | Typedtree.Tstr_include _ -> ()
| Typedtree.Tstr_eval _ -> () | Typedtree.Tstr_eval _ -> ()
| Typedtree.Tstr_attribute _ -> ()
let tables typedtree = let tables typedtree =
let t = Hashtbl.create 13 in let t = Hashtbl.create 13 in
@ -135,7 +136,7 @@ module Typedtree_search =
let search_exception_rebind table name = let search_exception_rebind table name =
match Hashtbl.find table (ER name) with match Hashtbl.find table (ER name) with
| (Typedtree.Tstr_exn_rebind (_, _, p, _)) -> p | (Typedtree.Tstr_exn_rebind (_, _, p, _, _)) -> p
| _ -> assert false | _ -> assert false
let search_type_declaration table name = let search_type_declaration table name =
@ -885,7 +886,7 @@ module Analyser =
let tt_get_included_module_list tt_structure = let tt_get_included_module_list tt_structure =
let f acc item = let f acc item =
match item.str_desc with match item.str_desc with
Typedtree.Tstr_include (mod_expr, _) -> Typedtree.Tstr_include (mod_expr, _, _) ->
acc @ [ acc @ [
{ (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *)
im_name = tt_name_from_module_expr mod_expr ; 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_pat pat ~pos ~env;
search_pos_expr exp ~pos search_pos_expr exp ~pos
end end
| Tstr_primitive (_, _, vd) ->()
| Tstr_type _ -> ()
| Tstr_exception _ -> ()
| Tstr_exn_rebind(_, _, _, _) -> ()
| Tstr_module (_, _, m) -> search_pos_module_expr m ~pos | Tstr_module (_, _, m) -> search_pos_module_expr m ~pos
| Tstr_recmodule bindings -> | Tstr_recmodule bindings ->
List.iter bindings ~f:(fun (_, _, _, m) -> search_pos_module_expr m ~pos) List.iter bindings ~f:(fun (_, _, _, m) -> search_pos_module_expr m ~pos)
| Tstr_modtype _ -> ()
| Tstr_open _ -> ()
| Tstr_class l -> | Tstr_class l ->
List.iter l ~f:(fun (cl, _, _) -> search_pos_class_expr cl.ci_expr ~pos) 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 end
and search_pos_class_structure ~pos cls = 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 option (i+1) core_type ppf x.ptype_manifest
and attributes i ppf l = and attributes i ppf l =
let i = i + 1 in
List.iter List.iter
(fun (s, arg) -> (fun (s, arg) ->
line i ppf "attribute \"%s\"\n" s; line i ppf "attribute \"%s\"\n" s;
expression i ppf arg; expression (i + 1) ppf arg;
) )
l l

2
parsing/printast.mli
View File

@ -16,3 +16,5 @@ open Format;;
val interface : formatter -> signature_item list -> unit;; val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;; val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> 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 -> | Tstr_type list ->
List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
| Tstr_exception (_id, _, decl) -> sub # exception_declaration decl | 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_module (_id, _, mexpr) -> sub # module_expr mexpr
| Tstr_recmodule list -> | Tstr_recmodule list ->
List.iter List.iter
@ -41,7 +41,8 @@ let structure_item sub x =
List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
| Tstr_class_type list -> | Tstr_class_type list ->
List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) 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 = let value_description sub x =
sub # core_type x.val_desc sub # core_type x.val_desc
@ -68,7 +69,7 @@ let pattern sub pat =
| Tpat_unpack -> () | Tpat_unpack -> ()
| Tpat_constraint ct -> sub # core_type ct | Tpat_constraint ct -> sub # core_type ct
in in
List.iter (fun (c, _) -> extra c) pat.pat_extra; List.iter (fun (c, _, _) -> extra c) pat.pat_extra;
match pat.pat_desc with match pat.pat_desc with
| Tpat_any | Tpat_any
| Tpat_var _ | Tpat_var _
@ -90,7 +91,7 @@ let expression sub exp =
| Texp_newtype _ -> () | Texp_newtype _ -> ()
| Texp_poly cto -> opt (sub # core_type) cto | Texp_poly cto -> opt (sub # core_type) cto
in in
List.iter (function (c, _) -> extra c) exp.exp_extra; List.iter (fun (c, _, _) -> extra c) exp.exp_extra;
match exp.exp_desc with match exp.exp_desc with
| Texp_ident _ | Texp_ident _
| Texp_constant _ -> () | Texp_constant _ -> ()
@ -183,11 +184,12 @@ let signature_item sub item =
| Tsig_modtype (_id, _, mdecl) -> | Tsig_modtype (_id, _, mdecl) ->
sub # modtype_declaration mdecl sub # modtype_declaration mdecl
| Tsig_open _ -> () | Tsig_open _ -> ()
| Tsig_include (mty,_) -> sub # module_type mty | Tsig_include (mty,_,_) -> sub # module_type mty
| Tsig_class list -> | Tsig_class list ->
List.iter (sub # class_description) list List.iter (sub # class_description) list
| Tsig_class_type list -> | Tsig_class_type list ->
List.iter (sub # class_type_declaration) list List.iter (sub # class_type_declaration) list
| Tsig_attribute _ -> ()
let modtype_declaration sub mdecl = let modtype_declaration sub mdecl =
match mdecl with match mdecl with

46
tools/untypeast.ml
View File

@ -55,8 +55,8 @@ and untype_structure_item item =
untype_type_declaration name decl) list) untype_type_declaration name decl) list)
| Tstr_exception (_id, name, decl) -> | Tstr_exception (_id, name, decl) ->
Pstr_exception (untype_exception_declaration name decl) Pstr_exception (untype_exception_declaration name decl)
| Tstr_exn_rebind (_id, name, _p, lid) -> | Tstr_exn_rebind (_id, name, _p, lid, attrs) ->
Pstr_exn_rebind (name, lid, []) Pstr_exn_rebind (name, lid, attrs)
| Tstr_module (_id, name, mexpr) -> | Tstr_module (_id, name, mexpr) ->
Pstr_module (Mb.mk name (untype_module_expr mexpr)) Pstr_module (Mb.mk name (untype_module_expr mexpr))
| Tstr_recmodule list -> | Tstr_recmodule list ->
@ -73,7 +73,7 @@ and untype_structure_item item =
| Tstr_modtype (_id, name, mtype) -> | Tstr_modtype (_id, name, mtype) ->
Pstr_modtype {pmtb_name=name; pmtb_type=untype_module_type mtype; Pstr_modtype {pmtb_name=name; pmtb_type=untype_module_type mtype;
pmtb_attributes=[]} pmtb_attributes=[]}
| Tstr_open (_path, lid) -> Pstr_open (lid, []) | Tstr_open (_path, lid, attrs) -> Pstr_open (lid, attrs)
| Tstr_class list -> | Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) -> Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt; { pci_virt = ci.ci_virt;
@ -82,7 +82,7 @@ and untype_structure_item item =
pci_expr = untype_class_expr ci.ci_expr; pci_expr = untype_class_expr ci.ci_expr;
pci_variance = ci.ci_variance; pci_variance = ci.ci_variance;
pci_loc = ci.ci_loc; pci_loc = ci.ci_loc;
pci_attributes = []; pci_attributes = ci.ci_attributes;
} }
) list) ) list)
| Tstr_class_type list -> | Tstr_class_type list ->
@ -94,11 +94,13 @@ and untype_structure_item item =
pci_expr = untype_class_type ct.ci_expr; pci_expr = untype_class_type ct.ci_expr;
pci_variance = ct.ci_variance; pci_variance = ct.ci_variance;
pci_loc = ct.ci_loc; pci_loc = ct.ci_loc;
pci_attributes = []; pci_attributes = ct.ci_attributes;
} }
) list) ) list)
| Tstr_include (mexpr, _) -> | Tstr_include (mexpr, _, attrs) ->
Pstr_include (untype_module_expr mexpr, []) Pstr_include (untype_module_expr mexpr, attrs)
| Tstr_attribute x ->
Pstr_attribute x
in in
{ pstr_desc = desc; pstr_loc = item.str_loc; } { pstr_desc = desc; pstr_loc = item.str_loc; }
@ -108,7 +110,7 @@ and untype_value_description name v =
pval_prim = v.val_prim; pval_prim = v.val_prim;
pval_type = untype_core_type v.val_desc; pval_type = untype_core_type v.val_desc;
pval_loc = v.val_loc; pval_loc = v.val_loc;
pval_attributes = []; pval_attributes = v.val_attributes;
} }
and untype_type_declaration name decl = and untype_type_declaration name decl =
@ -138,7 +140,7 @@ and untype_type_declaration name decl =
None -> None None -> None
| Some ct -> Some (untype_core_type ct)); | Some ct -> Some (untype_core_type ct));
ptype_variance = decl.typ_variance; ptype_variance = decl.typ_variance;
ptype_attributes = []; (* TODO *) ptype_attributes = decl.typ_attributes;
ptype_loc = decl.typ_loc; ptype_loc = decl.typ_loc;
} }
@ -146,15 +148,15 @@ and untype_exception_declaration name decl =
{ {
ped_name = name; ped_name = name;
ped_args = List.map untype_core_type decl.exn_params; ped_args = List.map untype_core_type decl.exn_params;
ped_attributes = []; ped_attributes = decl.exn_attributes;
} }
and untype_pattern pat = and untype_pattern pat =
let desc = let desc =
match pat with match pat with
{ pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name
| { pat_extra=[Tpat_type (_path, lid), _]; _ } -> Ppat_type lid | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type lid
| { pat_extra= (Tpat_constraint ct, _) :: rem; _ } -> | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct) Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct)
| _ -> | _ ->
match pat.pat_desc with 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_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
| Tpat_lazy p -> Ppat_lazy (untype_pattern p) | Tpat_lazy p -> Ppat_lazy (untype_pattern p)
in 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 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 = let desc =
match extra with match extra with
Texp_constraint (cty1, cty2) -> 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_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
| Texp_newtype s -> Pexp_newtype (s, sexp) | Texp_newtype s -> Pexp_newtype (s, sexp)
in in
Exp.mk ~loc desc Exp.mk ~loc ~attrs desc
and untype_expression exp = and untype_expression exp =
let desc = let desc =
@ -309,7 +311,7 @@ and untype_expression exp =
Pexp_pack (untype_module_expr mexpr) Pexp_pack (untype_module_expr mexpr)
in in
List.fold_right untype_extra exp.exp_extra 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 = and untype_package_type pack =
(pack.pack_txt, (pack.pack_txt,
@ -338,12 +340,14 @@ and untype_signature_item item =
pmd_attributes = []}) list) pmd_attributes = []}) list)
| Tsig_modtype (_id, name, mdecl) -> | Tsig_modtype (_id, name, mdecl) ->
Psig_modtype {pmtd_name=name; pmtd_type=untype_modtype_declaration mdecl; pmtd_attributes=[]} Psig_modtype {pmtd_name=name; pmtd_type=untype_modtype_declaration mdecl; pmtd_attributes=[]}
| Tsig_open (_path, lid) -> Psig_open (lid, []) | Tsig_open (_path, lid, attrs) -> Psig_open (lid, attrs)
| Tsig_include (mty, _lid) -> Psig_include (untype_module_type mty, []) | Tsig_include (mty, _lid, attrs) -> Psig_include (untype_module_type mty, attrs)
| Tsig_class list -> | Tsig_class list ->
Psig_class (List.map untype_class_description list) Psig_class (List.map untype_class_description list)
| Tsig_class_type list -> | Tsig_class_type list ->
Psig_class_type (List.map untype_class_type_declaration list) Psig_class_type (List.map untype_class_type_declaration list)
| Tsig_attribute x ->
Psig_attribute x
in in
{ psig_desc = desc; { psig_desc = desc;
psig_loc = item.sig_loc; psig_loc = item.sig_loc;
@ -362,7 +366,7 @@ and untype_class_description cd =
pci_expr = untype_class_type cd.ci_expr; pci_expr = untype_class_type cd.ci_expr;
pci_variance = cd.ci_variance; pci_variance = cd.ci_variance;
pci_loc = cd.ci_loc; pci_loc = cd.ci_loc;
pci_attributes = []; pci_attributes = cd.ci_attributes;
} }
and untype_class_type_declaration cd = 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_expr = untype_class_type cd.ci_expr;
pci_variance = cd.ci_variance; pci_variance = cd.ci_variance;
pci_loc = cd.ci_loc; pci_loc = cd.ci_loc;
pci_attributes = []; pci_attributes = cd.ci_attributes;
} }
and untype_module_type mty = 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_pattern p = { p with pat_env = keep_only_summary p.pat_env }
let leave_expression e = let leave_expression e =
let exp_extra = List.map (function let exp_extra = List.map (function
(Texp_open (path, lloc, env), loc) -> (Texp_open (path, lloc, env), loc, attrs) ->
(Texp_open (path, lloc, keep_only_summary env), loc) (Texp_open (path, lloc, keep_only_summary env), loc, attrs)
| exp_extra -> exp_extra) e.exp_extra in | exp_extra -> exp_extra) e.exp_extra in
{ e with { e with
exp_env = keep_only_summary e.exp_env; 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 = let make_pat desc ty tenv =
{pat_desc = desc; pat_loc = Location.none; pat_extra = []; {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 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 = let rec pretty_val ppf v =
match v.pat_extra with match v.pat_extra with
(cstr,_) :: rem -> (cstr, _loc, _attrs) :: rem ->
begin match cstr with begin match cstr with
| Tpat_unpack -> | Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } 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 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 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 = let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ctyp_loc; line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
let i = i+1 in let i = i+1 in
@ -184,17 +193,21 @@ and core_field_type i ppf x =
and pattern i ppf x = and pattern i ppf x =
line i ppf "pattern %a\n" fmt_location x.pat_loc; line i ppf "pattern %a\n" fmt_location x.pat_loc;
attributes i ppf x.pat_attributes;
let i = i+1 in let i = i+1 in
match x.pat_extra with match x.pat_extra with
| (Tpat_unpack, _) :: rem -> | (Tpat_unpack, _, attrs) :: rem ->
line i ppf "Tpat_unpack\n"; line i ppf "Tpat_unpack\n";
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem } pattern i ppf { x with pat_extra = rem }
| (Tpat_constraint cty, _) :: rem -> | (Tpat_constraint cty, _, attrs) :: rem ->
line i ppf "Tpat_constraint\n"; line i ppf "Tpat_constraint\n";
attributes i ppf attrs;
core_type i ppf cty; core_type i ppf cty;
pattern i ppf { x with pat_extra = rem } 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; line i ppf "Tpat_type %a\n" fmt_path id;
attributes i ppf attrs;
pattern i ppf { x with pat_extra = rem } pattern i ppf { x with pat_extra = rem }
| [] -> | [] ->
match x.pat_desc with match x.pat_desc with
@ -228,24 +241,29 @@ and pattern i ppf x =
line i ppf "Ppat_lazy\n"; line i ppf "Ppat_lazy\n";
pattern i ppf p; pattern i ppf p;
and expression_extra i ppf x = and expression_extra i ppf x attrs =
match x with match x with
| Texp_constraint (cto1, cto2) -> | Texp_constraint (cto1, cto2) ->
line i ppf "Pexp_constraint\n"; line i ppf "Pexp_constraint\n";
attributes i ppf attrs;
option i core_type ppf cto1; option i core_type ppf cto1;
option i core_type ppf cto2; option i core_type ppf cto2;
| Texp_open (m, _, _) -> | Texp_open (m, _, _) ->
line i ppf "Pexp_open \"%a\"\n" fmt_path m; line i ppf "Pexp_open \"%a\"\n" fmt_path m;
attributes i ppf attrs;
| Texp_poly cto -> | Texp_poly cto ->
line i ppf "Pexp_poly\n"; line i ppf "Pexp_poly\n";
attributes i ppf attrs;
option i core_type ppf cto; option i core_type ppf cto;
| Texp_newtype s -> | Texp_newtype s ->
line i ppf "Pexp_newtype \"%s\"\n" s; line i ppf "Pexp_newtype \"%s\"\n" s;
attributes i ppf attrs;
and expression i ppf x = and expression i ppf x =
line i ppf "expression %a\n" fmt_location x.exp_loc; line i ppf "expression %a\n" fmt_location x.exp_loc;
attributes i ppf x.exp_attributes;
let i = 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 (i+1) x.exp_extra
in in
match x.exp_desc with match x.exp_desc with
@ -579,16 +597,22 @@ and signature_item i ppf x =
| Tsig_modtype (s, _, md) -> | Tsig_modtype (s, _, md) ->
line i ppf "Psig_modtype \"%a\"\n" fmt_ident s; line i ppf "Psig_modtype \"%a\"\n" fmt_ident s;
modtype_declaration i ppf md; modtype_declaration i ppf md;
| Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li; | Tsig_open (li,_,attrs) ->
| Tsig_include (mt, _) -> line i ppf "Psig_open %a\n" fmt_path li;
attributes i ppf attrs
| Tsig_include (mt, _, attrs) ->
line i ppf "Psig_include\n"; line i ppf "Psig_include\n";
module_type i ppf mt; module_type i ppf mt;
attributes i ppf attrs
| Tsig_class (l) -> | Tsig_class (l) ->
line i ppf "Psig_class\n"; line i ppf "Psig_class\n";
list i class_description ppf l; list i class_description ppf l;
| Tsig_class_type (l) -> | Tsig_class_type (l) ->
line i ppf "Psig_class_type\n"; line i ppf "Psig_class_type\n";
list i class_type_declaration ppf l; 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 = and modtype_declaration i ppf x =
match x with match x with
@ -657,8 +681,9 @@ and structure_item i ppf x =
| Tstr_exception (s, _, ed) -> | Tstr_exception (s, _, ed) ->
line i ppf "Pstr_exception \"%a\"\n" fmt_ident s; line i ppf "Pstr_exception \"%a\"\n" fmt_ident s;
exception_declaration i ppf ed.exn_params; 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; line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
attributes i ppf attrs
| Tstr_module (s, _, me) -> | Tstr_module (s, _, me) ->
line i ppf "Pstr_module \"%a\"\n" fmt_ident s; line i ppf "Pstr_module \"%a\"\n" fmt_ident s;
module_expr i ppf me; module_expr i ppf me;
@ -668,16 +693,22 @@ and structure_item i ppf x =
| Tstr_modtype (s, _, mt) -> | Tstr_modtype (s, _, mt) ->
line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s; line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s;
module_type i ppf mt; 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) -> | Tstr_class (l) ->
line i ppf "Pstr_class\n"; line i ppf "Pstr_class\n";
list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l);
| Tstr_class_type (l) -> | Tstr_class_type (l) ->
line i ppf "Pstr_class_type\n"; line i ppf "Pstr_class_type\n";
list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
| Tstr_include (me, _) -> | Tstr_include (me, _, attrs) ->
line i ppf "Pstr_include"; 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) = and string_x_type_declaration i ppf (s, _, td) =
ident i ppf s; ident i ppf s;

18
typing/typeclass.ml
View File

@ -51,7 +51,7 @@ exception Error of Location.t * Env.t * error
open Typedtree open Typedtree
let ctyp desc typ env loc = 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 = let cltyp desc typ env loc =
{ cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env } { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env }
let mkcf desc loc = { cf_desc = desc; cf_loc = loc } 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); Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
exp_loc = Location.none; exp_extra = []; exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.instance val_env' vd.val_type; exp_type = Ctype.instance val_env' vd.val_type;
exp_attributes = []; (* check *)
exp_env = val_env'}) exp_env = val_env'})
end end
pv pv
@ -897,6 +898,7 @@ and class_expr cl_num val_env met_env scl =
{exp_desc = Texp_constant (Asttypes.Const_int 1); {exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none; exp_extra = []; exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.none; exp_type = Ctype.none;
exp_attributes = [];
exp_env = Env.empty }] exp_env = Env.empty }]
in in
Ctype.raise_nongen_level (); 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); Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
exp_loc = Location.none; exp_extra = []; exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.instance val_env vd.val_type; exp_type = Ctype.instance val_env vd.val_type;
exp_attributes = [];
exp_env = val_env; exp_env = val_env;
} }
in in
@ -1402,16 +1405,17 @@ let final_decl env define_class
{ ci_variance = cl.pci_variance; { ci_variance = cl.pci_variance;
ci_loc = cl.pci_loc; ci_loc = cl.pci_loc;
ci_virt = cl.pci_virt; 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 *) (* TODO : check that we have the correct use of identifiers *)
ci_id_name = cl.pci_name; ci_id_name = cl.pci_name;
ci_id_class = id; ci_id_class = id;
ci_id_class_type = ty_id; ci_id_class_type = ty_id;
ci_id_object = obj_id; ci_id_object = obj_id;
ci_id_typesharp = cl_id; ci_id_typesharp = cl_id;
ci_expr = expr; ci_expr = expr;
ci_decl = clty; ci_decl = clty;
ci_type_decl = cltydef; ci_type_decl = cltydef;
ci_attributes = cl.pci_attributes;
}) })
(* (cl.pci_variance, cl.pci_loc)) *) (* (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)) newty (Tconstr(Predef.path_option,[ty], ref Mnil))
let mkexp exp_desc exp_type exp_loc exp_env = 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 option_none ty loc =
let lid = Longident.Lident "None" in let lid = Longident.Lident "None" in
@ -503,7 +503,7 @@ let build_or_pat env loc lid =
(l, Reither(true,[], true, ref None)) :: fields (l, Reither(true,[], true, ref None)) :: fields
| Rpresent (Some ty) -> | Rpresent (Some ty) ->
(l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; (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, :: pats,
(l, Reither(false, [ty], true, ref None)) :: fields (l, Reither(false, [ty], true, ref None)) :: fields
| _ -> pats, fields) | _ -> pats, fields)
@ -517,7 +517,7 @@ let build_or_pat env loc lid =
let row' = ref {row with row_more=newvar()} in let row' = ref {row with row_more=newvar()} in
let pats = let pats =
List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; 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 pats
in in
match pats with match pats with
@ -526,7 +526,7 @@ let build_or_pat env loc lid =
let r = let r =
List.fold_left List.fold_left
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; (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 pat pats in
(path, rp { r with pat_loc = loc },ty) (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_desc = Tpat_any;
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_var name -> | Ppat_var name ->
let id = enter_variable loc name expected_ty in 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_desc = Tpat_var (id, name);
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_unpack name -> | Ppat_unpack name ->
let id = enter_variable loc name expected_ty ~is_module:true in let id = enter_variable loc name expected_ty ~is_module:true in
rp { rp {
pat_desc = Tpat_var (id, name); pat_desc = Tpat_var (id, name);
pat_loc = sp.ppat_loc; pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, loc]; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = [];
pat_env = !env } pat_env = !env }
| Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
({ptyp_desc=Ptyp_poly _} as sty)) -> ({ptyp_desc=Ptyp_poly _} as sty)) ->
@ -885,8 +888,9 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
rp { rp {
pat_desc = Tpat_var (id, name); pat_desc = Tpat_var (id, name);
pat_loc = lloc; pat_loc = lloc;
pat_extra = [Tpat_constraint cty, loc]; pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
pat_type = ty; pat_type = ty;
pat_attributes = [];
pat_env = !env pat_env = !env
} }
| _ -> assert false | _ -> 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_desc = Tpat_alias(q, id, name);
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = q.pat_type; pat_type = q.pat_type;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_constant cst -> | Ppat_constant cst ->
unify_pat_types loc !env (type_constant cst) expected_ty; 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_desc = Tpat_constant cst;
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_tuple spl -> | Ppat_tuple spl ->
let spl_ann = List.map (fun p -> (p,newvar ())) spl in 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_desc = Tpat_tuple pl;
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_construct(lid, sarg, explicit_arity) -> | Ppat_construct(lid, sarg, explicit_arity) ->
let opath = 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_desc=Tpat_construct(lid, constr, args,explicit_arity);
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_variant(l, sarg) -> | Ppat_variant(l, sarg) ->
let arg = may_map (fun p -> type_pat p (newvar())) sarg in 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_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_record(lid_sp_list, closed) -> | Ppat_record(lid_sp_list, closed) ->
let opath, record_ty = 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_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_array spl -> | Ppat_array spl ->
let ty_elt = newvar() in 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_desc = Tpat_array pl;
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_or(sp1, sp2) -> | Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in 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_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_lazy sp1 -> | Ppat_lazy sp1 ->
let nv = newvar () in 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_desc = Tpat_lazy p1;
pat_loc = loc; pat_extra=[]; pat_loc = loc; pat_extra=[];
pat_type = expected_ty; pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env } pat_env = !env }
| Ppat_constraint(sp, sty) -> | Ppat_constraint(sp, sty) ->
(* Separate when not already separated by !principal *) (* 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 ty
Printtyp.raw_type_expr p.pat_type;*) Printtyp.raw_type_expr p.pat_type;*)
pattern_force := force :: !pattern_force; pattern_force := force :: !pattern_force;
let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
if separate then if separate then
match p.pat_desc with match p.pat_desc with
Tpat_var (id,s) -> Tpat_var (id,s) ->
{p with pat_type = ty; {p with pat_type = ty;
pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s); pat_desc = Tpat_alias ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
pat_extra = [Tpat_constraint cty, loc]; pat_extra = [extra];
} }
| _ -> {p with pat_type = ty; | _ -> {p with pat_type = ty;
pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra} pat_extra = extra :: p.pat_extra}
else p else p
| Ppat_type lid -> | Ppat_type lid ->
let (path, p,ty) = build_or_pat !env loc lid.txt in let (path, p,ty) = build_or_pat !env loc lid.txt in
unify_pat_types loc !env ty expected_ty; 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) -> | Ppat_extension (s, _arg) ->
raise (Error (loc, !env, Extension s)) 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_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true
| Tstr_value (_, pat_exp_list) -> | Tstr_value (_, pat_exp_list) ->
List.for_all (fun (_, exp) -> is_nonexpansive exp) 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 -> | Tstr_recmodule id_mod_list ->
List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m) List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m)
id_mod_list id_mod_list
| Tstr_exception _ -> false (* true would be unsound *) | Tstr_exception _ -> false (* true would be unsound *)
| Tstr_class _ -> false (* could be more precise *) | Tstr_class _ -> false (* could be more precise *)
| Tstr_attribute _ -> true
) )
str.str_items str.str_items
| Tmod_apply _ -> false | Tmod_apply _ -> false
@ -1838,6 +1853,7 @@ and type_expect_ ?in_function env sexp ty_expected =
end; end;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env desc.val_type; exp_type = instance env desc.val_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
end end
| Pexp_constant(Const_string s as cst) -> | Pexp_constant(Const_string s as cst) ->
@ -1851,12 +1867,14 @@ and type_expect_ ?in_function env sexp ty_expected =
type_format loc s type_format loc s
| _ -> instance_def Predef.type_string | _ -> instance_def Predef.type_string
end; end;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_constant cst -> | Pexp_constant cst ->
rue { rue {
exp_desc = Texp_constant cst; exp_desc = Texp_constant cst;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = type_constant cst; exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat -> | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
type_expect ?in_function env 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_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = body.exp_type; exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_function (l, Some default, [spat, sbody]) -> | Pexp_function (l, Some default, [spat, sbody]) ->
let default_loc = default.pexp_loc in 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_desc = Texp_function(l,cases, partial);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_apply(sfunct, sargs) -> | Pexp_apply(sfunct, sargs) ->
begin_def (); (* one more level for non-returning functions *) 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_desc = Texp_apply(funct, args);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty_res; exp_type = ty_res;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_match(sarg, caselist) -> | Pexp_match(sarg, caselist) ->
begin_def (); begin_def ();
@ -1997,6 +2018,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_match(arg, cases, partial); exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected; exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_try(sbody, caselist) -> | Pexp_try(sbody, caselist) ->
let body = type_expect env sbody ty_expected in 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_desc = Texp_try(body, cases);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = body.exp_type; exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_tuple sexpl -> | Pexp_tuple sexpl ->
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in 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 = []; exp_loc = loc; exp_extra = [];
(* Keep sharing *) (* Keep sharing *)
exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_construct(lid, sarg, explicit_arity) -> | 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) -> | Pexp_variant(l, sarg) ->
(* Keep sharing *) (* Keep sharing *)
let ty_expected0 = instance env ty_expected in 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); re { exp_desc = Texp_variant(l, Some arg);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty_expected0; exp_type = ty_expected0;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| _ -> raise Not_found | _ -> raise Not_found
end end
@ -2052,6 +2077,7 @@ and type_expect_ ?in_function env sexp ty_expected =
row_closed = false; row_closed = false;
row_fixed = false; row_fixed = false;
row_name = None}); row_name = None});
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
end end
| Pexp_record(lid_sexp_list, opt_sexp) -> | 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_desc = Texp_record(lbl_exp_list, opt_exp);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected; exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_field(srecord, lid) -> | Pexp_field(srecord, lid) ->
let (record, label, _) = type_label_access env loc srecord lid in 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_desc = Texp_field(record, lid, label);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty_arg; exp_type = ty_arg;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_setfield(srecord, lid, snewval) -> | Pexp_setfield(srecord, lid, snewval) ->
let (record, label, opath) = type_label_access env loc srecord lid in 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_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit; exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_array(sargl) -> | Pexp_array(sargl) ->
let ty = newgenvar() in let ty = newgenvar() in
@ -2178,6 +2207,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_array argl; exp_desc = Texp_array argl;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected; exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_ifthenelse(scond, sifso, sifnot) -> | Pexp_ifthenelse(scond, sifso, sifnot) ->
let cond = type_expect env scond Predef.type_bool in 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_desc = Texp_ifthenelse(cond, ifso, None);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type; exp_type = ifso.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Some sifnot -> | Some sifnot ->
let ifso = type_expect env sifso ty_expected in 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_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ifso.exp_type; exp_type = ifso.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
end end
| Pexp_sequence(sexp1, sexp2) -> | Pexp_sequence(sexp1, sexp2) ->
@ -2207,6 +2239,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_sequence(exp1, exp2); exp_desc = Texp_sequence(exp1, exp2);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = exp2.exp_type; exp_type = exp2.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_while(scond, sbody) -> | Pexp_while(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in 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_desc = Texp_while(cond, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit; exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_for(param, slow, shigh, dir, sbody) -> | Pexp_for(param, slow, shigh, dir, sbody) ->
let low = type_expect env slow Predef.type_int in 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_desc = Texp_for(id, param, low, high, dir, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit; exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_constraint(sarg, sty, sty') -> | Pexp_constraint(sarg, sty, sty') ->
let separate = true (* always separate, 1% slowdown for lablgtk *) 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_desc = arg.exp_desc;
exp_loc = arg.exp_loc; exp_loc = arg.exp_loc;
exp_type = ty'; exp_type = ty';
exp_attributes = arg.exp_attributes;
exp_env = env; 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) -> | Pexp_when(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in 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_desc = Texp_when(cond, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = body.exp_type; exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_send (e, met) -> | Pexp_send (e, met) ->
if !Clflags.principal then begin_def (); if !Clflags.principal then begin_def ();
@ -2380,17 +2417,20 @@ and type_expect_ ?in_function env sexp ty_expected =
Types.val_loc = Location.none}); Types.val_loc = Location.none});
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = method_type; exp_type = method_type;
exp_attributes = []; (* check *)
exp_env = env}, exp_env = env},
["", ["",
Some {exp_desc = Texp_ident(path, lid, desc); Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = []; exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type; exp_type = desc.val_type;
exp_attributes = []; (* check *)
exp_env = env}, exp_env = env},
Required]) Required])
in in
(Tmeth_name met, Some (re {exp_desc = exp; (Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = typ; exp_type = typ;
exp_attributes = []; (* check *)
exp_env = env}), typ) exp_env = env}), typ)
| _ -> | _ ->
assert false assert false
@ -2425,6 +2465,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_send(obj, meth, exp); exp_desc = Texp_send(obj, meth, exp);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = typ; exp_type = typ;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
with Unify _ -> with Unify _ ->
raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met))) 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_desc = Texp_new (cl_path, cl, cl_decl);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def ty; exp_type = instance_def ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
end end
| Pexp_setinstvar (lab, snewval) -> | 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_desc = Texp_setinstvar(path_self, path, lab, newval);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit; exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Val_ivar _ -> | Val_ivar _ ->
raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt))) 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_desc = Texp_override(path_self, modifs);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = self_ty; exp_type = self_ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| _ -> | _ ->
assert false assert false
@ -2528,6 +2572,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_letmodule(id, name, modl, body); exp_desc = Texp_letmodule(id, name, modl, body);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty; exp_type = ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_assert (e) -> | Pexp_assert (e) ->
let cond = type_expect env e Predef.type_bool in 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_desc = Texp_assert (cond);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit; exp_type = instance_def Predef.type_unit;
exp_attributes = sexp.pexp_attributes;
exp_env = env; exp_env = env;
} }
| Pexp_assertfalse -> | Pexp_assertfalse ->
@ -2542,6 +2588,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_assertfalse; exp_desc = Texp_assertfalse;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected; exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env; exp_env = env;
} }
| Pexp_lazy e -> | Pexp_lazy e ->
@ -2553,6 +2600,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_lazy arg; exp_desc = Texp_lazy arg;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected; exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;
exp_env = env; exp_env = env;
} }
| Pexp_object s -> | Pexp_object s ->
@ -2561,6 +2609,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_desc = Texp_object (desc, (*sign,*) meths); exp_desc = Texp_object (desc, (*sign,*) meths);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = sign.cty_self; exp_type = sign.cty_self;
exp_attributes = sexp.pexp_attributes;
exp_env = env; exp_env = env;
} }
| Pexp_poly(sbody, sty) -> | Pexp_poly(sbody, sty) ->
@ -2602,7 +2651,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp exp
| _ -> assert false | _ -> assert false
in 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) -> | Pexp_newtype(name, sbody) ->
let ty = newvar () in let ty = newvar () in
(* remember original level *) (* 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 (* non-expansive if the body is non-expansive, so we don't introduce
any new extra node in the typed AST. *) any new extra node in the typed AST. *)
rue { body with exp_loc = loc; exp_type = ety; 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 -> | Pexp_pack m ->
let (p, nl, tl) = let (p, nl, tl) =
match Ctype.expand_head env (instance env ty_expected) with 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_desc = Texp_pack modl;
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = newty (Tpackage (p, nl, tl')); exp_type = newty (Tpackage (p, nl, tl'));
exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_open (lid, e) -> | Pexp_open (lid, e) ->
let (path, newenv) = !type_open env sexp.pexp_loc lid in let (path, newenv) = !type_open env sexp.pexp_loc lid in
let exp = type_expect newenv e ty_expected in let exp = type_expect newenv e ty_expected in
{ exp with { 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) -> | Pexp_extension (s, _arg) ->
raise (Error (loc, env, Extension s)) 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 var_pair name ty =
let id = Ident.create name in let id = Ident.create name in
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
pat_attributes = [];
pat_loc = Location.none; pat_env = env}, pat_loc = Location.none; pat_env = env},
{exp_type = ty; exp_loc = Location.none; exp_env = env; {exp_type = ty; exp_loc = Location.none; exp_env = env;
exp_extra = []; exp_extra = []; exp_attributes = [];
exp_desc = exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
{val_type = ty; val_kind = Val_reg; {val_type = ty; val_kind = Val_reg;
@ -3012,7 +3063,7 @@ and type_application env funct sargs =
else else
type_args [] [] ty (instance env ty) ty sargs [] 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 = let opath =
try try
let (p0, p,_) = extract_concrete_variant env ty_expected in 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_desc = Texp_construct(lid, constr, [],explicit_arity);
exp_loc = loc; exp_extra = []; exp_loc = loc; exp_extra = [];
exp_type = ty_res; exp_type = ty_res;
exp_attributes = attrs;
exp_env = env } in exp_env = env } in
if separate then begin if separate then begin
end_def (); end_def ();

8
typing/typedecl.ml
View File

@ -263,6 +263,7 @@ let transl_declaration env sdecl id =
typ_kind = tkind; typ_kind = tkind;
typ_variance = sdecl.ptype_variance; typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private; typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
} in } in
(id, sdecl.ptype_name, tdecl) (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 let types = List.map (fun cty -> cty.ctyp_type) ttypes in
List.iter Ctype.generalize types; List.iter Ctype.generalize types;
let exn_decl = { exn_args = types; Types.exn_loc = loc } in 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 *) (* Translate an exception rebinding *)
let transl_exn_rebind env loc lid = let transl_exn_rebind env loc lid =
@ -919,7 +920,9 @@ let transl_value_decl env loc valdecl =
in in
{ val_desc = cty; val_val = v; { val_desc = cty; val_val = v;
val_prim = valdecl.pval_prim; 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 (* Translate a "with" constraint -- much simplified version of
transl_type_decl. *) transl_type_decl. *)
@ -985,6 +988,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
typ_kind = Ttype_abstract; typ_kind = Ttype_abstract;
typ_variance = sdecl.ptype_variance; typ_variance = sdecl.ptype_variance;
typ_private = sdecl.ptype_private; typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
} }
(* Approximate a type declaration: just make all types abstract *) (* 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 partial = Partial | Total
type optional = Required | Optional type optional = Required | Optional
type attribute = string * Parsetree.expression
type pattern = type pattern =
{ pat_desc: pattern_desc; { pat_desc: pattern_desc;
pat_loc: Location.t; pat_loc: Location.t;
pat_extra : (pat_extra * Location.t) list; pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr; pat_type: type_expr;
mutable pat_env: Env.t } mutable pat_env: Env.t;
pat_attributes: attribute list;
}
and pat_extra = and pat_extra =
| Tpat_constraint of core_type | Tpat_constraint of core_type
@ -52,9 +56,11 @@ and pattern_desc =
and expression = and expression =
{ exp_desc: expression_desc; { exp_desc: expression_desc;
exp_loc: Location.t; 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_type: type_expr;
exp_env: Env.t } exp_env: Env.t;
exp_attributes: attribute list;
}
and exp_extra = and exp_extra =
| Texp_constraint of core_type option * core_type option | Texp_constraint of core_type option * core_type option
@ -114,7 +120,7 @@ and class_expr =
cl_env: Env.t } cl_env: Env.t }
and class_expr_desc = 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_structure of class_structure
| Tcl_fun of | Tcl_fun of
label * pattern * (Ident.t * string loc * expression) list * class_expr * 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_primitive of Ident.t * string loc * value_description
| Tstr_type of (Ident.t * string loc * type_declaration) list | Tstr_type of (Ident.t * string loc * type_declaration) list
| Tstr_exception of Ident.t * string loc * exception_declaration | 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_module of Ident.t * string loc * module_expr
| Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
| Tstr_modtype of Ident.t * string loc * module_type | 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 of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) 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 = and module_coercion =
Tcoerce_none Tcoerce_none
@ -213,8 +220,10 @@ and module_coercion =
and module_type = and module_type =
{ mty_desc: module_type_desc; { mty_desc: module_type_desc;
mty_type : Types.module_type; mty_type : Types.module_type;
mty_env : Env.t; (* BINANNOT ADDED *) mty_env : Env.t;
mty_loc: Location.t } mty_loc: Location.t;
mty_attributes: attribute list;
}
and module_type_desc = and module_type_desc =
Tmty_ident of Path.t * Longident.t loc 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_module of Ident.t * string loc * module_type
| Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_recmodule of (Ident.t * string loc * module_type) list
| Tsig_modtype of Ident.t * string loc * modtype_declaration | Tsig_modtype of Ident.t * string loc * modtype_declaration
| Tsig_open of Path.t * Longident.t loc | Tsig_open of Path.t * Longident.t loc * attribute list
| Tsig_include of module_type * Types.signature | Tsig_include of module_type * Types.signature * attribute list
| Tsig_class of class_description list | Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list | Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
and modtype_declaration = and modtype_declaration =
Tmodtype_abstract Tmodtype_abstract
@ -261,7 +271,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc; { mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr; mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *) ctyp_env : Env.t; (* BINANNOT ADDED *)
ctyp_loc : Location.t } ctyp_loc : Location.t;
ctyp_attributes: attribute list;
}
and core_type_desc = and core_type_desc =
Ttyp_any Ttyp_any
@ -300,6 +312,7 @@ and value_description =
val_val : Types.value_description; val_val : Types.value_description;
val_prim : string list; val_prim : string list;
val_loc : Location.t; val_loc : Location.t;
val_attributes: attribute list;
} }
and type_declaration = and type_declaration =
@ -310,7 +323,9 @@ and type_declaration =
typ_private: private_flag; typ_private: private_flag;
typ_manifest: core_type option; typ_manifest: core_type option;
typ_variance: (bool * bool) list; typ_variance: (bool * bool) list;
typ_loc: Location.t } typ_loc: Location.t;
typ_attributes: attribute list;
}
and type_kind = and type_kind =
Ttype_abstract Ttype_abstract
@ -321,7 +336,9 @@ and type_kind =
and exception_declaration = and exception_declaration =
{ exn_params : core_type list; { exn_params : core_type list;
exn_exn : Types.exception_declaration; exn_exn : Types.exception_declaration;
exn_loc : Location.t } exn_loc : Location.t;
exn_attributes: attribute list;
}
and class_type = and class_type =
{ cltyp_desc: class_type_desc; { cltyp_desc: class_type_desc;
@ -374,7 +391,9 @@ and 'a class_infos =
ci_decl: Types.class_declaration; ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration; ci_type_decl : Types.class_type_declaration;
ci_variance: (bool * bool) list; ci_variance: (bool * bool) list;
ci_loc: Location.t } ci_loc: Location.t;
ci_attributes: attribute list;
}
(* Auxiliary functions over the a.s.t. *) (* Auxiliary functions over the a.s.t. *)

47
typing/typedtree.mli
View File

@ -20,12 +20,16 @@ open Types
type partial = Partial | Total type partial = Partial | Total
type optional = Required | Optional type optional = Required | Optional
type attribute = string * Parsetree.expression
type pattern = type pattern =
{ pat_desc: pattern_desc; { pat_desc: pattern_desc;
pat_loc: Location.t; pat_loc: Location.t;
pat_extra : (pat_extra * Location.t) list; pat_extra : (pat_extra * Location.t * attribute list) list;
pat_type: type_expr; pat_type: type_expr;
mutable pat_env: Env.t } mutable pat_env: Env.t;
pat_attributes: attribute list;
}
and pat_extra = and pat_extra =
| Tpat_constraint of core_type | Tpat_constraint of core_type
@ -51,9 +55,11 @@ and pattern_desc =
and expression = and expression =
{ exp_desc: expression_desc; { exp_desc: expression_desc;
exp_loc: Location.t; 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_type: type_expr;
exp_env: Env.t } exp_env: Env.t;
exp_attributes: attribute list;
}
and exp_extra = and exp_extra =
| Texp_constraint of core_type option * core_type option | 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_primitive of Ident.t * string loc * value_description
| Tstr_type of (Ident.t * string loc * type_declaration) list | Tstr_type of (Ident.t * string loc * type_declaration) list
| Tstr_exception of Ident.t * string loc * exception_declaration | 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_module of Ident.t * string loc * module_expr
| Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
| Tstr_modtype of Ident.t * string loc * module_type | 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 of (class_declaration * string list * virtual_flag) list
| Tstr_class_type of (Ident.t * string loc * class_type_declaration) 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 = and module_coercion =
Tcoerce_none Tcoerce_none
@ -213,7 +220,9 @@ and module_type =
{ mty_desc: module_type_desc; { mty_desc: module_type_desc;
mty_type : Types.module_type; mty_type : Types.module_type;
mty_env : Env.t; mty_env : Env.t;
mty_loc: Location.t } mty_loc: Location.t;
mty_attributes: attribute list;
}
and module_type_desc = and module_type_desc =
Tmty_ident of Path.t * Longident.t loc 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_module of Ident.t * string loc * module_type
| Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_recmodule of (Ident.t * string loc * module_type) list
| Tsig_modtype of Ident.t * string loc * modtype_declaration | Tsig_modtype of Ident.t * string loc * modtype_declaration
| Tsig_open of Path.t * Longident.t loc | Tsig_open of Path.t * Longident.t loc * attribute list
| Tsig_include of module_type * Types.signature | Tsig_include of module_type * Types.signature * attribute list
| Tsig_class of class_description list | Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list | Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
and modtype_declaration = and modtype_declaration =
Tmodtype_abstract Tmodtype_abstract
@ -260,7 +270,9 @@ and core_type =
{ mutable ctyp_desc : core_type_desc; { mutable ctyp_desc : core_type_desc;
mutable ctyp_type : type_expr; mutable ctyp_type : type_expr;
ctyp_env : Env.t; (* BINANNOT ADDED *) ctyp_env : Env.t; (* BINANNOT ADDED *)
ctyp_loc : Location.t } ctyp_loc : Location.t;
ctyp_attributes: attribute list;
}
and core_type_desc = and core_type_desc =
Ttyp_any Ttyp_any
@ -299,6 +311,7 @@ and value_description =
val_val : Types.value_description; val_val : Types.value_description;
val_prim : string list; val_prim : string list;
val_loc : Location.t; val_loc : Location.t;
val_attributes: attribute list;
} }
and type_declaration = and type_declaration =
@ -309,7 +322,9 @@ and type_declaration =
typ_private: private_flag; typ_private: private_flag;
typ_manifest: core_type option; typ_manifest: core_type option;
typ_variance: (bool * bool) list; typ_variance: (bool * bool) list;
typ_loc: Location.t } typ_loc: Location.t;
typ_attributes: attribute list;
}
and type_kind = and type_kind =
Ttype_abstract Ttype_abstract
@ -320,7 +335,9 @@ and type_kind =
and exception_declaration = and exception_declaration =
{ exn_params : core_type list; { exn_params : core_type list;
exn_exn : Types.exception_declaration; exn_exn : Types.exception_declaration;
exn_loc : Location.t } exn_loc : Location.t;
exn_attributes: attribute list;
}
and class_type = and class_type =
{ cltyp_desc: class_type_desc; { cltyp_desc: class_type_desc;
@ -373,7 +390,9 @@ and 'a class_infos =
ci_decl: Types.class_declaration; ci_decl: Types.class_declaration;
ci_type_decl : Types.class_type_declaration; ci_type_decl : Types.class_type_declaration;
ci_variance: (bool * bool) list; ci_variance: (bool * bool) list;
ci_loc: Location.t } ci_loc: Location.t;
ci_attributes: attribute list;
}
(* Auxiliary functions over the a.s.t. *) (* 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 -> | Tstr_type list ->
List.iter (fun (id, _, decl) -> iter_type_declaration decl) list List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
| Tstr_exception (id, _, decl) -> iter_exception_declaration decl | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
| Tstr_exn_rebind (id, _, p, _) -> () | Tstr_exn_rebind _ -> ()
| Tstr_module (id, _, mexpr) -> | Tstr_module (id, _, mexpr) ->
iter_module_expr mexpr iter_module_expr mexpr
| Tstr_recmodule list -> | Tstr_recmodule list ->
@ -154,8 +154,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_class_type ct.ci_expr; iter_class_type ct.ci_expr;
Iter.leave_class_type_declaration ct; Iter.leave_class_type_declaration ct;
) list ) list
| Tstr_include (mexpr, _) -> | Tstr_include (mexpr, _, _attrs) ->
iter_module_expr mexpr iter_module_expr mexpr
| Tstr_attribute _ ->
()
end; end;
Iter.leave_structure_item item Iter.leave_structure_item item
@ -194,7 +196,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
and iter_pattern pat = and iter_pattern pat =
Iter.enter_pattern pat; Iter.enter_pattern pat;
List.iter (fun (cstr, _) -> match cstr with List.iter (fun (cstr, _, _attrs) -> match cstr with
| Tpat_type _ -> () | Tpat_type _ -> ()
| Tpat_unpack -> () | Tpat_unpack -> ()
| Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
@ -225,7 +227,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
and iter_expression exp = and iter_expression exp =
Iter.enter_expression exp; Iter.enter_expression exp;
List.iter (function (cstr, _) -> List.iter (function (cstr, _, _attrs) ->
match cstr with match cstr with
Texp_constraint (cty1, cty2) -> Texp_constraint (cty1, cty2) ->
option iter_core_type cty1; option iter_core_type cty2 option iter_core_type cty1; option iter_core_type cty2
@ -354,11 +356,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tsig_modtype (id, _, mdecl) -> | Tsig_modtype (id, _, mdecl) ->
iter_modtype_declaration mdecl iter_modtype_declaration mdecl
| Tsig_open _ -> () | Tsig_open _ -> ()
| Tsig_include (mty,_) -> iter_module_type mty | Tsig_include (mty, _, _attrs) -> iter_module_type mty
| Tsig_class list -> | Tsig_class list ->
List.iter iter_class_description list List.iter iter_class_description list
| Tsig_class_type list -> | Tsig_class_type list ->
List.iter iter_class_type_declaration list List.iter iter_class_type_declaration list
| Tsig_attribute _ -> ()
end; end;
Iter.leave_signature_item item; 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) (id, name, map_type_declaration decl) ) list)
| Tstr_exception (id, name, decl) -> | Tstr_exception (id, name, decl) ->
Tstr_exception (id, name, map_exception_declaration decl) Tstr_exception (id, name, map_exception_declaration decl)
| Tstr_exn_rebind (id, name, path, lid) -> | Tstr_exn_rebind (id, name, path, lid, attrs) ->
Tstr_exn_rebind (id, name, path, lid) Tstr_exn_rebind (id, name, path, lid, attrs)
| Tstr_module (id, name, mexpr) -> | Tstr_module (id, name, mexpr) ->
Tstr_module (id, name, map_module_expr mexpr) Tstr_module (id, name, map_module_expr mexpr)
| Tstr_recmodule list -> | Tstr_recmodule list ->
@ -121,7 +121,7 @@ module MakeMap(Map : MapArgument) = struct
Tstr_recmodule list Tstr_recmodule list
| Tstr_modtype (id, name, mtype) -> | Tstr_modtype (id, name, mtype) ->
Tstr_modtype (id, name, map_module_type 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 -> | Tstr_class list ->
let list = let list =
List.map (fun (ci, string_list, virtual_flag) -> 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}) (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
) list in ) list in
Tstr_class_type list Tstr_class_type list
| Tstr_include (mexpr, idents) -> | Tstr_include (mexpr, idents, attrs) ->
Tstr_include (map_module_expr mexpr, idents) Tstr_include (map_module_expr mexpr, idents, attrs)
| Tstr_attribute x -> Tstr_attribute x
in in
Map.leave_structure_item { item with str_desc = str_desc} 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 exn_params = List.map map_core_type decl.exn_params in
let decl = { exn_params = exn_params; let decl = { exn_params = exn_params;
exn_exn = decl.exn_exn; 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; Map.leave_exception_declaration decl;
and map_pattern pat = and map_pattern pat =
@ -220,8 +223,8 @@ module MakeMap(Map : MapArgument) = struct
and map_pat_extra pat_extra = and map_pat_extra pat_extra =
match pat_extra with match pat_extra with
| Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) | Tpat_constraint ct, loc, attrs -> (Tpat_constraint (map_core_type ct), loc, attrs)
| (Tpat_type _ | Tpat_unpack), _ -> pat_extra | (Tpat_type _ | Tpat_unpack), _, _ -> pat_extra
and map_expression exp = and map_expression exp =
let exp = Map.enter_expression exp in let exp = Map.enter_expression exp in
@ -349,20 +352,19 @@ module MakeMap(Map : MapArgument) = struct
Map.leave_expression { Map.leave_expression {
exp with exp with
exp_desc = exp_desc; exp_desc = exp_desc;
exp_extra = exp_extra } exp_extra = exp_extra; }
and map_exp_extra exp_extra = and map_exp_extra ((desc, loc, attrs) as exp_extra) =
let loc = snd exp_extra in match desc with
match fst exp_extra with
| Texp_constraint (Some ct, None) -> | 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 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 ct1, Some ct2) ->
Texp_constraint (Some (map_core_type ct1), 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 ct) ->
Texp_poly (Some ( map_core_type ct )), loc Texp_poly (Some ( map_core_type ct )), loc, attrs
| Texp_newtype _ | Texp_newtype _
| Texp_constraint (None, None) | Texp_constraint (None, None)
| Texp_open _ | Texp_open _
@ -401,11 +403,12 @@ module MakeMap(Map : MapArgument) = struct
(id, name, map_module_type mtype) ) list) (id, name, map_module_type mtype) ) list)
| Tsig_modtype (id, name, mdecl) -> | Tsig_modtype (id, name, mdecl) ->
Tsig_modtype (id, name, map_modtype_declaration mdecl) Tsig_modtype (id, name, map_modtype_declaration mdecl)
| Tsig_open (path, lid) -> item.sig_desc | Tsig_open (path, lid, _attrs) -> item.sig_desc
| Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) | 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 list -> Tsig_class (List.map map_class_description list)
| Tsig_class_type list -> | Tsig_class_type list ->
Tsig_class_type (List.map map_class_type_declaration list) Tsig_class_type (List.map map_class_type_declaration list)
| Tsig_attribute _ as x -> x
in in
Map.leave_signature_item { item with sig_desc = sig_desc } 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 let (path, info) = Typetexp.find_modtype env loc lid in
path path
let mkmty desc typ env loc = let mkmty desc typ env loc attrs =
let mty = { let mty = {
mty_desc = desc; mty_desc = desc;
mty_type = typ; mty_type = typ;
mty_loc = loc; mty_loc = loc;
mty_env = env; mty_env = env;
mty_attributes = attrs;
} in } in
Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty);
mty mty
@ -414,15 +415,18 @@ let rec transl_modtype env smty =
Pmty_ident lid -> Pmty_ident lid ->
let path = transl_modtype_longident loc env lid.txt in let path = transl_modtype_longident loc env lid.txt in
mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc
smty.pmty_attributes
| Pmty_signature ssg -> | Pmty_signature ssg ->
let sg = transl_signature env ssg in let sg = transl_signature env ssg in
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
smty.pmty_attributes
| Pmty_functor(param, sarg, sres) -> | Pmty_functor(param, sarg, sres) ->
let arg = transl_modtype env sarg in let arg = transl_modtype env sarg in
let (id, newenv) = Env.enter_module param.txt arg.mty_type env in let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
let res = transl_modtype newenv sres in let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res)) mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, arg.mty_type, res.mty_type)) env loc (Mty_functor(id, arg.mty_type, res.mty_type)) env loc
smty.pmty_attributes
| Pmty_with(sbody, constraints) -> | Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in let body = transl_modtype env sbody in
let init_sg = extract_sig env sbody.pmty_loc body.mty_type 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 ([],init_sg) constraints in
mkmty (Tmty_with ( body, tcstrs)) 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 -> | Pmty_typeof smod ->
let tmty, mty = !type_module_type_of_fwd env smod in 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) -> | Pmty_extension (s, _arg) ->
raise (Error (smty.pmty_loc, env, Extension s)) 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, mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem,
Sig_modtype(id, info) :: rem, Sig_modtype(id, info) :: rem,
final_env final_env
| Psig_open (lid, _attrs) -> | Psig_open (lid, attrs) ->
let (path, newenv) = type_open env item.psig_loc lid in let (path, newenv) = type_open env item.psig_loc lid in
let (trem, rem, final_env) = transl_sig newenv srem in let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env mksig (Tsig_open (path,lid,attrs)) env loc :: trem, rem, final_env
| Psig_include (smty, _attrs) -> | Psig_include (smty, attrs) ->
let tmty = transl_modtype env smty in let tmty = transl_modtype env smty in
let mty = tmty.mty_type in let mty = tmty.mty_type in
let sg = Subst.signature Subst.identity let sg = Subst.signature Subst.identity
@ -527,7 +532,7 @@ and transl_signature env sg =
sg; sg;
let newenv = Env.add_signature sg env in let newenv = Env.add_signature sg env in
let (trem, rem, final_env) = transl_sig newenv srem 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 remove_values (get_values rem) sg @ rem, final_env
| Psig_class cl -> | Psig_class cl ->
List.iter List.iter
@ -571,8 +576,9 @@ and transl_signature env sg =
Sig_type(i'', d'', rs)]) Sig_type(i'', d'', rs)])
classes [rem]), classes [rem]),
final_env final_env
| Psig_attribute _ -> | Psig_attribute x ->
transl_sig env srem let (trem,rem, final_env) = transl_sig env srem in
mksig (Tsig_attribute x) env loc :: trem, rem, final_env
| Psig_extension ((s, _), _) -> | Psig_extension ((s, _), _) ->
raise (Error (loc, env, Extension s)) raise (Error (loc, env, Extension s))
in in
@ -997,10 +1003,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem, (item :: str_rem,
Sig_exception(id, arg.exn_exn) :: sig_rem, Sig_exception(id, arg.exn_exn) :: sig_rem,
final_env) 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 (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
let (id, newenv) = Env.enter_exception name.txt arg env 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 let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem, (item :: str_rem,
Sig_exception(id, arg) :: sig_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, (item :: str_rem,
Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem, Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
final_env) final_env)
| Pstr_open (lid, _attrs) -> | Pstr_open (lid, attrs) ->
let (path, newenv) = type_open ~toplevel env loc lid in 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 let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(item :: str_rem, sig_rem, final_env) (item :: str_rem, sig_rem, final_env)
| Pstr_class cl -> | Pstr_class cl ->
@ -1125,7 +1131,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_type(i'', d'', rs)]) Sig_type(i'', d'', rs)])
classes [sig_rem]), classes [sig_rem]),
final_env) final_env)
| Pstr_include (smodl, _attrs) -> | Pstr_include (smodl, attrs) ->
let modl = type_module true funct_body None env smodl in let modl = type_module true funct_body None env smodl in
(* Rename all identifiers bound by this signature to avoid clashes *) (* Rename all identifiers bound by this signature to avoid clashes *)
let sg = Subst.signature Subst.identity let sg = Subst.signature Subst.identity
@ -1133,15 +1139,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
List.iter List.iter
(check_sig_item type_names module_names modtype_names loc) sg; (check_sig_item type_names module_names modtype_names loc) sg;
let new_env = Env.add_signature sg env in 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 let (str_rem, sig_rem, final_env) = type_struct new_env srem in
(item :: str_rem, (item :: str_rem,
sg @ sig_rem, sg @ sig_rem,
final_env) final_env)
| Pstr_extension ((s, _), _) -> | Pstr_extension ((s, _), _) ->
raise (Error (loc, env, Extension s)) raise (Error (loc, env, Extension s))
| Pstr_attribute _ -> | Pstr_attribute x ->
type_struct env srem let (str_rem, sig_rem, final_env) = type_struct env srem in
mk (Tstr_attribute x) :: str_rem, sig_rem, final_env
in in
if !Clflags.annotations then if !Clflags.annotations then
(* moved to genannot *) (* moved to genannot *)

38
typing/typetexp.ml
View File

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