Commit 35c1b010 authored by Andrei Paskevich's avatar Andrei Paskevich

WhyML: allow "ghost" over arbitrary subpatterns

This lets us write "let ghost (x, y) = 0, 0"
instead of "let ghost x, ghost y = 0, 0".
parent 55429026
...@@ -63,7 +63,7 @@ let return ~loc = ...@@ -63,7 +63,7 @@ let return ~loc =
Qident (mk_id ~loc "Return") Qident (mk_id ~loc "Return")
let return_handler ~loc = let return_handler ~loc =
let x = mk_id ~loc "x" in let x = mk_id ~loc "x" in
[return ~loc, Some (mk_pat ~loc (Pvar (x, false))), mk_var ~loc x] [return ~loc, Some (mk_pat ~loc (Pvar x)), mk_var ~loc x]
let array_make ~loc n v = let array_make ~loc n v =
mk_expr ~loc (Eidapp (Qdot (Qident (mk_id ~loc "Array"), mk_id ~loc "make"), mk_expr ~loc (Eidapp (Qdot (Qident (mk_id ~loc "Array"), mk_id ~loc "make"),
[n; v])) [n; v]))
......
...@@ -134,7 +134,7 @@ single_spec: ...@@ -134,7 +134,7 @@ single_spec:
ensures: ensures:
| term | term
{ let id = mk_id "result" $startpos $endpos in { let id = mk_id "result" $startpos $endpos in
[mk_pat (Pvar (id, false)) $startpos $endpos, $1] } [mk_pat (Pvar id) $startpos $endpos, $1] }
expr: expr:
| d = expr_desc | d = expr_desc
......
This diff is collapsed.
...@@ -22,8 +22,7 @@ ...@@ -22,8 +22,7 @@
~desc:"When set, model attributes are not added during parsing" ~desc:"When set, model attributes are not added during parsing"
"no_auto_model" "no_auto_model"
let add_attr id l = let add_attr id l = { id with id_ats = l }
{ id with id_ats = l }
let add_model_trace_attr id = let add_model_trace_attr id =
if Debug.test_flag debug_auto_model then id else if Debug.test_flag debug_auto_model then id else
...@@ -100,7 +99,7 @@ ...@@ -100,7 +99,7 @@
let apply_return pat sp = let apply_return pat sp =
let apply = function let apply = function
| loc, [{pat_desc = Pvar ({id_str = "result"; id_loc = l}, false)}, f] | loc, [{pat_desc = Pvar {id_str = "result"; id_loc = l}}, f]
when Loc.equal loc l -> loc, [pat, f] when Loc.equal loc l -> loc, [pat, f]
| post -> post in | post -> post in
match pat.pat_desc with match pat.pat_desc with
...@@ -174,6 +173,7 @@ ...@@ -174,6 +173,7 @@
%nonassoc LARROW %nonassoc LARROW
%nonassoc below_COMMA %nonassoc below_COMMA
%nonassoc COMMA %nonassoc COMMA
%nonassoc AS
%nonassoc GHOST %nonassoc GHOST
%nonassoc prec_attr %nonassoc prec_attr
%nonassoc COLON (* weaker than -> because of t: a -> b *) %nonassoc COLON (* weaker than -> because of t: a -> b *)
...@@ -565,19 +565,25 @@ single_term_: ...@@ -565,19 +565,25 @@ single_term_:
{ Tinfix (l, o, r) } { Tinfix (l, o, r) }
| l = single_term ; o = infix_op_234 ; r = single_term | l = single_term ; o = infix_op_234 ; r = single_term
{ Tidapp (Qident o, [l; r]) } { Tidapp (Qident o, [l; r]) }
| term_arg located(term_arg)+ (* FIXME/TODO: "term term_arg" *) | term_arg located(term_arg)+
{ let join f (a,_,e) = mk_term (Tapply (f,a)) $startpos e in { let join f (a,_,e) = mk_term (Tapply (f,a)) $startpos e in
(List.fold_left join $1 $2).term_desc } (List.fold_left join $1 $2).term_desc }
| IF term THEN term ELSE term | IF term THEN term ELSE term
{ Tif ($2, $4, $6) } { Tif ($2, $4, $6) }
| LET pattern EQUAL term IN term | LET pattern EQUAL term IN term
{ let cast ty = { $4 with term_desc = Tcast ($4, ty) } in { let re_pat pat d = { pat with pat_desc = d } in
let pat, def = match $2.pat_desc with let rec deparen pat = match pat.pat_desc with
| Ptuple [] -> { $2 with pat_desc = Pwild }, cast (PTtuple []) | Pparen p -> deparen p
| Pcast ({pat_desc = (Pvar (_,false)|Pwild)} as p, ty) -> p, cast ty | Pcast (p,ty) -> re_pat pat (Pcast (deparen p, ty))
| _ -> $2, $4 in | _ -> pat in
let pat = deparen $2 in
let cast ty = { $4 with term_desc = Tcast ($4, ty) } in
let pat, def = match pat.pat_desc with
| Ptuple [] -> re_pat pat Pwild, cast (PTtuple [])
| Pcast ({pat_desc = (Pvar _|Pwild)} as p, ty) -> p, cast ty
| _ -> pat, $4 in
match pat.pat_desc with match pat.pat_desc with
| Pvar (id,false) -> Tlet (id, def, $6) | Pvar id -> Tlet (id, def, $6)
| Pwild -> Tlet (id_anonymous pat.pat_loc, def, $6) | Pwild -> Tlet (id_anonymous pat.pat_loc, def, $6)
| _ -> Tcase (def, [pat, $6]) } | _ -> Tcase (def, [pat, $6]) }
| LET attrs(lident_op_id) EQUAL term IN term | LET attrs(lident_op_id) EQUAL term IN term
...@@ -793,7 +799,7 @@ single_expr_: ...@@ -793,7 +799,7 @@ single_expr_:
{ Einfix (l,o,r) } { Einfix (l,o,r) }
| l = single_expr ; o = infix_op_234 ; r = single_expr | l = single_expr ; o = infix_op_234 ; r = single_expr
{ Eidapp (Qident o, [l;r]) } { Eidapp (Qident o, [l;r]) }
| expr_arg located(expr_arg)+ (* FIXME/TODO: "expr expr_arg" *) | expr_arg located(expr_arg)+
{ let join f (a,_,e) = mk_expr (Eapply (f,a)) $startpos e in { let join f (a,_,e) = mk_expr (Eapply (f,a)) $startpos e in
(List.fold_left join $1 $2).expr_desc } (List.fold_left join $1 $2).expr_desc }
| IF seq_expr THEN contract_expr ELSE contract_expr | IF seq_expr THEN contract_expr ELSE contract_expr
...@@ -802,32 +808,33 @@ single_expr_: ...@@ -802,32 +808,33 @@ single_expr_:
{ Eif ($2, $4, mk_expr (Etuple []) $startpos $endpos) } { Eif ($2, $4, mk_expr (Etuple []) $startpos $endpos) }
| LET ghost kind let_pattern EQUAL seq_expr IN seq_expr | LET ghost kind let_pattern EQUAL seq_expr IN seq_expr
{ let re_pat pat d = { pat with pat_desc = d } in { let re_pat pat d = { pat with pat_desc = d } in
let rec ghostify pat = match pat.pat_desc with let rec deparen gh pat = match pat.pat_desc with
(* let_pattern marks the opening variable with Ptuple [_] *) | Ptuple (p::pl) -> re_pat pat (Ptuple (deparen gh p :: pl))
| Ptuple [{pat_desc = Pvar (id,_)}] -> re_pat pat (Pvar (id,$2)) | Pas (p,id,g) -> re_pat pat (Pas (deparen gh p, id, g))
| Ptuple (p::pl) -> re_pat pat (Ptuple (ghostify p :: pl)) | Por (p,q) -> re_pat pat (Por (deparen gh p, q))
| Pas (p,id,gh) -> re_pat pat (Pas (ghostify p, id, gh)) | Pcast (p,ty) -> re_pat pat (Pcast (deparen gh p, ty))
| Por (p1,p2) -> re_pat pat (Por (ghostify p1, p2)) | _ when gh -> re_pat pat (Pghost (deparen false pat))
| Pcast (p,t) -> re_pat pat (Pcast (ghostify p, t)) | Pghost p -> re_pat pat (Pghost (deparen false p))
| _ when $2 -> Loc.errorm ~loc:(floc $startpos($2) $endpos($2)) | Pparen p -> deparen false p (* gh == false *)
"illegal ghost qualifier" (* $4 does not start with a Pvar *)
| _ -> pat in | _ -> pat in
let pat = ghostify $4 in let pat = deparen $2 $4 in
let kind = match pat.pat_desc with let kind = match pat.pat_desc with
| _ when $3 = Expr.RKnone -> $3 | _ when $3 = Expr.RKnone -> $3
| Pvar (_,_) | Pcast ({pat_desc = Pvar (_,_)},_) -> $3 | Pvar _ | Pcast ({pat_desc = Pvar _},_) -> $3
| _ -> Loc.errorm ~loc:(floc $startpos($3) $endpos($3)) | _ -> Loc.errorm ~loc:(floc $startpos($3) $endpos($3))
"illegal kind qualifier" in "illegal kind qualifier" in
let cast ty = { $6 with expr_desc = Ecast ($6, ty) } in let cast ty = { $6 with expr_desc = Ecast ($6, ty) } in
let pat, def = match pat.pat_desc with let pat, def = match pat.pat_desc with
| Ptuple [] -> re_pat pat Pwild, cast (PTtuple []) | Ptuple [] -> re_pat pat Pwild, cast (PTtuple [])
| Pcast ({pat_desc = (Pvar _|Pwild)} as pat, ty) -> pat, cast ty | Pcast ({pat_desc = (Pvar _|Pwild)} as p, ty) -> p, cast ty
| _ -> pat, $6 in | _ -> pat, $6 in
match pat.pat_desc with match pat.pat_desc with
| Pvar (id, gh) -> | Pvar id -> Elet (add_model_trace_attr id, false, kind, def, $8)
let id = add_model_trace_attr id in
Elet (id, gh, kind, def, $8)
| Pwild -> Elet (id_anonymous pat.pat_loc, false, kind, def, $8) | Pwild -> Elet (id_anonymous pat.pat_loc, false, kind, def, $8)
| Pghost {pat_desc = Pvar id} ->
Elet (add_model_trace_attr id, true, kind, def, $8)
| Pghost {pat_desc = Pwild} ->
Elet (id_anonymous pat.pat_loc, true, kind, def, $8)
| _ -> Ematch (def, [pat, $8], []) } | _ -> Ematch (def, [pat, $8], []) }
| LET ghost kind attrs(lident_op_id) EQUAL seq_expr IN seq_expr | LET ghost kind attrs(lident_op_id) EQUAL seq_expr IN seq_expr
{ Elet ($4, $2, $3, $6, $8) } { Elet ($4, $2, $3, $6, $8) }
...@@ -1033,7 +1040,7 @@ alias: ...@@ -1033,7 +1040,7 @@ alias:
ensures: ensures:
| term | term
{ let id = mk_id "result" $startpos $endpos in { let id = mk_id "result" $startpos $endpos in
[mk_pat (Pvar (id,false)) $startpos $endpos, $1] } [mk_pat (Pvar id) $startpos $endpos, $1] }
raises: raises:
| uqualid ARROW term | uqualid ARROW term
...@@ -1074,7 +1081,7 @@ ret_cast: ...@@ -1074,7 +1081,7 @@ ret_cast:
ret_ident: ret_ident:
| id = attrs(lident_nq) | id = attrs(lident_nq)
{ let ats = ATstr Dterm.attr_w_unused_var_no :: id.id_ats in { let ats = ATstr Dterm.attr_w_unused_var_no :: id.id_ats in
mk_pat (Pvar ({id with id_ats = ats}, false)) $startpos $endpos } mk_pat (Pvar {id with id_ats = ats}) $startpos $endpos }
| UNDERSCORE | UNDERSCORE
{ mk_pat Pwild $startpos $endpos } { mk_pat Pwild $startpos $endpos }
...@@ -1113,26 +1120,20 @@ pat_conj_: ...@@ -1113,26 +1120,20 @@ pat_conj_:
pat_uni_: pat_uni_:
| pat_arg_ { $1 } | pat_arg_ { $1 }
| uqualid pat_arg+ { Papp ($1,$2) } | uqualid pat_arg+ { Papp ($1,$2) }
| GHOST mk_pat(pat_uni_) { Pghost $2 }
| mk_pat(pat_uni_) AS ghost attrs(lident_nq) | mk_pat(pat_uni_) AS ghost attrs(lident_nq)
{ let id = add_model_trace_attr $4 in { Pas ($1,add_model_trace_attr $4,$3) }
Pas ($1,id,$3) }
| mk_pat(pat_uni_) cast { Pcast ($1,$2) } | mk_pat(pat_uni_) cast { Pcast ($1,$2) }
pat_arg_: pat_arg_:
| pat_arg_shared_ { $1 }
| attrs(lident_nq)
{ let id = add_model_trace_attr $1 in
Pvar (id, false) }
| GHOST attrs(lident_nq) { Pvar ($2,true) }
pat_arg_shared_:
| UNDERSCORE { Pwild } | UNDERSCORE { Pwild }
| attrs(lident_nq) { Pvar (add_model_trace_attr $1) }
| uqualid { Papp ($1,[]) } | uqualid { Papp ($1,[]) }
| LEFTPAR RIGHTPAR { Ptuple [] } | LEFTPAR RIGHTPAR { Ptuple [] }
| LEFTPAR pattern_ RIGHTPAR { $2 } | LEFTPAR pattern RIGHTPAR { Pparen $2 }
| LEFTBRC field_list1(pattern) RIGHTBRC { Prec $2 } | LEFTBRC field_list1(pattern) RIGHTBRC { Prec $2 }
(* let-patterns that cannot start with "ghost" *) (* let-patterns cannot start with "ghost" *)
let_pattern: mk_pat(let_pattern_) { $1 } let_pattern: mk_pat(let_pattern_) { $1 }
...@@ -1146,16 +1147,12 @@ let_pat_conj_: ...@@ -1146,16 +1147,12 @@ let_pat_conj_:
{ Ptuple ($1::$3) } { Ptuple ($1::$3) }
let_pat_uni_: let_pat_uni_:
| let_pat_arg_ { $1 } | pat_arg_ { $1 }
| uqualid pat_arg+ { Papp ($1,$2) } | uqualid pat_arg+ { Papp ($1,$2) }
| mk_pat(let_pat_uni_) AS ghost attrs(lident_nq) | mk_pat(let_pat_uni_) AS ghost attrs(lident_nq)
{ Pas ($1,$4,$3) } { Pas ($1,add_model_trace_attr $4,$3) }
| mk_pat(let_pat_uni_) cast { Pcast ($1,$2) } | mk_pat(let_pat_uni_) cast { Pcast ($1,$2) }
let_pat_arg_:
| pat_arg_shared_ { $1 }
| attrs(lident_nq) { Ptuple [{pat_desc = Pvar ($1,false); pat_loc = $1.id_loc}] }
(* Idents *) (* Idents *)
ident: ident:
......
...@@ -46,13 +46,15 @@ type pattern = { ...@@ -46,13 +46,15 @@ type pattern = {
and pat_desc = and pat_desc =
| Pwild | Pwild
| Pvar of ident * ghost | Pvar of ident
| Papp of qualid * pattern list | Papp of qualid * pattern list
| Prec of (qualid * pattern) list | Prec of (qualid * pattern) list
| Ptuple of pattern list | Ptuple of pattern list
| Pas of pattern * ident * ghost | Pas of pattern * ident * ghost
| Por of pattern * pattern | Por of pattern * pattern
| Pcast of pattern * pty | Pcast of pattern * pty
| Pghost of pattern
| Pparen of pattern
(*s Logical terms and formulas *) (*s Logical terms and formulas *)
......
...@@ -154,10 +154,14 @@ let parse_record ~loc ns km get_val fl = ...@@ -154,10 +154,14 @@ let parse_record ~loc ns km get_val fl =
cs, List.map get_val pjl cs, List.map get_val pjl
let rec dpattern ns km { pat_desc = desc; pat_loc = loc } = let rec dpattern ns km { pat_desc = desc; pat_loc = loc } =
match desc with
| Ptree.Pparen p -> dpattern ns km p
| _ -> (* creative indentation ahead *)
Dterm.dpattern ~loc (match desc with Dterm.dpattern ~loc (match desc with
| Ptree.Pwild -> DPwild | Ptree.Pwild -> DPwild
| Ptree.Pvar (x, false) -> DPvar (create_user_id x) | Ptree.Pparen _ -> assert false (* never *)
| Ptree.Papp (q, pl) -> | Ptree.Pvar x -> DPvar (create_user_id x)
| Ptree.Papp (q,pl) ->
let pl = List.map (dpattern ns km) pl in let pl = List.map (dpattern ns km) pl in
DPapp (find_lsymbol_ns ns q, pl) DPapp (find_lsymbol_ns ns q, pl)
| Ptree.Ptuple pl -> | Ptree.Ptuple pl ->
...@@ -169,11 +173,11 @@ let rec dpattern ns km { pat_desc = desc; pat_loc = loc } = ...@@ -169,11 +173,11 @@ let rec dpattern ns km { pat_desc = desc; pat_loc = loc } =
| None -> Dterm.dpattern DPwild in | None -> Dterm.dpattern DPwild in
let cs,fl = parse_record ~loc ns km get_val fl in let cs,fl = parse_record ~loc ns km get_val fl in
DPapp (cs,fl) DPapp (cs,fl)
| Ptree.Pas (p, x, false) -> DPas (dpattern ns km p, create_user_id x) | Ptree.Pas (p,x,false) -> DPas (dpattern ns km p, create_user_id x)
| Ptree.Por (p, q) -> DPor (dpattern ns km p, dpattern ns km q) | Ptree.Por (p,q) -> DPor (dpattern ns km p, dpattern ns km q)
| Ptree.Pcast (p, ty) -> DPcast (dpattern ns km p, dty_of_pty ns ty) | Ptree.Pcast (p,ty) -> DPcast (dpattern ns km p, dty_of_pty ns ty)
| Ptree.Pvar (_, true) | Ptree.Pas (_, _, true) -> Loc.errorm ~loc | Ptree.Pghost _ | Ptree.Pas (_,_,true) ->
"ghost variables are only allowed in programs") Loc.errorm ~loc "ghost patterns are only allowed in programs")
let quant_var ns (loc, id, gh, ty) = let quant_var ns (loc, id, gh, ty) =
if gh then Loc.errorm ~loc "ghost variables are only allowed in programs"; if gh then Loc.errorm ~loc "ghost variables are only allowed in programs";
...@@ -491,24 +495,30 @@ let find_constructor muc q = ...@@ -491,24 +495,30 @@ let find_constructor muc q =
| _ -> false in | _ -> false in
find_special muc test "constructor" q find_special muc test "constructor" q
let rec dpattern muc { pat_desc = desc; pat_loc = loc } = let rec dpattern muc gh { pat_desc = desc; pat_loc = loc } =
match desc with
| Ptree.Pparen p -> dpattern muc gh p
| Ptree.Pghost p -> dpattern muc true p
| _ -> (* creative indentation ahead *)
Dexpr.dpattern ~loc (match desc with Dexpr.dpattern ~loc (match desc with
| Ptree.Pwild -> DPwild | Ptree.Pwild -> DPwild
| Ptree.Pvar (x, gh) -> DPvar (create_user_id x, gh) | Ptree.Pparen _ | Ptree.Pghost _ -> assert false
| Ptree.Papp (q, pl) -> | Ptree.Pvar x -> DPvar (create_user_id x, gh)
DPapp (find_constructor muc q, List.map (dpattern muc) pl) | Ptree.Papp (q,pl) ->
DPapp (find_constructor muc q, List.map (dpattern muc gh) pl)
| Ptree.Prec fl -> | Ptree.Prec fl ->
let get_val _ _ = function let get_val _ _ = function
| Some p -> dpattern muc p | Some p -> dpattern muc gh p
| None -> Dexpr.dpattern DPwild in | None -> Dexpr.dpattern DPwild in
let cs,fl = parse_record ~loc muc get_val fl in let cs,fl = parse_record ~loc muc get_val fl in
DPapp (cs,fl) DPapp (cs,fl)
| Ptree.Ptuple pl -> | Ptree.Ptuple pl ->
DPapp (rs_tuple (List.length pl), List.map (dpattern muc) pl) DPapp (rs_tuple (List.length pl), List.map (dpattern muc gh) pl)
| Ptree.Pcast (p, pty) -> DPcast (dpattern muc p, dity_of_pty muc pty) | Ptree.Pcast (p,pty) -> DPcast (dpattern muc gh p, dity_of_pty muc pty)
| Ptree.Pas (p, x, gh) -> DPas (dpattern muc p, create_user_id x, gh) | Ptree.Pas (p,x,g) -> DPas (dpattern muc gh p, create_user_id x, gh || g)
| Ptree.Por (p, q) -> DPor (dpattern muc p, dpattern muc q)) | Ptree.Por (p,q) -> DPor (dpattern muc gh p, dpattern muc gh q))
let dpattern muc pat = dpattern muc false pat
(* specifications *) (* specifications *)
...@@ -547,11 +557,13 @@ let dpre muc pl lvm old = ...@@ -547,11 +557,13 @@ let dpre muc pl lvm old =
List.map dpre pl List.map dpre pl
let dpost muc ql lvm old ity = let dpost muc ql lvm old ity =
let dpost (loc,pfl) = match pfl with let rec dpost (loc,pfl) = match pfl with
| [{ pat_desc = Ptree.Pparen p; pat_loc = loc}, f] ->
dpost (loc, [p,f])
| [{ pat_desc = Ptree.Pwild | Ptree.Ptuple [] }, f] -> | [{ pat_desc = Ptree.Pwild | Ptree.Ptuple [] }, f] ->
let v = create_pvsymbol (id_fresh "result") ity in let v = create_pvsymbol (id_fresh "result") ity in
v, Loc.try3 ~loc type_fmla muc lvm old f v, Loc.try3 ~loc type_fmla muc lvm old f
| [{ pat_desc = Ptree.Pvar (id,false) }, f] -> | [{ pat_desc = Ptree.Pvar id }, f] ->
let v = create_pvsymbol (create_user_id id) ity in let v = create_pvsymbol (create_user_id id) ity in
let lvm = Mstr.add id.id_str v lvm in let lvm = Mstr.add id.id_str v lvm in
v, Loc.try3 ~loc type_fmla muc lvm old f v, Loc.try3 ~loc type_fmla muc lvm old f
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment