programs: abstract types

parent 5f1bd9b7
module Char
abstract type char model int
end
module String
use import int.Int
use import module Char
use array.ArrayLength as S
mutable type string model S.t int char
parameter get : s:string -> i:int ->
{ 0 <= i < S.length s } char reads s { result = S.get s i }
parameter set : s:string -> i:int -> v:char ->
{ 0 <= i < S.length s } unit writes s { s = S.set (old s) i v }
parameter length : s:string -> {} int reads s { result = S.length s }
end
...@@ -29,7 +29,7 @@ ...@@ -29,7 +29,7 @@
;; Note: comment font-lock is guaranteed by suitable syntax entries ;; Note: comment font-lock is guaranteed by suitable syntax entries
;; '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-face) ;; '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-face)
'("{\\([^}]*\\)}" . font-lock-type-face) '("{\\([^}]*\\)}" . font-lock-type-face)
`(,(why-regexp-opt '("use" "clone" "namespace" "import" "export" "inductive" "external" "logic" "parameter" "exception" "axiom" "lemma" "goal" "type" "mutable" "model")) . font-lock-builtin-face) `(,(why-regexp-opt '("use" "clone" "namespace" "import" "export" "inductive" "external" "logic" "parameter" "exception" "axiom" "lemma" "goal" "type" "mutable" "model" "abstract")) . font-lock-builtin-face)
`(,(why-regexp-opt '("and" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "invariant" "variant" "for" "to" "downto" "do" "done" "label" "assert" "absurd" "assume" "check" "ghost" "try" "with" "theory" "uses" "module")) . font-lock-keyword-face) `(,(why-regexp-opt '("and" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "invariant" "variant" "for" "to" "downto" "do" "done" "label" "assert" "absurd" "assume" "check" "ghost" "try" "with" "theory" "uses" "module")) . font-lock-keyword-face)
; `(,(why-regexp-opt '("unit" "bool" "int" "float" "prop" "array")) . font-lock-type-face) ; `(,(why-regexp-opt '("unit" "bool" "int" "float" "prop" "array")) . font-lock-type-face)
) )
......
...@@ -76,6 +76,7 @@ ...@@ -76,6 +76,7 @@
"use", USE; "use", USE;
"with", WITH; "with", WITH;
(* programs *) (* programs *)
"abstract", ABSTRACT;
"absurd", ABSURD; "absurd", ABSURD;
"any", ANY; "any", ANY;
"assert", ASSERT; "assert", ASSERT;
......
...@@ -157,7 +157,8 @@ ...@@ -157,7 +157,8 @@
/* program keywords */ /* program keywords */
%token ABSURD ANY ASSERT ASSUME BEGIN CHECK DO DONE DOWNTO EXCEPTION FOR %token ABSTRACT ABSURD ANY ASSERT ASSUME BEGIN CHECK DO DONE DOWNTO
%token EXCEPTION FOR
%token FUN GHOST INVARIANT LABEL MODEL MODULE MUTABLE PARAMETER RAISE %token FUN GHOST INVARIANT LABEL MODEL MODULE MUTABLE PARAMETER RAISE
%token RAISES READS REC TO TRY VARIANT WHILE WRITES %token RAISES READS REC TO TRY VARIANT WHILE WRITES
...@@ -871,8 +872,10 @@ program_decl: ...@@ -871,8 +872,10 @@ program_decl:
{ $2 } { $2 }
| NAMESPACE namespace_import uident list0_program_decl END | NAMESPACE namespace_import uident list0_program_decl END
{ Dnamespace ($3, $2, $4) } { Dnamespace ($3, $2, $4) }
| ABSTRACT TYPE lident type_args model
{ Dmodel_type (false, $3, $4, $5) }
| MUTABLE TYPE lident type_args model | MUTABLE TYPE lident type_args model
{ Dmutable_type ($3, $4, $5) } { Dmodel_type (true, $3, $4, $5) }
; ;
use_module: use_module:
......
...@@ -230,7 +230,7 @@ type program_decl = ...@@ -230,7 +230,7 @@ type program_decl =
(* modules *) (* modules *)
| Duse of qualid * imp_exp * (*as:*) ident option | Duse of qualid * imp_exp * (*as:*) ident option
| Dnamespace of ident * (* import: *) bool * program_decl list | Dnamespace of ident * (* import: *) bool * program_decl list
| Dmutable_type of ident * ident list * pty option | Dmodel_type of bool * ident * ident list * pty option
type module_ = { type module_ = {
mod_name : ident; mod_name : ident;
......
...@@ -11,4 +11,6 @@ o fixed precedence of label (label L: e) wrt sequence (e ; e) ...@@ -11,4 +11,6 @@ o fixed precedence of label (label L: e) wrt sequence (e ; e)
o misfix _[_] and _[_] := _ for arrays (both in logic and programs) o misfix _[_] and _[_] := _ for arrays (both in logic and programs)
o model types (abstract but not mutable)
abstract types (no model)
...@@ -7,55 +7,63 @@ open Theory ...@@ -7,55 +7,63 @@ open Theory
open Term open Term
open Decl open Decl
(* mutable types *) (* model types *)
type mtsymbol = { type mtsymbol = {
mt_name : ident; mt_name : ident;
mt_args : tvsymbol list; mt_args : tvsymbol list;
mt_model : ty option; mt_model : ty option;
mt_abstr : tysymbol; mt_abstr : tysymbol;
mt_mutable: bool;
} }
let mt_equal : mtsymbol -> mtsymbol -> bool = (==) let mt_equal : mtsymbol -> mtsymbol -> bool = (==)
let mutable_types = Hts.create 17 let model_types = Hts.create 17
let create_mtsymbol name args model = let create_mtsymbol ~mut name args model =
let id = id_register name in let id = id_register name in
let ts = create_tysymbol name args None in let ts = create_tysymbol name args None in
let mt = let mt =
{ mt_name = id; { mt_name = id;
mt_args = args; mt_args = args;
mt_model = model; mt_model = model;
mt_abstr = ts; } mt_abstr = ts;
mt_mutable = mut; }
in in
Hts.add mutable_types ts mt; Hts.add model_types ts mt;
mt mt
let is_mutable_ts = Hts.mem mutable_types let is_mutable_ts ts =
try (Hts.find model_types ts).mt_mutable with Not_found -> false
let is_mutable_ty ty = match ty.ty_node with let is_mutable_ty ty = match ty.ty_node with
| Ty.Tyapp (ts, _) -> is_mutable_ts ts | Ty.Tyapp (ts, _) -> is_mutable_ts ts
| Ty.Tyvar _ -> false | Ty.Tyvar _ -> false
exception NotMutable exception NotModelType
let get_mtsymbol ts = let get_mtsymbol ts =
try Hts.find mutable_types ts with Not_found -> raise NotMutable try Hts.find model_types ts with Not_found -> raise NotModelType
let model_type ty = match ty.ty_node with let rec model_type ty = match ty.ty_node with
| Tyapp (ts, tyl) when Hts.mem mutable_types ts -> | Tyapp (ts, tyl) ->
let mt = Hts.find mutable_types ts in let tyl = List.map model_type tyl in
begin match mt.mt_model with begin try
| None -> let mt = Hts.find model_types ts in
ty begin match mt.mt_model with
| Some ty -> | None ->
let add mtv tv ty = Mtv.add tv ty mtv in ty
let mtv = List.fold_left2 add Mtv.empty mt.mt_args tyl in | Some ty ->
ty_inst mtv ty let add mtv tv ty = Mtv.add tv ty mtv in
let mtv = List.fold_left2 add Mtv.empty mt.mt_args tyl in
model_type (ty_inst mtv ty) (* FIXME: could be optimized? *)
end
with Not_found ->
ty_app ts tyl
end end
| Tyvar _ | Tyapp _ -> | Tyvar _ ->
raise NotMutable ty
(* types *) (* types *)
...@@ -185,7 +193,7 @@ end = struct ...@@ -185,7 +193,7 @@ end = struct
(* purify: turns program types into logic types *) (* purify: turns program types into logic types *)
let purify ty = try model_type ty with NotMutable -> ty let purify ty = model_type ty
let rec uncurry_type ?(logic=false) = function let rec uncurry_type ?(logic=false) = function
| Tpure ty when not logic -> | Tpure ty when not logic ->
......
...@@ -7,23 +7,25 @@ open Theory ...@@ -7,23 +7,25 @@ open Theory
open Term open Term
open Decl open Decl
(* mutable type symbols *) (* model type symbols *)
type mtsymbol = private { type mtsymbol = private {
mt_name : ident; mt_name : ident;
mt_args : tvsymbol list; mt_args : tvsymbol list;
mt_model : ty option; mt_model : ty option;
mt_abstr : tysymbol; mt_abstr : tysymbol;
mt_mutable: bool;
} }
val create_mtsymbol : preid -> tvsymbol list -> ty option -> mtsymbol val create_mtsymbol :
mut:bool -> preid -> tvsymbol list -> ty option -> mtsymbol
val mt_equal : mtsymbol -> mtsymbol -> bool val mt_equal : mtsymbol -> mtsymbol -> bool
exception NotMutable exception NotModelType
val get_mtsymbol : tysymbol -> mtsymbol val get_mtsymbol : tysymbol -> mtsymbol
(** raises [NotMutable] if [ts] is not a mutable type *) (** raises [NotModelType] if [ts] is not a model type *)
val is_mutable_ts : tysymbol -> bool val is_mutable_ts : tysymbol -> bool
val is_mutable_ty : ty -> bool val is_mutable_ty : ty -> bool
......
...@@ -1604,7 +1604,7 @@ let rec decl ~wp env penv lmod uc = function ...@@ -1604,7 +1604,7 @@ let rec decl ~wp env penv lmod uc = function
let uc = List.fold_left (decl ~wp env penv lmod) uc dl in let uc = List.fold_left (decl ~wp env penv lmod) uc dl in
begin try close_namespace uc import (Some id.id) begin try close_namespace uc import (Some id.id)
with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end with ClashSymbol s -> errorm ~loc "clash with previous symbol %s" s end
| Ptree.Dmutable_type (id, args, model) -> | Ptree.Dmodel_type (mut, id, args, model) ->
let loc = id.id_loc in let loc = id.id_loc in
let id = id_user id.id loc in let id = id_user id.id loc in
let denv = Typing.create_denv (theory_uc uc) in let denv = Typing.create_denv (theory_uc uc) in
...@@ -1619,7 +1619,7 @@ let rec decl ~wp env penv lmod uc = function ...@@ -1619,7 +1619,7 @@ let rec decl ~wp env penv lmod uc = function
model model
in in
option_iter (check_type_vars ~loc args) model; option_iter (check_type_vars ~loc args) model;
let mt = create_mtsymbol id args model in let mt = create_mtsymbol ~mut id args model in
let uc = let uc =
let d = Decl.create_ty_decl [mt.mt_abstr, Decl.Tabstract] in let d = Decl.create_ty_decl [mt.mt_abstr, Decl.Tabstract] in
Pgm_module.add_logic_decl d uc Pgm_module.add_logic_decl d uc
......
...@@ -166,7 +166,10 @@ let abstract_wp env ef (q',ql') (q,ql) = ...@@ -166,7 +166,10 @@ let abstract_wp env ef (q',ql') (q,ql) =
in in
let f = let f =
let res, f = q and res', f' = q' in let res, f = q and res', f' = q' in
let f' = f_subst (subst1 res' (t_var res)) f' in let f' =
if is_arrow_ty res'.vs_ty then f'
else f_subst (subst1 res' (t_var res)) f'
in
quantify_res f' f (Some res) quantify_res f' f (Some res)
in in
wp_ands (f :: List.map2 quantify_h ql' ql) wp_ands (f :: List.map2 quantify_h ql' ql)
......
...@@ -2,13 +2,10 @@ ...@@ -2,13 +2,10 @@
module P module P
use import int.Int use import int.Int
use import module stdlib.Ref use import module string.String
let f1 () (a : ref int) = !a let foo (s:string) = { S.length s = 1 } get s 0 { true }
parameter r : ref int
let f2 () = f1 () r
end end
......
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