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

Add lazy patterns. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8906 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Michel Mauny 2008-07-09 13:03:38 +00:00
parent 0ccc1f7ff0
commit 6ba024a12e
25 changed files with 1474 additions and 1217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
VERSION
View File

@ -1,4 +1,4 @@
3.11+dev12 Private_abbrevs+natdynlink (2008-02-29)
3.11+dev12 Private_abbrevs+natdynlink+lazy_patterns (2008-07-09)
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

61
bytecomp/matching.ml
View File

@ -203,7 +203,11 @@ let ctx_matcher p =
let l' = all_record_args l' in
p, List.fold_right (fun (_,p) r -> p::r) l' rem
| _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem)
| _ -> fatal_error "Matching.ctx_matcher"
| Tpat_lazy omega ->
(fun q rem -> match q.pat_desc with
| Tpat_lazy arg -> p, (arg::rem)
| _ -> p, (omega::rem))
| _ -> fatal_error "Matching.ctx_matcher"
@ -616,6 +620,7 @@ let rec extract_vars r p = match p.pat_desc with
| Tpat_array pats ->
List.fold_left extract_vars r pats
| Tpat_variant (_,Some p, _) -> extract_vars r p
| Tpat_lazy p -> extract_vars r p
| Tpat_or (p,_,_) -> extract_vars r p
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
@ -683,6 +688,10 @@ and group_array = function
| {pat_desc=Tpat_array _} -> true
| _ -> false
and group_lazy = function
| {pat_desc = Tpat_lazy _} -> true
| _ -> false
let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
@ -691,6 +700,7 @@ let get_group p = match p.pat_desc with
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
| Tpat_variant (_,_,_) -> group_variant
| Tpat_lazy _ -> group_lazy
| _ -> fatal_error "Matching.get_group"
@ -1287,6 +1297,50 @@ let make_var_matching def = function
let divide_var ctx pm =
divide_line ctx_lshift make_var_matching get_args_var omega ctx pm
(* Matching and forcing a lazy value *)
let get_arg_lazy p rem = match p with
| {pat_desc = Tpat_any} -> omega :: rem
| {pat_desc = Tpat_lazy arg} -> arg :: rem
| _ -> assert false
let matcher_lazy p rem = match p.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
| Tpat_lazy arg -> arg :: rem
| Tpat_var _ -> get_arg_lazy omega rem
| _ -> get_arg_lazy p rem
(* Compute lazily the lambda-code of Lazy.force *)
let lambda_of_force =
lazy (
let lazy_mod_ident = Ident.create_persistent "Lazy" in
let lazy_env = Env.open_pers_signature "Lazy" Env.initial in
let p = try
match Env.lookup_value (Longident.Lident "force") lazy_env with
| (Path.Pdot(_,_,i), _) -> i
| _ -> assert false
with Not_found -> assert false
in
Lprim(Pfield p, [Lprim(Pgetglobal lazy_mod_ident, [])])
)
let make_lazy_matching def = function
[] -> fatal_error "Matching.make_lazy_matching"
| (arg,mut) :: argl ->
{ cases = [];
args = (Lapply(Lazy.force lambda_of_force, [arg], Location.none),
Strict) :: argl;
default = make_default matcher_lazy def }
let divide_lazy p ctx pm =
divide_line
(filter_ctx p)
make_lazy_matching
get_arg_lazy
p ctx pm
(* Matching against a tuple pattern *)
@ -2335,6 +2389,10 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
compile_test (compile_match repr partial) partial
(divide_array kind) (combine_array arg kind partial)
ctx pm
| Tpat_lazy _ ->
compile_no_test
(divide_lazy (normalize_pat pat))
ctx_combine repr partial ctx pm
| Tpat_variant(lab, _, row) ->
compile_test (compile_match repr partial) partial
(divide_variant !row)
@ -2577,4 +2635,3 @@ let for_multiple_match loc paraml pat_act_list partial =
end
with Unused ->
assert false (* ; partial_function loc () *)

2
bytecomp/translcore.ml
View File

@ -851,7 +851,7 @@ and transl_apply lam sargs loc =
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)]
when Parmatch.irrefutable pat ->
when Parmatch.fluid pat ->
let param = name_pattern "param" pat_expr_list in
let ((_, params), body) =
transl_function exp.exp_loc false repr partial' pl in

3
camlp4/Camlp4/Camlp4Ast.partial.ml
View File

@ -86,7 +86,8 @@
| PaTup of loc and patt (* ( p ) *)
| PaTyc of loc and patt and ctyp (* (p : t) *)
| PaTyp of loc and ident (* #i *)
| PaVrn of loc and string (* `s *) ]
| PaVrn of loc and string (* `s *)
| PaLaz of loc and patt (* lazy p *) ]
and expr =
[ ExNil of loc
| ExId of loc and ident (* i *)

7
camlp4/Camlp4/Printers/OCaml.ml
View File

@ -589,6 +589,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
method patt5 f = fun
[ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p
| <:patt< lazy $p$ >> ->
pp f "@[<2>lazy %a@]" o#simple_patt p
| <:patt< $x$ $y$ >> ->
let (a, al) = get_patt_args x [y] in
if not (Ast.is_patt_constructor a) then
@ -637,8 +639,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e
| <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> |
<:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> |
<:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> as p ->
pp f "@[<1>(%a)@]" o#patt p ];
<:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> as p ->
pp f "@[<1>(%a)@]" o#patt p
];
method patt_tycon f =
fun

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

@ -500,6 +500,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t))
| PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
| PaVrn loc s -> mkpat loc (Ppat_variant s None)
| PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
| PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
error (loc_of_patt p) "invalid pattern" ]
and mklabpat =

1
camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
View File

@ -372,6 +372,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1
(Ast.list_of_patt p [])
| _ -> <:patt< $p1$ $p2$ >> ]
| "lazy"; p = SELF -> <:patt< lazy $p$ >>
| `ANTIQUOT (""|"pat"|"anti" as n) s ->
<:patt< $anti:mk_anti ~c:"patt" n s$ >>
| p = patt_constr -> p ]

3
camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
View File

@ -825,7 +825,8 @@ Very old (no more supported) syntax:
| ".." NONA
[ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
| "apply" LEFTA
[ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ]
[ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >>
| "lazy"; p = SELF -> <:patt< lazy $p$ >> ]
| "simple"
[ `ANTIQUOT (""|"pat"|"anti" as n) s ->
<:patt< $anti:mk_anti ~c:"patt" n s$ >>

2413
camlp4/boot/Camlp4.ml
View File

File diff suppressed because it is too large Load Diff

27
camlp4/boot/Camlp4Ast.ml
View File

@ -1806,7 +1806,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
(meta_loc _loc x0) ]
and meta_patt _loc =
fun
[ Ast.PaVrn x0 x1 ->
[ Ast.PaLaz x0 x1 ->
Ast.ExApp _loc
(Ast.ExApp _loc
(Ast.ExId _loc
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
(Ast.IdUid _loc "PaLaz")))
(meta_loc _loc x0))
(meta_patt _loc x1)
| Ast.PaVrn x0 x1 ->
Ast.ExApp _loc
(Ast.ExApp _loc
(Ast.ExId _loc
@ -3718,7 +3726,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
(meta_loc _loc x0) ]
and meta_patt _loc =
fun
[ Ast.PaVrn x0 x1 ->
[ Ast.PaLaz x0 x1 ->
Ast.PaApp _loc
(Ast.PaApp _loc
(Ast.PaId _loc
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
(Ast.IdUid _loc "PaLaz")))
(meta_loc _loc x0))
(meta_patt _loc x1)
| Ast.PaVrn x0 x1 ->
Ast.PaApp _loc
(Ast.PaApp _loc
(Ast.PaId _loc
@ -4518,7 +4534,9 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
let _x_i1 = o#ident _x_i1 in PaTyp _x _x_i1
| PaVrn _x _x_i1 ->
let _x = o#loc _x in
let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 ];
let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1
| PaLaz _x _x_i1 ->
let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ];
method module_type : module_type -> module_type =
fun
[ MtNil _x -> let _x = o#loc _x in MtNil _x
@ -5237,7 +5255,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
let o = o#loc _x in
let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o
| PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o
| PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ];
| PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
| PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ];
method module_type : module_type -> 'self_type =
fun
[ MtNil _x -> let o = o#loc _x in o

87
camlp4/boot/camlp4boot.ml
View File

@ -21,9 +21,13 @@ module R =
* - Nicolas Pouillard: refactoring
*)
module Id =
struct let name = "Camlp4OCamlRevisedParser"
let version = "$Id$"
end
struct
let name = "Camlp4OCamlRevisedParser"
let version =
"$Id: Camlp4OCamlRevisedParser.ml,v 1.9 2007/12/18 09:02:17 ertai Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
@ -3126,7 +3130,11 @@ Very old (no more supported) syntax:
(_loc : Gram.Loc.t) ->
(Ast.PaRng (_loc, p1, p2) : 'patt)))) ]);
((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA),
[ ([ Gram.Sself; Gram.Sself ],
[ ([ Gram.Skeyword "lazy"; Gram.Sself ],
(Gram.Action.mk
(fun (p : 'patt) _ (_loc : Gram.Loc.t) ->
(Ast.PaLaz (_loc, p) : 'patt))));
([ Gram.Sself; Gram.Sself ],
(Gram.Action.mk
(fun (p2 : 'patt) (p1 : 'patt)
(_loc : Gram.Loc.t) ->
@ -8348,9 +8356,13 @@ module Camlp4QuotationCommon =
* - Nicolas Pouillard: initial version
*)
module Id =
struct let name = "Camlp4QuotationCommon"
let version = "$Id$"
end
struct
let name = "Camlp4QuotationCommon"
let version =
"$Id: Camlp4QuotationCommon.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $"
end
module Make
(Syntax : Sig.Camlp4Syntax)
@ -9047,9 +9059,13 @@ module Q =
* - Nicolas Pouillard: refactoring
*)
module Id =
struct let name = "Camlp4QuotationExpander"
let version = "$Id$"
end
struct
let name = "Camlp4QuotationExpander"
let version =
"$Id: Camlp4QuotationExpander.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
@ -9086,9 +9102,12 @@ module Rp =
* - Nicolas Pouillard: refactoring
*)
module Id : Sig.Id =
struct let name = "Camlp4OCamlRevisedParserParser"
let version = "$Id$"
struct
let name = "Camlp4OCamlRevisedParserParser"
let version =
"$Id: Camlp4OCamlRevisedParserParser.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
@ -10017,9 +10036,13 @@ module G =
* - Nicolas Pouillard: refactoring
*)
module Id =
struct let name = "Camlp4GrammarParser"
let version = "$Id$"
end
struct
let name = "Camlp4GrammarParser"
let version =
"$Id: Camlp4GrammarParser.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
@ -12414,9 +12437,13 @@ module M =
* - Christopher Conway: extra feature (-D<uident>=)
*)
module Id =
struct let name = "Camlp4MacroParser"
let version = "$Id$"
end
struct
let name = "Camlp4MacroParser"
let version =
"$Id: Camlp4MacroParser.ml,v 1.3 2007/11/21 17:51:16 ertai Exp $"
end
(*
Added statements:
@ -13313,9 +13340,13 @@ module D =
* - Nicolas Pouillard: initial version
*)
module Id =
struct let name = "Camlp4DebugParser"
let version = "$Id$"
end
struct
let name = "Camlp4DebugParser"
let version =
"$Id: Camlp4DebugParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
@ -13506,9 +13537,13 @@ module L =
* - Nicolas Pouillard: revised syntax version
*)
module Id =
struct let name = "Camlp4ListComprenhsion"
let version = "$Id$"
end
struct
let name = "Camlp4ListComprenhsion"
let version =
"$Id: Camlp4ListComprehension.ml,v 1.2 2007/11/21 17:51:16 ertai Exp $"
end
module Make (Syntax : Sig.Camlp4Syntax) =
struct
@ -13882,7 +13917,7 @@ module B =
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* $Id$ *)
(* $Id: Camlp4Bin.ml,v 1.18 2008/01/11 16:13:16 doligez Exp $ *)
open Camlp4
open PreCast.Syntax

2
parsing/parser.mly
View File

@ -1077,6 +1077,8 @@ pattern:
false)) }
| pattern BAR pattern
{ mkpat(Ppat_or($1, $3)) }
| LAZY simple_pattern
{ mkpat(Ppat_lazy $2) }
;
simple_pattern:
val_ident %prec below_EQUAL

1
parsing/parsetree.mli
View File

@ -75,6 +75,7 @@ and pattern_desc =
| Ppat_or of pattern * pattern
| Ppat_constraint of pattern * core_type
| Ppat_type of Longident.t
| Ppat_lazy of pattern
type expression =
{ pexp_desc: expression_desc;

3
parsing/printast.ml
View File

@ -186,6 +186,9 @@ and pattern i ppf x =
line i ppf "Ppat_or\n";
pattern i ppf p1;
pattern i ppf p2;
| Ppat_lazy p ->
line i ppf "Ppat_lazy\n";
pattern i ppf p;
| Ppat_constraint (p, ct) ->
line i ppf "Ppat_constraint";
pattern i ppf p;

1
tools/addlabels.ml
View File

@ -62,6 +62,7 @@ let rec pattern_vars pat =
List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p))
| Ppat_or (pat1, pat2) ->
pattern_vars pat1 @ pattern_vars pat2
| Ppat_lazy pat -> pattern_vars pat
| Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
| Ppat_type _ ->
[]

1
tools/depend.ml
View File

@ -112,6 +112,7 @@ let rec add_pattern bv pat =
| Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
| Ppat_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type (li) -> add bv li
| Ppat_lazy p -> add_pattern bv p
let rec add_expr bv exp =
match exp.pexp_desc with

56
typing/parmatch.ml
View File

@ -83,6 +83,7 @@ let rec compat p q =
| _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2
| Tpat_constant c1, Tpat_constant c2 -> c1=c2
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_lazy p, Tpat_lazy q -> compat p q
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
@ -164,7 +165,7 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
| "::" -> true
| _ -> false
let rec pretty_val ppf v = match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
| Tpat_var x -> Ident.print ppf x
@ -204,6 +205,8 @@ let rec pretty_val ppf v = match v.pat_desc with
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
| Tpat_lazy v ->
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
| Tpat_alias (v,x) ->
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
| Tpat_or (v,w,_) ->
@ -269,6 +272,7 @@ let simple_match p1 p2 =
float_of_string s1 = float_of_string s2
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
| Tpat_tuple _, Tpat_tuple _ -> true
| Tpat_lazy _, Tpat_lazy _ -> true
| Tpat_record _ , Tpat_record _ -> true
| Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s
| _, (Tpat_any | Tpat_var(_)) -> true
@ -329,6 +333,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_tuple(args) -> args
| Tpat_record(args) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
Tpat_construct(_, args) -> omega_list args
@ -336,6 +341,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args) -> omega_list args
| Tpat_array(args) -> omega_list args
| Tpat_lazy _ -> [omega]
| _ -> []
end
| _ -> []
@ -361,6 +367,8 @@ let rec normalize_pat q = match q.pat_desc with
| Tpat_record (largs) ->
make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs))
q.pat_type q.pat_env
| Tpat_lazy _ ->
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
| Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
@ -379,6 +387,7 @@ let discr_pat q pss =
| ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss ->
acc_pat acc pss
| (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p
| (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
| (({pat_desc = Tpat_record largs} as p)::_)::pss ->
let new_omegas =
List.fold_left
@ -448,6 +457,12 @@ let do_set_args erase_mutable q r = match q with
make_pat
(Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_lazy omega} ->
begin match r with
arg::rest ->
make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
| _ -> fatal_error "Parmatch.do_set_args (lazy)"
end
| {pat_desc = Tpat_array omegas} ->
let args,rest = read_args omegas r in
make_pat
@ -541,7 +556,7 @@ let filter_all pat0 pss =
filter_omega
(filter_rec
(match pat0.pat_desc with
(Tpat_record(_) | Tpat_tuple(_)) -> [pat0,[]]
(Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
| _ -> [])
pss)
pss
@ -630,6 +645,7 @@ let full_match closing env = match env with
| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
| ({pat_desc = Tpat_record(_)},_) :: _ -> true
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
| _ -> fatal_error "Parmatch.full_match"
let extendable_match env = match env with
@ -867,6 +883,7 @@ let rec has_instance p = match p.pat_desc with
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
| Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps
| Tpat_record lps -> has_instances (List.map snd lps)
| Tpat_lazy p -> has_instance p
and has_instances = function
| [] -> true
@ -1299,6 +1316,7 @@ let rec le_pat p q =
l1 = l2
| Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
| Tpat_lazy p, Tpat_lazy q -> le_pat p q
| Tpat_record l1, Tpat_record l2 ->
let ps,qs = records_args l1 l2 in
le_pats ps qs
@ -1337,6 +1355,9 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
| Tpat_tuple ps, Tpat_tuple qs ->
let rs = lubs ps qs in
make_pat (Tpat_tuple rs) p.pat_type p.pat_env
| Tpat_lazy p, Tpat_lazy q ->
let r = lub p q in
make_pat (Tpat_lazy r) p.pat_type p.pat_env
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
@ -1570,6 +1591,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
collect_paths_from_pat (collect_paths_from_pat r p1) p2
| Tpat_lazy p1 ->
collect_paths_from_pat r p
(*
@ -1659,8 +1682,31 @@ let check_unused tdefs casel =
do_rec [] casel
(********************************)
(* Exported irrefutability test *)
(********************************)
(*********************************)
(* Exported irrefutability tests *)
(*********************************)
let irrefutable pat = le_pat pat omega
(* An inactive pattern is a pattern whose matching needs only
trivial computations (tag/equality tests).
Patterns containing (lazy _) subpatterns are active. *)
let rec inactive pat = match pat with
| Tpat_lazy _ ->
false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
true
| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps ->
List.for_all (fun p -> inactive p.pat_desc) ps
| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) ->
inactive p.pat_desc
| Tpat_record ldps ->
List.exists (fun (_, p) -> inactive p.pat_desc) ldps
| Tpat_or (p,q,_) ->
inactive p.pat_desc && inactive q.pat_desc
(* A `fluid' pattern is both irrefutable and inactive *)
let fluid pat = irrefutable pat && inactive pat.pat_desc

3
typing/parmatch.mli
View File

@ -54,5 +54,6 @@ val pressure_variants: Env.t -> pattern list -> unit
val check_partial: Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
(* Irrefutability test *)
(* Irrefutability tests *)
val irrefutable : pattern -> bool
val fluid : pattern -> bool

12
typing/typecore.ml
View File

@ -294,7 +294,8 @@ let rec build_as_type env p =
let row = row_repr row in
newty (Tvariant{row with row_closed=false; row_more=newvar()})
end
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type
| Tpat_any | Tpat_var _ | Tpat_constant _
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
let build_or_pat env loc lid =
let path, decl =
@ -509,6 +510,13 @@ let rec type_pat env sp =
pat_loc = sp.ppat_loc;
pat_type = p1.pat_type;
pat_env = env }
| Ppat_lazy sp1 ->
let p1 = type_pat env sp1 in
rp {
pat_desc = Tpat_lazy p1;
pat_loc = sp.ppat_loc;
pat_type = instance (Predef.type_lazy_t p1.pat_type);
pat_env = env }
| Ppat_constraint(sp, sty) ->
let p = type_pat env sp in
let ty, force = Typetexp.transl_simple_type_delayed env sty in
@ -1466,7 +1474,7 @@ let rec type_exp env sexp =
exp_type = newvar ();
exp_env = env;
}
| Pexp_lazy (e) ->
| Pexp_lazy e ->
let arg = type_exp env e in
re {
exp_desc = Texp_lazy arg;

3
typing/typedtree.ml
View File

@ -37,6 +37,7 @@ and pattern_desc =
| Tpat_record of (label_description * pattern) list
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
| Tpat_lazy of pattern
type partial = Partial | Total
type optional = Required | Optional
@ -162,6 +163,7 @@ let iter_pattern_desc f = function
List.iter (fun (lbl, pat) -> f pat) lbl_pat_list
| Tpat_array patl -> List.iter f patl
| Tpat_or(p1, p2, _) -> f p1; f p2
| Tpat_lazy p -> f p
| Tpat_any
| Tpat_var _
| Tpat_constant _ -> ()
@ -178,6 +180,7 @@ let map_pattern_desc f d =
Tpat_construct (c, List.map f pats)
| Tpat_array pats ->
Tpat_array (List.map f pats)
| Tpat_lazy p1 -> Tpat_lazy (f p1)
| Tpat_variant (x1, Some p1, x2) ->
Tpat_variant (x1, Some (f p1), x2)
| Tpat_or (p1,p2,path) ->

1
typing/typedtree.mli
View File

@ -36,6 +36,7 @@ and pattern_desc =
| Tpat_record of (label_description * pattern) list
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
| Tpat_lazy of pattern
type partial = Partial | Total
type optional = Required | Optional

1
typing/unused_var.ml
View File

@ -73,6 +73,7 @@ let rec get_vars ((vacc, asacc) as acc) p =
List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
| Ppat_array pl -> List.fold_left get_vars acc pl
| Ppat_or (p1, _p2) -> get_vars acc p1
| Ppat_lazy p -> get_vars acc p
| Ppat_constraint (pp, _) -> get_vars acc pp
| Ppat_type _ -> acc