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

Represent label and constructor declarations as records in the typedtree. Also keep return type for GADT constructors. 

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

1
parsing/printast.ml
View File

@ -446,6 +446,7 @@ and class_type_field i ppf x =
and class_description i ppf x =
line i ppf "class_description %a\n" fmt_location x.pci_loc;
attributes i ppf x.pci_attributes;
let i = i+1 in
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
line i ppf "pci_params =\n";

4
tools/tast_iter.ml
View File

@ -54,9 +54,9 @@ let type_declaration sub decl =
begin match decl.typ_kind with
| Ttype_abstract -> ()
| Ttype_variant list ->
List.iter (fun (_s, _, cts, _loc) -> List.iter (sub # core_type) cts) list
List.iter (fun cd -> List.iter (sub # core_type) cd.cd_args; opt (sub # core_type) cd.cd_res) list
| Ttype_record list ->
List.iter (fun (_s, _, _mut, ct, _loc) -> sub # core_type ct) list
List.iter (fun ld -> sub # core_type ld.ld_type) list
end;
opt (sub # core_type) decl.typ_manifest

40
tools/untypeast.ml
View File

@ -31,6 +31,8 @@ Some notes:
*)
let option f = function None -> None | Some e -> Some (f e)
let rec lident_of_path path =
match path with
Path.Pident id -> Longident.Lident (Ident.name id)
@ -124,21 +126,19 @@ and untype_type_declaration name decl =
ptype_kind = (match decl.typ_kind with
Ttype_abstract -> Ptype_abstract
| Ttype_variant list ->
Ptype_variant (List.map (fun (_s, name, cts, loc) ->
{pcd_name = name; pcd_args = List.map untype_core_type cts; pcd_res = None; pcd_loc = loc; pcd_attributes = []}) list)
Ptype_variant (List.map (fun cd ->
{pcd_name = cd.cd_name; pcd_args = List.map untype_core_type cd.cd_args; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes}) list)
| Ttype_record list ->
Ptype_record (List.map (fun (_s, name, mut, ct, loc) ->
{pld_name=name;
pld_mutable=mut;
pld_type=untype_core_type ct;
pld_loc=loc;
pld_attributes=[]}
Ptype_record (List.map (fun ld ->
{pld_name=ld.ld_name;
pld_mutable=ld.ld_mutable;
pld_type=untype_core_type ld.ld_type;
pld_loc=ld.ld_loc;
pld_attributes=ld.ld_attributes}
) list)
);
ptype_private = decl.typ_private;
ptype_manifest = (match decl.typ_manifest with
None -> None
| Some ct -> Some (untype_core_type ct));
ptype_manifest = option untype_core_type decl.typ_manifest;
ptype_variance = decl.typ_variance;
ptype_attributes = decl.typ_attributes;
ptype_loc = decl.typ_loc;
@ -185,9 +185,7 @@ and untype_pattern pat =
)
), explicit_arity)
| Tpat_variant (label, pato, _) ->
Ppat_variant (label, match pato with
None -> None
| Some pat -> Some (untype_pattern pat))
Ppat_variant (label, option untype_pattern pato)
| Tpat_record (list, closed) ->
Ppat_record (List.map (fun (lid, _, pat) ->
lid, untype_pattern pat) list, closed)
@ -197,8 +195,6 @@ and untype_pattern pat =
in
Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *)
and option f x = match x with None -> None | Some e -> Some (f e)
and untype_extra (extra, loc, attrs) sexp =
let desc =
match extra with
@ -253,16 +249,12 @@ and untype_expression exp =
(Exp.tuple ~loc:exp.exp_loc (List.map untype_expression args))
), explicit_arity)
| Texp_variant (label, expo) ->
Pexp_variant (label, match expo with
None -> None
| Some exp -> Some (untype_expression exp))
Pexp_variant (label, option untype_expression expo)
| Texp_record (list, expo) ->
Pexp_record (List.map (fun (lid, _, exp) ->
lid, untype_expression exp
) list,
match expo with
None -> None
| Some exp -> Some (untype_expression exp))
option untype_expression expo)
| Texp_field (exp, lid, _label) ->
Pexp_field (untype_expression exp, lid)
| Texp_setfield (exp1, lid, _label, exp2) ->
@ -273,9 +265,7 @@ and untype_expression exp =
| Texp_ifthenelse (exp1, exp2, expo) ->
Pexp_ifthenelse (untype_expression exp1,
untype_expression exp2,
match expo with
None -> None
| Some exp -> Some (untype_expression exp))
option untype_expression expo)
| Texp_sequence (exp1, exp2) ->
Pexp_sequence (untype_expression exp1, untype_expression exp2)
| Texp_while (exp1, exp2) ->

43
typing/printtyped.ml
View File

@ -141,6 +141,7 @@ let attributes i ppf l =
let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
attributes i ppf x.ctyp_attributes;
let i = i+1 in
match x.ctyp_desc with
| Ttyp_any -> line i ppf "Ptyp_any\n";
@ -374,6 +375,7 @@ and expression i ppf x =
and value_description i ppf x =
line i ppf "value_description\n";
attributes i ppf x.val_attributes;
core_type (i+1) ppf x.val_desc;
list (i+1) string ppf x.val_prim;
@ -386,6 +388,7 @@ and string_option_underscore i ppf =
and type_declaration i ppf x =
line i ppf "type_declaration %a\n" fmt_location x.typ_loc;
attributes i ppf x.typ_attributes;
let i = i+1 in
line i ppf "ptype_params =\n";
list (i+1) string_option_underscore ppf x.typ_params;
@ -403,12 +406,15 @@ and type_kind i ppf x =
line i ppf "Ptype_abstract\n"
| Ttype_variant l ->
line i ppf "Ptype_variant\n";
list (i+1) string_x_core_type_list_x_location ppf l;
list (i+1) constructor_decl ppf l;
| Ttype_record l ->
line i ppf "Ptype_record\n";
list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
list (i+1) label_decl ppf l;
and exception_declaration i ppf x = list i core_type ppf x
and exception_declaration i ppf x =
(* string_loc i ppf x.ped_name; *)
attributes i ppf x.exn_attributes;
list i core_type ppf x.exn_params
and class_type i ppf x =
line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
@ -456,6 +462,7 @@ and class_type_field i ppf x =
and class_description i ppf x =
line i ppf "class_description %a\n" fmt_location x.ci_loc;
attributes i ppf x.ci_attributes;
let i = i+1 in
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
line i ppf "pci_params =\n";
@ -555,6 +562,7 @@ and class_declaration i ppf x =
and module_type i ppf x =
line i ppf "module_type %a\n" fmt_location x.mty_loc;
attributes i ppf x.mty_attributes;
let i = i+1 in
match x.mty_desc with
| Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li;
@ -587,7 +595,7 @@ and signature_item i ppf x =
list i string_x_type_declaration ppf l;
| Tsig_exception (s, _, ed) ->
line i ppf "Psig_exception \"%a\"\n" fmt_ident s;
exception_declaration i ppf ed.exn_params;
exception_declaration i ppf ed;
| Tsig_module (s, _, mt) ->
line i ppf "Psig_module \"%a\"\n" fmt_ident s;
module_type i ppf mt;
@ -602,8 +610,8 @@ and signature_item i ppf x =
attributes i ppf attrs
| Tsig_include (mt, _, attrs) ->
line i ppf "Psig_include\n";
module_type i ppf mt;
attributes i ppf attrs
attributes i ppf attrs;
module_type i ppf mt
| Tsig_class (l) ->
line i ppf "Psig_class\n";
list i class_description ppf l;
@ -680,7 +688,7 @@ and structure_item i ppf x =
list i string_x_type_declaration ppf l;
| Tstr_exception (s, _, ed) ->
line i ppf "Pstr_exception \"%a\"\n" fmt_ident s;
exception_declaration i ppf ed.exn_params;
exception_declaration i ppf ed;
| Tstr_exn_rebind (s, _, li, _, attrs) ->
line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
attributes i ppf attrs
@ -704,8 +712,8 @@ and structure_item i ppf x =
list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
| Tstr_include (me, _, attrs) ->
line i ppf "Pstr_include";
attributes i ppf attrs;
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
@ -732,14 +740,19 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) =
line i ppf "\"%a\"\n" fmt_ident s;
list (i+1) core_type ppf l;
(* option (i+1) core_type ppf r_opt; *)
and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} =
line i ppf "%a\n" fmt_location cd_loc;
attributes i ppf cd_attributes;
line (i+1) ppf "%a\n" fmt_ident cd_id;
list (i+1) core_type ppf cd_args;
option (i+1) core_type ppf cd_res
and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) =
line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc;
core_type (i+1) ppf ct;
and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} =
line i ppf "%a\n" fmt_location ld_loc;
attributes i ppf ld_attributes;
line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
line (i+1) ppf "%a" fmt_ident ld_id;
core_type (i+1) ppf ld_type
and string_list_x_location i ppf (l, loc) =
line i ppf "<params> %a\n" fmt_location loc;

28
typing/typedecl.ml
View File

@ -159,19 +159,19 @@ let transl_declaration env sdecl id =
(List.filter (fun cd -> cd.pcd_args <> []) cstrs)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc} =
let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
let name = Ident.create lid.txt in
match ret_type with
| None ->
(name, lid, List.map (transl_simple_type env true) args, None, loc)
(name, lid, List.map (transl_simple_type env true) args, None, None, loc, attrs)
| Some sty ->
(* if it's a generalized constructor we must first narrow and
then widen so as to not introduce any new constraints *)
let z = narrow () in
reset_type_variables ();
let args = List.map (transl_simple_type env false) args in
let cty = transl_simple_type env false sty in
let ret_type =
let cty = transl_simple_type env false sty in
let ty = cty.ctyp_type in
let p = Path.Pident id in
match (Ctype.repr ty).desc with
@ -181,13 +181,14 @@ let transl_declaration env sdecl id =
(ty, Ctype.newconstr p params)))
in
widen z;
(name, lid, args, Some ret_type, loc)
(name, lid, args, Some cty, Some ret_type, loc, attrs)
in
let cstrs = List.map make_cstr cstrs in
Ttype_variant (List.map (fun (name, lid, ctys, _, loc) ->
name, lid, ctys, loc
Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs) ->
{cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res;
cd_loc = loc; cd_attributes = attrs}
) cstrs),
Type_variant (List.map (fun (name, name_loc, ctys, option, loc) ->
Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, _attrs) ->
name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs)
| Ptype_record lbls ->
@ -198,15 +199,16 @@ let transl_declaration env sdecl id =
raise(Error(sdecl.ptype_loc, Duplicate_label name));
all_labels := StringSet.add name !all_labels)
lbls;
let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc} ->
let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} ->
let cty = transl_simple_type env true arg in
(Ident.create name.txt, name, mut, cty, loc)
) lbls in
{ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty;
ld_loc = loc; ld_attributes = attrs}
) lbls in
let lbls' =
List.map
(fun (name, name_loc, mut, cty, loc) ->
let ty = cty.ctyp_type in
name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
(fun ld ->
let ty = ld.ld_type.ctyp_type in
ld.ld_id, ld.ld_mutable, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
lbls in
let rep =
if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls'

25
typing/typedtree.ml
View File

@ -329,9 +329,28 @@ and type_declaration =
and type_kind =
Ttype_abstract
| Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
| Ttype_record of
(Ident.t * string loc * mutable_flag * core_type * Location.t) list
| Ttype_variant of constructor_declaration list
| Ttype_record of label_declaration list
and label_declaration =
{
ld_id: Ident.t;
ld_name: string loc;
ld_mutable: mutable_flag;
ld_type: core_type;
ld_loc: Location.t;
ld_attributes: attribute list;
}
and constructor_declaration =
{
cd_id: Ident.t;
cd_name: string loc;
cd_args: core_type list;
cd_res: core_type option;
cd_loc: Location.t;
cd_attributes: attribute list;
}
and exception_declaration =
{ exn_params : core_type list;

25
typing/typedtree.mli
View File

@ -328,9 +328,28 @@ and type_declaration =
and type_kind =
Ttype_abstract
| Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
| Ttype_record of
(Ident.t * string loc * mutable_flag * core_type * Location.t) list
| Ttype_variant of constructor_declaration list
| Ttype_record of label_declaration list
and label_declaration =
{
ld_id: Ident.t;
ld_name: string loc;
ld_mutable: mutable_flag;
ld_type: core_type;
ld_loc: Location.t;
ld_attributes: attribute list;
}
and constructor_declaration =
{
cd_id: Ident.t;
cd_name: string loc;
cd_args: core_type list;
cd_res: core_type option;
cd_loc: Location.t;
cd_attributes: attribute list;
}
and exception_declaration =
{ exn_params : core_type list;

13
typing/typedtreeIter.ml
View File

@ -175,12 +175,15 @@ module MakeIterator(Iter : IteratorArgument) : sig
begin match decl.typ_kind with
Ttype_abstract -> ()
| Ttype_variant list ->
List.iter (fun (s, _, cts, loc) ->
List.iter iter_core_type cts
) list
List.iter
(fun cd ->
List.iter iter_core_type cd.cd_args;
option iter_core_type cd.cd_res;
) list
| Ttype_record list ->
List.iter (fun (s, _, mut, ct, loc) ->
iter_core_type ct
List.iter
(fun ld ->
iter_core_type ld.ld_type
) list
end;
begin match decl.typ_manifest with

21
typing/typedtreeMap.ml
View File

@ -160,15 +160,22 @@ module MakeMap(Map : MapArgument) = struct
let typ_kind = match decl.typ_kind with
Ttype_abstract -> Ttype_abstract
| Ttype_variant list ->
let list = List.map (fun (s, name, cts, loc) ->
(s, name, List.map map_core_type cts, loc)
) list in
Ttype_variant list
let list =
List.map
(fun cd ->
{cd with cd_args = List.map map_core_type cd.cd_args;
cd_res = may_map map_core_type cd.cd_res
}
) list
in
Ttype_variant list
| Ttype_record list ->
let list =
List.map (fun (s, name, mut, ct, loc) ->
(s, name, mut, map_core_type ct, loc)
) list in
List.map
(fun ld ->
{ld with ld_type = map_core_type ld.ld_type}
) list
in
Ttype_record list
in
let typ_manifest =