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

Item attributes on each let-binding. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13736 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-06-03 15:14:19 +00:00
parent 8cee3aedf9
commit 2e199ef1f2
41 changed files with 242 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

6
bytecomp/translcore.ml
View File

@ -982,18 +982,18 @@ and transl_let rec_flag pat_expr_list body =
let rec transl = function
[] ->
body
| (pat, expr) :: rem ->
| {vb_pat=pat; vb_expr=expr} :: rem ->
Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem)
in transl pat_expr_list
| Recursive ->
let idlist =
List.map
(fun (pat, expr) -> match pat.pat_desc with
(fun {vb_pat=pat} -> match pat.pat_desc with
Tpat_var (id,_) -> id
| Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
| _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
pat_expr_list in
let transl_case (pat, expr) id =
let transl_case {vb_pat=pat; vb_expr=expr} id =
let lam = transl_exp expr in
if not (check_recursive_lambda idlist lam) then
raise(Error(expr.exp_loc, Illegal_letrec_expr));

3
bytecomp/translcore.mli
View File

@ -20,8 +20,7 @@ open Lambda
val transl_exp: expression -> lambda
val transl_apply: lambda -> (label * expression option * optional) list
-> Location.t -> lambda
val transl_let:
rec_flag -> (pattern * expression) list -> lambda -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> lambda
val transl_exception:
Path.t option -> constructor_declaration -> lambda

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, _attrs) ->
| Tstr_value(rec_flag, pat_expr_list) ->
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, _attrs) ->
| Tstr_value(rec_flag, pat_expr_list) ->
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, _attrs) -> more_idents rem
| Tstr_value(rec_flag, pat_expr_list, _attrs) -> more_idents rem
| Tstr_value(rec_flag, pat_expr_list) -> 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, _attrs) -> all_idents rem
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
| Tstr_value(rec_flag, pat_expr_list) ->
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, _attrs) ->
Lsequence(subst_lambda subst (transl_exp expr),
transl_store rootpath subst rem)
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
| Tstr_value(rec_flag, pat_expr_list) ->
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, _attrs) ->
transl_exp expr
| Tstr_value(rec_flag, pat_expr_list, _attrs) ->
| Tstr_value(rec_flag, pat_expr_list) ->
let idents = let_bound_idents pat_expr_list in
transl_let rec_flag pat_expr_list
(make_sequence toploop_setvalue_id idents)

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

@ -918,10 +918,12 @@ value varify_constructors var_names =
mktyp _loc (Ptyp_poly ampersand_vars ty')))
in
let e = mk_newtypes vars in
[( pat, e) :: acc]
[{pvb_pat=pat; pvb_expr=e; pvb_attributes=[]} :: acc]
| <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> ->
[(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc]
| <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc]
[{pvb_pat=patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>;
pvb_expr=expr e;
pvb_attributes=[]} :: acc]
| <:binding< $p$ = $e$ >> -> [{pvb_pat=patt p; pvb_expr=expr e; pvb_attributes=[]} :: acc]
| <:binding<>> -> acc
| _ -> assert False ]
and match_case x acc =
@ -1100,7 +1102,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

11
camlp4/boot/Camlp4.ml
View File

@ -15202,12 +15202,13 @@ module Struct =
(Ppat_constraint
(((mkpat (Ppat_var (with_loc bind_name sloc))),
(mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in
let e = mk_newtypes vars in (pat, e) :: acc
let e = mk_newtypes vars in {pvb_pat=pat; pvb_expr=e; pvb_attributes=[]} :: acc
| Ast.BiEq (_loc, p,
(Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) ->
((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))),
(expr e)) :: acc
| Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc
{pvb_pat=patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))));
pvb_expr=expr e;
pvb_attributes=[]} :: acc
| Ast.BiEq (_, p, e) -> {pvb_pat=patt p; pvb_expr=expr e; pvb_attributes=[]} :: acc
| Ast.BiNil _ -> acc
| _ -> assert false
and match_case x acc =
@ -15451,7 +15452,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

7
experimental/frisch/Makefile
View File

@ -71,3 +71,10 @@ copy_typedef:
$(OCAMLC) -linkall -o copy_typedef.exe -w +A-4 $(COMMON) copy_typedef.ml
$(OCAMLC) -c -ppx ./copy_typedef.exe test_copy_typedef.mli
$(OCAMLC) -o test_copy_typedef.exe -w +A -ppx ./copy_typedef.exe -dsource test_copy_typedef.ml
## Create mli files from ml files
.PHONY: nomli
nomli:
$(OCAMLC) -linkall -o nomli.exe -w +A-4-9 $(COMMON) $(BYTECMP) ../../tools/untypeast.cmo ../../tools/tast_iter.cmo nomli.ml

16
experimental/frisch/extension_points.txt
View File

@ -41,10 +41,12 @@ Attributes on items:
... [@@id s]
Items designate signature items, structure items, class fields,
class type fields and also individual components of multiple
declaration in structures and signatures (type declarations, recursive modules, class
declarations, class type declarations).
Items designate:
- structure and signature items (for type declarations, recursive modules, class
declarations and class type declarations, each component has its own attributes)
- class fields and class type fields
- each binding in a let declaration (for let structure item, local let-bindings in
expression and class expressions)
For instance, consider:
@ -53,8 +55,10 @@ Attributes on items:
Here, the attributes on t1 are id1, id23; the attributes on
t2 are id3 and id4.
Note: item attributes are currently not supported on Pstr_eval
and Pstr_value structure items.
Similarly for:
let x1 = ... [@@id1] [@@id2] and x2 = ... [@@id3] [@@id4]
The [@@id s] form, when used at the beginning of a signature or
structure, or after a double semi-colon (;;), defines an attribute

2
experimental/frisch/genlifter.ml
View File

@ -105,7 +105,7 @@ and tyexpr env ty x =
app f [x]
| Ttuple tl ->
let p, e = gentuple env tl in
let_in [Pat.tuple p, x] (selfcall "tuple" [list e])
let_in [Vb.mk (Pat.tuple p) x] (selfcall "tuple" [list e])
| Tconstr (path, [t], _) when Path.same path Predef.path_list ->
selfcall "list" [app (evar "List.map") [tyexpr_fun env t; x]]
| Tconstr (path, [t], _) when Path.same path Predef.path_array ->

2
experimental/frisch/js_syntax.ml
View File

@ -51,7 +51,7 @@ let access_object loc e m m_typ f =
let y = random_var () in
let o = annot (evar y) (Typ.var obj_type) in
let constr = lam (pvar y) (annot (send o m) m_typ) in
let_in [pvar x, obj; Pat.any (), constr] (f (evar x))
let_in [Vb.mk (pvar x) obj; Vb.mk (Pat.any ()) constr] (f (evar x))
)
let method_call loc obj meth args =

4
experimental/frisch/ppx_builder.ml
View File

@ -59,7 +59,7 @@ module Main : sig end = struct
let fields = List.map field fields in
let body = lam (punit()) (record (List.map snd fields)) in
let f = List.fold_right (fun (f, _) k -> f k) fields body in
let s = Str.value Nonrecursive [pvar tdecl.ptype_name.txt, f] in
let s = Str.value Nonrecursive [Vb.mk (pvar tdecl.ptype_name.txt) f] in
[s]
| Ptype_variant constrs ->
let constr {pcd_name={txt=name;_}; pcd_args=args; _} =
@ -67,7 +67,7 @@ module Main : sig end = struct
let args = List.mapi arg args in
let body = lam (punit()) (constr name (List.map (fun (_, (_, e)) -> e) args)) in
let f = List.fold_right (fun (f, _) k -> f k) args body in
let s = Str.value Nonrecursive [pvar (tdecl.ptype_name.txt ^ "_" ^ name), f] in
let s = Str.value Nonrecursive [Vb.mk (pvar (tdecl.ptype_name.txt ^ "_" ^ name)) f] in
s
in
List.map constr constrs

17
ocamldoc/odoc_ast.ml
View File

@ -98,9 +98,9 @@ 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) ->
(fun {vb_pat=pat; vb_expr=exp} ->
match iter_val_pattern pat.Typedtree.pat_desc with
None -> ()
| Some n -> Hashtbl.add table_values n (pat,exp)
@ -320,7 +320,8 @@ module Analyser =
(
(
match func_body.exp_desc with
Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var (id, _) } , exp) :: _, func_body2) ->
Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _) };
vb_expr=exp} :: _, func_body2) ->
let name = Name.from_ident id in
let new_param = Simple_name
{ sn_name = name ;
@ -479,7 +480,8 @@ module Analyser =
(
(
match body.exp_desc with
Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var (id, _) } , exp) :: _, body2) ->
Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _) };
vb_expr=exp} :: _, body2) ->
let name = Name.from_ident id in
let new_param = Simple_name
{ sn_name = name ;
@ -741,7 +743,8 @@ module Analyser =
(
(* there must be a Tcl_let just after *)
match tt_class_expr2.Typedtree.cl_desc with
Typedtree.Tcl_let (_, ({pat_desc = Typedtree.Tpat_var (id,_) } , exp) :: _, _, tt_class_expr3) ->
Typedtree.Tcl_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id,_) };
vb_expr=exp} :: _, _, tt_class_expr3) ->
let name = Name.from_ident id in
let new_param = Simple_name
{ sn_name = name ;
@ -1059,7 +1062,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,
@ -1075,7 +1078,7 @@ module Analyser =
match p_e_list with
[] ->
(acc_env, acc)
| (pat, exp) :: q ->
| {Parsetree.pvb_pat=pat; pvb_expr=exp} :: q ->
let value_name_opt = iter_pat pat.Parsetree.ppat_desc in
let new_last_pos = exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum in
match value_name_opt with

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

@ -453,9 +453,9 @@ 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,_) ->
begin fun {pvb_pat=pat} ->
if List.mem name (bound_variables pat)
then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum
end;

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

@ -660,9 +660,9 @@ 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) ->
begin fun {vb_pat=pat;vb_expr=exp} ->
let env =
if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in
search_pos_pat pat ~pos ~env;
@ -716,7 +716,7 @@ and search_pos_class_expr ~pos cl =
List.iter el ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x)
| Tcl_let (_, pel, iel, cl) ->
List.iter pel ~f:
begin fun (pat, exp) ->
begin fun {vb_pat=pat; vb_expr=exp} ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end;
@ -748,7 +748,7 @@ and search_pos_expr ~pos exp =
~env:exp.exp_env ~loc:exp.exp_loc
| Texp_let (_, expl, exp) ->
List.iter expl ~f:
begin fun (pat, exp') ->
begin fun {vb_pat=pat; vb_expr=exp'} ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp' ~pos
end;

11
parsing/ast_helper.ml
View File

@ -166,7 +166,7 @@ module Str = struct
let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc}
let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs))
let value ?loc ?(attrs = []) a b = mk ?loc (Pstr_value (a, b, attrs))
let value ?loc a b = mk ?loc (Pstr_value (a, b))
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)
@ -289,6 +289,15 @@ module Mb = struct
}
end
module Vb = struct
let mk ?(attrs = []) pat expr =
{
pvb_pat = pat;
pvb_expr = expr;
pvb_attributes = attrs;
}
end
module Ci = struct
let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) name expr =
{

16
parsing/ast_helper.mli
View File

@ -84,7 +84,7 @@ module Exp:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> (pattern * expression) list -> expression -> expression
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> expression -> expression
val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> expression -> expression
val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression
@ -191,7 +191,7 @@ module Str:
val mk: ?loc:loc -> structure_item_desc -> structure_item
val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item
val value: ?loc:loc -> ?attrs:attributes -> rec_flag -> (pattern * expression) list -> structure_item
val value: ?loc:loc -> rec_flag -> value_binding 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
@ -225,6 +225,14 @@ module Mb:
val mk: ?attrs:attrs -> str -> module_expr -> module_binding
end
(** Value bindings *)
module Vb:
sig
val mk: ?attrs:attrs -> pattern -> expression -> value_binding
end
(** {2 Class language} *)
(** Class type expressions *)
@ -262,7 +270,7 @@ module Cl:
val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> class_expr -> class_expr
val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (label * expression) list -> class_expr
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr
val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr
val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
end
@ -316,7 +324,7 @@ module Convenience :
(** {2 Expressions} *)
val evar: string -> expression
val let_in: ?recursive:bool -> (pattern * expression) list -> expression -> expression
val let_in: ?recursive:bool -> value_binding list -> expression -> expression
val constr: string -> expression list -> expression
val record: ?over:expression -> (string * expression) list -> expression

17
parsing/ast_mapper.ml
View File

@ -168,7 +168,7 @@ module M = struct
let loc = sub # location loc in
match desc with
| Pstr_eval (x, attrs) -> eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x)
| Pstr_value (r, pel, attrs) -> value ~loc ~attrs:(sub # attributes attrs) r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
| Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs)
| 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)
@ -198,7 +198,7 @@ module E = struct
match desc with
| Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pexp_constant x -> constant ~loc ~attrs x
| Pexp_let (r, pel, e) -> let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
| Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) (sub # expr e)
| Pexp_fun (lab, def, p, e) -> fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) (sub # expr e)
| Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel)
| Pexp_apply (e, l) -> apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
@ -276,10 +276,8 @@ module CE = struct
(sub # class_expr ce)
| Pcl_apply (ce, l) ->
apply ~loc ~attrs (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
| Pcl_let (r, pel, ce) ->
let_ ~loc ~attrs r
(List.map (map_tuple (sub # pat) (sub # expr)) pel)
(sub # class_expr ce)
| Pcl_let (r, vbs, ce) ->
let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) (sub # class_expr ce)
| Pcl_constraint (ce, ct) ->
constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct)
| Pcl_extension x -> extension ~loc ~attrs (sub # extension x)
@ -376,6 +374,13 @@ class mapper =
Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr)
~attrs:(this # attributes pmb_attributes)
method value_binding {pvb_pat; pvb_expr; pvb_attributes} =
Vb.mk
(this # pat pvb_pat)
(this # expr pvb_expr)
~attrs:(this # attributes pvb_attributes)
method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
Type.constructor
(map_loc this pcd_name)

1
parsing/ast_mapper.mli
View File

@ -53,6 +53,7 @@ class mapper:
method extension: extension -> extension
method constructor_declaration: constructor_declaration -> constructor_declaration
method label_declaration: label_declaration -> label_declaration
method value_binding: value_binding -> value_binding
end
class type main_entry_points =

11
parsing/parser.mly
View File

@ -588,15 +588,15 @@ str_attribute:
post_item_attribute { mkstr(Pstr_attribute $1) }
;
structure_item:
LET ext_attributes rec_flag let_bindings post_item_attributes
LET ext_attributes rec_flag let_bindings
{
match $4 with
[{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] ->
[ {pvb_pat = { ppat_desc = Ppat_any; ppat_loc = _ }; pvb_expr = exp; pvb_attributes = attrs}] ->
let exp = wrap_exp_attrs exp $2 in
mkstr(Pstr_eval (exp, $5))
mkstr(Pstr_eval (exp, attrs))
| l ->
begin match $2 with
| None, [] -> mkstr(Pstr_value($3, List.rev l, $5))
| None, [] -> mkstr(Pstr_value($3, List.rev l))
| Some _, _ -> not_expecting 2 "extension"
| None, _ :: _ -> not_expecting 2 "attribute"
end
@ -1230,6 +1230,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_:
val_ident fun_binding
{ (mkpatvar $1 1, $2) }
| val_ident COLON typevar_list DOT core_type EQUAL seq_expr

13
parsing/parsetree.mli
View File

@ -185,7 +185,7 @@ and expression_desc =
*)
| Pexp_constant of constant
(* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
| Pexp_let of rec_flag * (pattern * expression) list * expression
| Pexp_let of rec_flag * value_binding list * expression
(* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
*)
@ -469,7 +469,7 @@ and class_expr_desc =
li can be empty (non labeled argument) or start with '?'
(optional argument).
*)
| Pcl_let of rec_flag * (pattern * expression) list * class_expr
| Pcl_let of rec_flag * value_binding list * class_expr
(* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive)
*)
@ -654,7 +654,7 @@ and structure_item =
and structure_item_desc =
| Pstr_eval of expression * attributes
(* E *)
| Pstr_value of rec_flag * (pattern * expression) list * attributes
| Pstr_value of rec_flag * value_binding list
(* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN (flag = Recursive)
*)
@ -687,6 +687,13 @@ and structure_item_desc =
| Pstr_extension of extension * attributes
(* [%%id] *)
and value_binding =
{
pvb_pat: pattern;
pvb_expr: expression;
pvb_attributes: attributes;
}
and module_binding =
{
pmb_name: string loc;

8
parsing/pprintast.ml
View File

@ -770,7 +770,9 @@ class printer ()= object(self:'self)
pp f "%s :@;%a=@;%a"
s.txt (self#core_type) ct self#expression e
| Pexp_poly (e,None) ->
self#binding f ({ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]} ,e)
self#binding f {pvb_pat={ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
pvb_expr=e;
pvb_attributes=[]}
| _ ->
self#expression f e ) e
| Pcf_constraint (ct1, ct2) ->
@ -937,7 +939,7 @@ class printer ()= object(self:'self)
method structure f x = self#list ~sep:"@\n" self#structure_item f x
(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
method binding f ((p:pattern),(x:expression)) =
method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *)
let rec pp_print_pexp_function f x =
if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x
else match x.pexp_desc with
@ -996,7 +998,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, _attrs) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *)
| Pstr_value (rf, l) -> (* 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 ->

4
parsing/pprintast.mli
View File

@ -17,10 +17,10 @@ class printer :
val pipe : bool
val semi : bool
method binding :
Format.formatter -> Parsetree.pattern * Parsetree.expression -> unit
Format.formatter -> Parsetree.value_binding -> unit
method bindings:
Format.formatter ->
Asttypes.rec_flag * (Parsetree.pattern * Parsetree.expression) list ->
Asttypes.rec_flag * Parsetree.value_binding list ->
unit
method case_list :
Format.formatter -> Parsetree.case list -> unit

16
parsing/printast.ml
View File

@ -239,7 +239,7 @@ and expression i ppf x =
| Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
| Pexp_let (rf, l, e) ->
line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def ppf l;
list i value_binding ppf l;
expression i ppf e;
| Pexp_function l ->
line i ppf "Pexp_function\n";
@ -492,7 +492,7 @@ and class_expr i ppf x =
list i label_x_expression ppf l;
| Pcl_let (rf, l, ce) ->
line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def ppf l;
list i value_binding ppf l;
class_expr i ppf ce;
| Pcl_constraint (ce, ct) ->
line i ppf "Pcl_constraint\n";
@ -684,10 +684,9 @@ and structure_item i ppf x =
line i ppf "Pstr_eval\n";
attributes i ppf attrs;
expression i ppf e;
| Pstr_value (rf, l, attrs) ->
| Pstr_value (rf, l) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
attributes i ppf attrs;
list i pattern_x_expression_def ppf l;
list i value_binding ppf l;
| Pstr_primitive vd ->
line i ppf "Pstr_primitive\n";
value_description i ppf vd;
@ -782,10 +781,11 @@ and case i ppf {pc_lhs; pc_guard; pc_rhs} =
end;
expression (i+1) ppf pc_rhs;
and pattern_x_expression_def i ppf (p, e) =
and value_binding i ppf x =
line i ppf "<def>\n";
pattern (i+1) ppf p;
expression (i+1) ppf e;
attributes (i+1) ppf x.pvb_attributes;
pattern (i+1) ppf x.pvb_pat;
expression (i+1) ppf x.pvb_expr
and string_x_expression i ppf (s, e) =
line i ppf "<override> %a\n" fmt_string_loc s;

4
tools/cmt2annot.ml
View File

@ -29,7 +29,7 @@ let bind_variables scope =
let bind_bindings scope bindings =
let o = bind_variables scope in
List.iter (fun (p, _) -> o # pattern p) bindings
List.iter (fun x -> o # pattern x.vb_pat) bindings
let bind_cases l =
List.iter
@ -100,7 +100,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

6
tools/depend.ml
View File

@ -191,9 +191,9 @@ and add_case bv {pc_lhs; pc_guard; pc_rhs} =
add_expr bv pc_rhs
and add_bindings recf bv pel =
let bv' = List.fold_left (fun bv (p, _) -> add_pattern bv p) bv pel in
let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
let bv = if recf = Recursive then bv' else bv in
List.iter (fun (_, e) -> add_expr bv e) pel;
List.iter (fun x -> add_expr bv x.pvb_expr) pel;
bv'
and add_modtype bv mty =
@ -273,7 +273,7 @@ and add_struct_item bv item =
match item.pstr_desc with
Pstr_eval (e, _attrs) ->
add_expr bv e; bv
| Pstr_value(rf, pel, _attrs) ->
| Pstr_value(rf, pel) ->
let bv = add_bindings rf bv pel in bv
| Pstr_primitive vd ->
add_type bv vd.pval_type; bv

6
tools/ocamlprof.ml
View File

@ -148,7 +148,7 @@ let final_rewrite add_function =
;;
let rec rewrite_patexp_list iflag l =
rewrite_exp_list iflag (List.map snd l)
rewrite_exp_list iflag (List.map (fun x -> x.pvb_expr) l)
and rewrite_cases iflag l =
List.iter
@ -381,8 +381,8 @@ and rewrite_mod iflag smod =
and rewrite_str_item iflag item =
match item.pstr_desc with
Pstr_eval (exp, _attrs) -> rewrite_exp iflag exp
| Pstr_value(_, exps, _attrs)
-> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps
| Pstr_value(_, exps)
-> List.iter (fun x -> rewrite_exp iflag x.pvb_expr) exps
| Pstr_module x -> rewrite_mod iflag x.pmb_expr
(* todo: Pstr_recmodule?? *)
| Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes

8
tools/tast_iter.ml
View File

@ -24,7 +24,7 @@ let constructor_decl sub cd =
let structure_item sub x =
match x.str_desc with
| Tstr_eval (exp, _attrs) -> 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
@ -333,9 +333,9 @@ let case sub {c_lhs; c_guard; c_rhs} =
opt (sub # expression) c_guard;
sub # expression c_rhs
let binding sub (pat, exp) =
sub # pattern pat;
sub # expression exp
let binding sub vb =
sub # pattern vb.vb_pat;
sub # expression vb.vb_expr
class iter = object(this)
method binding = binding this

8
tools/tast_iter.mli
View File

@ -14,8 +14,8 @@ open Asttypes
open Typedtree
class iter: object
method binding: (pattern * expression) -> unit
method bindings: (rec_flag * (pattern * expression) list) -> unit
method binding: value_binding -> unit
method bindings: (rec_flag * value_binding list) -> unit
method case: case -> unit
method cases: case list -> unit
method class_description: class_description -> unit
@ -51,8 +51,8 @@ end
(** The following functions apply the provided iterator to each
sub-component of the argument. *)
val binding: iter -> (pattern * expression) -> unit
val bindings: iter -> (rec_flag * (pattern * expression) list) -> unit
val binding: iter -> value_binding -> unit
val bindings: iter -> (rec_flag * value_binding list) -> unit
val class_description: iter -> class_description -> unit
val class_expr: iter -> class_expr -> unit
val class_field: iter -> class_field -> unit

18
tools/untypeast.ml
View File

@ -47,9 +47,8 @@ and untype_structure_item item =
let desc =
match item.str_desc with
Tstr_eval (exp, attrs) -> Pstr_eval (untype_expression exp, attrs)
| Tstr_value (rec_flag, list, attrs) ->
Pstr_value (rec_flag, List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list, attrs)
| Tstr_value (rec_flag, list) ->
Pstr_value (rec_flag, List.map untype_binding list)
| Tstr_primitive vd ->
Pstr_primitive (untype_value_description vd)
| Tstr_type list ->
@ -213,6 +212,13 @@ and untype_case {c_lhs; c_guard; c_rhs} =
pc_rhs = untype_expression c_rhs;
}
and untype_binding {vb_pat; vb_expr; vb_attributes} =
{
pvb_pat = untype_pattern vb_pat;
pvb_expr = untype_expression vb_expr;
pvb_attributes = vb_attributes;
}
and untype_expression exp =
let desc =
match exp.exp_desc with
@ -220,8 +226,7 @@ and untype_expression exp =
| Texp_constant cst -> Pexp_constant cst
| Texp_let (rec_flag, list, exp) ->
Pexp_let (rec_flag,
List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list,
List.map untype_binding list,
untype_expression exp)
| Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) ->
Pexp_fun (label, None, untype_pattern p, untype_expression e)
@ -431,8 +436,7 @@ and untype_class_expr cexpr =
| Tcl_let (rec_flat, bindings, _ivars, cl) ->
Pcl_let (rec_flat,
List.map (fun (pat, exp) ->
(untype_pattern pat, untype_expression exp)) bindings,
List.map untype_binding bindings,
untype_class_expr cl)
| Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->

1
tools/untypeast.mli
View File

@ -13,5 +13,6 @@
val untype_structure : Typedtree.structure -> Parsetree.structure
val untype_signature : Typedtree.signature -> Parsetree.signature
val untype_expression : Typedtree.expression -> Parsetree.expression
val untype_type_declaration : Typedtree.type_declaration -> Parsetree.type_declaration
val lident_of_path : Path.t -> Longident.t

16
typing/printtyped.ml
View File

@ -278,7 +278,7 @@ and expression i ppf x =
| Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
| Texp_let (rf, l, e) ->
line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def ppf l;
list i value_binding ppf l;
expression i ppf e;
| Texp_function (p, l, _partial) ->
line i ppf "Pexp_function \"%s\"\n" p;
@ -494,7 +494,7 @@ and class_expr i ppf x =
list i label_x_expression ppf l;
| Tcl_let (rf, l1, l2, ce) ->
line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def ppf l1;
list i value_binding ppf l1;
list i ident_x_loc_x_expression_def ppf l2;
class_expr i ppf ce;
| Tcl_constraint (ce, Some ct, _, _, _) ->
@ -679,10 +679,9 @@ and structure_item i ppf x =
line i ppf "Pstr_eval\n";
attributes i ppf attrs;
expression i ppf e;
| Tstr_value (rf, l, attrs) ->
| Tstr_value (rf, l) ->
line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
attributes i ppf attrs;
list i pattern_x_expression_def ppf l;
list i value_binding ppf l;
| Tstr_primitive vd ->
line i ppf "Pstr_primitive\n";
value_description i ppf vd;
@ -774,10 +773,11 @@ and case i ppf {c_lhs; c_guard; c_rhs} =
end;
expression (i+1) ppf c_rhs;
and pattern_x_expression_def i ppf (p, e) =
and value_binding i ppf x =
line i ppf "<def>\n";
pattern (i+1) ppf p;
expression (i+1) ppf e;
attributes (i+1) ppf x.vb_attributes;
pattern (i+1) ppf x.vb_pat;
expression (i+1) ppf x.vb_expr
and string_x_expression i ppf (s, _, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;

2
typing/typeclass.ml
View File

@ -876,7 +876,7 @@ and class_expr cl_num val_env met_env scl =
Cl.fun_ ~loc:scl.pcl_loc
l None
(Pat.var ~loc (mknoloc "*opt*"))
(Cl.let_ ~loc:scl.pcl_loc Nonrecursive [spat, smatch] sbody)
(Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
(* Note: we don't put the '#default' attribute, as it
is not detected for class-level let bindings. See #5975.*)
in

44
typing/typecore.ml
View File

@ -127,7 +127,7 @@ let iter_expression f e =
| Pexp_function pel -> List.iter case pel
| Pexp_fun (_, eo, _, e) -> may expr eo; expr e
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
| Pexp_let (_, pel, e) -> expr e; List.iter (fun (_, e) -> expr e) pel
| Pexp_let (_, pel, e) -> expr e; List.iter binding pel
| Pexp_match (e, pel)
| Pexp_try (e, pel) -> expr e; List.iter case pel
| Pexp_array el
@ -160,6 +160,9 @@ let iter_expression f e =
may expr pc_guard;
expr pc_rhs
and binding x =
expr x.pvb_expr
and module_expr me =
match me.pmod_desc with
| Pmod_extension _
@ -174,7 +177,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 binding pel
| Pstr_primitive _
| Pstr_type _
| Pstr_exception _
@ -197,7 +200,7 @@ let iter_expression f e =
| Pcl_apply (ce, lel) ->
class_expr ce; List.iter (fun (_, e) -> expr e) lel
| Pcl_let (_, pel, ce) ->
List.iter (fun (_, e) -> expr e) pel; class_expr ce
List.iter binding pel; class_expr ce
| Pcl_constraint (ce, _) -> class_expr ce
| Pcl_extension _ -> ()
@ -1307,7 +1310,7 @@ let rec is_nonexpansive exp =
Texp_ident(_,_,_) -> true
| Texp_constant _ -> true
| Texp_let(rec_flag, pat_exp_list, body) ->
List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
is_nonexpansive body
| Texp_function _ -> true
| Texp_apply(e, (_,None,_)::el) ->
@ -1364,8 +1367,8 @@ 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, _) ->
List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list
| Tstr_value (_, pat_exp_list) ->
List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
| Tstr_module {mb_expr=m;_} | Tstr_include (m, _, _) -> is_nonexpansive_mod m
| Tstr_recmodule id_mod_list ->
List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
@ -1913,7 +1916,8 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
| Pexp_let(Nonrecursive, [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) when contains_gadt env spat ->
(* TODO: allow non-empty attributes? *)
type_expect ?in_function env
{sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
ty_expected
@ -1960,7 +1964,7 @@ and type_expect_ ?in_function env sexp ty_expected =
Exp.fun_ ~loc
l None
(Pat.var ~loc (mknoloc "*opt*"))
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",[]] [spat, smatch] sexp)
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",[]] [Vb.mk spat smatch] sexp)
in
type_expect ?in_function env sfun ty_expected
(* TODO: keep attributes, call type_function directly *)
@ -2915,7 +2919,7 @@ and type_argument env sarg ty_expected' ty_expected =
(* let-expand to have side effects *)
let let_pat, let_var = var_pair "let" texp.exp_type in
re { texp with exp_type = ty_fun; exp_desc =
Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
Texp_let (Nonrecursive, [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}], func let_var) }
end
| _ ->
let texp = type_expect env sarg ty_expected' in
@ -3335,8 +3339,8 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let is_fake_let =
match spat_sexp_list with
| [_, {pexp_desc=Pexp_match(
{pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] ->
| [{pvb_expr={pexp_desc=Pexp_match(
{pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
| _ ->
false
@ -3345,7 +3349,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let spatl =
List.map
(fun (spat, sexp) ->
(fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=_} ->
match spat.ppat_desc, sexp.pexp_desc with
(Ppat_any | Ppat_constraint _), _ -> spat
| _, Pexp_coerce (_, _, sty)
@ -3365,14 +3369,14 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
(* If recursive, first unify with an approximation of the expression *)
if is_recursive then
List.iter2
(fun pat (_, sexp) ->
(fun pat binding ->
let pat =
match pat.pat_type.desc with
| Tpoly (ty, tl) ->
{pat with pat_type =
snd (instance_poly ~keep_names:true false tl ty)}
| _ -> pat
in unify_pat env pat (type_approx env sexp))
in unify_pat env pat (type_approx env binding.pvb_expr))
pat_list spat_sexp_list;
(* Polymorphic variant processing *)
List.iter
@ -3461,7 +3465,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
in
let exp_list =
List.map2
(fun (spat, sexp) (pat, slot) ->
(fun {pvb_expr=sexp; _} (pat, slot) ->
let sexp =
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
if is_recursive then current_slot := slot;
@ -3483,7 +3487,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
current_slot := None;
if is_recursive && not !rec_needed
&& Warnings.is_active Warnings.Unused_rec_flag then
Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc
Location.prerr_warning (List.hd spat_sexp_list).pvb_pat.ppat_loc
Warnings.Unused_rec_flag;
List.iter2
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp]))
@ -3497,7 +3501,13 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
List.iter
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
pat_list;
(List.combine pat_list exp_list, new_env, unpacks)
let l = List.combine pat_list exp_list in
let l =
List.map2
(fun (p, e) pvb -> {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes})
l spat_sexp_list
in
(l, new_env, unpacks)
(* Typing of toplevel bindings *)

8
typing/typecore.mli
View File

@ -20,14 +20,14 @@ val is_nonexpansive: Typedtree.expression -> bool
val type_binding:
Env.t -> rec_flag ->
(Parsetree.pattern * Parsetree.expression) list ->
Parsetree.value_binding list ->
Annot.ident option ->
(Typedtree.pattern * Typedtree.expression) list * Env.t
Typedtree.value_binding list * Env.t
val type_let:
Env.t -> rec_flag ->
(Parsetree.pattern * Parsetree.expression) list ->
Parsetree.value_binding list ->
Annot.ident option ->
(Typedtree.pattern * Typedtree.expression) list * Env.t
Typedtree.value_binding list * Env.t
val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:

17
typing/typedtree.ml
View File

@ -73,7 +73,7 @@ and exp_extra =
and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
| Texp_let of rec_flag * (pattern * expression) list * expression
| Texp_let of rec_flag * value_binding list * expression
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_match of expression * case list * partial
@ -135,7 +135,7 @@ and class_expr_desc =
label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
| Tcl_let of rec_flag * (pattern * expression) list *
| Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
class_expr * class_type option * string list * string list * Concr.t
@ -207,7 +207,7 @@ and structure_item =
and structure_item_desc =
Tstr_eval of expression * attributes
| Tstr_value of rec_flag * (pattern * expression) list * attributes
| Tstr_value of rec_flag * value_binding list
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration
@ -229,6 +229,13 @@ and module_binding =
mb_attributes: attribute list;
}
and value_binding =
{
vb_pat: pattern;
vb_expr: expression;
vb_attributes: attributes;
}
and module_coercion =
Tcoerce_none
| Tcoerce_structure of (int * module_coercion) list
@ -488,9 +495,9 @@ let rec bound_idents pat =
let pat_bound_idents pat =
idents := []; bound_idents pat; let res = !idents in idents := []; res
let rev_let_bound_idents_with_loc pat_expr_list =
let rev_let_bound_idents_with_loc bindings =
idents := [];
List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list;
List.iter (fun vb -> bound_idents vb.vb_pat) bindings;
let res = !idents in idents := []; res
let let_bound_idents_with_loc pat_expr_list =

21
typing/typedtree.mli
View File

@ -72,7 +72,7 @@ and exp_extra =
and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
| Texp_let of rec_flag * (pattern * expression) list * expression
| Texp_let of rec_flag * value_binding list * expression
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_match of expression * case list * partial
@ -134,7 +134,7 @@ and class_expr_desc =
label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
| Tcl_let of rec_flag * (pattern * expression) list *
| Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
class_expr * class_type option * string list * string list * Concr.t
@ -206,7 +206,7 @@ and structure_item =
and structure_item_desc =
Tstr_eval of expression * attributes
| Tstr_value of rec_flag * (pattern * expression) list * attributes
| Tstr_value of rec_flag * value_binding list
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration
@ -228,6 +228,13 @@ and module_binding =
mb_attributes: attributes;
}
and value_binding =
{
vb_pat: pattern;
vb_expr: expression;
vb_attributes: attributes;
}
and module_coercion =
Tcoerce_none
| Tcoerce_structure of (int * module_coercion) list
@ -438,13 +445,11 @@ and 'a class_infos =
val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit
val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc
val let_bound_idents: (pattern * expression) list -> Ident.t list
val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
val let_bound_idents: value_binding list -> Ident.t list
val rev_let_bound_idents: value_binding list -> Ident.t list
val let_bound_idents_with_loc:
(pattern * expression) list -> (Ident.t * string loc) list
val rev_let_bound_idents_with_loc:
(pattern * expression) list -> (Ident.t * string loc) list
value_binding list -> (Ident.t * string loc) list
(* Alpha conversion of patterns *)
val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern

20
typing/typedtreeIter.ml
View File

@ -71,8 +71,8 @@ module type IteratorArgument = sig
val leave_structure_item : structure_item -> unit
val enter_bindings : rec_flag -> unit
val enter_binding : pattern -> expression -> unit
val leave_binding : pattern -> expression -> unit
val enter_binding : value_binding -> unit
val leave_binding : value_binding -> unit
val leave_bindings : rec_flag -> unit
end
@ -102,11 +102,11 @@ module MakeIterator(Iter : IteratorArgument) : sig
Iter.leave_structure str
and iter_binding (pat, exp) =
Iter.enter_binding pat exp;
iter_pattern pat;
iter_expression exp;
Iter.leave_binding pat exp
and iter_binding vb =
Iter.enter_binding vb;
iter_pattern vb.vb_pat;
iter_expression vb.vb_expr;
Iter.leave_binding vb
and iter_bindings rec_flag list =
Iter.enter_bindings rec_flag;
@ -126,7 +126,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
begin
match item.str_desc with
Tstr_eval (exp, _attrs) -> iter_expression exp
| Tstr_value (rec_flag, list, _attrs) ->
| Tstr_value (rec_flag, list) ->
iter_bindings rec_flag list
| Tstr_primitive vd -> iter_value_description vd
| Tstr_type list -> List.iter iter_type_declaration list
@ -613,8 +613,8 @@ module DefaultIteratorArgument = struct
let leave_class_field _ = ()
let leave_structure_item _ = ()
let enter_binding _ _ = ()
let leave_binding _ _ = ()
let enter_binding _ = ()
let leave_binding _ = ()
let enter_bindings _ = ()
let leave_bindings _ = ()

4
typing/typedtreeIter.mli
View File

@ -65,8 +65,8 @@ module type IteratorArgument = sig
val leave_structure_item : structure_item -> unit
val enter_bindings : rec_flag -> unit
val enter_binding : pattern -> expression -> unit
val leave_binding : pattern -> expression -> unit
val enter_binding : value_binding -> unit
val leave_binding : value_binding -> unit
val leave_bindings : rec_flag -> unit
end

11
typing/typedtreeMap.ml
View File

@ -81,7 +81,12 @@ module MakeMap(Map : MapArgument) = struct
let str_items = List.map map_structure_item str.str_items in
Map.leave_structure { str with str_items = str_items }
and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
and map_binding vb =
{
vb_pat = map_pattern vb.vb_pat;
vb_expr = map_expression vb.vb_expr;
vb_attributes = vb.vb_attributes;
}
and map_bindings rec_flag list =
List.map map_binding list
@ -101,8 +106,8 @@ module MakeMap(Map : MapArgument) = struct
let str_desc =
match item.str_desc with
Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs)
| Tstr_value (rec_flag, list, attrs) ->
Tstr_value (rec_flag, map_bindings rec_flag list, attrs)
| Tstr_value (rec_flag, list) ->
Tstr_value (rec_flag, map_bindings rec_flag list)
| Tstr_primitive vd ->
Tstr_primitive (map_value_description vd)
| Tstr_type list ->

8
typing/typemod.ml
View File

@ -683,9 +683,9 @@ and closed_signature_item = function
let check_nongen_scheme env str =
match str.str_desc with
Tstr_value(rec_flag, pat_exp_list, _attrs) ->
Tstr_value(rec_flag, pat_exp_list) ->
List.iter
(fun (pat, exp) ->
(fun {vb_expr=exp} ->
if not (Ctype.closed_schema exp.exp_type) then
raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type)))
pat_exp_list
@ -996,7 +996,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let item = mk (Tstr_eval (expr, attrs)) 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, attrs) ->
| Pstr_value(rec_flag, sdefs) ->
let scope =
match rec_flag with
| Recursive -> Some (Annot.Idef {scope with
@ -1009,7 +1009,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, attrs)) in
let item = mk (Tstr_value(rec_flag, defs)) 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