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

Keep item attributes on let-binding structure items. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13511 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-04-11 13:52:06 +00:00
parent 8a9188eb3f
commit 92ad47d47b
27 changed files with 57 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
bytecomp/translmod.ml
View File

@ -286,7 +286,7 @@ and transl_structure fields cc rootpath = function
match item.str_desc with
| Tstr_eval expr ->
Lsequence(transl_exp expr, transl_structure fields cc rootpath rem)
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
transl_let rec_flag pat_expr_list
(transl_structure ext_fields cc rootpath rem)
@ -365,7 +365,7 @@ let rec defined_idents = function
| item :: rem ->
match item.str_desc with
| Tstr_eval expr -> defined_idents rem
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
let_bound_idents pat_expr_list @ defined_idents rem
| Tstr_primitive desc -> defined_idents rem
| Tstr_type decls -> defined_idents rem
@ -388,7 +388,7 @@ let rec more_idents = function
| item :: rem ->
match item.str_desc with
| Tstr_eval expr -> more_idents rem
| Tstr_value(rec_flag, pat_expr_list) -> more_idents rem
| Tstr_value(rec_flag, pat_expr_list, _attrs) -> more_idents rem
| Tstr_primitive _ -> more_idents rem
| Tstr_type decls -> more_idents rem
| Tstr_exception _ -> more_idents rem
@ -409,7 +409,7 @@ and all_idents = function
| item :: rem ->
match item.str_desc with
| Tstr_eval expr -> all_idents rem
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
let_bound_idents pat_expr_list @ all_idents rem
| Tstr_primitive _ -> all_idents rem
| Tstr_type decls -> all_idents rem
@ -459,7 +459,7 @@ let transl_store_structure glob map prims str =
| Tstr_eval expr ->
Lsequence(subst_lambda subst (transl_exp expr),
transl_store rootpath subst rem)
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
let ids = let_bound_idents pat_expr_list in
let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
Lsequence(subst_lambda subst lam,
@ -672,7 +672,7 @@ let transl_toplevel_item item =
match item.str_desc with
Tstr_eval expr ->
transl_exp expr
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
let idents = let_bound_idents pat_expr_list in
transl_let rec_flag pat_expr_list
(make_sequence toploop_setvalue_id idents)

2
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -1085,7 +1085,7 @@ value varify_constructors var_names =
[mkstr loc (Pstr_open (long_uident id, [])) :: l]
| StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]
| StVal loc rf bi ->
[mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l]
[mkstr loc (Pstr_value (mkrf rf) (binding bi []) []) :: l]
| <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ]
and class_type =
fun

2
camlp4/boot/Camlp4.ml
View File

@ -15471,7 +15471,7 @@ module Struct =
| StTyp (loc, tdl) ->
(mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
| StVal (loc, rf, bi) ->
(mkstr loc (Pstr_value ((mkrf rf), (binding bi [])))) :: l
(mkstr loc (Pstr_value ((mkrf rf), (binding bi []), []))) :: l
| Ast.StAnt (loc, _) -> error loc "antiquotation in str_item"
and class_type =
function

4
ocamldoc/odoc_ast.ml
View File

@ -98,7 +98,7 @@ module Typedtree_search =
(CT (Name.from_ident id))
(Typedtree.Tstr_class_type [ci]))
info_list
| Typedtree.Tstr_value (_, pat_exp_list) ->
| Typedtree.Tstr_value (_, pat_exp_list, _) ->
List.iter
(fun (pat,exp) ->
match iter_val_pattern pat.Typedtree.pat_desc with
@ -1059,7 +1059,7 @@ module Analyser =
| Parsetree.Pstr_attribute _
| Parsetree.Pstr_extension _ ->
(0, env, [])
| Parsetree.Pstr_value (rec_flag, pat_exp_list) ->
| Parsetree.Pstr_value (rec_flag, pat_exp_list, _) ->
(* of rec_flag * (pattern * expression) list *)
(* For each value, look for the value name, then look in the
typedtree for the corresponding information,

2
otherlibs/labltk/browser/searchid.ml
View File

@ -452,7 +452,7 @@ let search_structure str ~name ~kind ~prefix =
List.iter (search_module str ~prefix) ~f:
begin fun item ->
if match item.pstr_desc with
Pstr_value (_, l) when kind = Pvalue ->
Pstr_value (_, l, _) when kind = Pvalue ->
List.iter l ~f:
begin fun (pat,_) ->
if List.mem name (bound_variables pat)

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

@ -660,7 +660,7 @@ let rec search_pos_structure ~pos str =
List.iter str ~f:
begin function str -> match str.str_desc with
Tstr_eval exp -> search_pos_expr exp ~pos
| Tstr_value (rec_flag, l) ->
| Tstr_value (rec_flag, l, _) ->
List.iter l ~f:
begin fun (pat, exp) ->
let env =

2
parsing/ast_helper.ml
View File

@ -158,7 +158,7 @@ module Str = struct
let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
let eval ?loc a = mk ?loc (Pstr_eval a)
let value ?loc a b = mk ?loc (Pstr_value (a, b))
let value ?loc ?(attrs = []) a b = mk ?loc (Pstr_value (a, b, attrs))
let primitive ?loc a = mk ?loc (Pstr_primitive a)
let type_ ?loc a = mk ?loc (Pstr_type a)
let exception_ ?loc a = mk ?loc (Pstr_exception a)

2
parsing/ast_helper.mli
View File

@ -154,7 +154,7 @@ module Str:
val mk: ?loc:loc -> structure_item_desc -> structure_item
val eval: ?loc:loc -> expression -> structure_item
val value: ?loc:loc -> rec_flag -> (pattern * expression) list -> structure_item
val value: ?loc:loc -> ?attrs:attributes -> rec_flag -> (pattern * expression) list -> structure_item
val primitive: ?loc:loc -> value_description -> structure_item
val type_: ?loc:loc -> type_declaration list -> structure_item
val exception_: ?loc:loc -> constructor_declaration -> structure_item

2
parsing/ast_mapper.ml
View File

@ -166,7 +166,7 @@ module M = struct
let loc = sub # location loc in
match desc with
| Pstr_eval x -> eval ~loc (sub # expr x)
| Pstr_value (r, pel) -> value ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
| Pstr_value (r, pel, attrs) -> value ~loc ~attrs:(sub # attributes attrs) r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
| Pstr_primitive vd -> primitive ~loc (sub # value_description vd)
| Pstr_type l -> type_ ~loc (List.map (sub # type_declaration) l)
| Pstr_exception ed -> exception_ ~loc (sub # constructor_declaration ed)

16
parsing/parser.mly
View File

@ -173,6 +173,9 @@ let unclosed opening_name opening_num closing_name closing_num =
let expecting pos nonterm =
raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
let not_expecting pos nonterm =
raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm)))
let bigarray_function str name =
ghloc (Ldot(Ldot(Lident "Bigarray", str), name))
@ -597,11 +600,18 @@ str_attribute:
post_item_attribute { mkstr(Pstr_attribute $1) }
;
structure_item:
LET ext_attributes rec_flag let_bindings
{ (* todo: keep attributes *)
LET ext_attributes rec_flag let_bindings post_item_attributes
{
match $4 with
[{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
| l -> mkstr(Pstr_value($3, List.rev l)) }
(* todo: keep attributes, support extension *)
| l ->
begin match $2 with
| None, [] -> mkstr(Pstr_value($3, List.rev l, $5))
| Some _, _ -> not_expecting 2 "extension"
| None, _ :: _ -> not_expecting 2 "attribute"
end
}
| EXTERNAL val_ident COLON core_type EQUAL primitive_declaration post_item_attributes
{ mkstr
(Pstr_primitive (Val.mk (mkrhs $2 2) $4

2
parsing/parsetree.mli
View File

@ -337,7 +337,7 @@ and structure_item =
and structure_item_desc =
Pstr_eval of expression
| Pstr_value of rec_flag * (pattern * expression) list
| Pstr_value of rec_flag * (pattern * expression) list * attributes
| Pstr_primitive of value_description
| Pstr_type of type_declaration list
| Pstr_exception of constructor_declaration

2
parsing/pprintast.ml
View File

@ -1038,7 +1038,7 @@ class printer ()= object(self:'self)
pp f "@[<hov2>let@ _ =@ %a@]" self#expression e
| Pstr_type [] -> assert false
| Pstr_type l -> self#type_def_list f l
| Pstr_value (rf, l) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *)
| Pstr_value (rf, l, _attrs) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *)
pp f "@[<2>%a@]" self#bindings (rf,l)
| Pstr_exception ed -> self#exception_declaration f ed
| Pstr_module x ->

3
parsing/printast.ml
View File

@ -677,8 +677,9 @@ and structure_item i ppf x =
| Pstr_eval (e) ->
line i ppf "Pstr_eval\n";
expression i ppf e;
| Pstr_value (rf, l) ->
| Pstr_value (rf, l, attrs) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
attributes i ppf attrs;
list i pattern_x_expression_def ppf l;
| Pstr_primitive vd ->
line i ppf "Pstr_primitive\n";

6
parsing/syntaxerr.ml
View File

@ -17,6 +17,7 @@ open Format
type error =
Unclosed of Location.t * string * Location.t * string
| Expecting of Location.t * string
| Not_expecting of Location.t * string
| Applicative_path of Location.t
| Variable_in_scope of Location.t * string
| Other of Location.t
@ -42,6 +43,10 @@ let report_error ppf = function
fprintf ppf
"%a@[Syntax error: %s expected.@]"
Location.print_error loc nonterm
| Not_expecting (loc, nonterm) ->
fprintf ppf
"%a@[Syntax error: %s not expected.@]"
Location.print_error loc nonterm
| Applicative_path loc ->
fprintf ppf
"%aSyntax error: applicative paths of the form F(X).t \
@ -61,4 +66,5 @@ let location_of_error = function
| Applicative_path l
| Variable_in_scope(l,_)
| Other l
| Not_expecting (l, _)
| Expecting (l, _) -> l

1
parsing/syntaxerr.mli
View File

@ -17,6 +17,7 @@ open Format
type error =
Unclosed of Location.t * string * Location.t * string
| Expecting of Location.t * string
| Not_expecting of Location.t * string
| Applicative_path of Location.t
| Variable_in_scope of Location.t * string
| Other of Location.t

2
tools/cmt2annot.ml
View File

@ -92,7 +92,7 @@ let iterator rebuild_env =
method private structure_item_rem s rem =
begin match s with
| {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} ->
| {str_desc = Tstr_value (rec_flag, bindings, _); str_loc = loc} ->
let open Location in
let doit loc_start = bind_bindings {scope with loc_start} bindings in
begin match rec_flag, rem with

2
tools/depend.ml
View File

@ -262,7 +262,7 @@ and add_struct_item bv item =
match item.pstr_desc with
Pstr_eval e ->
add_expr bv e; bv
| Pstr_value(rf, pel) ->
| Pstr_value(rf, pel, _attrs) ->
let bv = add_bindings rf bv pel in bv
| Pstr_primitive vd ->
add_type bv vd.pval_type; bv

2
tools/ocamlprof.ml
View File

@ -368,7 +368,7 @@ and rewrite_mod iflag smod =
and rewrite_str_item iflag item =
match item.pstr_desc with
Pstr_eval exp -> rewrite_exp iflag exp
| Pstr_value(_, exps)
| Pstr_value(_, exps, _attrs)
-> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps
| Pstr_module x -> rewrite_mod iflag x.pmb_expr
(* todo: Pstr_recmodule?? *)

2
tools/tast_iter.ml
View File

@ -25,7 +25,7 @@ let constructor_decl sub cd =
let structure_item sub x =
match x.str_desc with
| Tstr_eval exp -> sub # expression exp
| Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
| Tstr_value (rec_flag, list, _) -> sub # bindings (rec_flag, list)
| Tstr_primitive v -> sub # value_description v
| Tstr_type list -> List.iter (sub # type_declaration) list
| Tstr_exception decl -> constructor_decl sub decl

4
tools/untypeast.ml
View File

@ -47,9 +47,9 @@ and untype_structure_item item =
let desc =
match item.str_desc with
Tstr_eval exp -> Pstr_eval (untype_expression exp)
| Tstr_value (rec_flag, list) ->
| Tstr_value (rec_flag, list, attrs) ->
Pstr_value (rec_flag, List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list)
untype_pattern pat, untype_expression exp) list, attrs)
| Tstr_primitive vd ->
Pstr_primitive (untype_value_description vd)
| Tstr_type list ->

3
typing/printtyped.ml
View File

@ -683,8 +683,9 @@ and structure_item i ppf x =
| Tstr_eval (e) ->
line i ppf "Pstr_eval\n";
expression i ppf e;
| Tstr_value (rf, l) ->
| Tstr_value (rf, l, attrs) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
attributes i ppf attrs;
list i pattern_x_expression_def ppf l;
| Tstr_primitive vd ->
line i ppf "Pstr_primitive\n";

4
typing/typecore.ml
View File

@ -167,7 +167,7 @@ let iter_expression f e =
and structure_item str =
match str.pstr_desc with
| Pstr_eval e -> expr e
| Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
| Pstr_value (_, pel, _) -> List.iter (fun (_, e) -> expr e) pel
| Pstr_primitive _
| Pstr_type _
| Pstr_exception _
@ -1340,7 +1340,7 @@ and is_nonexpansive_mod mexp =
(fun item -> match item.str_desc with
| Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _
| 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
| Tstr_module {mb_expr=m;_} | Tstr_include (m, _, _) -> is_nonexpansive_mod m
| Tstr_recmodule id_mod_list ->

2
typing/typedtree.ml
View File

@ -202,7 +202,7 @@ and structure_item =
and structure_item_desc =
Tstr_eval of expression
| Tstr_value of rec_flag * (pattern * expression) list
| Tstr_value of rec_flag * (pattern * expression) list * attributes
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration

2
typing/typedtree.mli
View File

@ -201,7 +201,7 @@ and structure_item =
and structure_item_desc =
Tstr_eval of expression
| Tstr_value of rec_flag * (pattern * expression) list
| Tstr_value of rec_flag * (pattern * expression) list * attributes
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration

2
typing/typedtreeIter.ml
View File

@ -120,7 +120,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
begin
match item.str_desc with
Tstr_eval exp -> iter_expression exp
| Tstr_value (rec_flag, list) ->
| Tstr_value (rec_flag, list, _attrs) ->
iter_bindings rec_flag list
| Tstr_primitive vd -> iter_value_description vd
| Tstr_type list -> List.iter iter_type_declaration list

4
typing/typedtreeMap.ml
View File

@ -92,8 +92,8 @@ module MakeMap(Map : MapArgument) = struct
let str_desc =
match item.str_desc with
Tstr_eval exp -> Tstr_eval (map_expression exp)
| Tstr_value (rec_flag, list) ->
Tstr_value (rec_flag, map_bindings rec_flag list)
| Tstr_value (rec_flag, list, attrs) ->
Tstr_value (rec_flag, map_bindings rec_flag list, attrs)
| Tstr_primitive vd ->
Tstr_primitive (map_value_description vd)
| Tstr_type list ->

6
typing/typemod.ml
View File

@ -662,7 +662,7 @@ and closed_signature_item = function
let check_nongen_scheme env str =
match str.str_desc with
Tstr_value(rec_flag, pat_exp_list) ->
Tstr_value(rec_flag, pat_exp_list, _attrs) ->
List.iter
(fun (pat, exp) ->
if not (Ctype.closed_schema exp.exp_type) then
@ -975,7 +975,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let item = mk (Tstr_eval expr) in
let (str_rem, sig_rem, final_env) = type_struct env srem in
(item :: str_rem, sig_rem, final_env)
| Pstr_value(rec_flag, sdefs) ->
| Pstr_value(rec_flag, sdefs, attrs) ->
let scope =
match rec_flag with
| Recursive -> Some (Annot.Idef {scope with
@ -988,7 +988,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
in
let (defs, newenv) =
Typecore.type_binding env rec_flag sdefs scope in
let item = mk (Tstr_value(rec_flag, defs)) in
let item = mk (Tstr_value(rec_flag, defs, attrs)) in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
let bound_idents = let_bound_idents defs in
(* Note: Env.find_value does not trigger the value_used event. Values