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

Make Parsetree more uniform by keeping locations in all records which have attributes. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14659 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-04-22 15:28:20 +00:00
parent af3d4aa91f
commit 3b6c0c88a5
15 changed files with 115 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
parsing/ast_helper.ml
View File

@ -300,28 +300,31 @@ module Mb = struct
end
module Opn = struct
let mk ?(attrs = []) ?(override = Fresh) lid =
let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid =
{
popen_lid = lid;
popen_override = override;
popen_loc = loc;
popen_attributes = attrs;
}
end
module Incl = struct
let mk ?(attrs = []) mexpr =
let mk ?(loc = !default_loc) ?(attrs = []) mexpr =
{
pincl_mod = mexpr;
pincl_loc = loc;
pincl_attributes = attrs;
}
end
module Vb = struct
let mk ?(attrs = []) pat expr =
let mk ?(loc = !default_loc) ?(attrs = []) pat expr =
{
pvb_pat = pat;
pvb_expr = expr;
pvb_attributes = attrs;
pvb_loc = loc;
}
end
@ -393,11 +396,12 @@ module Cstr = struct
end
module Exrb = struct
let mk ?(attrs = []) name lid =
let mk ?(loc = !default_loc) ?(attrs = []) name lid =
{
pexrb_name = name;
pexrb_lid = lid;
pexrb_attributes = attrs;
pexrb_loc = loc;
}
end

8
parsing/ast_helper.mli
View File

@ -241,20 +241,20 @@ module Mb:
(* Opens *)
module Opn:
sig
val mk: ?attrs:attrs -> ?override:override_flag -> lid -> open_description
val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description
end
(* Includes *)
module Incl:
sig
val mk: ?attrs:attrs -> 'a -> 'a include_infos
val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos
end
(** Value bindings *)
module Vb:
sig
val mk: ?attrs:attrs -> pattern -> expression -> value_binding
val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding
end
@ -338,7 +338,7 @@ module Cstr:
(** Exception rebinding *)
module Exrb:
sig
val mk: ?attrs:attrs -> str -> lid -> exception_rebind
val mk: ?loc:loc -> ?attrs:attrs -> str -> lid -> exception_rebind
end

17
parsing/ast_mapper.ml
View File

@ -13,7 +13,7 @@
(* A generic Parsetree mapping class *)
(*
[@@@warning "+9"]
[@@@ocaml.warning "+9"]
(* Ensure that record patterns don't miss any field. *)
*)
@ -495,31 +495,35 @@ let default_mapper =
open_description =
(fun this {popen_lid; popen_override; popen_attributes} ->
(fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
Opn.mk (map_loc this popen_lid)
~override:popen_override
~loc:(this.location this popen_loc)
~attrs:(this.attributes this popen_attributes)
);
include_description =
(fun this {pincl_mod; pincl_attributes} ->
(fun this {pincl_mod; pincl_attributes; pincl_loc} ->
Incl.mk (this.module_type this pincl_mod)
~loc:(this.location this pincl_loc)
~attrs:(this.attributes this pincl_attributes)
);
include_declaration =
(fun this {pincl_mod; pincl_attributes} ->
(fun this {pincl_mod; pincl_attributes; pincl_loc} ->
Incl.mk (this.module_expr this pincl_mod)
~loc:(this.location this pincl_loc)
~attrs:(this.attributes this pincl_attributes)
);
value_binding =
(fun this {pvb_pat; pvb_expr; pvb_attributes} ->
(fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} ->
Vb.mk
(this.pat this pvb_pat)
(this.expr this pvb_expr)
~loc:(this.location this pvb_loc)
~attrs:(this.attributes this pvb_attributes)
);
@ -545,10 +549,11 @@ let default_mapper =
);
exception_rebind =
(fun this {pexrb_name; pexrb_lid; pexrb_attributes} ->
(fun this {pexrb_name; pexrb_lid; pexrb_attributes; pexrb_loc} ->
Exrb.mk
(map_loc this pexrb_name)
(map_loc this pexrb_lid)
~loc:(this.location this pexrb_loc)
~attrs:(this.attributes this pexrb_attributes)
);

25
parsing/parser.mly
View File

@ -640,8 +640,9 @@ structure_item:
| EXCEPTION exception_declaration
{ mkstr(Pstr_exception $2) }
| EXCEPTION UIDENT EQUAL constr_longident post_item_attributes
{ mkstr (Pstr_exn_rebind (Exrb.mk (mkrhs $2 2)
(mkloc $4 (rhs_loc 4)) ~attrs:$5)) }
{ mkstr (Pstr_exn_rebind
(Exrb.mk (mkrhs $2 2)
(mkloc $4 (rhs_loc 4)) ~attrs:$5 ~loc:(symbol_rloc()))) }
| MODULE module_binding
{ mkstr(Pstr_module $2) }
| MODULE REC module_bindings
@ -652,14 +653,13 @@ structure_item:
| MODULE TYPE ident EQUAL module_type post_item_attributes
{ mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3)
~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) }
| OPEN override_flag mod_longident post_item_attributes
{ mkstr(Pstr_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
| open_statement { mkstr(Pstr_open $1) }
| CLASS class_declarations
{ mkstr(Pstr_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
{ mkstr(Pstr_class_type (List.rev $3)) }
| INCLUDE module_expr post_item_attributes
{ mkstr(Pstr_include (Incl.mk $2 ~attrs:$3)) }
{ mkstr(Pstr_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) }
| item_extension post_item_attributes
{ mkstr(Pstr_extension ($1, $2)) }
| floating_attribute
@ -746,10 +746,10 @@ signature_item:
{ mksig(Psig_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5
~loc:(symbol_rloc())
~attrs:$6)) }
| OPEN override_flag mod_longident post_item_attributes
{ mksig(Psig_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
| open_statement
{ mksig(Psig_open $1) }
| INCLUDE module_type post_item_attributes %prec below_WITH
{ mksig(Psig_include (Incl.mk $2 ~attrs:$3)) }
{ mksig(Psig_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) }
| CLASS class_descriptions
{ mksig(Psig_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
@ -759,7 +759,10 @@ signature_item:
| floating_attribute
{ mksig(Psig_attribute $1) }
;
open_statement:
| OPEN override_flag mod_longident post_item_attributes
{ Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 ~loc:(symbol_rloc()) }
;
module_declaration:
COLON module_type
{ $2 }
@ -1309,7 +1312,9 @@ lident_list:
| LIDENT lident_list { $1 :: $2 }
;
let_binding:
let_binding_ post_item_attributes { let (p, e) = $1 in Vb.mk ~attrs:$2 p e }
let_binding_ post_item_attributes {
let (p, e) = $1 in Vb.mk ~loc:(symbol_rloc()) ~attrs:$2 p e
}
;
let_binding_:
val_ident fun_binding

6
parsing/parsetree.mli
View File

@ -297,7 +297,7 @@ and expression_desc =
Pexp_constraint(Pexp_pack, Ptyp_package S) *)
| Pexp_open of override_flag * Longident.t loc * expression
(* let open M in E
let! open M in E
let! open M in E
*)
| Pexp_extension of extension
(* [%id] *)
@ -390,6 +390,7 @@ and exception_rebind =
{
pexrb_name: string loc;
pexrb_lid: Longident.t loc;
pexrb_loc: Location.t;
pexrb_attributes: attributes;
}
(* exception C = M.X *)
@ -638,6 +639,7 @@ and open_description =
{
popen_lid: Longident.t loc;
popen_override: override_flag;
popen_loc: Location.t;
popen_attributes: attributes;
}
(* open! X - popen_override = Override (silences the 'used identifier
@ -648,6 +650,7 @@ and open_description =
and 'a include_infos =
{
pincl_mod: 'a;
pincl_loc: Location.t;
pincl_attributes: attributes;
}
@ -742,6 +745,7 @@ and value_binding =
pvb_pat: pattern;
pvb_expr: expression;
pvb_attributes: attributes;
pvb_loc: Location.t;
}
and module_binding =

4
parsing/pprintast.ml
View File

@ -793,7 +793,9 @@ class printer ()= object(self:'self)
| Pexp_poly (e,None) ->
self#binding f {pvb_pat={ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
pvb_expr=e;
pvb_attributes=[]}
pvb_attributes=[];
pvb_loc=Location.none;
}
| _ ->
self#expression f e ) e
| Pcf_constraint (ct1, ct2) ->

20
tools/untypeast.ml
View File

@ -67,7 +67,9 @@ and untype_structure_item item =
pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;}
| Tstr_open od ->
Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override;
popen_attributes = od.open_attributes}
popen_attributes = od.open_attributes;
popen_loc = od.open_loc;
}
| Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt;
@ -91,7 +93,9 @@ and untype_structure_item item =
) list)
| Tstr_include incl ->
Pstr_include {pincl_mod = untype_module_expr incl.incl_mod;
pincl_attributes = incl.incl_attributes}
pincl_attributes = incl.incl_attributes;
pincl_loc = incl.incl_loc;
}
| Tstr_attribute x ->
Pstr_attribute x
in
@ -155,6 +159,7 @@ and untype_exception_rebind er =
pexrb_name = er.exrb_name;
pexrb_lid = er.exrb_txt;
pexrb_attributes = er.exrb_attributes;
pexrb_loc = er.exrb_loc;
}
and untype_pattern pat =
@ -229,11 +234,12 @@ and untype_case {c_lhs; c_guard; c_rhs} =
pc_rhs = untype_expression c_rhs;
}
and untype_binding {vb_pat; vb_expr; vb_attributes} =
and untype_binding {vb_pat; vb_expr; vb_attributes; vb_loc} =
{
pvb_pat = untype_pattern vb_pat;
pvb_expr = untype_expression vb_expr;
pvb_attributes = vb_attributes;
pvb_loc = vb_loc;
}
and untype_expression exp =
@ -358,10 +364,14 @@ and untype_signature_item item =
| Tsig_open od ->
Psig_open {popen_lid = od.open_txt;
popen_override = od.open_override;
popen_attributes = od.open_attributes}
popen_attributes = od.open_attributes;
popen_loc = od.open_loc;
}
| Tsig_include incl ->
Psig_include {pincl_mod = untype_module_type incl.incl_mod;
pincl_attributes = incl.incl_attributes}
pincl_attributes = incl.incl_attributes;
pincl_loc = incl.incl_loc;
}
| Tsig_class list ->
Psig_class (List.map untype_class_description list)
| Tsig_class_type list ->

8
typing/typecore.ml
View File

@ -3035,7 +3035,9 @@ and type_argument env sarg ty_expected' ty_expected =
let let_pat, let_var = var_pair "arg" texp.exp_type in
re { texp with exp_type = ty_fun; exp_desc =
Texp_let (Nonrecursive,
[{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}],
[{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
vb_loc=Location.none;
}],
func let_var) }
end
| _ ->
@ -3627,7 +3629,9 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let l =
List.map2
(fun (p, e) pvb ->
{vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes})
{vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
vb_loc=pvb.pvb_loc;
})
l spat_sexp_list
in
(l, new_env, unpacks)

5
typing/typedecl.ml
View File

@ -1049,7 +1049,7 @@ let transl_exception env excdecl =
cd, exn_decl, newenv
(* Translate an exception rebinding *)
let transl_exn_rebind env loc ser =
let transl_exn_rebind env ser =
let name = ser.pexrb_name in
let lid = ser.pexrb_lid in
let cdescr =
@ -1067,7 +1067,7 @@ let transl_exn_rebind env loc ser =
{
exn_args = cdescr.cstr_args;
exn_attributes = [];
Types.exn_loc = loc
Types.exn_loc = ser.pexrb_loc;
}
in
let (id, newenv) = Env.enter_exception name.txt exn_decl env in
@ -1078,6 +1078,7 @@ let transl_exn_rebind env loc ser =
exrb_txt = lid;
exrb_type = exn_decl;
exrb_attributes = ser.pexrb_attributes;
exrb_loc = ser.pexrb_loc;
}
in
er, newenv

2
typing/typedecl.mli
View File

@ -24,7 +24,7 @@ val transl_exception:
Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t
val transl_exn_rebind:
Env.t -> Location.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t
Env.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t
val transl_value_decl:
Env.t -> Location.t ->

4
typing/typedtree.ml
View File

@ -235,6 +235,7 @@ and value_binding =
vb_pat: pattern;
vb_expr: expression;
vb_attributes: attributes;
vb_loc: Location.t;
}
and module_coercion =
@ -308,6 +309,7 @@ and open_description =
open_path: Path.t;
open_txt: Longident.t loc;
open_override: override_flag;
open_loc: Location.t;
open_attributes: attribute list;
}
@ -315,6 +317,7 @@ and 'a include_infos =
{
incl_mod: 'a;
incl_type: Types.signature;
incl_loc: Location.t;
incl_attributes: attribute list;
}
@ -416,6 +419,7 @@ and exception_rebind =
exrb_path: Path.t;
exrb_txt: Longident.t loc;
exrb_type: Types.exception_declaration;
exrb_loc: Location.t;
exrb_attributes: attribute list;
}

4
typing/typedtree.mli
View File

@ -234,6 +234,7 @@ and value_binding =
vb_pat: pattern;
vb_expr: expression;
vb_attributes: attributes;
vb_loc: Location.t;
}
and module_coercion =
@ -307,6 +308,7 @@ and open_description =
open_path: Path.t;
open_txt: Longident.t loc;
open_override: override_flag;
open_loc: Location.t;
open_attributes: attribute list;
}
@ -314,6 +316,7 @@ and 'a include_infos =
{
incl_mod: 'a;
incl_type: Types.signature;
incl_loc: Location.t;
incl_attributes: attribute list;
}
@ -416,6 +419,7 @@ and exception_rebind =
exrb_path: Path.t;
exrb_txt: Longident.t loc;
exrb_type: Types.exception_declaration;
exrb_loc: Location.t;
exrb_attributes: attribute list;
}

1
typing/typedtreeMap.ml
View File

@ -86,6 +86,7 @@ module MakeMap(Map : MapArgument) = struct
vb_pat = map_pattern vb.vb_pat;
vb_expr = map_expression vb.vb_expr;
vb_attributes = vb.vb_attributes;
vb_loc = vb.vb_loc;
}
and map_bindings rec_flag list =

61
typing/typemod.ml
View File

@ -67,12 +67,27 @@ let extract_sig_open env loc mty =
(* Compute the environment after opening a module *)
let type_open ?toplevel ovf env loc lid =
let path = Typetexp.find_module env loc lid.txt in
let type_open_ ?toplevel ovf env loc lid =
let path = Typetexp.find_module env lid.loc lid.txt in
let md = Env.find_module path env in
let sg = extract_sig_open env loc md.md_type in
let sg = extract_sig_open env lid.loc md.md_type in
path, Env.open_signature ~loc ?toplevel ovf path sg env
let type_open ?toplevel env sod =
let (path, newenv) =
type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid
in
let od =
{
open_override = sod.popen_override;
open_path = path;
open_txt = sod.popen_lid;
open_attributes = sod.popen_attributes;
open_loc = sod.popen_loc;
}
in
(path, newenv, od)
(* Record a module type *)
let rm node =
Stypes.record (Stypes.Ti_mod node);
@ -362,9 +377,7 @@ and approx_sig env ssg =
let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
Sig_modtype(id, info) :: approx_sig newenv srem
| Psig_open sod ->
let (path, mty) =
type_open sod.popen_override env item.psig_loc sod.popen_lid
in
let (path, mty, _od) = type_open env sod in
approx_sig mty srem
| Psig_include sincl ->
let smty = sincl.pincl_mod in
@ -602,17 +615,7 @@ and transl_signature env sg =
sg :: rem,
final_env
| Psig_open sod ->
let (path, newenv) =
type_open sod.popen_override env item.psig_loc sod.popen_lid
in
let od =
{
open_override = sod.popen_override;
open_path = path;
open_txt = sod.popen_lid;
open_attributes = sod.popen_attributes;
}
in
let (path, newenv, od) = type_open env sod in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_open od) env loc :: trem,
rem, final_env
@ -630,7 +633,9 @@ and transl_signature env sg =
let incl =
{ incl_mod = tmty;
incl_type = sg;
incl_attributes = sincl.pincl_attributes }
incl_attributes = sincl.pincl_attributes;
incl_loc = sincl.pincl_loc;
}
in
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_include incl) env loc :: trem,
@ -1175,7 +1180,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
Tstr_exception arg, [Sig_exception(arg.cd_id, decl)], newenv
| Pstr_exn_rebind ser ->
let (er, newenv) = Typedecl.transl_exn_rebind env loc ser in
let (er, newenv) = Typedecl.transl_exn_rebind env ser in
Tstr_exn_rebind er,
[Sig_exception(er.exrb_id, er.exrb_type)],
newenv
@ -1261,17 +1266,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
in
Tstr_modtype mtd, [sg], newenv
| Pstr_open sod ->
let (path, newenv) =
type_open sod.popen_override ~toplevel env loc sod.popen_lid
in
let od =
{
open_override = sod.popen_override;
open_path = path;
open_txt = sod.popen_lid;
open_attributes = sod.popen_attributes;
}
in
let (path, newenv, od) = type_open ~toplevel env sod in
Tstr_open od, [], newenv
| Pstr_class cl ->
List.iter
@ -1354,7 +1349,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let incl =
{ incl_mod = modl;
incl_type = sg;
incl_attributes = sincl.pincl_attributes }
incl_attributes = sincl.pincl_attributes;
incl_loc = sincl.pincl_loc;
}
in
Tstr_include incl, sg, new_env
| Pstr_extension ((s, _), _) ->
@ -1518,7 +1515,7 @@ let () =
Typecore.type_module := type_module;
Typetexp.transl_modtype_longident := transl_modtype_longident;
Typetexp.transl_modtype := transl_modtype;
Typecore.type_open := type_open ?toplevel:None;
Typecore.type_open := type_open_ ?toplevel:None;
Typecore.type_package := type_package;
type_module_type_of_fwd := type_module_type_of

6
typing/typetexp.ml
View File

@ -333,6 +333,12 @@ let rec transl_type env policy styp =
ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
let (path, decl) = find_type env styp.ptyp_loc lid.txt in
let stl =
match stl with
| [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
List.map (fun _ -> t) decl.type_params
| _ -> stl
in
if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env,
Type_arity_mismatch(lid.txt, decl.type_arity,