Skip to content

Commit

Permalink
Make Parsetree more uniform by keeping locations in all records which…
Browse files Browse the repository at this point in the history 
… have attributes.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14659 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information
@alainfrisch
alainfrisch committed Apr 22, 2014
1 parent af3d4aa commit 3b6c0c8
Show file tree
Hide file tree
Showing 15 changed files with 115 additions and 68 deletions.
12 changes: 8 additions & 4 deletions parsing/ast_helper.ml
View file
Expand Up @@ -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

Expand Down Expand Up @@ -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

Expand Down
8 changes: 4 additions & 4 deletions parsing/ast_helper.mli
View file
Expand Up @@ -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


Expand Down Expand Up @@ -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


Expand Down
17 changes: 11 additions & 6 deletions parsing/ast_mapper.ml
View file
Expand Up @@ -13,7 +13,7 @@
(* A generic Parsetree mapping class *)

(*
[@@@warning "+9"]
[@@@ocaml.warning "+9"]
(* Ensure that record patterns don't miss any field. *)
*)

Expand Down Expand Up @@ -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)
);

Expand All @@ -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)
);

Expand Down
25 changes: 15 additions & 10 deletions parsing/parser.mly
View file
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 }
Expand Down Expand Up @@ -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
Expand Down
6 changes: 5 additions & 1 deletion parsing/parsetree.mli
View file
Expand Up @@ -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] *)
Expand Down Expand Up @@ -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 *)
Expand Down Expand Up @@ -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
Expand All @@ -648,6 +650,7 @@ and open_description =
and 'a include_infos =
{
pincl_mod: 'a;
pincl_loc: Location.t;
pincl_attributes: attributes;
}

Expand Down Expand Up @@ -742,6 +745,7 @@ and value_binding =
pvb_pat: pattern;
pvb_expr: expression;
pvb_attributes: attributes;
pvb_loc: Location.t;
}

and module_binding =
Expand Down
4 changes: 3 additions & 1 deletion parsing/pprintast.ml
View file
Expand Up @@ -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) ->
Expand Down
20 changes: 15 additions & 5 deletions tools/untypeast.ml
View file
Expand Up @@ -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;
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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 ->
Expand Down
8 changes: 6 additions & 2 deletions typing/typecore.ml
View file
Expand Up @@ -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
| _ ->
Expand Down Expand Up @@ -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)
Expand Down
5 changes: 3 additions & 2 deletions typing/typedecl.ml
View file
Expand Up @@ -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 =
Expand All @@ -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
Expand All @@ -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
Expand Down
2 changes: 1 addition & 1 deletion typing/typedecl.mli
View file
Expand Up @@ -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 ->
Expand Down

0 comments on commit 3b6c0c8

Please sign in to comment.