programs: parsing of annotations done later (ocamlyacc is not reentrant at all); typing exceptions

parent 87fa1632
...@@ -511,6 +511,9 @@ test: bin/why.byte $(TOOLS) ...@@ -511,6 +511,9 @@ test: bin/why.byte $(TOOLS)
testl: bin/whyml.byte testl: bin/whyml.byte
ocamlrun -bt bin/whyml.byte -I theories/ tests/test-pgm-jcf.mlw ocamlrun -bt bin/whyml.byte -I theories/ tests/test-pgm-jcf.mlw
bench/programs/good/%: bin/whyml.byte
bin/whyml.byte -I theories bench/programs/good/$*.mlw
examples/programs/%: bin/whyml.byte examples/programs/%: bin/whyml.byte
bin/whyml.byte -I theories examples/programs/$*.mlw bin/whyml.byte -I theories examples/programs/$*.mlw
......
...@@ -111,6 +111,7 @@ echo "" ...@@ -111,6 +111,7 @@ echo ""
echo "=== Type-checking good programs ===" echo "=== Type-checking good programs ==="
pgml_options=--type-only pgml_options=--type-only
programs bench/programs/good
programs examples/programs programs examples/programs
echo "" echo ""
(* exception without argument *)
exception E
let p1 () = {} (raise E : unit) { false } | E -> { true }
(* exception with an argument *)
exception F of int
let p2 () = {} raise (F 1) : unit { false } | F -> { result = 1 }
let p2a () =
{} raise (F (raise E : int)) : unit { false } | E -> { true } | F -> { false }
(* composition of exceptions with other constructs *)
let p3 () =
{} begin raise (F 1); raise (F 2) : unit end { false } | F -> { result = 1 }
let p4 () =
{}
(if True then raise (F 1) else raise (F 2)) : unit
{ false } | F -> { result = 1 }
let p5 () =
{}
begin
if True then raise (F 1);
raise E : unit
end
{ false } | E -> { false } | F -> { result = 1 }
let p6 () =
{}
begin
if False then raise (F 1);
raise E : unit
end
{ false } | E -> { true } | F -> { false }
(* composition of exceptions with side-effect on a reference *)
parameter x : int ref
let p7 () =
{} begin x := 1; raise E; x := 2 end { false } | E -> { !x = 1 }
let p8 () =
{}
begin x := 1; raise (F !x); x := 2 end
{ false } | F -> { !x = 1 and result = 1 }
let p9 () =
{}
(raise (F begin x := 1; !x end) : unit)
{ false } | F -> { !x = 1 and result = 1 }
(* try / with *)
let p10 () = {} (try raise E : int with E -> 0 end) { result = 0 }
let p11 () = {} (try raise (F 1) : int with F x -> x end) { result = 1 }
let p12 () =
{}
try
begin raise E; raise (F 1); 1 end
with E -> 2
| F x -> 3
end
{ result = 2 }
let p13 () =
{}
try
begin raise E; raise (F 1); x := 1 end
with E -> x := 2
| F _ -> x := 3
end
{ !x = 2 }
let p13a () =
{}
try
(if !x = 1 then raise E)
(*{ true | E => x = 1 }*)
with E ->
x := 0
end
{ !x <> 1 }
exception E1
exception E2
exception E3
let p14 () =
{}
begin
if !x = 1 then raise E1;
if !x = 2 then raise E2;
if !x = 3 then raise E3;
raise E : unit
end
{ false } | E1 -> { !x = 1 } | E2 -> { !x = 2 } | E3 -> { !x = 3 }
| E -> { !x <> 1 and !x <> 2 and !x <> 3 }
let p15 () =
{}
if !x = 0 then raise E else (x := 0; raise (F !x)) : unit
{ false } | E -> { !x=0 } | F -> { result=0 }
let p16 () = {} if !x = 0 then (x:=1; raise E) { !x<>0 } | E -> { !x=1 }
let p17 () = {} (x := 0; (raise E; x := 1)) { false } | E -> { !x=0 }
(*
Local Variables:
compile-command: "unset LANG; make -C ../../.. bench/programs/good/exns"
End:
*)
{ {
use set.Fset as S use set.Fset as S
use array.Array as M use array.Array as M
...@@ -205,7 +204,6 @@ let shortest_path_code (src:vertex) (dst:vertex) = ...@@ -205,7 +204,6 @@ let shortest_path_code (src:vertex) (dst:vertex) =
(forall v:vertex. (forall v:vertex.
not S.mem(v, !visited) -> forall dv:int. not path(src, v, dv)) } not S.mem(v, !visited) -> forall dv:int. not path(src, v, dv)) }
(* (*
Local Variables: Local Variables:
compile-command: "unset LANG; make -C ../.. examples/programs/dijkstra" compile-command: "unset LANG; make -C ../.. examples/programs/dijkstra"
......
...@@ -39,6 +39,7 @@ ...@@ -39,6 +39,7 @@
(fun (x,y) -> Hashtbl.add keywords x y) (fun (x,y) -> Hashtbl.add keywords x y)
[ "absurd", ABSURD; [ "absurd", ABSURD;
"and", AND; "and", AND;
"any", ANY;
"as", AS; "as", AS;
"assert", ASSERT; "assert", ASSERT;
"assume", ASSUME; "assume", ASSUME;
...@@ -146,8 +147,6 @@ rule token = parse ...@@ -146,8 +147,6 @@ rule token = parse
{ LEFTPAR } { LEFTPAR }
| ")" | ")"
{ RIGHTPAR } { RIGHTPAR }
| "()"
{ UIDENT "Unit" }
| ":" | ":"
{ COLON } { COLON }
| ";" | ";"
......
...@@ -68,31 +68,24 @@ ...@@ -68,31 +68,24 @@
let id = { id = prefix op; id_loc = loc_i 1 } in let id = { id = prefix op; id_loc = loc_i 1 } in
mk_expr (mk_apply_id id [e1]) mk_expr (mk_apply_id id [e1])
let id_unit () = { id = "Unit"; id_loc = loc () } let id_unit () = { id = "unit"; id_loc = loc () }
let id_result () = { id = "result"; id_loc = loc () } let id_result () = { id = "result"; id_loc = loc () }
let id_anonymous () = { id = "_"; id_loc = loc () } let id_anonymous () = { id = "_"; id_loc = loc () }
let lexpr_true () = { Ptree.pp_loc = loc (); Ptree.pp_desc = PPtrue } let ty_unit () = Tpure (PPTtyapp ([], Qident (id_unit ())))
let lexpr_false () = { Ptree.pp_loc = loc (); Ptree.pp_desc = PPfalse }
(* parsing LOGIC strings using functions from src/parser/ let lexpr_true () = symbol_start_pos (), "true"
requires proper relocation *) let lexpr_false () = symbol_start_pos (), "false"
let reloc loc lb =
lb.lex_curr_p <- loc;
lb.lex_abs_pos <- loc.pos_cnum
let parse_string f loc s =
let lb = Lexing.from_string s in
reloc loc lb;
f lb
let logic_list0_decl (loc, s) = parse_string Lexer.parse_list0_decl loc s
let lexpr (loc, s) = parse_string Lexer.parse_lexpr loc s
let empty_effect = { pe_reads = []; pe_writes = []; pe_raises = [] } let empty_effect = { pe_reads = []; pe_writes = []; pe_raises = [] }
let type_c p ty ef q =
{ pc_result_name = id_result ();
pc_result_type = ty;
pc_effect = ef;
pc_pre = p;
pc_post = q; }
%} %}
/* Tokens */ /* Tokens */
...@@ -106,7 +99,7 @@ ...@@ -106,7 +99,7 @@
/* keywords */ /* keywords */
%token ABSURD AND AS ASSERT ASSUME BEGIN CHECK DO DONE ELSE END %token ABSURD AND ANY AS ASSERT ASSUME BEGIN CHECK DO DONE ELSE END
%token EXCEPTION FOR %token EXCEPTION FOR
%token FUN GHOST IF IN INVARIANT LABEL LET MATCH NOT OF PARAMETER %token FUN GHOST IF IN INVARIANT LABEL LET MATCH NOT OF PARAMETER
%token RAISE RAISES READS REC %token RAISE RAISES READS REC
...@@ -121,6 +114,9 @@ ...@@ -121,6 +114,9 @@
/* Precedences */ /* Precedences */
%nonassoc prec_post
%nonassoc BAR
%nonassoc prec_recfun %nonassoc prec_recfun
%nonassoc prec_triple %nonassoc prec_triple
%left LEFTBLEFTB %left LEFTBLEFTB
...@@ -154,6 +150,8 @@ ...@@ -154,6 +150,8 @@
%nonassoc prec_decls %nonassoc prec_decls
%nonassoc LOGIC TYPE INDUCTIVE %nonassoc LOGIC TYPE INDUCTIVE
/* Entry points */ /* Entry points */
%type <Pgm_ptree.file> file %type <Pgm_ptree.file> file
...@@ -181,7 +179,7 @@ list1_decl: ...@@ -181,7 +179,7 @@ list1_decl:
decl: decl:
| LOGIC | LOGIC
{ Dlogic (logic_list0_decl $1) } { Dlogic $1 (*(logic_list0_decl $1)*) }
| LET lident EQUAL expr | LET lident EQUAL expr
{ Dlet ($2, $4) } { Dlet ($2, $4) }
| LET lident list1_type_v_binder EQUAL triple | LET lident list1_type_v_binder EQUAL triple
...@@ -268,7 +266,7 @@ expr: ...@@ -268,7 +266,7 @@ expr:
| expr SEMICOLON expr | expr SEMICOLON expr
{ mk_expr (Esequence ($1, $3)) } { mk_expr (Esequence ($1, $3)) }
| assertion_kind LOGIC | assertion_kind LOGIC
{ mk_expr (Eassert ($1, lexpr $2)) } { mk_expr (Eassert ($1, $2)) }
| expr AMPAMP expr | expr AMPAMP expr
{ mk_expr (Elazy (LazyAnd, $1, $3)) } { mk_expr (Elazy (LazyAnd, $1, $3)) }
| expr BARBAR expr | expr BARBAR expr
...@@ -297,13 +295,17 @@ expr: ...@@ -297,13 +295,17 @@ expr:
{ mk_expr (Eraise ($2, None)) } { mk_expr (Eraise ($2, None)) }
| RAISE LEFTPAR uident expr RIGHTPAR | RAISE LEFTPAR uident expr RIGHTPAR
{ mk_expr (Eraise ($3, Some $4)) } { mk_expr (Eraise ($3, Some $4)) }
| TRY expr WITH option_bar list1_handler_sep_bar END
{ mk_expr (Etry ($2, $5)) }
| ANY simple_type_c
{ mk_expr (Eany $2) }
; ;
triple: triple:
| LOGIC expr LOGIC | pre expr post
{ lexpr $1, $2, lexpr $3 } { $1, $2, $3 }
| expr %prec prec_triple | expr %prec prec_triple
{ lexpr_true (), $1, lexpr_true () } { lexpr_true (), $1, (lexpr_true (), []) }
; ;
simple_expr: simple_expr:
...@@ -338,6 +340,17 @@ option_bar: ...@@ -338,6 +340,17 @@ option_bar:
| BAR { () } | BAR { () }
; ;
list1_handler_sep_bar:
| handler { [$1] }
| handler BAR list1_handler_sep_bar { $1 :: $3 }
;
handler:
| ident ARROW expr { ($1, None, $3) }
| ident ident ARROW expr { ($1, Some $2, $4) }
| ident UNDERSCORE ARROW expr { ($1, Some (id_anonymous ()), $4) }
;
match_cases: match_cases:
| match_case { [$1] } | match_case { [$1] }
| match_case BAR match_cases { $1::$3 } | match_case BAR match_cases { $1::$3 }
...@@ -371,13 +384,13 @@ loop_annotation: ...@@ -371,13 +384,13 @@ loop_annotation:
; ;
loop_invariant: loop_invariant:
| INVARIANT LOGIC { Some (lexpr $2) } | INVARIANT LOGIC { Some $2 }
| /* epsilon */ { None } | /* epsilon */ { None }
; ;
loop_variant: loop_variant:
| VARIANT LOGIC { Some (lexpr $2) } | VARIANT LOGIC { Some $2 }
| /* epsilon */ { None } | /* epsilon */ { None }
; ;
constant: constant:
...@@ -414,14 +427,10 @@ list1_type_v_binder: ...@@ -414,14 +427,10 @@ list1_type_v_binder:
type_v_binder: type_v_binder:
| lident { $1, None } | lident { $1, None }
| LEFTPAR RIGHTPAR { id_anonymous (), Some (ty_unit ()) }
| LEFTPAR lident COLON type_v RIGHTPAR { $2, Some $4 } | LEFTPAR lident COLON type_v RIGHTPAR { $2, Some $4 }
; ;
opt_colon_spec:
| /* epsilon */ { None }
| COLON type_c { Some $2 }
;
type_v: type_v:
| simple_type_v | simple_type_v
{ $1 } { $1 }
...@@ -440,17 +449,38 @@ simple_type_v: ...@@ -440,17 +449,38 @@ simple_type_v:
type_c: type_c:
| type_v | type_v
{ { pc_result_name = id_result (); { type_c (lexpr_true ()) $1 empty_effect (lexpr_true (), []) }
pc_result_type = $1; | pre type_v effects post
pc_effect = empty_effect; { type_c $1 $2 $3 $4 }
pc_pre = lexpr_true (); ;
pc_post = lexpr_true (); } }
| LOGIC type_v effects LOGIC simple_type_c:
{ { pc_result_name = id_result (); | simple_type_v
pc_result_type = $2; { type_c (lexpr_true ()) $1 empty_effect (lexpr_true (), []) }
pc_effect = $3; | pre type_v effects post
pc_pre = lexpr $1; { type_c $1 $2 $3 $4 }
pc_post = lexpr $4; } } ;
pre:
| LOGIC { $1 }
;
post:
| LOGIC list0_post_exn { $1, $2 }
;
list0_post_exn:
| /* epsilon */ %prec prec_post { [] }
| list1_post_exn { $1 }
;
list1_post_exn:
| post_exn %prec prec_post { [$1] }
| post_exn list1_post_exn { $1 :: $2 }
;
post_exn:
| BAR uident ARROW LOGIC { $2, $4 }
; ;
effects: effects:
...@@ -475,7 +505,7 @@ opt_raises: ...@@ -475,7 +505,7 @@ opt_raises:
opt_variant: opt_variant:
| /* epsilon */ { None } | /* epsilon */ { None }
| VARIANT LOGIC { Some (lexpr $2) } | VARIANT LOGIC { Some $2 }
; ;
list0_lident_sep_comma: list0_lident_sep_comma:
......
...@@ -29,10 +29,12 @@ type constant = Term.constant ...@@ -29,10 +29,12 @@ type constant = Term.constant
type assertion_kind = Aassert | Aassume | Acheck type assertion_kind = Aassert | Aassume | Acheck
type lexpr = Ptree.lexpr
type lazy_op = LazyAnd | LazyOr type lazy_op = LazyAnd | LazyOr
type logic = Lexing.position * string
type lexpr = logic
type loop_annotation = { type loop_annotation = {
loop_invariant : lexpr option; loop_invariant : lexpr option;
loop_variant : lexpr option; loop_variant : lexpr option;
...@@ -44,6 +46,10 @@ type effect = { ...@@ -44,6 +46,10 @@ type effect = {
pe_raises : ident list; pe_raises : ident list;
} }
type pre = lexpr
type post = lexpr * (ident * lexpr) list
type type_v = type type_v =
| Tpure of Ptree.pty | Tpure of Ptree.pty
| Tarrow of binder list * type_c | Tarrow of binder list * type_c
...@@ -52,8 +58,8 @@ and type_c = ...@@ -52,8 +58,8 @@ and type_c =
{ pc_result_name : ident; { pc_result_name : ident;
pc_result_type : type_v; pc_result_type : type_v;
pc_effect : effect; pc_effect : effect;
pc_pre : lexpr; pc_pre : pre;
pc_post : lexpr; } pc_post : post; }
and binder = ident * type_v option and binder = ident * type_v option
...@@ -81,20 +87,22 @@ and expr_desc = ...@@ -81,20 +87,22 @@ and expr_desc =
| Eskip | Eskip
| Eabsurd | Eabsurd
| Eraise of ident * expr option | Eraise of ident * expr option
| Etry of expr * (ident * ident option * expr) list
(* annotations *) (* annotations *)
| Eassert of assertion_kind * lexpr | Eassert of assertion_kind * lexpr
| Eghost of expr | Eghost of expr
| Elabel of ident * expr | Elabel of ident * expr
| Ecast of expr * Ptree.pty | Ecast of expr * Ptree.pty
| Eany of type_c
(* TODO: try, any, post?, ghost *) (* TODO: post?, ghost *)
and triple = lexpr * expr * lexpr and triple = pre * expr * post
type decl = type decl =
| Dlet of ident * expr | Dlet of ident * expr
| Dletrec of (ident * binder list * variant option * triple) list | Dletrec of (ident * binder list * variant option * triple) list
| Dlogic of Ptree.decl list | Dlogic of logic
| Dparam of ident * type_v | Dparam of ident * type_v
| Dexn of ident * Ptree.pty option | Dexn of ident * Ptree.pty option
......
...@@ -41,6 +41,10 @@ type deffect = { ...@@ -41,6 +41,10 @@ type deffect = {
type dlexpr = Typing.denv * Ptree.lexpr type dlexpr = Typing.denv * Ptree.lexpr
type dpre = dlexpr
type dpost = dlexpr * (Term.lsymbol * dlexpr) list
type dtype_v = type dtype_v =
| DTpure of Denv.dty | DTpure of Denv.dty
| DTarrow of dbinder list * dtype_c | DTarrow of dbinder list * dtype_c
...@@ -49,12 +53,17 @@ and dtype_c = ...@@ -49,12 +53,17 @@ and dtype_c =
{ dc_result_name : string; { dc_result_name : string;
dc_result_type : dtype_v; dc_result_type : dtype_v;
dc_effect : deffect; dc_effect : deffect;
dc_pre : dlexpr; dc_pre : dpre;
dc_post : dlexpr; } dc_post : dpost; }
and dbinder = string * dtype_v and dbinder = string * dtype_v
type dvariant = Pgm_ptree.lexpr type dloop_annotation = {
dloop_invariant : Ptree.lexpr option;
dloop_variant : Ptree.lexpr option;
}
type dvariant = Ptree.lexpr
type dexpr = { type dexpr = {
dexpr_desc : dexpr_desc; dexpr_desc : dexpr_desc;
...@@ -76,18 +85,19 @@ and dexpr_desc = ...@@ -76,18 +85,19 @@ and dexpr_desc =
| DEsequence of dexpr * dexpr | DEsequence of dexpr * dexpr
| DEif of dexpr * dexpr * dexpr | DEif of dexpr * dexpr * dexpr
| DEwhile of dexpr * Pgm_ptree.loop_annotation * dexpr | DEwhile of dexpr * dloop_annotation * dexpr
| DElazy of lazy_op * dexpr * dexpr | DElazy of lazy_op * dexpr * dexpr
| DEmatch of dexpr list * (Typing.dpattern list * dexpr) list | DEmatch of dexpr list * (Typing.dpattern list * dexpr) list
| DEskip | DEskip
| DEabsurd | DEabsurd
| DEraise of Term.lsymbol * dexpr option | DEraise of Term.lsymbol * dexpr option
| DEtry of dexpr * (Term.lsymbol * string option * dexpr) list
| DEassert of assertion_kind * Ptree.lexpr | DEassert of assertion_kind * Ptree.lexpr
| DEghost of dexpr | DEghost of dexpr
| DElabel of string * dexpr | DElabel of string * dexpr
and dtriple = dlexpr * dexpr * dlexpr and dtriple = dpre * dexpr * dpost
(* phase 2: typing annotations *) (* phase 2: typing annotations *)
...@@ -103,6 +113,10 @@ type effect = { ...@@ -103,6 +113,10 @@ type effect = {
e_raises : Term.lsymbol list; e_raises : Term.lsymbol list;
} }
type pre = Term.fmla
type post = Term.fmla * (Term.lsymbol * Term.fmla) list
type type_v = type type_v =
| Tpure of Ty.ty | Tpure of Ty.ty
| Tarrow of binder list * type_c | Tarrow of binder list * type_c
...@@ -111,8 +125,8 @@ and type_c = ...@@ -111,8 +125,8 @@ and type_c =
{ c_result_name : Term.vsymbol; { c_result_name : Term.vsymbol;
c_result_type : type_v; c_result_type : type_v;
c_effect : effect; c_effect : effect;
c_pre : Term.fmla; c_pre : pre;
c_post : Term.fmla; } c_post : post; }
and binder = Term.vsymbol * type_v and binder = Term.vsymbol * type_v
...@@ -144,6 +158,7 @@ and expr_desc = ...@@ -144,6 +158,7 @@ and expr_desc =
| Eskip | Eskip
| Eabsurd | Eabsurd
| Eraise of Term.lsymbol * expr option | Eraise of Term.lsymbol * expr option
| Etry of expr * (Term.lsymbol * Term.vsymbol option * expr) list
| Eassert of assertion_kind * Term.fmla | Eassert of assertion_kind * Term.fmla
| Eghost of expr | Eghost of expr
...@@ -151,7 +166,7 @@ and expr_desc = ...@@ -151,7 +166,7 @@ and expr_desc =
and recfun = Term.vsymbol * binder list * variant option * triple and recfun = Term.vsymbol * binder list * variant option * triple
and triple = Term.fmla * expr * Term.fmla