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

Explicit representation of guards, get rid of Pexp_when. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13528 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-04-15 16:23:22 +00:00
parent c16b98ec9f
commit e7736899fb
33 changed files with 423 additions and 309 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.

10
bytecomp/translclass.ml
View File

@ -109,6 +109,12 @@ let create_object cl obj init =
[obj; Lvar obj'; Lvar cl]))))
end
let name_pattern default p =
match p.pat_desc with
| Tpat_var (id, _) -> id
| Tpat_alias(p, id, _) -> id
| _ -> Ident.create default
let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
@ -156,7 +162,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
in
(inh_init,
let build params rem =
let param = name_pattern "param" [pat, ()] in
let param = name_pattern "param" pat in
Lfunction (Curried, param::params,
Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial)
@ -396,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf =
| Tcl_fun (_, pat, _, cl, partial) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
let param = name_pattern "param" [pat, ()] in
let param = name_pattern "param" pat in
Lfunction (Curried, param::params,
Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial)

87
bytecomp/translcore.ml
View File

@ -493,7 +493,7 @@ let extract_float = function
let rec name_pattern default = function
[] -> Ident.create default
| (p, e) :: rem ->
| {c_lhs=p; _} :: rem ->
match p.pat_desc with
Tpat_var (id, _) -> id
| Tpat_alias(p, id, _) -> id
@ -501,25 +501,27 @@ let rec name_pattern default = function
(* Push the default values under the functional abstractions *)
let rec push_defaults loc bindings pat_expr_list partial =
match pat_expr_list with
[pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] ->
let rec push_defaults loc bindings cases partial =
match cases with
[{c_lhs=pat; c_guard=None;
c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] ->
let pl = push_defaults exp.exp_loc bindings pl partial in
[pat, {exp with exp_desc = Texp_function(l, pl, partial)}]
| [pat, {exp_attributes=["#default",_];
exp_desc = Texp_let
(Nonrecursive, cases, ({exp_desc = Texp_function _} as e2))}] ->
push_defaults loc (cases :: bindings) [pat, e2] partial
| [pat, exp] ->
[{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}]
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=["#default",_];
exp_desc = Texp_let
(Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial
| [case] ->
let exp =
List.fold_left
(fun exp cases ->
{exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
exp bindings
(fun exp binds ->
{exp with exp_desc = Texp_let(Nonrecursive, binds, exp)})
case.c_rhs bindings
in
[pat, exp]
| (pat, exp) :: _ when bindings <> [] ->
let param = name_pattern "param" pat_expr_list in
[{case with c_rhs=exp}]
| {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
let param = name_pattern "param" cases in
let name = Ident.name param in
let exp =
{ exp with exp_loc = loc; exp_desc =
@ -529,12 +531,12 @@ let rec push_defaults loc bindings pat_expr_list partial =
{val_type = pat.pat_type; val_kind = Val_reg;
Types.val_loc = Location.none;
})},
pat_expr_list, partial) }
cases, partial) }
in
push_defaults loc bindings
[{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total
[{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; c_guard=None; c_rhs=exp}] Total
| _ ->
pat_expr_list
cases
(* Insertion of debugging events *)
@ -771,10 +773,6 @@ and transl_exp0 e =
| Texp_for(param, _, low, high, dir, body) ->
Lfor(param, transl_exp low, transl_exp high, dir,
event_before body (transl_exp body))
| Texp_when(cond, body) ->
event_before cond
(Lifthenelse(transl_exp cond, event_before body (transl_exp body),
staticfail))
| Texp_send(_, _, Some exp) -> transl_exp exp
| Texp_send(expr, met, None) ->
let obj = transl_exp expr in
@ -876,13 +874,22 @@ and transl_exp0 e =
and transl_list expr_list =
List.map transl_exp expr_list
and transl_cases pat_expr_list =
List.map
(fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
pat_expr_list
and transl_guard guard rhs =
let expr = event_before rhs (transl_exp rhs) in
match guard with
| None -> expr
| Some cond ->
event_before cond (Lifthenelse(transl_exp cond, expr, staticfail))
and transl_case {c_lhs; c_guard; c_rhs} =
c_lhs, transl_guard c_guard c_rhs
and transl_cases cases =
List.map transl_case cases
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
patl_expr_list
and transl_apply lam sargs loc =
let lapply funct args =
@ -934,37 +941,39 @@ and transl_apply lam sargs loc =
in
build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs)
and transl_function loc untuplify_fn repr partial pat_expr_list =
match pat_expr_list with
[pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)]
and transl_function loc untuplify_fn repr partial cases =
match cases with
[{c_lhs=pat; c_guard=None;
c_rhs={exp_desc = Texp_function(_, pl,partial')} as exp}]
when Parmatch.fluid pat ->
let param = name_pattern "param" pat_expr_list in
let param = name_pattern "param" cases in
let ((_, params), body) =
transl_function exp.exp_loc false repr partial' pl in
((Curried, param :: params),
Matching.for_function loc None (Lvar param) [pat, body] partial)
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
| {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
begin try
let size = List.length pl in
let pats_expr_list =
List.map
(fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
pat_expr_list in
(fun {c_lhs; c_guard; c_rhs} ->
(Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
cases in
let params = List.map (fun p -> Ident.create "param") pl in
((Tupled, params),
Matching.for_tupled_function loc params
(transl_tupled_cases pats_expr_list) partial)
with Matching.Cannot_flatten ->
let param = name_pattern "param" pat_expr_list in
let param = name_pattern "param" cases in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list) partial)
(transl_cases cases) partial)
end
| _ ->
let param = name_pattern "param" pat_expr_list in
let param = name_pattern "param" cases in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list) partial)
(transl_cases cases) partial)
and transl_let rec_flag pat_expr_list body =
match rec_flag with

2
bytecomp/translcore.mli
View File

@ -17,8 +17,6 @@ open Asttypes
open Typedtree
open Lambda
val name_pattern: string -> (pattern * 'a) list -> Ident.t
val transl_exp: expression -> lambda
val transl_apply: lambda -> (label * expression option * optional) list
-> Location.t -> lambda

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

@ -778,15 +778,15 @@ value varify_constructors var_names =
| <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
mkexp loc
(Pexp_function lab None
[(patt_of_lab loc lab po, when_expr e w)])
[when_expr (patt_of_lab loc lab po) e w])
| <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> ->
let lab = paolab lab p in
mkexp loc
(Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)])
(Pexp_function ("?" ^ lab) (Some (expr e1)) [when_expr (patt p) e2 w])
| <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> ->
let lab = paolab lab p in
mkexp loc
(Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)])
(Pexp_function ("?" ^ lab) None [when_expr (patt_of_lab loc lab p) e w])
| ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a []))
| ExIfe loc e1 e2 e3 ->
mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
@ -931,13 +931,15 @@ value varify_constructors var_names =
match x with
[ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc)
| <:match_case< $pat:p$ when $w$ -> $e$ >> ->
[(patt p, when_expr e w) :: acc]
[when_expr (patt p) e w :: acc]
| <:match_case<>> -> acc
| _ -> assert False ]
and when_expr e w =
match w with
[ <:expr<>> -> expr e
| w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ]
and when_expr p e w =
let g = match w with
[ <:expr<>> -> None
| g -> Some (expr g) ]
in
{pc_lhs = p; pc_guard = g; pc_rhs = expr e}
and mklabexp x acc =
match x with
[ <:rec_binding< $x$; $y$ >> ->

19
camlp4/boot/Camlp4.ml
View File

@ -15035,21 +15035,21 @@ module Struct =
->
mkexp loc
(Pexp_function (lab, None,
[ ((patt_of_lab loc lab po), (when_expr e w)) ]))
[ when_expr (patt_of_lab loc lab po) e w ]))
| Ast.ExFun (loc,
(Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) ->
let lab = paolab lab p
in
mkexp loc
(Pexp_function (("?" ^ lab), (Some (expr e1)),
[ ((patt p), (when_expr e2 w)) ]))
[ when_expr (patt p) e2 w ]))
| Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e)))
->
let lab = paolab lab p
in
mkexp loc
(Pexp_function (("?" ^ lab), None,
[ ((patt_of_lab loc lab p), (when_expr e w)) ]))
[ when_expr (patt_of_lab loc lab p) e w ]))
| ExFun (loc, a) ->
mkexp loc (Pexp_function ("", None, (match_case a [])))
| ExIfe (loc, e1, e2, e3) ->
@ -15240,13 +15240,16 @@ module Struct =
and match_case x acc =
match x with
| Ast.McOr (_, x, y) -> match_case x (match_case y acc)
| Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc
| Ast.McArr (_, p, w, e) -> when_expr (patt p) e w :: acc
| Ast.McNil _ -> acc
| _ -> assert false
and when_expr e w =
match w with
| Ast.ExNil _ -> expr e
| w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e)))
and when_expr p e w =
let g =
match w with
| Ast.ExNil _ -> None
| w -> Some (expr w)
in
{pc_lhs = p; pc_guard = g; pc_rhs = expr e}
and mklabexp x acc =
match x with
| Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc)

17
experimental/frisch/extension_points.txt
View File

@ -404,6 +404,23 @@ As in the Typedtree.
+ | Cfk_concrete of override_flag * expression
+
--- Explicit representation of "when" guards
Replaced the "(pattern * expression) list" argument of Pexp_function, Pexp_match, Pexp_try
with "case list", with case defined as:
{
pc_lhs: pattern;
pc_guard: expression option;
pc_rhs: expression;
}
and get rid of Pexp_when. Idem in the Typedtree.
Rationale:
- Make it explicit when the guard can appear.
=== More TODOs

8
ocamldoc/odoc_ast.ml
View File

@ -297,13 +297,13 @@ module Analyser =
(* This case means we have a 'function' without pattern, that's impossible *)
raise (Failure "tt_analyse_function_parameters: 'function' without pattern")
| (pattern_param, exp) :: second_ele :: q ->
| {c_lhs=pattern_param} :: second_ele :: q ->
(* implicit pattern matching -> anonymous parameter and no more parameter *)
(* A VOIR : le label ? *)
let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in
[ parameter ]
| (pattern_param, func_body) :: [] ->
| {c_lhs=pattern_param; c_rhs=func_body} :: [] ->
let parameter =
tt_param_info_from_pattern
env
@ -451,7 +451,7 @@ module Analyser =
[] ->
(* cas impossible, on l'a filtre avant *)
assert false
| (pattern_param, exp) :: second_ele :: q ->
| {c_lhs=pattern_param} :: second_ele :: q ->
(* implicit pattern matching -> anonymous parameter *)
(* Note : We can't match this pattern if it is the first call to the function. *)
let new_param = Simple_name
@ -460,7 +460,7 @@ module Analyser =
in
[ new_param ]
| (pattern_param, body) :: [] ->
| {c_lhs=pattern_param; c_rhs=body} :: [] ->
(* if this is the first call to the function, this is the first parameter and we skip it *)
if not first then
(

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

@ -729,6 +729,14 @@ and search_pos_class_expr ~pos cl =
~env:!start_env ~loc:cl.cl_loc
end
and search_case ~pos {c_lhs; c_guard; c_rhs} =
search_pos_pat c_lhs ~pos ~env:c_rhs.exp_env;
begin match c_guard with
| None -> ()
| Some g -> search_pos_expr g ~pos
end;
search_pos_expr c_rhs ~pos
and search_pos_expr ~pos exp =
if in_loc exp.exp_loc ~pos then begin
begin match exp.exp_desc with
@ -746,28 +754,16 @@ and search_pos_expr ~pos exp =
end;
search_pos_expr exp ~pos
| Texp_function (_, l, _) ->
List.iter l ~f:
begin fun (pat, exp) ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end
List.iter l ~f:(search_case ~pos)
| Texp_apply (exp, l) ->
List.iter l ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x);
search_pos_expr exp ~pos
| Texp_match (exp, l, _) ->
search_pos_expr exp ~pos;
List.iter l ~f:
begin fun (pat, exp) ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end
List.iter l ~f:(search_case ~pos)
| Texp_try (exp, l) ->
search_pos_expr exp ~pos;
List.iter l ~f:
begin fun (pat, exp) ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end
List.iter l ~f:(search_case ~pos)
| Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_construct (_, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_variant (_, None) -> ()
@ -790,8 +786,6 @@ and search_pos_expr ~pos exp =
search_pos_expr a ~pos; search_pos_expr b ~pos
| Texp_for (_, _, a, b, _, c) ->
List.iter [a;b;c] ~f:(search_pos_expr ~pos)
| Texp_when (a, b) ->
search_pos_expr a ~pos; search_pos_expr b ~pos
| Texp_send (exp, _, _) -> search_pos_expr exp ~pos
| Texp_new (path, _, _) ->
add_found_str (`Exp(`New path, exp.exp_type))

12
parsing/ast_helper.ml
View File

@ -95,7 +95,6 @@ module Exp = struct
let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b))
let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e))
let constraint_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_constraint (a, b, c))
let when_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_when (a, b))
let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b))
let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a)
let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
@ -110,6 +109,13 @@ module Exp = struct
let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a)
let case lhs ?guard rhs =
{
pc_lhs = lhs;
pc_guard = guard;
pc_rhs = rhs;
}
end
module Mty = struct
@ -376,8 +382,8 @@ module Convenience = struct
let float x = Exp.constant (Const_float (string_of_float x))
let record ?over l =
Exp.record (List.map (fun (s, e) -> (lid s, e)) l) over
let func l = Exp.function_ "" None l
let lam ?(label = "") ?default pat exp = Exp.function_ label default [pat, exp]
let func l = Exp.function_ "" None (List.map (fun (p, e) -> Exp.case p e) l)
let lam ?(label = "") ?default pat exp = Exp.function_ label default [{pc_lhs=pat; pc_guard=None; pc_rhs=exp}]
let app f l = Exp.apply f (List.map (fun a -> "", a) l)
let evar s = Exp.ident (lid s)
let let_in ?(recursive = false) b body =

9
parsing/ast_helper.mli
View File

@ -75,10 +75,10 @@ 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 function_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> (pattern * expression) list -> expression
val function_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> case list -> expression
val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression
val match_: ?loc:loc -> ?attrs:attrs -> expression -> (pattern * expression) list -> expression
val try_: ?loc:loc -> ?attrs:attrs -> expression -> (pattern * expression) list -> expression
val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> bool -> expression
val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression
@ -91,7 +91,6 @@ module Exp:
val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
val for_: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression -> direction_flag -> expression -> expression
val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> core_type option -> expression
val when_: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression
val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression
val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
@ -106,6 +105,8 @@ module Exp:
val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
val open_: ?loc:loc -> ?attrs:attrs -> lid -> expression -> expression
val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
val case: pattern -> ?guard:expression -> expression -> case
end
module Mty:
sig

14
parsing/ast_mapper.ml
View File

@ -189,6 +189,13 @@ module E = struct
let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
let map_case sub {pc_lhs; pc_guard; pc_rhs} =
{
pc_lhs = sub # pat pc_lhs;
pc_guard = map_opt (sub # expr) pc_guard;
pc_rhs = sub # expr pc_rhs;
}
let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
let open Exp in
let loc = sub # location loc in
@ -197,10 +204,10 @@ module E = struct
| 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_function (lab, def, pel) -> function_ ~loc ~attrs lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
| Pexp_function (lab, def, pel) -> function_ ~loc ~attrs lab (map_opt (sub # expr) def) (List.map (map_case sub) pel)
| Pexp_apply (e, l) -> apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
| Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
| Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
| Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
| Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
| Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el)
| Pexp_construct (lid, arg, b) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) b
| Pexp_variant (lab, eo) -> variant ~loc ~attrs lab (map_opt (sub # expr) eo)
@ -213,7 +220,6 @@ module E = struct
| Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
| Pexp_for (id, e1, e2, d, e3) -> for_ ~loc ~attrs (map_loc sub id) (sub # expr e1) (sub # expr e2) d (sub # expr e3)
| Pexp_constraint (e, t1, t2) -> constraint_ ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) (map_opt (sub # typ) t2)
| Pexp_when (e1, e2) -> when_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
| Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s
| Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
| Pexp_setinstvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e)

28
parsing/parser.mly
View File

@ -1034,7 +1034,8 @@ expr:
| FUNCTION ext_attributes opt_bar match_cases
{ mkexp_attrs (Pexp_function("", None, List.rev $4)) $2 }
| FUN ext_attributes labeled_simple_pattern fun_def
{ let (l,o,p) = $3 in mkexp_attrs (Pexp_function(l, o, [p, $4])) $2 }
{ let (l,o,p) = $3 in
mkexp_attrs (Pexp_function(l, o, [Exp.case p $4])) $2 }
| FUN ext_attributes LPAREN TYPE LIDENT RPAREN fun_def
{ mkexp_attrs (Pexp_newtype($5, $7)) $2 }
| MATCH ext_attributes seq_expr WITH opt_bar match_cases
@ -1261,25 +1262,32 @@ strict_binding:
EQUAL seq_expr
{ $2 }
| labeled_simple_pattern fun_binding
{ let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
{ let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [Exp.case p $2])) }
| LPAREN TYPE LIDENT RPAREN fun_binding
{ mkexp(Pexp_newtype($3, $5)) }
;
match_cases:
pattern match_action { [$1, $2] }
| match_cases BAR pattern match_action { ($3, $4) :: $1 }
match_case { [$1] }
| match_cases BAR match_case { $3 :: $1 }
;
match_case:
pattern MINUSGREATER seq_expr
{ Exp.case $1 $3 }
| pattern WHEN seq_expr MINUSGREATER seq_expr
{ Exp.case $1 ~guard:$3 $5 }
;
fun_def:
match_action { $1 }
MINUSGREATER seq_expr { $2 }
/* Cf #5939: we used to accept (fun p when e0 -> e) */
| labeled_simple_pattern fun_def
{ let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
{
let (l,o,p) = $1 in
let case = Exp.case p $2 in
ghexp(Pexp_function(l, o, [case]))
}
| LPAREN TYPE LIDENT RPAREN fun_def
{ mkexp(Pexp_newtype($3, $5)) }
;
match_action:
MINUSGREATER seq_expr { $2 }
| WHEN seq_expr MINUSGREATER seq_expr { ghexp(Pexp_when($2, $4)) }
;
expr_comma_list:
expr_comma_list COMMA expr { $3 :: $1 }
| expr COMMA expr { [$3; $1] }

27
parsing/parsetree.mli
View File

@ -194,8 +194,7 @@ and expression_desc =
(* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
*)
| Pexp_function of label * expression option *
(pattern * guarded_expression) list
| Pexp_function of label * expression option * case list
(* function P1 -> E1 | ... | Pn -> En (lab = "", None)
fun P1 -> E1 (lab = "", None)
fun ~l:P1 -> E1 (lab = "l", None)
@ -203,18 +202,19 @@ and expression_desc =
fun ?l:(P1 = E0) -> E1 (lab = "?l", Some E0)
Notes:
- n >= 1
- There is no concrete syntax if n >= 2 and lab <> ""
- If E0 is provided, lab must start with '?'
- n >= 1.
- There is no concrete syntax if n >= 2 and lab <> "".
- If E0 is provided, lab must start with '?'.
- Guards are only possible if lab = "".
*)
| Pexp_apply of expression * (label * expression) list
(* E0 ~l1:E1 ... ~ln:En
li can be empty (non labeled argument) or start with '?'
(optional argument).
*)
| Pexp_match of expression * (pattern * guarded_expression) list
| Pexp_match of expression * case list
(* match E0 with P1 -> E1 | ... | Pn -> En *)
| Pexp_try of expression * (pattern * guarded_expression) list
| Pexp_try of expression * case list
(* try E0 with P1 -> E1 | ... | Pn -> En *)
| Pexp_tuple of expression list
(* (E1, ..., En) (n >= 2) *)
@ -258,10 +258,6 @@ and expression_desc =
Invariant: one of the two types must be provided
(otherwise this is currently accepted as equivalent to just E).
*)
| Pexp_when of expression * expression
(* ... when E1 -> E2
This node can occur only in contexts marked as guarded_expression.
*)
| Pexp_send of expression * string
(* E # m *)
| Pexp_new of Longident.t loc
@ -298,9 +294,12 @@ and expression_desc =
| Pexp_extension of extension
(* [%id E] *)
and guarded_expression = expression
(* This type abbreviation is used to mark contexts where Pexp_when
can be used. *)
and case = (* (P -> E) or (P when E0 -> E) *)
{
pc_lhs: pattern;
pc_guard: expression option;
pc_rhs: expression;
}
(* Value descriptions *)

23
parsing/pprintast.ml
View File

@ -531,6 +531,9 @@ class printer ()= object(self:'self)
| Pexp_let _ | Pexp_letmodule _ when semi ->
self#paren true self#reset#expression f x
| Pexp_function _(* (p, eo, l) *) ->
assert false
(* TODO *)
(*
let rec aux acc = function
| {pexp_desc = Pexp_function (l,eo, [(p',e')]);_}
-> aux ((l,eo,p')::acc) e'
@ -550,6 +553,8 @@ class printer ()= object(self:'self)
(fun f (l,eo,p) ->
self#label_exp f (l,eo,p))) ls
self#expression e end
*)
| Pexp_match (e, l) ->
pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" self#reset#expression e self#case_list l
@ -612,7 +617,6 @@ class printer ()= object(self:'self)
let lst = sequence_helper [] x in
pp f "@[<hv>%a@]"
(self#list self#under_semi#expression ~sep:";@;") lst
| Pexp_when (_e1, _e2) -> assert false (*FIXME handled already in pattern *)
| Pexp_new (li) ->
pp f "@[<hov2>new@ %a@]" self#longident_loc li;
| Pexp_setinstvar (s, e) ->
@ -977,23 +981,20 @@ class printer ()= object(self:'self)
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
| Pexp_function (label,eo,[(p,e)]) ->
(* | Pexp_function (label,eo,[(p,e)]) -> (* TODO *)
if label="" then
match e.pexp_desc with
| Pexp_when _ -> pp f "=@;%a" self#expression x
| _ ->
pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
else
pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e *)
| Pexp_newtype (str,e) ->
pp f "(type@ %s)@ %a" str pp_print_pexp_function e
| _ -> pp f "=@;%a" self#expression x in
if x.pexp_attributes <> [] then
pp f "%a@;=@;%a" self#pattern p self#expression x
else match (x.pexp_desc,p.ppat_desc) with
| (Pexp_when (e1,e2),_) ->
pp f "=@[<2>fun@ %a@ when@ %a@ ->@ %a@]"
self#simple_pattern p self#expression e1 self#expression e2
| ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
(match ty.ptyp_desc with
| Ptyp_poly _ ->
@ -1192,14 +1193,10 @@ class printer ()= object(self:'self)
self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ;
(* TODO: attributes *)
end
method case_list f (l:(pattern * expression) list) :unit=
let aux f (p,e) =
let (e,w) =
(match e with
| {pexp_desc = Pexp_when (e1, e2);_} -> (e2, Some (e1))
| _ -> (e, None)) in
method case_list f l : unit =
let aux f {pc_lhs; pc_guard; pc_rhs} =
pp f "@;| @[<2>%a%a@;->@;%a@]"
self#pattern p (self#option self#expression ~first:"@;when@;") w self#under_pipe#expression e in
self#pattern pc_lhs (self#option self#expression ~first:"@;when@;") pc_guard self#under_pipe#expression pc_rhs in
self#list aux f l ~sep:""
method label_x_expression_param f (l,e) =
match l with

3
parsing/pprintast.mli
View File

@ -23,8 +23,7 @@ class printer :
Asttypes.rec_flag * (Parsetree.pattern * Parsetree.expression) list ->
unit
method case_list :
Format.formatter ->
(Parsetree.pattern * Parsetree.expression) list -> unit
Format.formatter -> Parsetree.case list -> unit
method class_expr : Format.formatter -> Parsetree.class_expr -> unit
method class_field : Format.formatter -> Parsetree.class_field -> unit
method class_params_def :

20
parsing/printast.ml
View File

@ -245,7 +245,7 @@ and expression i ppf x =
| Pexp_function (p, eo, l) ->
line i ppf "Pexp_function \"%s\"\n" p;
option i expression ppf eo;
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Pexp_apply (e, l) ->
line i ppf "Pexp_apply\n";
expression i ppf e;
@ -253,11 +253,11 @@ and expression i ppf x =
| Pexp_match (e, l) ->
line i ppf "Pexp_match\n";
expression i ppf e;
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Pexp_try (e, l) ->
line i ppf "Pexp_try\n";
expression i ppf e;
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Pexp_tuple (l) ->
line i ppf "Pexp_tuple\n";
list i expression ppf l;
@ -307,10 +307,6 @@ and expression i ppf x =
expression i ppf e;
option i core_type ppf cto1;
option i core_type ppf cto2;
| Pexp_when (e1, e2) ->
line i ppf "Pexp_when\n";
expression i ppf e1;
expression i ppf e2;
| Pexp_send (e, s) ->
line i ppf "Pexp_send \"%s\"\n" s;
expression i ppf e;
@ -771,10 +767,14 @@ and longident_x_pattern i ppf (li, p) =
line i ppf "%a\n" fmt_longident_loc li;
pattern (i+1) ppf p;
and pattern_x_expression_case i ppf (p, e) =
and case i ppf {pc_lhs; pc_guard; pc_rhs} =
line i ppf "<case>\n";
pattern (i+1) ppf p;
expression (i+1) ppf e;
pattern (i+1) ppf pc_lhs;
begin match pc_guard with
| None -> ()
| Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
end;
expression (i+1) ppf pc_rhs;
and pattern_x_expression_def i ppf (p, e) =
line i ppf "<def>\n";

10
tools/cmt2annot.ml
View File

@ -32,7 +32,15 @@ let bind_bindings scope bindings =
List.iter (fun (p, _) -> o # pattern p) bindings
let bind_cases l =
List.iter (fun (p, e) -> (bind_variables e.exp_loc) # pattern p) l
List.iter
(fun {c_lhs; c_guard; c_rhs} ->
let loc =
let open Location in
match c_guard with
| None -> c_rhs.exp_loc
| Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start}
in
(bind_variables loc) # pattern c_lhs) l
let iterator rebuild_env =
object(this)

16
tools/depend.ml
View File

@ -136,11 +136,11 @@ let rec add_expr bv exp =
| Pexp_let(rf, pel, e) ->
let bv = add_bindings rf bv pel in add_expr bv e
| Pexp_function (_, opte, pel) ->
add_opt add_expr bv opte; add_pat_expr_list bv pel
add_opt add_expr bv opte; add_cases bv pel
| Pexp_apply(e, el) ->
add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
| Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
| Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
| Pexp_tuple el -> List.iter (add_expr bv) el
| Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte
| Pexp_variant(_, opte) -> add_opt add_expr bv opte
@ -160,7 +160,6 @@ let rec add_expr bv exp =
add_expr bv e1;
add_opt add_type bv oty2;
add_opt add_type bv oty3
| Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2
| Pexp_send(e, m) -> add_expr bv e
| Pexp_new li -> add bv li
| Pexp_setinstvar(v, e) -> add_expr bv e
@ -178,8 +177,13 @@ let rec add_expr bv exp =
| Pexp_open (m, e) -> addmodule bv m; add_expr bv e
| Pexp_extension _ -> ()
and add_pat_expr_list bv pel =
List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel
and add_cases bv cases =
List.iter (add_case bv) cases
and add_case bv {pc_lhs; pc_guard; pc_rhs} =
let bv = add_pattern bv pc_lhs in
add_opt add_expr bv pc_guard;
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

39
tools/ocamlprof.ml
View File

@ -150,8 +150,16 @@ let final_rewrite add_function =
let rec rewrite_patexp_list iflag l =
rewrite_exp_list iflag (List.map snd l)
and rewrite_patlexp_list iflag l =
rewrite_exp_list iflag (List.map snd l)
and rewrite_cases iflag l =
List.iter
(fun pc ->
begin match pc.pc_guard with
| None -> ()
| Some g -> rewrite_exp iflag g
end;
rewrite_exp iflag pc.pc_rhs
)
l
and rewrite_labelexp_list iflag l =
rewrite_exp_list iflag (List.map snd l)
@ -176,21 +184,21 @@ and rw_exp iflag sexp =
if !instr_fun then
rewrite_function iflag caselist
else
rewrite_patlexp_list iflag caselist
rewrite_cases iflag caselist
| Pexp_match(sarg, caselist) ->
rewrite_exp iflag sarg;
if !instr_match && not sexp.pexp_loc.loc_ghost then
rewrite_funmatching caselist
else
rewrite_patlexp_list iflag caselist
rewrite_cases iflag caselist
| Pexp_try(sbody, caselist) ->
rewrite_exp iflag sbody;
if !instr_try && not sexp.pexp_loc.loc_ghost then
rewrite_trymatching caselist
else
rewrite_patexp_list iflag caselist
rewrite_cases iflag caselist
| Pexp_apply(sfunct, sargs) ->
rewrite_exp iflag sfunct;
@ -251,10 +259,6 @@ and rw_exp iflag sexp =
| Pexp_constraint(sarg, _, _) ->
rewrite_exp iflag sarg
| Pexp_when(scond, sbody) ->
rewrite_exp iflag scond;
rewrite_exp iflag sbody
| Pexp_send (sobj, _) ->
rewrite_exp iflag sobj
@ -295,23 +299,24 @@ and rewrite_ifbody iflag ghost sifbody =
and rewrite_annotate_exp_list l =
List.iter
(function
| {pexp_desc = Pexp_when(scond, sbody)}
-> insert_profile rw_exp scond;
insert_profile rw_exp sbody;
| {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *)
| {pc_guard=Some scond; pc_rhs=sbody} ->
insert_profile rw_exp scond;
insert_profile rw_exp sbody;
| {pc_rhs={pexp_desc = Pexp_constraint(sbody, _, _)}} (* let f x : t = e *)
-> insert_profile rw_exp sbody
| sexp -> insert_profile rw_exp sexp)
| {pc_rhs=sexp} -> insert_profile rw_exp sexp)
l
and rewrite_function iflag = function
| [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp
| [{pc_lhs=spat; pc_guard=None;
pc_rhs={pexp_desc = Pexp_function _} as sexp}] -> rewrite_exp iflag sexp
| l -> rewrite_funmatching l
and rewrite_funmatching l =
rewrite_annotate_exp_list (List.map snd l)
rewrite_annotate_exp_list l
and rewrite_trymatching l =
rewrite_annotate_exp_list (List.map snd l)
rewrite_annotate_exp_list l
(* Rewrite a class definition *)

24
tools/tast_iter.ml
View File

@ -10,7 +10,6 @@
(* *)
(***********************************************************************)
open Asttypes
open Typedtree
let opt f = function None -> () | Some x -> f x
@ -93,16 +92,16 @@ let expression sub exp =
sub # bindings (rec_flag, list);
sub # expression exp
| Texp_function (_, cases, _) ->
sub # bindings (Nonrecursive, cases)
sub # cases cases
| Texp_apply (exp, list) ->
sub # expression exp;
List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
| Texp_match (exp, list, _) ->
| Texp_match (exp, cases, _) ->
sub # expression exp;
sub # bindings (Nonrecursive, list)
| Texp_try (exp, list) ->
sub # cases cases
| Texp_try (exp, cases) ->
sub # expression exp;
sub # bindings (Nonrecursive, list)
sub # cases cases
| Texp_tuple list ->
List.iter (sub # expression) list
| Texp_construct (_, _, args, _) ->
@ -133,9 +132,6 @@ let expression sub exp =
sub # expression exp1;
sub # expression exp2;
sub # expression exp3
| Texp_when (exp1, exp2) ->
sub # expression exp1;
sub # expression exp2
| Texp_send (exp, _meth, expo) ->
sub # expression exp;
opt (sub # expression) expo
@ -331,6 +327,14 @@ let class_field sub cf =
let bindings sub (_rec_flag, list) =
List.iter (sub # binding) list
let cases sub l =
List.iter (sub # case) l
let case sub {c_lhs; c_guard; c_rhs} =
sub # pattern c_lhs;
opt (sub # expression) c_guard;
sub # expression c_rhs
let binding sub (pat, exp) =
sub # pattern pat;
sub # expression exp
@ -338,6 +342,8 @@ let binding sub (pat, exp) =
class iter = object(this)
method binding = binding this
method bindings = bindings this
method case = case this
method cases = cases this
method class_description = class_description this
method class_expr = class_expr this
method class_field = class_field this

2
tools/tast_iter.mli
View File

@ -16,6 +16,8 @@ open Typedtree
class iter: object
method binding: (pattern * expression) -> unit
method bindings: (rec_flag * (pattern * expression) list) -> unit
method case: case -> unit
method cases: case list -> unit
method class_description: class_description -> unit
method class_expr: class_expr -> unit
method class_field: class_field -> unit

27
tools/untypeast.ml
View File

@ -210,6 +210,15 @@ and untype_extra (extra, loc, attrs) sexp =
in
Exp.mk ~loc ~attrs desc
and untype_cases l = List.map untype_case l
and untype_case {c_lhs; c_guard; c_rhs} =
{
pc_lhs = untype_pattern c_lhs;
pc_guard = option untype_expression c_guard;
pc_rhs = untype_expression c_rhs;
}
and untype_expression exp =
let desc =
match exp.exp_desc with
@ -221,9 +230,7 @@ and untype_expression exp =
untype_pattern pat, untype_expression exp) list,
untype_expression exp)
| Texp_function (label, cases, _) ->
Pexp_function (label, None,
List.map (fun (pat, exp) ->
(untype_pattern pat, untype_expression exp)) cases)
Pexp_function (label, None, untype_cases cases)
| Texp_apply (exp, list) ->
Pexp_apply (untype_expression exp,
List.fold_right (fun (label, expo, _) list ->
@ -231,14 +238,10 @@ and untype_expression exp =
None -> list
| Some exp -> (label, untype_expression exp) :: list
) list [])
| Texp_match (exp, list, _) ->
Pexp_match (untype_expression exp,
List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list)
| Texp_try (exp, list) ->
Pexp_try (untype_expression exp,
List.map (fun (pat, exp) ->
untype_pattern pat, untype_expression exp) list)
| Texp_match (exp, cases, _) ->
Pexp_match (untype_expression exp, untype_cases cases)
| Texp_try (exp, cases) ->
Pexp_try (untype_expression exp, untype_cases cases)
| Texp_tuple list ->
Pexp_tuple (List.map untype_expression list)
| Texp_construct (lid, _, args, explicit_arity) ->
@ -276,8 +279,6 @@ and untype_expression exp =
Pexp_for (name,
untype_expression exp1, untype_expression exp2,
dir, untype_expression exp3)
| Texp_when (exp1, exp2) ->
Pexp_when (untype_expression exp1, untype_expression exp2)
| Texp_send (exp, meth, _) ->
Pexp_send (untype_expression exp, match meth with
Tmeth_name name -> name

23
typing/parmatch.ml
View File

@ -1641,19 +1641,10 @@ let pressure_variants tdefs patl =
about guarded patterns
*)
let has_guard act = match act.exp_desc with
| Texp_when(_, _) -> true
| _ -> false
let rec initial_matrix = function
[] -> []
| (pat, act) :: rem ->
if has_guard act
then
initial_matrix rem
else
[pat] :: initial_matrix rem
| {c_guard=Some _} :: rem -> initial_matrix rem
| {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem
(******************************************)
(* Look for a row that matches some value *)
@ -1675,8 +1666,8 @@ let rec initial_all no_guard = function
raise NoGuard
else
[]
| (pat, act) :: rem ->
([pat], pat.pat_loc) :: initial_all (no_guard && not (has_guard act)) rem
| {c_lhs=pat; c_guard; _} :: rem ->
([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem
let rec do_filter_var = function
@ -1957,7 +1948,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
let do_check_fragile_param exhaust loc casel pss =
let exts =
List.fold_left
(fun r (p,_) -> collect_paths_from_pat r p)
(fun r c -> collect_paths_from_pat r c.c_lhs)
[] casel in
match exts with
| [] -> ()
@ -1985,7 +1976,7 @@ let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
| [] -> ()
| (q,act)::rem ->
| {c_lhs=q; c_guard} :: rem ->
let qs = [q] in
begin try
let pss =
@ -2005,7 +1996,7 @@ let check_unused tdefs casel =
with Empty | Not_an_adt | Not_found | NoGuard -> assert false
end ;
if has_guard act then
if c_guard <> None then
do_rec pref rem
else
do_rec ([q]::pref) rem in

6
typing/parmatch.mli
View File

@ -53,13 +53,13 @@ val complete_constrs :
pattern -> constructor_tag list -> constructor_description list
val pressure_variants: Env.t -> pattern list -> unit
val check_partial: Location.t -> (pattern * expression) list -> partial
val check_partial: Location.t -> case list -> partial
val check_partial_gadt:
((string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
Location.t -> case list -> partial
val check_unused: Env.t -> case list -> unit
(* Irrefutability tests *)
val irrefutable : pattern -> bool

20
typing/printtyped.ml
View File

@ -281,7 +281,7 @@ and expression i ppf x =
| Texp_function (p, l, _partial) ->
line i ppf "Pexp_function \"%s\"\n" p;
(* option i expression ppf eo; *)
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Texp_apply (e, l) ->
line i ppf "Pexp_apply\n";
expression i ppf e;
@ -289,11 +289,11 @@ and expression i ppf x =
| Texp_match (e, l, partial) ->
line i ppf "Pexp_match\n";
expression i ppf e;
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Texp_try (e, l) ->
line i ppf "Pexp_try\n";
expression i ppf e;
list i pattern_x_expression_case ppf l;
list i case ppf l;
| Texp_tuple (l) ->
line i ppf "Pexp_tuple\n";
list i expression ppf l;
@ -338,10 +338,6 @@ and expression i ppf x =
expression i ppf e1;
expression i ppf e2;
expression i ppf e3;
| Texp_when (e1, e2) ->
line i ppf "Pexp_when\n";
expression i ppf e1;
expression i ppf e2;
| Texp_send (e, Tmeth_name s, eo) ->
line i ppf "Pexp_send \"%s\"\n" s;
expression i ppf e;
@ -770,10 +766,14 @@ and longident_x_pattern i ppf (li, _, p) =
line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
and pattern_x_expression_case i ppf (p, e) =
and case i ppf {c_lhs; c_guard; c_rhs} =
line i ppf "<case>\n";
pattern (i+1) ppf p;
expression (i+1) ppf e;
pattern (i+1) ppf c_lhs;
begin match c_guard with
| None -> ()
| Some g -> line (i+1) ppf "<when>\n"; expression (i + 2) ppf g
end;
expression (i+1) ppf c_rhs;
and pattern_x_expression_def i ppf (p, e) =
line i ppf "<def>\n";

41
typing/typeclass.ml
View File

@ -344,8 +344,9 @@ let make_method loc cl_num expr =
let mkid s = mkloc s loc in
Exp.function_ ~loc:expr.pexp_loc "" None
[
Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)),
expr
Exp.case
(Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
expr
]
@ -855,17 +856,19 @@ and class_expr cl_num val_env met_env scl =
let loc = default.pexp_loc in
let open Ast_helper in
let scases = [
Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
(Some (Pat.var ~loc (mknoloc "*sth*")))
false,
Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"));
Exp.case
(Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
(Some (Pat.var ~loc (mknoloc "*sth*")))
false)
(Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
None
false,
default;
Exp.case
(Pat.construct ~loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
None
false)
default;
]
in
let smatch =
@ -912,12 +915,14 @@ and class_expr cl_num val_env met_env scl =
in
let partial =
Parmatch.check_partial pat.pat_loc
[pat, (* Dummy expression *)
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.none;
exp_attributes = [];
exp_env = Env.empty }]
[{c_lhs=pat;
c_guard=None;
c_rhs = (* Dummy expression *)
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none; exp_extra = [];
exp_type = Ctype.none;
exp_attributes = [];
exp_env = Env.empty }}]
in
Ctype.raise_nongen_level ();
let cl = class_expr cl_num val_env' met_env scl' in

130
typing/typecore.ml
View File

@ -109,6 +109,9 @@ let rp node =
let snd3 (_,x,_) = x
let case lhs rhs =
{c_lhs = lhs; c_guard = None; c_rhs = rhs}
(* Upper approximation of free identifiers on the parse tree *)
let iter_expression f e =
@ -122,11 +125,11 @@ let iter_expression f e =
| Pexp_new _
| Pexp_constant _ -> ()
| Pexp_function (_, eo, pel) ->
may expr eo; List.iter (fun (_, e) -> expr e) pel
may expr eo; List.iter case pel
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
| Pexp_let (_, pel, e)
| Pexp_let (_, pel, e) -> expr e; List.iter (fun (_, e) -> expr e) pel
| Pexp_match (e, pel)
| Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
| Pexp_try (e, pel) -> expr e; List.iter case pel
| Pexp_array el
| Pexp_tuple el -> List.iter expr el
| Pexp_construct (_, eo, _)
@ -142,7 +145,6 @@ let iter_expression f e =
| Pexp_send (e, _)
| Pexp_constraint (e, _, _)
| Pexp_field (e, _) -> expr e
| Pexp_when (e1, e2)
| Pexp_while (e1, e2)
| Pexp_sequence (e1, e2)
| Pexp_setfield (e1, _, e2) -> expr e1; expr e2
@ -153,6 +155,10 @@ let iter_expression f e =
| Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
| Pexp_pack me -> module_expr me
and case {pc_lhs = _; pc_guard; pc_rhs} =
may expr pc_guard;
expr pc_rhs
and module_expr me =
match me.pmod_desc with
| Pmod_extension _
@ -208,14 +214,19 @@ let iter_expression f e =
expr e
let all_idents el =
let all_idents_cases el =
let idents = Hashtbl.create 8 in
let f = function
| {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
Hashtbl.replace idents id ()
| _ -> ()
in
List.iter (iter_expression f) el;
List.iter
(fun cp ->
may (iter_expression f) cp.pc_guard;
iter_expression f cp.pc_rhs
)
el;
Hashtbl.fold (fun x () rest -> x :: rest) idents []
@ -1272,7 +1283,7 @@ let rec final_subexpression sexp =
| Pexp_sequence (_, e)
| Pexp_try (e, _)
| Pexp_ifthenelse (_, e, _)
| Pexp_match (_, (_, e) :: _)
| Pexp_match (_, {pc_rhs=e} :: _)
-> final_subexpression e
| _ -> sexp
@ -1586,11 +1597,11 @@ let rec approx_type env sty =
let rec type_approx env sexp =
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
| Pexp_function (p,_,(_,e)::_) when is_optional p ->
| Pexp_function (p,_,{pc_rhs=e}::_) when is_optional p ->
newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
| Pexp_function (p,_,(_,e)::_) ->
| Pexp_function (p,_,{pc_rhs=e}::_) ->
newty (Tarrow(p, newvar (), type_approx env e, Cok))
| Pexp_match (_, (_,e)::_) -> type_approx env e
| Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
| Pexp_try (e, _) -> type_approx env e
| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
| Pexp_ifthenelse (_,e,_) -> type_approx env e
@ -1775,8 +1786,8 @@ let check_absent_variant env =
let duplicate_ident_types loc caselist env =
let caselist =
List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
let idents = all_idents (List.map snd caselist) in
List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
let idents = all_idents_cases caselist in
List.fold_left
(fun env s ->
try
@ -1882,7 +1893,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_env = env }
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
type_expect ?in_function env
{sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
{sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let scp =
@ -1901,21 +1912,24 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_function (l, Some default, [spat, sbody]) ->
| Pexp_function (l, Some default, [{pc_lhs;pc_guard;pc_rhs}]) ->
assert(pc_guard = None); (* fun ~l:p when e0 -> e is no longer allowed *)
let open Ast_helper in
let default_loc = default.pexp_loc in
let scases = [
Pat.construct ~loc:default_loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
(Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))
false,
Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"));
Exp.case
(Pat.construct ~loc:default_loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
(Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))
false)
(Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
Pat.construct ~loc:default_loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
None
false,
default;
Exp.case
(Pat.construct ~loc:default_loc
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
None
false)
default;
]
in
let smatch =
@ -1926,8 +1940,9 @@ and type_expect_ ?in_function env sexp ty_expected =
Exp.function_ ~loc
l None
[
Pat.var ~loc (mknoloc "*opt*"),
Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [spat, smatch] sbody;
Exp.case
(Pat.var ~loc (mknoloc "*opt*"))
(Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [pc_lhs, smatch] pc_rhs)
]
in
type_expect ?in_function env sfun ty_expected
@ -1971,7 +1986,7 @@ and type_expect_ ?in_function env sexp ty_expected =
ls = [] && not tvar
in
if is_optional l && not_function ty_res then
Location.prerr_warning (fst (List.hd cases)).pat_loc
Location.prerr_warning (List.hd cases).c_lhs.pat_loc
Warnings.Unerasable_optional_argument;
re {
exp_desc = Texp_function(l,cases, partial);
@ -2371,15 +2386,6 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_env = env;
exp_extra = (Texp_constraint (cty, cty'), loc, sexp.pexp_attributes) :: arg.exp_extra;
}
| Pexp_when(scond, sbody) ->
let cond = type_expect env scond Predef.type_bool in
let body = type_expect env sbody ty_expected in
re {
exp_desc = Texp_when(cond, body);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_send (e, met) ->
if !Clflags.principal then begin_def ();
let obj = type_exp env e in
@ -2861,11 +2867,15 @@ and type_argument env sarg ty_expected' ty_expected =
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
let func texp =
let e =
{texp with exp_type = ty_res; exp_desc =
Texp_apply
(texp,
List.rev args @ ["", Some eta_var, Required])}
in
{ texp with exp_type = ty_fun; exp_desc =
Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
Texp_apply (texp,
List.rev args @ ["", Some eta_var, Required])}],
Total) } in
Texp_function("", [case eta_pat e], Total) }
in
if warn then Location.prerr_warning texp.exp_loc
(Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
@ -3148,9 +3158,9 @@ and type_statement env sexp =
(* Typing of match cases *)
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedtree.case list * _ =
(* ty_arg is _fully_ generalized *)
let patterns = List.map fst caselist in
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
let erase_either =
List.exists contains_polymorphic_variant patterns
&& contains_variant_either ty_arg
@ -3183,8 +3193,13 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
Printtyp.raw_type_expr ty_arg; *)
let pat_env_list =
List.map
(fun (spat, sexp) ->
let loc = sexp.pexp_loc in
(fun {pc_lhs; pc_guard; pc_rhs} ->
let loc =
let open Location in
match pc_guard with
| None -> pc_rhs.pexp_loc
| Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
in
if !Clflags.principal then begin_def (); (* propagation of pattern *)
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force, unpacks) =
@ -3192,7 +3207,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
if !Clflags.principal || erase_either
then Some false else None in
let ty_arg = instance ?partial env ty_arg in
type_pattern ~lev env spat scope ty_arg
type_pattern ~lev env pc_lhs scope ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
@ -3224,8 +3239,8 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
let in_function = if List.length caselist = 1 then in_function else None in
let cases =
List.map2
(fun (pat, (ext_env, unpacks)) (spat, sexp) ->
let sexp = wrap_unpacks sexp unpacks in
(fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
let sexp = wrap_unpacks pc_rhs unpacks in
let ty_res' =
if !Clflags.principal then begin
begin_def ();
@ -3233,17 +3248,30 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
end_def ();
generalize_structure ty; ty
end
else if contains_gadt env spat then correct_levels ty_res
else if contains_gadt env pc_lhs then correct_levels ty_res
else ty_res in
(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
Printtyp.raw_type_expr ty_res'; *)
let guard =
match pc_guard with
| None -> None
| Some scond ->
Some
(type_expect ext_env (wrap_unpacks scond unpacks)
Predef.type_bool)
in
let exp = type_expect ?in_function ext_env sexp ty_res' in
(pat, {exp with exp_type = instance env ty_res'}))
{
c_lhs = pat;
c_guard = guard;
c_rhs = {exp with exp_type = instance env ty_res'}
}
)
pat_env_list caselist
in
if !Clflags.principal || has_gadts then begin
let ty_res' = instance env ty_res in
List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
end;
let partial =
if partial_flag then
@ -3425,7 +3453,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc
Warnings.Unused_rec_flag;
List.iter2
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp]))
pat_list exp_list;
end_def();
List.iter2

14
typing/typedtree.ml
View File

@ -73,10 +73,10 @@ 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_function of label * (pattern * expression) list * partial
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_match of expression * (pattern * expression) list * partial
| Texp_try of expression * (pattern * expression) list
| Texp_match of expression * case list * partial
| Texp_try of expression * case list
| Texp_tuple of expression list
| Texp_construct of
Longident.t loc * constructor_description * expression list *
@ -95,7 +95,6 @@ and expression_desc =
| Texp_for of
Ident.t * string loc * expression * expression * direction_flag *
expression
| Texp_when of expression * expression
| Texp_send of expression * meth * expression option
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
| Texp_instvar of Path.t * Path.t * string loc
@ -112,6 +111,13 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
and case =
{
c_lhs: pattern;
c_guard: expression option;
c_rhs: expression;
}
(* Value expressions for the class language *)
and class_expr =

14
typing/typedtree.mli
View File

@ -72,10 +72,10 @@ 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_function of label * (pattern * expression) list * partial
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_match of expression * (pattern * expression) list * partial
| Texp_try of expression * (pattern * expression) list
| Texp_match of expression * case list * partial
| Texp_try of expression * case list
| Texp_tuple of expression list
| Texp_construct of
Longident.t loc * constructor_description * expression list *
@ -94,7 +94,6 @@ and expression_desc =
| Texp_for of
Ident.t * string loc * expression * expression * direction_flag *
expression
| Texp_when of expression * expression
| Texp_send of expression * meth * expression option
| Texp_new of Path.t * Longident.t loc * Types.class_declaration
| Texp_instvar of Path.t * Path.t * string loc
@ -111,6 +110,13 @@ and meth =
Tmeth_name of string
| Tmeth_val of Ident.t
and case =
{
c_lhs: pattern;
c_guard: expression option;
c_rhs: expression;
}
(* Value expressions for the class language *)
and class_expr =

19
typing/typedtreeIter.ml
View File

@ -96,8 +96,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Some x -> f x
open Asttypes
let rec iter_structure str =
Iter.enter_structure str;
List.iter iter_structure_item str.str_items;
@ -115,6 +113,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
List.iter iter_binding list;
Iter.leave_bindings rec_flag
and iter_case {c_lhs; c_guard; c_rhs} =
iter_pattern c_lhs;
may_iter iter_expression c_guard;
iter_expression c_rhs
and iter_cases cases =
List.iter iter_case cases
and iter_structure_item item =
Iter.enter_structure_item item;
begin
@ -235,7 +241,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_bindings rec_flag list;
iter_expression exp
| Texp_function (label, cases, _) ->
iter_bindings Nonrecursive cases
iter_cases cases
| Texp_apply (exp, list) ->
iter_expression exp;
List.iter (fun (label, expo, _) ->
@ -245,10 +251,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
) list
| Texp_match (exp, list, _) ->
iter_expression exp;
iter_bindings Nonrecursive list
iter_cases list
| Texp_try (exp, list) ->
iter_expression exp;
iter_bindings Nonrecursive list
iter_cases list
| Texp_tuple list ->
List.iter iter_expression list
| Texp_construct (_, _, args, _) ->
@ -288,9 +294,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_expression exp1;
iter_expression exp2;
iter_expression exp3
| Texp_when (exp1, exp2) ->
iter_expression exp1;
iter_expression exp2
| Texp_send (exp, meth, expo) ->
iter_expression exp;
begin

22
typing/typedtreeMap.ml
View File

@ -75,7 +75,6 @@ module MakeMap(Map : MapArgument) = struct
open Misc
open Asttypes
let rec map_structure str =
let str = Map.enter_structure str in
@ -87,6 +86,16 @@ module MakeMap(Map : MapArgument) = struct
and map_bindings rec_flag list =
List.map map_binding list
and map_case {c_lhs; c_guard; c_rhs} =
{
c_lhs = map_pattern c_lhs;
c_guard = may_map map_expression c_guard;
c_rhs = map_expression c_rhs;
}
and map_cases list =
List.map map_case list
and map_structure_item item =
let item = Map.enter_structure_item item in
let str_desc =
@ -226,7 +235,7 @@ module MakeMap(Map : MapArgument) = struct
map_bindings rec_flag list,
map_expression exp)
| Texp_function (label, cases, partial) ->
Texp_function (label, map_bindings Nonrecursive cases, partial)
Texp_function (label, map_cases cases, partial)
| Texp_apply (exp, list) ->
Texp_apply (map_expression exp,
List.map (fun (label, expo, optional) ->
@ -240,13 +249,13 @@ module MakeMap(Map : MapArgument) = struct
| Texp_match (exp, list, partial) ->
Texp_match (
map_expression exp,
map_bindings Nonrecursive list,
map_cases list,
partial
)
| Texp_try (exp, list) ->
Texp_try (
map_expression exp,
map_bindings Nonrecursive list
map_cases list
)
| Texp_tuple list ->
Texp_tuple (List.map map_expression list)
@ -305,11 +314,6 @@ module MakeMap(Map : MapArgument) = struct
dir,
map_expression exp3
)
| Texp_when (exp1, exp2) ->
Texp_when (
map_expression exp1,
map_expression exp2
)
| Texp_send (exp, meth, expo) ->
Texp_send (map_expression exp, meth, may_map map_expression expo)
| Texp_new (path, lid, cl_decl) -> exp.exp_desc