From 30835a54469aaad2feb2909312ea9a4699e0d3fb Mon Sep 17 00:00:00 2001 From: zoep Date: Mon, 16 Mar 2026 13:29:02 +0200 Subject: [PATCH 1/3] add vim syntax highlighting for .act files Co-Authored-By: Claude Opus 4.6 (1M context) --- vim/syntax/act.vim | 91 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 vim/syntax/act.vim diff --git a/vim/syntax/act.vim b/vim/syntax/act.vim new file mode 100644 index 00000000..744ace92 --- /dev/null +++ b/vim/syntax/act.vim @@ -0,0 +1,91 @@ +" Vim syntax file +" Language: Act (formal specification language for EVM smart contracts) +" Maintainer: Act contributors +" Latest Revision: 2026-03-16 + +if exists("b:current_syntax") + finish +endif + +" Keywords +syn keyword actTopLevel contract constructor transition behaviour +syn keyword actBlock creates updates invariants ensures interface pointers storage +syn keyword actClause iff returns case of + +" Modifiers +syn keyword actModifier payable + +" Control flow +syn keyword actConditional if then else + +" Logical operators (word-form) +syn keyword actLogical and or not + +" Boolean literals +syn keyword actBoolean true false + +" Built-in types +syn keyword actType uint uint8 uint16 uint32 uint64 uint128 uint192 uint256 +syn keyword actType int int8 int16 int32 int56 int64 int128 int192 int256 +syn keyword actType bool address string bytes bytes32 mapping + +" Object creation +syn keyword actKeyword new create pre post + +" Built-in functions +syn match actBuiltin /\/ +syn match actBuiltin /\=\@!/ +syn match actOperator /==>/ +syn match actOperator /=\/=/ +syn match actOperator /:=/ +syn match actOperator /=>/ +syn match actOperator /|->/ +syn match actOperator /[+\-\*\/\^%]/ +syn match actOperator // + +" Numbers +syn match actNumber /\<\d\+\>/ +syn match actNumber /\<0x[0-9a-fA-F]\+\>/ + +" Strings +syn region actString start=/"/ skip=/\\"/ end=/"/ + +" Comments +syn match actComment /\/\/.*$/ contains=actTodo +syn keyword actTodo TODO FIXME XXX NOTE contained + +" Typed addresses: address +syn match actTypedAddress /address<[A-Za-z_][A-Za-z0-9_]*>/ + +" Highlighting links +hi def link actTopLevel Structure +hi def link actBlock Keyword +hi def link actClause Keyword +hi def link actModifier StorageClass +hi def link actConditional Conditional +hi def link actLogical Operator +hi def link actBoolean Boolean +hi def link actType Type +hi def link actKeyword Keyword +hi def link actBuiltin Function +hi def link actEnvironment Constant +hi def link actOperator Operator +hi def link actNumber Number +hi def link actString String +hi def link actComment Comment +hi def link actTodo Todo +hi def link actTypedAddress Type + +let b:current_syntax = "act" From b8d8f2ad24227f15781941c27b8d864b578120bc Mon Sep 17 00:00:00 2001 From: zoep Date: Tue, 17 Mar 2026 11:42:47 +0200 Subject: [PATCH 2/3] LLM-assisted mechanized metatheory for act --- theories/Domains.v | 372 +++++++ theories/Makefile | 13 + theories/Maps.v | 165 +++ theories/Semantics.v | 1185 +++++++++++++++++++++ theories/Soundness.v | 1105 ++++++++++++++++++++ theories/Syntax.v | 193 ++++ theories/TypeSafety.v | 2074 +++++++++++++++++++++++++++++++++++++ theories/Typing.v | 554 ++++++++++ theories/TypingT.v | 523 ++++++++++ theories/ValueSemantics.v | 1036 ++++++++++++++++++ theories/ValueTyping.v | 831 +++++++++++++++ theories/_CoqProject | 12 + theories/test.v | 10 + 13 files changed, 8073 insertions(+) create mode 100644 theories/Domains.v create mode 100644 theories/Makefile create mode 100644 theories/Maps.v create mode 100644 theories/Semantics.v create mode 100644 theories/Soundness.v create mode 100644 theories/Syntax.v create mode 100644 theories/TypeSafety.v create mode 100644 theories/Typing.v create mode 100644 theories/TypingT.v create mode 100644 theories/ValueSemantics.v create mode 100644 theories/ValueTyping.v create mode 100644 theories/_CoqProject create mode 100644 theories/test.v diff --git a/theories/Domains.v b/theories/Domains.v new file mode 100644 index 00000000..02da8f61 --- /dev/null +++ b/theories/Domains.v @@ -0,0 +1,372 @@ +(** * Semantic Domains + Values, states, and environments for the pointer semantics + (Section 2 of the tech report). *) + +From Stdlib Require Import String ZArith List Bool PeanoNat Lia. +From Act Require Import Maps Syntax. +Import ListNotations. + +(* ================================================================= *) +(** ** Addresses *) + +Definition addr := nat. + +(* ================================================================= *) +(** ** Values *) + +(** BaseValue ≡ Z + B + Addr *) +Inductive base_value : Type := + | BVInt : Z -> base_value + | BVBool : bool -> base_value + | BVAddr : addr -> base_value. + +(** Value ≡ (Z → Value) + (B → Value) + (Addr → Value) + BaseValue *) +Inductive value : Type := + | VBase : base_value -> value + | VMapZ : (Z -> value) -> value + | VMapB : (bool -> value) -> value + | VMapA : (addr -> value) -> value. + +(** Coercions from base values *) +Definition VInt (n : Z) : value := VBase (BVInt n). +Definition VBool (b : bool) : value := VBase (BVBool b). +Definition VAddr (a : addr) : value := VBase (BVAddr a). + +(* ================================================================= *) +(** ** State *) + +(** A single storage location stores a contract type name and + a mapping from variable names to values. *) +Record loc_store := mk_loc_store { + loc_type : ident; + loc_vars : partial_map value; +}. + +(** State: a store mapping addresses to location stores, + together with the next fresh address and a proof that it is fresh. *) +Record state := mk_state { + state_store :> addr -> option loc_store; + state_next : addr; + state_fresh : forall l, l >= state_next -> state_store l = None; +}. + +Definition state_empty : state := + mk_state (fun _ => None) 0 (fun _ _ => eq_refl). + +Definition state_lookup (s : state) (l : addr) : option loc_store := s l. + +Definition state_dom (s : state) (l : addr) : Prop := + exists ls, s l = Some ls. + +(** If a location is in the domain, its address is below state_next. *) +Lemma state_store_bound : forall (s : state) (l : addr) (ls : loc_store), + s l = Some ls -> l < state_next s. +Proof. + intros s l ls H. + destruct (Nat.lt_ge_cases l (state_next s)) as [Hlt | Hge]; auto. + rewrite (state_fresh s l Hge) in H. discriminate. +Qed. + +Lemma state_dom_bound : forall s l, state_dom s l -> l < state_next s. +Proof. intros s l [ls H]. eapply state_store_bound; eauto. Qed. + +Definition state_update (s : state) (l : addr) (ls : loc_store) + (Hl : l < state_next s) : state := + mk_state + (fun l' => if Nat.eqb l l' then Some ls else s l') + (state_next s) + (fun l' Hge => + match Nat.eqb_spec l l' with + | ReflectT _ Heq => + ltac:(exfalso; abstract lia) + | ReflectF _ _ => state_fresh s l' Hge + end). + +(** s(ℓ).type *) +Definition state_type (s : state) (l : addr) : option ident := + match s l with + | Some ls => Some (loc_type ls) + | None => None + end. + +(** s(ℓ)(x) *) +Definition state_var (s : state) (l : addr) (x : ident) : option value := + match s l with + | Some ls => loc_vars ls x + | None => None + end. + +(** x ∈ dom(s(ℓ)) *) +Definition state_var_dom (s : state) (l : addr) (x : ident) : Prop := + exists v, state_var s l x = Some v. + +(** Force-extract a value from state, defaulting to VInt 0 *) +Definition state_var_force (s : state) (l : addr) (x : ident) : value := + match state_var s l x with + | Some v => v + | None => VInt 0%Z + end. + +(** Update a single variable in the store at location ℓ: + s[ℓ ↦ s(ℓ)[x ↦ v]] *) +Definition state_update_var (s : state) (l : addr) (x : ident) (v : value) : state := + mk_state + (fun l' => match s l with + | Some ls => + if Nat.eqb l l' then + Some (mk_loc_store (loc_type ls) (Maps.update (loc_vars ls) x v)) + else s l' + | None => s l' + end) + (state_next s) + ltac:(intros l' Hge; destruct (s l) eqn:El; + [ destruct (Nat.eqb_spec l l'); + [exfalso; apply (state_store_bound s l) in El; lia + |apply state_fresh; lia] + | apply state_fresh; lia]). + +(** Spec lemmas for state_update and state_update_var *) +Lemma state_update_store : forall s l ls Hl l', + state_update s l ls Hl l' = if Nat.eqb l l' then Some ls else s l'. +Proof. reflexivity. Qed. + +Lemma state_update_next_eq : forall s l ls Hl, + state_next (state_update s l ls Hl) = state_next s. +Proof. reflexivity. Qed. + +Lemma state_update_var_store : forall s l x v l', + state_update_var s l x v l' = + match s l with + | Some ls => if Nat.eqb l l' then + Some (mk_loc_store (loc_type ls) (Maps.update (loc_vars ls) x v)) + else s l' + | None => s l' + end. +Proof. reflexivity. Qed. + +Lemma state_update_var_next : forall s l x v, + state_next (state_update_var s l x v) = state_next s. +Proof. reflexivity. Qed. + +(** Allocate a new location using the next fresh address. *) +Definition state_alloc (s : state) (id : ident) (bindings : partial_map value) : state := + let l := state_next s in + mk_state + (fun l' => if Nat.eqb l l' then Some (mk_loc_store id bindings) else s l') + (S l) + (fun l' Hge => + match Nat.eqb_spec l l' with + | ReflectT _ Heq => + ltac:(exfalso; abstract lia) + | ReflectF _ _ => + state_fresh s l' ltac:(abstract lia) + end). + +Definition state_alloc_addr (s : state) : addr := state_next s. + +Lemma state_alloc_store : forall s id bindings l', + state_alloc s id bindings l' = + if Nat.eqb (state_next s) l' then Some (mk_loc_store id bindings) else s l'. +Proof. reflexivity. Qed. + +Lemma state_alloc_next : forall s id bindings, + state_next (state_alloc s id bindings) = S (state_next s). +Proof. reflexivity. Qed. + +Lemma state_alloc_self : forall s id bindings, + state_alloc s id bindings (state_next s) = Some (mk_loc_store id bindings). +Proof. intros. rewrite state_alloc_store. rewrite Nat.eqb_refl. auto. Qed. + +Lemma state_alloc_other : forall s id bindings l', + l' <> state_next s -> + state_alloc s id bindings l' = s l'. +Proof. + intros. rewrite state_alloc_store. + destruct (Nat.eqb_spec (state_next s) l'); auto. subst. exfalso; auto. +Qed. + +(** State inclusion: s ⊆ s' means dom(s) ⊆ dom(s') and + for all ℓ ∈ dom(s), s(ℓ) = s'(ℓ). *) +Definition state_incl (s s' : state) : Prop := + forall l ls, s l = Some ls -> s' l = Some ls. + +Lemma state_incl_alloc : forall s id bindings, + state_incl s (state_alloc s id bindings). +Proof. + intros s id bindings l ls H. + rewrite state_alloc_other; auto. + intro Heq. subst. pose proof (state_store_bound _ _ _ H). lia. +Qed. + +(* ================================================================= *) +(** ** Environment *) + +(** Env ≡ String ⇀ BaseValue + For our formalization, the environment maps identifiers to values + (since base values are embedded in values). *) +Definition env := partial_map value. + +(* ================================================================= *) +(** ** Timing Tags *) + +(** The tag t on references: U (untimed) or T (timed) *) +Inductive time_tag : Type := + | TagU : time_tag (** untimed *) + | TagT : time_tag. (** timed *) + +(** The timing of an evaluated reference: U, pre, or post *) +Inductive ref_time : Type := + | RTU : ref_time (** untimed *) + | RTPre : ref_time (** pre-state *) + | RTPost : ref_time. (** post-state *) + +(** Timed state: either a single state (untimed) or a pair (timed) *) +Inductive timed_state : Type := + | TSUntimed : state -> timed_state + | TSTimed : state -> state -> timed_state. (** (s_pre, s_post) *) + +(* ================================================================= *) +(** ** State Environment Σ *) + +(** The typing environment Σ has three components: + - Storage: maps contract names to their storage layout + - Cnstr: maps contract names to their constructor + - Trans: maps contract names to their list of transitions + We use association lists for finite enumerability (needed for + induction on Σ-size in type safety proofs). *) +Record contract_env := mk_contract_env { + Σ_storage_list : alist storage_layout; + Σ_cnstr_list : alist constructor; + Σ_trans_list : alist (list transition); +}. + +(** Accessor functions (partial_map view) *) +Definition Σ_storage (Σ : contract_env) : partial_map storage_layout := + alist_lookup (Σ_storage_list Σ). +Definition Σ_cnstr (Σ : contract_env) : partial_map constructor := + alist_lookup (Σ_cnstr_list Σ). +Definition Σ_trans (Σ : contract_env) : partial_map (list transition) := + alist_lookup (Σ_trans_list Σ). + +Definition Σ_empty : contract_env := mk_contract_env [] [] []. + +(** Σ with updated storage *) +Definition Σ_with_storage (Σ : contract_env) (id : ident) (c : storage_layout) : contract_env := + mk_contract_env ((id, c) :: Σ_storage_list Σ) (Σ_cnstr_list Σ) (Σ_trans_list Σ). + +(** Σ with updated constructor *) +Definition Σ_with_cnstr (Σ : contract_env) (id : ident) (ct : constructor) : contract_env := + mk_contract_env (Σ_storage_list Σ) ((id, ct) :: Σ_cnstr_list Σ) (Σ_trans_list Σ). + +(** Σ with updated transitions *) +Definition Σ_with_trans (Σ : contract_env) (id : ident) (ts : list transition) : contract_env := + mk_contract_env (Σ_storage_list Σ) (Σ_cnstr_list Σ) ((id, ts) :: Σ_trans_list Σ). + +(** Size of Σ (number of constructor entries) *) +Definition Σ_cnstr_size (Σ : contract_env) : nat := length (Σ_cnstr_list Σ). + +(** Interaction lemmas: Σ_with_* and accessors *) +Lemma Σ_storage_with_storage : forall Σ id c, + Σ_storage (Σ_with_storage Σ id c) = Maps.update (Σ_storage Σ) id c. +Proof. reflexivity. Qed. +Lemma Σ_cnstr_with_storage : forall Σ id c, + Σ_cnstr (Σ_with_storage Σ id c) = Σ_cnstr Σ. +Proof. reflexivity. Qed. +Lemma Σ_trans_with_storage : forall Σ id c, + Σ_trans (Σ_with_storage Σ id c) = Σ_trans Σ. +Proof. reflexivity. Qed. + +Lemma Σ_storage_with_cnstr : forall Σ id ct, + Σ_storage (Σ_with_cnstr Σ id ct) = Σ_storage Σ. +Proof. reflexivity. Qed. +Lemma Σ_cnstr_with_cnstr : forall Σ id ct, + Σ_cnstr (Σ_with_cnstr Σ id ct) = Maps.update (Σ_cnstr Σ) id ct. +Proof. reflexivity. Qed. +Lemma Σ_trans_with_cnstr : forall Σ id ct, + Σ_trans (Σ_with_cnstr Σ id ct) = Σ_trans Σ. +Proof. reflexivity. Qed. + +Lemma Σ_storage_with_trans : forall Σ id ts, + Σ_storage (Σ_with_trans Σ id ts) = Σ_storage Σ. +Proof. reflexivity. Qed. +Lemma Σ_cnstr_with_trans : forall Σ id ts, + Σ_cnstr (Σ_with_trans Σ id ts) = Σ_cnstr Σ. +Proof. reflexivity. Qed. +Lemma Σ_trans_with_trans : forall Σ id ts, + Σ_trans (Σ_with_trans Σ id ts) = Maps.update (Σ_trans Σ) id ts. +Proof. reflexivity. Qed. + +Lemma Σ_cnstr_size_with_cnstr : forall Σ id ct, + Σ_cnstr_size (Σ_with_cnstr Σ id ct) = S (Σ_cnstr_size Σ). +Proof. reflexivity. Qed. + +Lemma Σ_cnstr_size_with_storage : forall Σ id c, + Σ_cnstr_size (Σ_with_storage Σ id c) = Σ_cnstr_size Σ. +Proof. reflexivity. Qed. + +Lemma Σ_cnstr_size_with_trans : forall Σ id ts, + Σ_cnstr_size (Σ_with_trans Σ id ts) = Σ_cnstr_size Σ. +Proof. reflexivity. Qed. + +(** Σ ⊆ Σ' *) +Definition Σ_incl (Σ Σ' : contract_env) : Prop := + includes (Σ_storage Σ) (Σ_storage Σ') /\ + includes (Σ_cnstr Σ) (Σ_cnstr Σ') /\ + includes (Σ_trans Σ) (Σ_trans Σ'). + +(** Look up a storage variable type: Σ_Storage(A)(x) *) +Definition Σ_storage_var (Σ : contract_env) (a : ident) (x : ident) : option slot_type := + match Σ_storage Σ a with + | Some layout => alist_lookup layout x + | None => None + end. + +(** Σ ⊢ ℓ :_s A — shorthand for: location ℓ has contract type A in state s *) +(** (defined formally in ValueTyping.v) *) + +(** Helper: is a constructor payable? *) +Definition isPayable (ct : constructor) : bool := ctor_payable ct. + +(** dummy location — used when location is irrelevant (written · in the paper) *) +Definition dummy_loc : addr := 0. + +(** meta(β) — the Coq type corresponding to a base type *) +(** meta(ι) = Z, meta(bool) = B, meta(address) = Addr *) +(** We don't reify this as a Coq type; instead we use predicates on values. *) + +(** default(μ) — the default value of a mapping type *) +Fixpoint default_value (mu : mapping_type) : value := + match mu with + | MBase (TInt _) => VInt 0%Z + | MBase TBool => VBool false + | MBase TAddress => VAddr 0 + | MMapping (TInt _) mu' => VMapZ (fun _ => default_value mu') + | MMapping TBool mu' => VMapB (fun _ => default_value mu') + | MMapping TAddress mu' => VMapA (fun _ => default_value mu') + end. + +(** min and max for integer types *) +Definition int_min (it : int_type) : option Z := + match it with + | UintT _ => Some 0%Z + | IntT m => Some (- Z.pow 2 (Z.of_nat m - 1))%Z + | IntUnbounded => None (** unbounded int has no min *) + end. + +Definition int_max (it : int_type) : option Z := + match it with + | UintT m => Some (Z.pow 2 (Z.of_nat m) - 1)%Z + | IntT m => Some (Z.pow 2 (Z.of_nat m - 1) - 1)%Z + | IntUnbounded => None + end. + +(** In-range check: (min(ι) ≤ v ≤ max(ι)) ∨ ι = int *) +Definition in_range (it : int_type) (v : Z) : Prop := + match it with + | IntUnbounded => True + | _ => + match int_min it, int_max it with + | Some lo, Some hi => (lo <= v)%Z /\ (v <= hi)%Z + | _, _ => False + end + end. diff --git a/theories/Makefile b/theories/Makefile new file mode 100644 index 00000000..e4f145fa --- /dev/null +++ b/theories/Makefile @@ -0,0 +1,13 @@ +COQMF := CoqMakefile.mk + +all: $(COQMF) + $(MAKE) -f $(COQMF) + +$(COQMF): _CoqProject + rocq makefile -f _CoqProject -o $(COQMF) + +clean: + -$(MAKE) -f $(COQMF) clean + rm -f $(COQMF) $(COQMF).conf + +.PHONY: all clean diff --git a/theories/Maps.v b/theories/Maps.v new file mode 100644 index 00000000..f01cbe3a --- /dev/null +++ b/theories/Maps.v @@ -0,0 +1,165 @@ +(** * Partial Maps + Lightweight partial-map library used throughout the development. *) + +From Stdlib Require Import String List. +Import ListNotations. + +Definition ident := string. + +Definition partial_map (A : Type) := ident -> option A. + +Definition empty {A : Type} : partial_map A := fun _ => None. + +Definition update {A : Type} (m : partial_map A) (x : ident) (v : A) : partial_map A := + fun y => if String.eqb x y then Some v else m y. + +Notation "x '|->' v ';' m" := (update m x v) + (at level 100, v at next level, right associativity). +Notation "x '|->' v" := (update empty x v) + (at level 100). + +Definition dom {A : Type} (m : partial_map A) (x : ident) : Prop := + exists v, m x = Some v. + +Definition includes {A : Type} (m1 m2 : partial_map A) : Prop := + forall x v, m1 x = Some v -> m2 x = Some v. + +Lemma update_eq : forall A (m : partial_map A) x v, + (update m x v) x = Some v. +Proof. + intros. unfold update. rewrite String.eqb_refl. reflexivity. +Qed. + +Lemma update_neq : forall A (m : partial_map A) x1 x2 v, + x1 <> x2 -> (update m x1 v) x2 = m x2. +Proof. + intros. unfold update. + destruct (String.eqb_spec x1 x2); [contradiction | reflexivity]. +Qed. + +(** Association-list maps for finite environments *) +Definition alist (A : Type) := list (ident * A). + +Fixpoint alist_lookup {A : Type} (l : alist A) (x : ident) : option A := + match l with + | [] => None + | (k, v) :: rest => if String.eqb k x then Some v else alist_lookup rest x + end. + +Definition alist_dom {A : Type} (l : alist A) (x : ident) : Prop := + exists v, alist_lookup l x = Some v. + +Definition alist_to_map {A : Type} (l : alist A) : partial_map A := + alist_lookup l. + +Lemma alist_lookup_In : forall A (l : alist A) x v, + alist_lookup l x = Some v -> + exists p, In p l /\ snd p = v. +Proof. + intros A l. induction l as [|h t IH]; intros x v Hlook. + - discriminate. + - simpl in Hlook. destruct h as [k w]. + destruct (String.eqb_spec k x). + + injection Hlook as ->. exists (k, v). split; [left; auto|auto]. + + destruct (IH x v Hlook) as [p [Hin Hp]]. + exists p. split; [right; auto|auto]. +Qed. + +Lemma includes_refl : forall A (m : partial_map A), includes m m. +Proof. intros A m x v H. exact H. Qed. + +Lemma includes_trans : forall A (m1 m2 m3 : partial_map A), + includes m1 m2 -> includes m2 m3 -> includes m1 m3. +Proof. intros A m1 m2 m3 H12 H23 x v Hx. apply H23. apply H12. exact Hx. Qed. + +Lemma includes_update_fresh : forall A (m : partial_map A) x v, + ~ dom m x -> includes m (update m x v). +Proof. + intros A m x v Hfresh y w Hy. + unfold update. destruct (String.eqb_spec x y). + - subst. exfalso. apply Hfresh. exists w. exact Hy. + - exact Hy. +Qed. + +(** alist_lookup of a cons is definitionally Maps.update *) +Lemma alist_cons_update : forall A (x : ident) (v : A) (l : alist A), + alist_lookup ((x, v) :: l) = update (alist_lookup l) x v. +Proof. reflexivity. Qed. + +Lemma alist_cons_eq : forall A (x : ident) (v : A) (l : alist A), + alist_lookup ((x, v) :: l) x = Some v. +Proof. intros. simpl. rewrite String.eqb_refl. reflexivity. Qed. + +Lemma alist_cons_neq : forall A (x y : ident) (v : A) (l : alist A), + x <> y -> alist_lookup ((x, v) :: l) y = alist_lookup l y. +Proof. + intros. simpl. destruct (String.eqb_spec x y); [contradiction|reflexivity]. +Qed. + +Lemma alist_empty_lookup : forall A (x : ident), + @alist_lookup A [] x = None. +Proof. reflexivity. Qed. + +(** alist_lookup on app *) +Lemma alist_lookup_app_some : forall A (l1 l2 : alist A) x v, + alist_lookup l1 x = Some v -> + alist_lookup (l1 ++ l2) x = Some v. +Proof. + intros A l1. induction l1 as [|[k w] t IH]; intros l2 x v H. + - discriminate. + - simpl in *. destruct (String.eqb k x); auto. +Qed. + +Lemma alist_lookup_app_none : forall A (l1 l2 : alist A) x, + alist_lookup l1 x = None -> + alist_lookup (l1 ++ l2) x = alist_lookup l2 x. +Proof. + intros A l1. induction l1 as [|[k w] t IH]; intros l2 x H. + - reflexivity. + - simpl in *. destruct (String.eqb k x); [discriminate | auto]. +Qed. + +Lemma alist_lookup_app : forall A (l1 l2 : alist A) x, + alist_lookup (l1 ++ l2) x = + match alist_lookup l1 x with Some v => Some v | None => alist_lookup l2 x end. +Proof. + intros A l1. induction l1 as [|[k w] t IH]; intros l2 x; simpl. + - reflexivity. + - destruct (String.eqb k x); auto. +Qed. + +(** alist_lookup on combine *) +Lemma alist_lookup_combine : forall A B (ks : list ident) (vs : list A) + (iface : list (ident * B)) x b, + ks = map fst iface -> + length vs = length iface -> + alist_lookup iface x = Some b -> + exists v, alist_lookup (combine ks vs) x = Some v. +Proof. + intros A B ks vs iface x b Hks Hlen. + subst ks. generalize dependent vs. + induction iface as [|[k w] t IH]; intros vs Hlen Hlk. + - discriminate. + - destruct vs as [|v vt]; [simpl in Hlen; discriminate|]. + simpl in *. injection Hlen as Hlen. + destruct (String.eqb k x). + + eexists; reflexivity. + + eauto. +Qed. + +(** dom on alist_lookup app *) +Lemma alist_dom_app_l : forall A (l1 l2 : alist A) x, + alist_dom l1 x -> alist_dom (l1 ++ l2) x. +Proof. + intros A l1 l2 x [v Hv]. exists v. apply alist_lookup_app_some. exact Hv. +Qed. + +Lemma alist_dom_app_r : forall A (l1 l2 : alist A) x, + alist_dom l2 x -> + alist_dom (l1 ++ l2) x. +Proof. + intros A l1 l2 x [v Hv]. + destruct (alist_lookup l1 x) eqn:E. + - exists a. apply alist_lookup_app_some. exact E. + - exists v. rewrite alist_lookup_app_none; auto. +Qed. diff --git a/theories/Semantics.v b/theories/Semantics.v new file mode 100644 index 00000000..51c62953 --- /dev/null +++ b/theories/Semantics.v @@ -0,0 +1,1185 @@ +(** * Pointer Semantics + Formalizes Section 2 of the tech report: the big-step + operational semantics for environment references, variable + references, expressions, mapping expressions, slot expressions, + creates, updates, constructor/transition cases, constructors, + and transitions. *) + +From Stdlib Require Import String ZArith List Bool PeanoNat Lia. +From Act Require Import Maps Syntax Domains. +Import ListNotations. + +(* ================================================================= *) +(** ** Helper functions for operators *) + +Definition eval_int_binop (op : int_binop) (v1 v2 : Z) : Z := + match op with + | OpAdd => (v1 + v2)%Z + | OpSub => (v1 - v2)%Z + | OpMul => (v1 * v2)%Z + | OpExp => (Z.pow v1 v2) + | OpDiv => (Z.div v1 v2) + | OpMod => if (v2 =? 0)%Z then 0%Z else (Z.modulo v1 v2) + end. + +Definition eval_bool_binop (op : bool_binop) (b1 b2 : bool) : bool := + match op with + | OpAnd => andb b1 b2 + | OpOr => orb b1 b2 + | OpImpl => implb b1 b2 + end. + +Definition eval_cmp (op : cmp_op) (v1 v2 : Z) : bool := + match op with + | CmpLt => Z.ltb v1 v2 + | CmpLe => Z.leb v1 v2 + | CmpGe => Z.leb v2 v1 + | CmpGt => Z.ltb v2 v1 + end. + +(** Apply a mapping value to a key value *) +Definition apply_map (vr ve : value) : option value := + match vr, ve with + | VMapZ f, VBase (BVInt n) => Some (f n) + | VMapB f, VBase (BVBool b) => Some (f b) + | VMapA f, VBase (BVAddr a) => Some (f a) + | _, _ => None + end. + +(** Convert a list of (ident * value) pairs to a partial map *) +Definition list_to_map (bindings : list (ident * value)) : partial_map value := + fun x => alist_lookup bindings x. + +(** Build constructor environment: + ρ' = {xᵢ ↦ vᵢ} ∪ {caller ↦ ℓ, origin ↦ ρ(origin), callvalue ↦ cv} *) +Definition build_ctor_env (iface : interface) (vals : list value) + (caller : addr) (origin : value) (callvalue : value) : env := + list_to_map (combine (map fst iface) vals ++ + [("caller"%string, VAddr caller); + ("origin"%string, origin); + ("callvalue"%string, callvalue)]). + +(** Extract origin from environment, defaulting to address 0 *) +Definition env_origin (rho : env) : value := + match rho "origin"%string with Some v => v | None => VAddr 0 end. + +(* ================================================================= *) +(** ** Semantics of Environment References *) +(** Judgment: ρ ; env ⇓_ℓ v *) + +Inductive eval_env : env -> env_var -> addr -> value -> Prop := + | E_Caller : forall rho l v, + rho "caller"%string = Some v -> + eval_env rho EnvCaller l v + | E_Origin : forall rho l v, + rho "origin"%string = Some v -> + eval_env rho EnvOrigin l v + | E_Callvalue : forall rho l v, + rho "callvalue"%string = Some v -> + eval_env rho EnvCallvalue l v + | E_This : forall rho l, + eval_env rho EnvThis l (VAddr l). + +(* ================================================================= *) +(** ** Semantics of Variable References and Expressions *) +(** Judgment: s^t ; ρ ; ref ⇓_ℓ (v, t_p) + Judgment: s ; ρ ; e ⇓_ℓ v *) + +Inductive eval_ref : timed_state -> env -> ref -> addr -> value -> ref_time -> Prop := + (** E-Environment *) + | E_Environment : forall ts rho ev l v, + eval_env rho ev l v -> + eval_ref ts rho (REnv ev) l v RTU + + (** E-Storage: untimed *) + | E_Storage : forall s rho x l v, + state_var s l x = Some v -> + rho x = None -> + eval_ref (TSUntimed s) rho (RVar x) l v RTU + + (** E-StoragePre *) + | E_StoragePre : forall s_pre s_post rho x l v, + state_var s_pre l x = Some v -> + rho x = None -> + eval_ref (TSTimed s_pre s_post) rho (RPre x) l v RTPre + + (** E-StoragePost *) + | E_StoragePost : forall s_pre s_post rho x l v, + state_var s_post l x = Some v -> + rho x = None -> + eval_ref (TSTimed s_pre s_post) rho (RPost x) l v RTPost + + (** E-Calldata: untimed *) + | E_Calldata : forall s rho x l v, + rho x = Some v -> + eval_ref (TSUntimed s) rho (RVar x) l v RTU + + (** E-CalldataTimed *) + | E_CalldataTimed : forall s_pre s_post rho x l v, + rho x = Some v -> + eval_ref (TSTimed s_pre s_post) rho (RVar x) l v RTPre + + (** E-Coerce *) + | E_Coerce : forall ts rho r a l v tp, + eval_ref ts rho r l v tp -> + eval_ref ts rho (RCoerce r a) l v tp + + (** E-Field: untimed *) + | E_Field : forall s rho r x l l' v, + eval_ref (TSUntimed s) rho r l (VAddr l') RTU -> + state_var s l' x = Some v -> + eval_ref (TSUntimed s) rho (RField r x) l v RTU + + (** E-FieldPre *) + | E_FieldPre : forall s_pre s_post rho r x l l' v, + eval_ref (TSTimed s_pre s_post) rho r l (VAddr l') RTPre -> + state_var s_pre l' x = Some v -> + eval_ref (TSTimed s_pre s_post) rho (RField r x) l v RTPre + + (** E-FieldPost *) + | E_FieldPost : forall s_pre s_post rho r x l l' v, + eval_ref (TSTimed s_pre s_post) rho r l (VAddr l') RTPost -> + state_var s_post l' x = Some v -> + eval_ref (TSTimed s_pre s_post) rho (RField r x) l v RTPost + + (** E-RefMapping *) + | E_RefMapping : forall ts rho r e l vr ve vres tp, + eval_ref ts rho r l vr tp -> + eval_expr ts rho e l ve -> + apply_map vr ve = Some vres -> + eval_ref ts rho (RIndex r e) l vres tp + +with eval_expr : timed_state -> env -> expr -> addr -> value -> Prop := + (** E-Int *) + | E_Int : forall ts rho n l, + eval_expr ts rho (EInt n) l (VInt n) + + (** E-Bool *) + | E_Bool : forall ts rho b l, + eval_expr ts rho (EBool b) l (VBool b) + + (** E-Ref *) + | E_Ref : forall ts rho r l v tp, + eval_ref ts rho r l v tp -> + eval_expr ts rho (ERef r) l v + + (** E-Addr *) + | E_Addr : forall ts rho r l v tp, + eval_ref ts rho r l v tp -> + eval_expr ts rho (EAddr r) l v + + (** E-RangeTrue *) + | E_RangeTrue : forall ts rho iota e l n, + eval_expr ts rho e l (VInt n) -> + in_range iota n -> + eval_expr ts rho (EInRange iota e) l (VBool true) + + (** E-RangeFalse *) + | E_RangeFalse : forall ts rho iota e l n, + eval_expr ts rho e l (VInt n) -> + ~ in_range iota n -> + eval_expr ts rho (EInRange iota e) l (VBool false) + + (** E-Div *) + | E_Div : forall ts rho e1 e2 l v1 v2, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt v2) -> + (v2 <> 0)%Z -> + eval_expr ts rho (EBopI e1 OpDiv e2) l (VInt (Z.div v1 v2)) + + (** E-DivZero *) + | E_DivZero : forall ts rho e1 e2 l v1, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt 0%Z) -> + eval_expr ts rho (EBopI e1 OpDiv e2) l (VInt 0%Z) + + (** E-Mod *) + | E_Mod : forall ts rho e1 e2 l v1 v2, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt v2) -> + (v2 <> 0)%Z -> + eval_expr ts rho (EBopI e1 OpMod e2) l (VInt (Z.modulo v1 v2)) + + (** E-ModZero *) + | E_ModZero : forall ts rho e1 e2 l v1, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt 0%Z) -> + eval_expr ts rho (EBopI e1 OpMod e2) l (VInt 0%Z) + + (** E-BopI: other integer ops *) + | E_BopI : forall ts rho e1 op e2 l v1 v2, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt v2) -> + op <> OpDiv -> op <> OpMod -> + eval_expr ts rho (EBopI e1 op e2) l (VInt (eval_int_binop op v1 v2)) + + (** E-BopB *) + | E_BopB : forall ts rho e1 op e2 l b1 b2, + eval_expr ts rho e1 l (VBool b1) -> + eval_expr ts rho e2 l (VBool b2) -> + eval_expr ts rho (EBopB e1 op e2) l (VBool (eval_bool_binop op b1 b2)) + + (** E-Neg *) + | E_Neg : forall ts rho e l b, + eval_expr ts rho e l (VBool b) -> + eval_expr ts rho (ENeg e) l (VBool (negb b)) + + (** E-Cmp *) + | E_Cmp : forall ts rho e1 op e2 l v1 v2, + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt v2) -> + eval_expr ts rho (ECmp e1 op e2) l (VBool (eval_cmp op v1 v2)) + + (** E-ITETrue *) + | E_ITETrue : forall ts rho e1 e2 e3 l v2, + eval_expr ts rho e1 l (VBool true) -> + eval_expr ts rho e2 l v2 -> + eval_expr ts rho (EITE e1 e2 e3) l v2 + + (** E-ITEFalse *) + | E_ITEFalse : forall ts rho e1 e2 e3 l v3, + eval_expr ts rho e1 l (VBool false) -> + eval_expr ts rho e3 l v3 -> + eval_expr ts rho (EITE e1 e2 e3) l v3 + + (** E-EqTrue *) + | E_EqTrue : forall ts rho e1 e2 l v1 v2, + eval_expr ts rho e1 l v1 -> + eval_expr ts rho e2 l v2 -> + v1 = v2 -> + eval_expr ts rho (EEq e1 e2) l (VBool true) + + (** E-EqFalse *) + | E_EqFalse : forall ts rho e1 e2 l v1 v2, + eval_expr ts rho e1 l v1 -> + eval_expr ts rho e2 l v2 -> + v1 <> v2 -> + eval_expr ts rho (EEq e1 e2) l (VBool false). + +(** Decidable equality on base values — needed for mapping semantics *) +Definition base_value_eqb (v1 v2 : base_value) : bool := + match v1, v2 with + | BVInt n1, BVInt n2 => Z.eqb n1 n2 + | BVBool b1, BVBool b2 => Bool.eqb b1 b2 + | BVAddr a1, BVAddr a2 => Nat.eqb a1 a2 + | _, _ => false + end. + +Definition value_eqb (v1 v2 : value) : bool := + match v1, v2 with + | VBase bv1, VBase bv2 => base_value_eqb bv1 bv2 + | _, _ => false + end. + +(** Helper: look up a value in keys/vals list, return default if not found. *) +Fixpoint lookup_or_default (keys vals : list value) (x : value) (def : value) : value := + match keys, vals with + | k :: ks, v :: vs => if value_eqb k x then v else lookup_or_default ks vs x def + | _, _ => def + end. + +(** Helper: look up in keys/vals, fall back to applying old function *) +Fixpoint lookup_or_apply (keys vals : list value) (x : value) (f_old : value) : value := + match keys, vals with + | k :: ks, v :: vs => if value_eqb k x then v else lookup_or_apply ks vs x f_old + | _, _ => match apply_map f_old x with + | Some v => v + | None => VInt 0%Z + end + end. + +(** Build a mapping value from keys, vals, wrapped in the + appropriate value constructor based on the mapping type. + The default for unmapped keys comes from the value sub-type. *) +Definition build_map_from_bindings (keys vals : list value) + (mu : mapping_type) : option value := + match mu with + | MMapping (TInt _) mu' => + let def := default_value mu' in + Some (VMapZ (fun n => lookup_or_default keys vals (VInt n) def)) + | MMapping TBool mu' => + let def := default_value mu' in + Some (VMapB (fun b => lookup_or_default keys vals (VBool b) def)) + | MMapping TAddress mu' => + let def := default_value mu' in + Some (VMapA (fun a => lookup_or_default keys vals (VAddr a) def)) + | MBase _ => None (* not a mapping type *) + end. + +(** Update a mapping value using keys/vals, falling back to old function *) +Definition update_map_from_bindings (keys vals : list value) (f_old : value) + (mu : mapping_type) : option value := + match mu with + | MMapping (TInt _) _ => + Some (VMapZ (fun n => lookup_or_apply keys vals (VInt n) f_old)) + | MMapping TBool _ => + Some (VMapB (fun b => lookup_or_apply keys vals (VBool b) f_old)) + | MMapping TAddress _ => + Some (VMapA (fun a => lookup_or_apply keys vals (VAddr a) f_old)) + | MBase _ => None + end. + +(* ================================================================= *) +(** ** Semantics of Mapping Expressions *) +(** Judgment: s ; ρ ; m ⇓_ℓ v *) + +Inductive eval_mapexpr : timed_state -> env -> map_expr -> addr -> value -> Prop := + (** E-Exp *) + | E_MExp : forall ts rho e l v, + eval_expr ts rho e l v -> + eval_mapexpr ts rho (MExp e) l v + + (** E-Mapping: the result f is a value that encodes a function *) + | E_Mapping : forall ts rho bindings mu l keys vals f, + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys -> + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals -> + build_map_from_bindings keys vals mu = Some f -> + eval_mapexpr ts rho (MMap bindings mu) l f + + (** E-MappingUpd *) + | E_MappingUpd : forall ts rho r bindings mu l f_old f_new tp keys vals, + eval_ref ts rho r l f_old tp -> + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys -> + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals -> + update_map_from_bindings keys vals f_old mu = Some f_new -> + eval_mapexpr ts rho (MMapUpd r bindings mu) l f_new. + +(* ================================================================= *) +(** ** Insert Value *) +(** Judgment: s ; ρ ; ref ; v ⇓^ins_ℓ s' *) + +Inductive eval_insert : state -> env -> ref -> value -> addr -> state -> Prop := + (** E-InsStorage *) + | E_InsStorage : forall s rho x v l, + state_var_dom s l x -> + eval_insert s rho (RVar x) v l (state_update_var s l x v) + + (** E-InsField *) + | E_InsField : forall s rho r x v l l', + eval_ref (TSUntimed s) rho r l (VAddr l') RTU -> + state_var_dom s l' x -> + eval_insert s rho (RField r x) v l (state_update_var s l' x v). + +(** Update inserts — does not depend on cmap *) +Inductive eval_update_inserts : state -> env -> list update -> + list value -> addr -> state -> Prop := + | E_UpdInsertsNil : forall s rho l, + eval_update_inserts s rho [] [] l s + | E_UpdInsertsCons : forall s rho r se rest v vs l s' s_final, + eval_insert s rho r v l s' -> + eval_update_inserts s' rho rest vs l s_final -> + eval_update_inserts s rho ((r, se) :: rest) (v :: vs) l s_final. + +(* ================================================================= *) +(** ** Semantics of Slot Expressions *) +(** Judgment: s ; ρ ; se ⇓_ℓ (v, s') *) + +Section EvalCmap. +Variable cmap : partial_map constructor. + +Inductive eval_slotexpr : state -> env -> slot_expr -> addr -> value -> state -> Prop := + (** E-MapExp *) + | E_SlotMap : forall s rho m l v, + eval_mapexpr (TSUntimed s) rho m l v -> + eval_slotexpr s rho (SEMap m) l v s + + (** E-SlotRef *) + | E_SlotRef : forall s rho r l v tp, + eval_ref (TSUntimed s) rho r l v tp -> + eval_slotexpr s rho (SERef r) l v s + + (** E-SlotAddr *) + | E_SlotAddr : forall s rho se l v s', + eval_slotexpr s rho se l v s' -> + eval_slotexpr s rho (SEAddr se) l v s' + + (** E-Create: new Id(se₁,...,seₙ) — non-payable. + ctor is looked up from cmap, ρ' is constructed per the tech report. *) + | E_Create : forall s rho a ctor ses l l' vals s_final s', + cmap a = Some ctor -> + ctor_payable ctor = false -> + eval_slotexpr_list s rho ses l vals s_final -> + eval_ctor_cases s_final + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) (VInt 0%Z)) + (ctor_cases ctor) a l' s' -> + eval_slotexpr s rho (SENew a None ses) l (VAddr l') s' + + (** E-CreatePayable *) + | E_CreatePayable : forall s rho a ctor se_val ses l l' vals s_final sv s_v s', + cmap a = Some ctor -> + ctor_payable ctor = true -> + eval_slotexpr_list s rho ses l vals s_final -> + eval_slotexpr s_final rho se_val l sv s_v -> + eval_ctor_cases s_v + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) sv) + (ctor_cases ctor) a l' s' -> + eval_slotexpr s rho (SENew a (Some se_val) ses) l (VAddr l') s' + +(** Evaluate a list of slot expressions, threading state *) +with eval_slotexpr_list : state -> env -> list slot_expr -> addr -> + list value -> state -> Prop := + | E_SlotListNil : forall s rho l, + eval_slotexpr_list s rho [] l [] s + | E_SlotListCons : forall s rho se rest l v s' vs s_final, + eval_slotexpr s rho se l v s' -> + eval_slotexpr_list s' rho rest l vs s_final -> + eval_slotexpr_list s rho (se :: rest) l (v :: vs) s_final + +(** Constructor Cases *) +with eval_ctor_cases : state -> env -> list ctor_case -> ident -> + addr -> state -> Prop := + | E_CtorCases : forall s rho cases id j l s', + j < length cases -> + eval_expr (TSUntimed s) rho (fst (nth j cases (EBool false, []))) dummy_loc (VBool true) -> + (forall i, i <> j -> i < length cases -> + eval_expr (TSUntimed s) rho (fst (nth i cases (EBool false, []))) dummy_loc (VBool false)) -> + eval_creates s rho (snd (nth j cases (EBool false, []))) id l s' -> + eval_ctor_cases s rho cases id l s' + +(** Creates *) +with eval_creates : state -> env -> list create -> ident -> + addr -> state -> Prop := + | E_Creates : forall s rho creates id s_n bindings, + eval_create_list s rho creates dummy_loc s_n bindings -> + eval_creates s rho creates id (state_next s_n) + (state_alloc s_n id (list_to_map bindings)) + +with eval_create_list : state -> env -> list create -> addr -> + state -> list (ident * value) -> Prop := + | E_CreateListNil : forall s rho l, + eval_create_list s rho [] l s [] + | E_CreateListCons : forall s rho st x se rest l v s' s'' bs, + eval_slotexpr s rho se l v s' -> + eval_create_list s' rho rest l s'' bs -> + eval_create_list s rho ((st, x, se) :: rest) l s'' ((x, v) :: bs). + +(* ================================================================= *) +(** ** Semantics of Updates *) +(** Judgment: s ; ρ ; updates ⇓_ℓ s' *) + +Inductive eval_update_exprs : state -> env -> list update -> addr -> + list value -> state -> Prop := + | E_UpdExprsNil : forall s rho l, + eval_update_exprs s rho [] l [] s + | E_UpdExprsCons : forall s rho r se rest l v s' vs s_final, + eval_slotexpr s rho se l v s' -> + eval_update_exprs s' rho rest l vs s_final -> + eval_update_exprs s rho ((r, se) :: rest) l (v :: vs) s_final. + +Inductive eval_updates : state -> env -> list update -> addr -> state -> Prop := + | E_Updates : forall s rho updates l vals s_n s', + eval_update_exprs s rho updates l vals s_n -> + eval_update_inserts s_n rho updates vals l s' -> + eval_updates s rho updates l s'. + +(* ================================================================= *) +(** ** Semantics of Transition Cases *) +(** Judgment: s ; ρ ; tcases ⇓_ℓ (v, s') *) + +(** Accessors for trans_case components *) +Definition tc_cond (tc : trans_case) : expr := fst (fst tc). +Definition tc_updates (tc : trans_case) : list update := snd (fst tc). +Definition tc_return (tc : trans_case) : expr := snd tc. + +Definition tc_default : trans_case := (EBool false, [], EBool false). + +Inductive eval_trans_cases : state -> env -> list trans_case -> addr -> + value -> state -> Prop := + | E_TransCases : forall s rho cases j l v s', + j < length cases -> + eval_expr (TSUntimed s) rho (tc_cond (nth j cases tc_default)) l (VBool true) -> + (forall i, i <> j -> i < length cases -> + eval_expr (TSUntimed s) rho (tc_cond (nth i cases tc_default)) l (VBool false)) -> + eval_updates s rho (tc_updates (nth j cases tc_default)) l s' -> + eval_expr (TSTimed s s') rho (tc_return (nth j cases tc_default)) l v -> + eval_trans_cases s rho cases l v s'. + +(* ================================================================= *) +(** ** Semantics of Constructors *) + +Inductive eval_constructor : state -> env -> constructor -> ident -> + addr -> state -> Prop := + | E_Ctor : forall s rho ctor id l s', + Forall (fun pre => eval_expr (TSUntimed s) rho pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + eval_ctor_cases s rho (ctor_cases ctor) id l s' -> + eval_constructor s rho ctor id l s'. + +(* ================================================================= *) +(** ** Semantics of Transitions *) + +Inductive eval_transition : state -> env -> transition -> addr -> + value -> state -> Prop := + | E_Trans : forall s rho tr l v s', + Forall (fun pre => eval_expr (TSUntimed s) rho pre l (VBool true)) + (trans_iff tr) -> + eval_trans_cases s rho (trans_cases tr) l v s' -> + eval_transition s rho tr l v s'. + +End EvalCmap. + +(* ================================================================= *) +(** ** State Transitions *) + +Inductive step_cnstr (Σ : contract_env) : ident -> state -> addr -> state -> Prop := + | E_Step_Cnstr : forall a s l s' rho ctor, + Σ_cnstr Σ a = Some ctor -> + eval_constructor (Σ_cnstr Σ) s rho ctor a l s' -> + step_cnstr Σ a s l s'. + +Inductive step_trans (Σ : contract_env) : ident -> state -> addr -> state -> Prop := + | E_Step_Trans : forall a s l s' rho tr v transs, + Σ_trans Σ a = Some transs -> + In tr transs -> + eval_transition (Σ_cnstr Σ) s rho tr l v s' -> + step_trans Σ a s l s'. + +Definition step (Σ : contract_env) (s s' : state) : Prop := + (exists a l, step_cnstr Σ a s l s') \/ + (exists a l, step_trans Σ a s l s'). + +Inductive steps (Σ : contract_env) : state -> state -> Prop := + | Steps_refl : forall s, steps Σ s s + | Steps_step : forall s1 s2 s3, + step Σ s1 s2 -> steps Σ s2 s3 -> steps Σ s1 s3. + +Definition possible (Σ : contract_env) (s : state) : Prop := + steps Σ state_empty s. + +(* ================================================================= *) +(** ** Useful Tactics and Induction Schemes *) + +Ltac inv H := inversion H; subst; clear H. + +(** Mutual induction schemes for eval_ref / eval_expr *) +Scheme eval_ref_ind2 := Induction for eval_ref Sort Prop + with eval_expr_ind2 := Induction for eval_expr Sort Prop. +Combined Scheme eval_ref_expr_mutind from eval_ref_ind2, eval_expr_ind2. + +(** No mutual induction needed for eval_mapexpr — it is now a simple inductive. *) + +(** Mutual induction schemes for eval_slotexpr family *) +Scheme eval_slotexpr_ind2 := Induction for eval_slotexpr Sort Prop + with eval_slotexpr_list_ind2 := Induction for eval_slotexpr_list Sort Prop + with eval_ctor_cases_ind2 := Induction for eval_ctor_cases Sort Prop + with eval_creates_ind2 := Induction for eval_creates Sort Prop + with eval_create_list_ind2 := Induction for eval_create_list Sort Prop. + +(** eval_updates, eval_update_exprs, and eval_update_inserts are + no longer mutual — standard induction suffices. *) + +(* ================================================================= *) +(** ** Timed State Inclusion and State Inclusion Helpers *) + +(** Timed state inclusion *) +Definition ts_incl (ts ts' : timed_state) : Prop := + match ts, ts' with + | TSUntimed s, TSUntimed s' => state_incl s s' + | TSTimed sp spo, TSTimed sp' spo' => + state_incl sp sp' /\ state_incl spo spo' + | _, _ => False + end. + +(** Helpers for state_incl *) +Lemma state_incl_dom : forall s s' l, + state_incl s s' -> state_dom s l -> state_dom s' l. +Proof. + intros s s' l Hincl [ls Hls]. + exists ls. apply Hincl. exact Hls. +Qed. + +Lemma state_incl_type : forall s s' l a, + state_incl s s' -> state_type s l = Some a -> state_type s' l = Some a. +Proof. + intros s s' l a Hincl Htype. + unfold state_type in *. + destruct (s l) eqn:E; [|discriminate]. + rewrite (Hincl l l0 E). exact Htype. +Qed. + +Lemma state_incl_var : forall s s' l x v, + state_incl s s' -> state_dom s l -> state_var s l x = Some v -> state_var s' l x = Some v. +Proof. + intros s s' l x v Hincl [ls Hls] Hvar. + unfold state_var in *. + rewrite Hls in Hvar. + rewrite (Hincl l ls Hls). exact Hvar. +Qed. + +Lemma state_incl_var_eq : forall s s' l x, + state_incl s s' -> state_dom s l -> state_var s' l x = state_var s l x. +Proof. + intros s s' l x Hincl [ls Hls]. + unfold state_var. + rewrite Hls. rewrite (Hincl l ls Hls). reflexivity. +Qed. + +Lemma state_incl_var_dom : forall s s' l x, + state_incl s s' -> state_dom s l -> + (state_var_dom s l x <-> state_var_dom s' l x). +Proof. + intros s s' l x Hincl Hdom. split. + - intros [v Hv]. exists v. eapply state_incl_var; eauto. + - intros [v Hv]. unfold state_var_dom. + rewrite <- (state_incl_var_eq s s' l x Hincl Hdom). eauto. +Qed. + +Lemma state_incl_var_force : forall s s' l x, + state_incl s s' -> state_dom s l -> + state_var_force s' l x = state_var_force s l x. +Proof. + intros s s' l x Hincl Hdom. + unfold state_var_force. + rewrite (state_incl_var_eq s s' l x Hincl Hdom). reflexivity. +Qed. + +(* ================================================================= *) +(** ** Determinism of Pointer Semantics *) + +(** eval_env determinism *) +Lemma eval_env_determinism : + forall rho ev l v1 v2, + eval_env rho ev l v1 -> eval_env rho ev l v2 -> v1 = v2. +Proof. + intros rho ev l v1 v2 H1 H2. + inv H1; inv H2; congruence. +Qed. + +(** Determinism tactic for stepping through inversion + IH application *) +Ltac det_step := + match goal with + | [H : VAddr _ = VAddr _ |- _] => inv H + | [H : VInt _ = VInt _ |- _] => inv H + | [H : VBool _ = VBool _ |- _] => inv H + | [H1 : eval_env ?rho ?ev ?l ?v1, H2 : eval_env ?rho ?ev ?l ?v2 |- _] => + let E := fresh in assert (E := eval_env_determinism _ _ _ _ _ H1 H2); clear H2; subst + | [IH : forall v' tp', eval_ref ?ts ?rho ?r ?l v' tp' -> _ = v' /\ _ = tp', + H : eval_ref ?ts ?rho ?r ?l _ _ |- _] => + let P := fresh in let Q := fresh in + destruct (IH _ _ H) as [P Q]; clear H; try inv P; try subst + | [IH : forall v', eval_expr ?ts ?rho ?e ?l v' -> _ = v', + H : eval_expr ?ts ?rho ?e ?l _ |- _] => + let P := fresh in pose proof (IH _ H) as P; clear H; subst + | [H : eval_expr _ _ (ERef _) _ _ |- _] => inv H + | [H : eval_expr _ _ (EAddr _) _ _ |- _] => inv H + end. + +(** Determinism of Reference and Expression Evaluation *) +Lemma ref_expr_det_combined : + (forall ts rho r l v tp, + eval_ref ts rho r l v tp -> + forall v' tp', eval_ref ts rho r l v' tp' -> v = v' /\ tp = tp') /\ + (forall ts rho e l v, + eval_expr ts rho e l v -> + forall v', eval_expr ts rho e l v' -> v = v'). +Proof. + apply eval_ref_expr_mutind; intros; + match goal with + | [H : eval_ref _ _ _ _ _ _ |- _] => inv H + | [H : eval_expr _ _ _ _ _ |- _] => inv H + end; + try (split; congruence); + try congruence; + repeat det_step; + try (split; congruence); + try congruence; + try discriminate; + try contradiction; + auto. +Qed. + +Lemma expr_determinism : + forall ts rho e l v1 v2, + eval_expr ts rho e l v1 -> + eval_expr ts rho e l v2 -> + v1 = v2. +Proof. intros. eapply (proj2 ref_expr_det_combined); eauto. Qed. + +Lemma ref_determinism : + forall ts rho r l v1 tp1 v2 tp2, + eval_ref ts rho r l v1 tp1 -> + eval_ref ts rho r l v2 tp2 -> + v1 = v2 /\ tp1 = tp2. +Proof. intros. eapply (proj1 ref_expr_det_combined); eauto. Qed. + +(** Determinism of Forall2 with eval_expr *) +Lemma forall2_expr_det : + forall ts rho l (bindings : list (expr * map_expr)) keys1 keys2, + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys1 -> + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys2 -> + keys1 = keys2. +Proof. + intros ts rho l bindings keys1 keys2 H1 H2. + revert keys2 H2. induction H1; intros keys2 H2; inv H2; auto. + f_equal; [eapply expr_determinism; eauto | auto]. +Qed. + +(** Custom induction principle for eval_mapexpr that handles nested Forall2 *) +Lemma eval_mapexpr_ind_nested + (P : timed_state -> env -> map_expr -> addr -> value -> Prop) : + (forall ts rho e l v, + eval_expr ts rho e l v -> P ts rho (MExp e) l v) -> + (forall ts rho bindings mu l keys vals f, + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys -> + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals -> + Forall2 (fun p v => P ts rho (snd p) l v) bindings vals -> + build_map_from_bindings keys vals mu = Some f -> + P ts rho (MMap bindings mu) l f) -> + (forall ts rho r bindings mu l f_old f_new tp keys vals, + eval_ref ts rho r l f_old tp -> + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys -> + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals -> + Forall2 (fun p v => P ts rho (snd p) l v) bindings vals -> + update_map_from_bindings keys vals f_old mu = Some f_new -> + P ts rho (MMapUpd r bindings mu) l f_new) -> + forall ts rho m l v, eval_mapexpr ts rho m l v -> P ts rho m l v. +Proof. + intros HExp HMapping HMappingUpd. + fix IH 6. + intros ts rho m l v Hm. + destruct Hm as [? ? ? ? ? He + | ? ? ? ? ? ? ? ? Hk Hv Hb + | ? ? ? ? ? ? ? ? ? ? ? Hr Hk Hv Hu]. + - apply HExp. exact He. + - apply HMapping with (keys := keys) (vals := vals); auto. + clear Hk Hb. induction Hv; constructor; auto. + - eapply HMappingUpd; eauto. + clear Hk Hr Hu. induction Hv; constructor; auto. +Defined. + +(** Determinism of Mapping Expression Evaluation *) +Lemma forall2_mapexpr_vals_det : + forall ts rho l (bindings : list (expr * map_expr)) vals1 vals2, + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals2 -> + Forall2 (fun p v => forall v2, eval_mapexpr ts rho (snd p) l v2 -> v = v2) + bindings vals1 -> + vals1 = vals2. +Proof. + intros ts rho l bindings vals1 vals2 Hv2 HIH. + revert vals2 Hv2. induction HIH; intros vals2 Hv2; inv Hv2; auto. + f_equal; eauto. +Qed. + +Lemma mapexpr_determinism : + forall ts rho m l v1 v2, + eval_mapexpr ts rho m l v1 -> + eval_mapexpr ts rho m l v2 -> + v1 = v2. +Proof. + intros ts rho m l v1 v2 H1. + revert v2. induction H1 using eval_mapexpr_ind_nested; intros v2 Hm2; inv Hm2. + - eapply expr_determinism; eauto. + - assert (keys = keys0) by (eapply forall2_expr_det; eauto); subst. + assert (vals = vals0) by (eapply forall2_mapexpr_vals_det; eauto). + subst. congruence. + - match goal with + | [Hr1 : eval_ref _ _ ?r _ _ _, Hr2 : eval_ref _ _ ?r _ _ _ |- _] => + destruct (ref_determinism _ _ _ _ _ _ _ _ Hr1 Hr2); subst + end. + assert (keys = keys0) by (eapply forall2_expr_det; eauto); subst. + assert (vals = vals0) by (eapply forall2_mapexpr_vals_det; eauto). + subst. congruence. +Qed. + +(** Determinism of Value Insertion *) +Lemma insert_determinism : + forall s rho r v l s1 s2, + eval_insert s rho r v l s1 -> + eval_insert s rho r v l s2 -> + s1 = s2. +Proof. + intros s rho r v l s1 s2 H1 H2. + inv H1; inv H2; try congruence. + match goal with + | [Ha : eval_ref _ _ _ _ (VAddr ?l1) _, Hb : eval_ref _ _ _ _ (VAddr ?l2) _ |- _] => + destruct (ref_determinism _ _ _ _ _ _ _ _ Ha Hb) as [Heq _]; inv Heq; congruence + end. +Qed. + +(** Determinism of Slot Expressions — proved with mutual Fixpoint. *) + +Section SlotexprDet. + +Fixpoint slotexpr_det cmap s rho se l v s' + (H : eval_slotexpr cmap s rho se l v s') {struct H} : + forall v' s'', eval_slotexpr cmap s rho se l v' s'' -> v = v' /\ s' = s'' +with slotexpr_list_det cmap s rho ses l vals s_final + (H : eval_slotexpr_list cmap s rho ses l vals s_final) {struct H} : + forall vals' s_final', eval_slotexpr_list cmap s rho ses l vals' s_final' -> + vals = vals' /\ s_final = s_final' +with ctor_cases_det cmap s rho cases id l s' + (H : eval_ctor_cases cmap s rho cases id l s') {struct H} : + forall l' s'', eval_ctor_cases cmap s rho cases id l' s'' -> l = l' /\ s' = s'' +with creates_det cmap s rho creates id l s' + (H : eval_creates cmap s rho creates id l s') {struct H} : + forall l' s'', eval_creates cmap s rho creates id l' s'' -> l = l' /\ s' = s'' +with create_list_det cmap s rho creates l s' bindings + (H : eval_create_list cmap s rho creates l s' bindings) {struct H} : + forall s'' bindings', eval_create_list cmap s rho creates l s'' bindings' -> + s' = s'' /\ bindings = bindings'. +Proof. + all: destruct H; intros; + match goal with [Hx : _ |- _] => + inversion Hx; subst; clear Hx end. + (* E_SlotMap *) + all: try (split; [eapply mapexpr_determinism; eauto | auto]; fail). + (* E_SlotRef *) + all: try (match goal with + | [H1 : eval_ref _ _ ?r ?l _ _, H2 : eval_ref _ _ ?r ?l _ _ |- _] => + destruct (ref_determinism _ _ _ _ _ _ _ _ H1 H2); auto + end; fail). + (* E_SlotAddr *) + all: try (match goal with + | [IH : forall v' s'', eval_slotexpr _ _ _ ?se ?l v' s'' -> _, + H2 : eval_slotexpr _ _ _ ?se ?l _ _ |- _] => + eapply IH; eauto + end; fail). + (* payable/non-payable mismatch *) + all: try discriminate. + (* ctor unification *) + all: try (match goal with + | [Hcm1 : ?cm ?a = Some ?c1, Hcm2 : ?cm ?a = Some ?c2 |- _] => + let Heq := fresh in assert (Heq : c1 = c2) by congruence; subst + end). + (* E_Create: chain IH for list, then ctor_cases_det *) + all: try (match goal with + | [IHl : forall vals' s_final', eval_slotexpr_list _ _ _ ?ses _ vals' s_final' -> _ /\ _, + Hl : eval_slotexpr_list _ _ _ ?ses _ _ _ |- _] => + destruct (IHl _ _ Hl); subst + end). + (* E_Create (non-payable): ctor_cases_det *) + all: try (match goal with + | [Hcc : eval_ctor_cases _ _ _ _ _ ?l2 ?s2 |- _ = ?l2 /\ _ = ?s2] => + eapply ctor_cases_det; eauto + end; fail). + (* E_CreatePayable: unify slotexpr for value, then ctor_cases_det *) + all: try (match goal with + | [IHse : forall v' s'', eval_slotexpr _ _ _ _ _ v' s'' -> _ /\ _, + Hse : eval_slotexpr _ _ _ _ _ _ _, + Hcc : eval_ctor_cases _ _ _ _ _ _ _ |- _] => + destruct (IHse _ _ Hse); subst; + eapply ctor_cases_det; eauto + end; fail). + (* slotexpr_list: nil *) + all: try (auto; fail). + (* slotexpr_list: cons *) + all: try (match goal with + | [IHse : forall v' s'', eval_slotexpr _ _ _ _ _ v' s'' -> _ /\ _, + IHtl : forall vals' s_final', eval_slotexpr_list _ _ _ _ _ vals' s_final' -> _ /\ _, + Hse : eval_slotexpr _ _ _ _ _ _ _, + Htl : eval_slotexpr_list _ _ _ _ _ _ _ |- _] => + destruct (IHse _ _ Hse); subst; + destruct (IHtl _ _ Htl); subst; auto + end; fail). + all: try congruence. + (* ctor_cases and creates remaining *) + all: repeat match goal with + | [H1 : eval_create_list _ _ _ _ _ _ _, H2 : eval_create_list _ _ _ _ _ _ _ |- _] => + destruct (create_list_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + end. + (* ctor_cases: prove j = j0 *) + all: try (match goal with + | [He1 : eval_expr _ _ (fst (nth ?j1 ?cases _)) _ (VBool true), + He2 : eval_expr _ _ (fst (nth ?j2 ?cases _)) _ (VBool true), + Hf2 : forall i, i <> ?j2 -> i < _ -> eval_expr _ _ (fst (nth i ?cases _)) _ (VBool false), + Hlt1 : ?j1 < _ |- _] => + assert (j1 = j2) by ( + destruct (Nat.eq_dec j1 j2); [auto|]; + exfalso; + pose proof (expr_determinism _ _ _ _ _ _ He1 (Hf2 j1 n Hlt1)); + discriminate); + subst; eapply creates_det; eauto + end; fail). + (* creates: l = l' by minimality *) + all: try (match goal with + | [Hnd1 : ~ state_dom _ ?l1, + Hmin1 : forall l'', l'' < ?l1 -> state_dom _ l'', + Hnd2 : ~ state_dom _ ?l2, + Hmin2 : forall l'', l'' < ?l2 -> state_dom _ l'' |- _] => + assert (l1 = l2) by ( + destruct (Nat.lt_trichotomy l1 l2) as [?|[?|?]]; auto; + [exfalso; apply Hnd1; apply Hmin2; auto + |exfalso; apply Hnd2; apply Hmin1; auto]); + subst; auto + end; fail). + (* create_list: cons *) + all: try (match goal with + | [IHse : forall v' s'', eval_slotexpr _ _ _ _ _ v' s'' -> _ /\ _, + IHtl : forall s'' bindings', eval_create_list _ _ _ _ _ s'' bindings' -> _ /\ _, + Hse : eval_slotexpr _ _ _ _ _ _ _, + Htl : eval_create_list _ _ _ _ _ _ _ |- _] => + destruct (IHse _ _ Hse); subst; + destruct (IHtl _ _ Htl); subst; auto + end; fail). + (* Fallback *) + all: try (eapply slotexpr_det; eauto; fail). + all: repeat match goal with + | [H1 : eval_slotexpr _ _ _ _ _ _ _, H2 : eval_slotexpr _ _ _ _ _ _ _ |- _] => + destruct (slotexpr_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + | [H1 : eval_slotexpr_list _ _ _ _ _ _ _, H2 : eval_slotexpr_list _ _ _ _ _ _ _ |- _] => + destruct (slotexpr_list_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + | [H1 : eval_ctor_cases _ _ _ _ _ _ _, H2 : eval_ctor_cases _ _ _ _ _ _ _ |- _] => + destruct (ctor_cases_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + | [H1 : eval_creates _ _ _ _ _ _ _, H2 : eval_creates _ _ _ _ _ _ _ |- _] => + destruct (creates_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + | [H1 : eval_create_list _ _ _ _ _ _ _, H2 : eval_create_list _ _ _ _ _ _ _ |- _] => + destruct (create_list_det _ _ _ _ _ _ _ H1 _ _ H2); clear H2; subst + end; + try auto; try congruence; try (split; congruence); try (f_equal; congruence). +Defined. + +Lemma slotexpr_determinism : + forall cmap s rho se l v1 s1 v2 s2, + eval_slotexpr cmap s rho se l v1 s1 -> + eval_slotexpr cmap s rho se l v2 s2 -> + v1 = v2 /\ s1 = s2. +Proof. + intros. eapply slotexpr_det; eauto. +Qed. + +(** Determinism of Update Inserts *) +Lemma update_inserts_det : + forall s rho updates vals l s', + eval_update_inserts s rho updates vals l s' -> + forall s'', eval_update_inserts s rho updates vals l s'' -> s' = s''. +Proof. + induction 1; intros s'' Hx; inversion Hx; subst; auto. + match goal with [H1 : eval_insert ?s ?r ?ref ?v ?l _, H2 : eval_insert ?s ?r ?ref ?v ?l _ |- _] => + assert (E := insert_determinism _ _ _ _ _ _ _ H1 H2); subst end. + eauto. +Qed. + +(** Determinism of Update Exprs *) +Lemma update_exprs_det : + forall cmap s rho updates l vals s_n, + eval_update_exprs cmap s rho updates l vals s_n -> + forall vals' s_n', eval_update_exprs cmap s rho updates l vals' s_n' -> + vals = vals' /\ s_n = s_n'. +Proof. + induction 1; intros vals' s_n' Hx; inversion Hx; subst; auto. + match goal with [H1 : eval_slotexpr _ _ _ ?se _ _ _, H2 : eval_slotexpr _ _ _ ?se _ _ _ |- _] => + destruct (slotexpr_determinism _ _ _ _ _ _ _ _ _ H1 H2); subst end. + match goal with [H2 : eval_update_exprs _ _ _ _ _ _ _ |- _] => + destruct (IHeval_update_exprs _ _ H2); subst end. + auto. +Qed. + +(** Determinism of Updates *) +Lemma updates_det : + forall cmap s rho updates l s', + eval_updates cmap s rho updates l s' -> + forall s'', eval_updates cmap s rho updates l s'' -> s' = s''. +Proof. + intros cmap s rho updates l s' H s'' Hx. inv H; inv Hx. + match goal with [H1 : eval_update_exprs _ _ _ _ _ _ _, H2 : eval_update_exprs _ _ _ _ _ _ _ |- _] => + destruct (update_exprs_det _ _ _ _ _ _ _ H1 _ _ H2); subst end. + eapply update_inserts_det; eauto. +Qed. + +Lemma updates_determinism : + forall cmap s rho upds l s1 s2, + eval_updates cmap s rho upds l s1 -> + eval_updates cmap s rho upds l s2 -> + s1 = s2. +Proof. intros. eapply updates_det; eauto. Qed. + +(** Determinism of Transition Cases *) +Lemma trans_cases_determinism : + forall cmap s rho cases l v1 s1 v2 s2, + eval_trans_cases cmap s rho cases l v1 s1 -> + eval_trans_cases cmap s rho cases l v2 s2 -> + v1 = v2 /\ s1 = s2. +Proof. + intros. inv H; inv H0. + assert (j = j0). + { destruct (Nat.eq_dec j j0); auto. exfalso. + match goal with + | [Htrue : eval_expr _ _ (tc_cond (nth j _ _)) _ (VBool true), + Hfalse : forall i, i <> j0 -> _ -> eval_expr _ _ (tc_cond (nth i _ _)) _ (VBool false), + Hlt : j < length _ |- _] => + pose proof (expr_determinism _ _ _ _ _ _ Htrue (Hfalse j n Hlt)); discriminate + end. } + subst. + match goal with + | [Hu1 : eval_updates _ _ _ _ _ ?s1, Hu2 : eval_updates _ _ _ _ _ ?s2 |- _] => + assert (s1 = s2) by (eapply updates_determinism; eauto); subst + end. + split; auto. eapply expr_determinism; eauto. +Qed. + +(** Determinism of Constructor Evaluation *) +Lemma constructor_determinism : + forall cmap s rho ctor id l1 s1 l2 s2, + eval_constructor cmap s rho ctor id l1 s1 -> + eval_constructor cmap s rho ctor id l2 s2 -> + l1 = l2 /\ s1 = s2. +Proof. + intros. inv H; inv H0. + eapply ctor_cases_det; eauto. +Qed. + +(** Determinism of Transition Evaluation *) +Lemma transition_determinism : + forall cmap s rho tr l v1 s1 v2 s2, + eval_transition cmap s rho tr l v1 s1 -> + eval_transition cmap s rho tr l v2 s2 -> + v1 = v2 /\ s1 = s2. +Proof. + intros. inv H; inv H0. + eapply trans_cases_determinism; eauto. +Qed. + +End SlotexprDet. + +(* ================================================================= *) +(** ** Weakening of Storage for Pointer Semantics (Lemma 5.2) *) + +Lemma sem_storage_weak_combined : + (forall ts rho r l v tp, + eval_ref ts rho r l v tp -> + forall ts', ts_incl ts ts' -> eval_ref ts' rho r l v tp) /\ + (forall ts rho e l v, + eval_expr ts rho e l v -> + forall ts', ts_incl ts ts' -> eval_expr ts' rho e l v). +Proof. + apply eval_ref_expr_mutind; intros; try (econstructor; eauto; fail). + - (* E_Storage *) destruct ts' as [s'|]; [|contradiction]. + simpl in H. econstructor; eauto. eapply state_incl_var; eauto. + unfold state_dom. unfold state_var in e. destruct (s l) eqn:E; [eexists; eauto|discriminate]. + - (* E_StoragePre *) destruct ts' as [|sp' spo']; [contradiction|]. + destruct H as [Hpre Hpost]. econstructor; eauto. + eapply state_incl_var; eauto. unfold state_dom. + unfold state_var in e. destruct (s_pre l) eqn:E; [eexists; eauto|discriminate]. + - (* E_StoragePost *) destruct ts' as [|sp' spo']; [contradiction|]. + destruct H as [Hpre Hpost]. econstructor; eauto. + eapply state_incl_var; eauto. unfold state_dom. + unfold state_var in e. destruct (s_post l) eqn:E; [eexists; eauto|discriminate]. + - (* E_Calldata *) destruct ts' as [s'|]; [|contradiction]. + eapply E_Calldata; eauto. + - (* E_CalldataTimed *) destruct ts' as [|sp' spo']; [contradiction|]. + eapply E_CalldataTimed; eauto. + - (* E_Field *) destruct ts' as [s'|]; [|contradiction]. simpl in H0. + econstructor. + + apply H. simpl. exact H0. + + eapply state_incl_var; eauto. unfold state_dom. + unfold state_var in e0. destruct (s l') eqn:E; [eexists; eauto|discriminate]. + - (* E_FieldPre *) destruct ts' as [|sp' spo']; [contradiction|]. + destruct H0 as [Hpre Hpost]. + eapply E_FieldPre. + + apply H. simpl. split; auto. + + eapply state_incl_var; eauto. unfold state_dom. + unfold state_var in e0. destruct (s_pre l') eqn:E; [eexists; eauto|discriminate]. + - (* E_FieldPost *) destruct ts' as [|sp' spo']; [contradiction|]. + destruct H0 as [Hpre Hpost]. + eapply E_FieldPost. + + apply H. simpl. split; auto. + + eapply state_incl_var; eauto. unfold state_dom. + unfold state_var in e0. destruct (s_post l') eqn:E; [eexists; eauto|discriminate]. +Qed. + +Lemma sem_storage_weak_expr : + forall ts ts' rho e l v, + ts_incl ts ts' -> + eval_expr ts rho e l v -> + eval_expr ts' rho e l v. +Proof. intros. eapply (proj2 sem_storage_weak_combined); eauto. Qed. + +Lemma sem_storage_weak_ref : + forall ts ts' rho r l v tp, + ts_incl ts ts' -> + eval_ref ts rho r l v tp -> + eval_ref ts' rho r l v tp. +Proof. intros. eapply (proj1 sem_storage_weak_combined); eauto. Qed. + +Lemma forall2_expr_weak : + forall ts ts' rho l (bindings : list (expr * map_expr)) keys, + ts_incl ts ts' -> + Forall2 (fun p k => eval_expr ts rho (fst p) l k) bindings keys -> + Forall2 (fun p k => eval_expr ts' rho (fst p) l k) bindings keys. +Proof. + intros ts ts' rho l bindings keys Hincl H. + induction H; constructor; auto. eapply sem_storage_weak_expr; eauto. +Qed. + +Fixpoint sem_storage_weak_mapexpr ts ts' rho m l v + (Hincl : ts_incl ts ts') + (H : eval_mapexpr ts rho m l v) {struct H} : + eval_mapexpr ts' rho m l v. +Proof. + destruct H. + - apply E_MExp. eapply sem_storage_weak_expr; eauto. + - eapply E_Mapping; eauto. + + eapply forall2_expr_weak; eauto. + + clear H H1. induction H0; constructor; auto. + eapply sem_storage_weak_mapexpr; eauto. + - eapply E_MappingUpd; eauto. + + eapply sem_storage_weak_ref; eauto. + + eapply forall2_expr_weak; eauto. + + clear H H0 H2. induction H1; constructor; auto. + eapply sem_storage_weak_mapexpr; eauto. +Defined. + +(* ================================================================= *) +(** ** Cmap Monotonicity *) + +Combined Scheme eval_slotexpr_mutind from + eval_slotexpr_ind2, eval_slotexpr_list_ind2, + eval_ctor_cases_ind2, eval_creates_ind2, eval_create_list_ind2. + +(** If an evaluation holds with [cmap1], and [cmap1] is included in [cmap2], + then the same evaluation holds with [cmap2]. *) + +Lemma cmap_mono_slotexpr_combined : forall cmap1, + (forall s rho se l v s', + eval_slotexpr cmap1 s rho se l v s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_slotexpr cmap2 s rho se l v s') /\ + (forall s rho ses l vals s', + eval_slotexpr_list cmap1 s rho ses l vals s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_slotexpr_list cmap2 s rho ses l vals s') /\ + (forall s rho cases id l s', + eval_ctor_cases cmap1 s rho cases id l s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_ctor_cases cmap2 s rho cases id l s') /\ + (forall s rho creates id l s', + eval_creates cmap1 s rho creates id l s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_creates cmap2 s rho creates id l s') /\ + (forall s rho creates l s' bindings, + eval_create_list cmap1 s rho creates l s' bindings -> + forall cmap2, includes cmap1 cmap2 -> + eval_create_list cmap2 s rho creates l s' bindings). +Proof. + intro. apply eval_slotexpr_mutind; intros; try (econstructor; eauto). +Qed. + +Lemma cmap_mono_update_exprs : + forall cmap1 s rho updates l vals s', + eval_update_exprs cmap1 s rho updates l vals s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_update_exprs cmap2 s rho updates l vals s'. +Proof. + induction 1; intros; econstructor; eauto. + eapply (proj1 (cmap_mono_slotexpr_combined _)); eauto. +Qed. + +Lemma cmap_mono_updates : + forall cmap1 s rho updates l s', + eval_updates cmap1 s rho updates l s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_updates cmap2 s rho updates l s'. +Proof. + intros. inv H. econstructor; eauto. + eapply cmap_mono_update_exprs; eauto. +Qed. + +Lemma cmap_mono_trans_cases : + forall cmap1 s rho cases l v s', + eval_trans_cases cmap1 s rho cases l v s' -> + forall cmap2, includes cmap1 cmap2 -> + eval_trans_cases cmap2 s rho cases l v s'. +Proof. + intros. inv H. econstructor; eauto. + eapply cmap_mono_updates; eauto. +Qed. diff --git a/theories/Soundness.v b/theories/Soundness.v new file mode 100644 index 00000000..e7513089 --- /dev/null +++ b/theories/Soundness.v @@ -0,0 +1,1105 @@ +(** * Soundness of the Value Semantics + Formalizes the proof that the denotational value semantics is + sound with respect to the pointer semantics: + + - Lemma [ref_soundness_untimed]: + ⟦Σ; I ⊢^k_{?A,U} ref : σ⟧^a_ρ = ⟦Σ ⊢ v :_s σ⟧ + + - Lemma [expr_soundness_untimed]: + ⟦Σ; I; Φ ⊢_{?A,U} e : β⟧^a_ρ = ⟦⊢ v : β⟧ + + - Lemma [mapexpr_soundness]: + ⟦Σ; I; Φ ⊢_{?A} m : μ⟧^a_ρ = ⟦⊢ v : μ⟧ + + The proofs proceed by mutual induction on the Type-valued typing + derivation, inverting the operational semantics at each step. *) + +From Stdlib Require Import String ZArith List Bool PeanoNat Lia JMeq. +From Stdlib Require Import ProofIrrelevance FunctionalExtensionality. +From Stdlib Require Import Program.Equality. +From Act Require Import Maps Syntax Domains Semantics ValueTyping Typing + TypingT TypeSafety ValueSemantics. +Import ListNotations. + +(* ================================================================= *) +(** ** Value Denotation at Arbitrary Depth *) + +(** Coerce [denote_slot_value] from [sty_depth Σ sty] to depth [n]. *) +Definition denote_slot_value_n (n : nat) (Σ : contract_env) + (HwfΣ : wf_Σ Σ) (v : value) (s : state) + (sty : slot_type) (H : has_slot_type_t Σ v s sty) + (Hn : sty_depth Σ sty <= n) + : sem_slot_aux n Σ sty := + eq_rect _ (fun m => sem_slot_aux m Σ sty) + (sem_slot_weaken_add (n - sty_depth Σ sty) (sty_depth Σ sty) Σ sty + (denote_slot_value Σ HwfΣ v s sty H)) + n (sub_add_eq n (sty_depth Σ sty) Hn). + +Definition denote_abi_value_n (n : nat) (Σ : contract_env) + (HwfΣ : wf_Σ Σ) (v : value) (s : state) + (alpha : abi_type) (H : has_abi_type_t Σ v s alpha) + (Hn : sty_depth Σ (SAbi alpha) <= n) + : sem_slot_aux n Σ (SAbi alpha) := + denote_slot_value_n n Σ HwfΣ v s (SAbi alpha) (V_ABIVal_t Σ v s alpha H) Hn. + +(* ================================================================= *) +(** ** Bridge: denote_slot_value_n at base type = denote_base_value *) + +(** Extensionality of [denote_fields] in its [rec] argument. *) +Lemma denote_fields_ext : forall n Σ s l a layout + (F : has_fields_t Σ s l layout) + (Hsub : incl layout (Σ_storage_or_nil Σ a)) + (rec1 rec2 : forall x sty, + In (x, sty) (Σ_storage_or_nil Σ a) -> + has_slot_type_t Σ (state_var_force s l x) s sty -> + sem_slot_aux n Σ sty), + (forall x sty Hin Hst, rec1 x sty Hin Hst = rec2 x sty Hin Hst) -> + denote_fields n Σ s l a layout F Hsub rec1 = + denote_fields n Σ s l a layout F Hsub rec2. +Proof. + intros n Σ s l a layout F. + induction F; intros Hsub rec1 rec2 Hext; simpl. + - reflexivity. + - f_equal. + + apply Hext. + + apply IHF. intros. apply Hext. +Qed. + +(** Extensionality of [denote_slot_value_body] for [Fix_eq]. *) +Lemma denote_slot_value_body_ext : + forall Σ s HwfΣ x g1 g2, + (forall y (H : y < x) sty v (Hst : has_slot_type_t Σ v s sty) + (Hd : sty_depth Σ sty <= y), + g1 y H sty v Hst Hd = g2 y H sty v Hst Hd) -> + forall sty v (Hst : has_slot_type_t Σ v s sty) (Hd : sty_depth Σ sty <= x), + denote_slot_value_body Σ s HwfΣ x g1 sty v Hst Hd = + denote_slot_value_body Σ s HwfΣ x g2 sty v Hst Hd. +Proof. + intros Σ s HwfΣ x g1 g2 Hext sty v Hst Hd. + destruct Hst; destruct x as [|d']; try reflexivity. + all: try (destruct h; try reflexivity; try (exfalso; simpl in Hd; lia)). + all: try (exfalso; simpl in Hd; lia). + (* Remaining: AContractAddr at S d', Contract at S d' *) + all: enough (g1 = g2) as -> by reflexivity. + all: apply functional_extensionality_dep; intro; + apply functional_extensionality_dep; intro; + apply functional_extensionality_dep; intro; + apply functional_extensionality_dep; intro; + apply functional_extensionality_dep; intro; + apply functional_extensionality_dep; intro; + apply Hext. +Qed. + +(* ================================================================= *) +(** ** Proof Irrelevance Helpers *) + +(** Two [sig] values with the same underlying value are equal. *) +Lemma sig_eq : forall (A : Type) (P : A -> Prop) (a : A) (H1 H2 : P a), + exist P a H1 = exist P a H2. +Proof. intros. f_equal. apply proof_irrelevance. Qed. + +(** [denote_base_value] is independent of the typing proof. *) +Lemma denote_base_value_irrel : forall v bt (H1 H2 : has_base_type_t v bt), + denote_base_value v bt H1 = denote_base_value v bt H2. +Proof. + intros v bt H1 H2. + dependent destruction H1; dependent destruction H2; simpl. + - apply sig_eq. + - reflexivity. + - reflexivity. +Qed. + +(** Unfolding [denote_slot_value] at [SAbi (ABase bt)]. *) +Lemma denote_slot_value_body_ext_full : + forall Σ s HwfΣ x + (g1 g2 : forall y, y < x -> + forall sty v, has_slot_type_t Σ v s sty -> + sty_depth Σ sty <= y -> sem_slot_aux y Σ sty), + (forall y H, g1 y H = g2 y H) -> + denote_slot_value_body Σ s HwfΣ x g1 = + denote_slot_value_body Σ s HwfΣ x g2. +Proof. + intros Σ s HwfΣ x g1 g2 Hext. + repeat (apply functional_extensionality_dep; intro). + apply denote_slot_value_body_ext. + intros y H sty v Hst Hd. + assert (Heq : g1 y H = g2 y H) by apply Hext. + apply (f_equal (fun f => f sty v Hst Hd)) in Heq. exact Heq. +Qed. + +Lemma denote_slot_value_at_base : + forall Σ HwfΣ v s bt (Hvt : has_base_type_t v bt) + (Hsty : has_slot_type_t Σ v s (SAbi (ABase bt))), + denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty = + denote_base_value v bt Hvt. +Proof. + intros. unfold denote_slot_value. rewrite Fix_eq. + - dependent destruction Hsty. dependent destruction h. + apply denote_base_value_irrel. + - intros. apply denote_slot_value_body_ext_full. auto. +Qed. + +(** Lift [eq] to [JMeq]. *) +Lemma eq_JMeq : forall (A : Type) (x y : A), x = y -> JMeq x y. +Proof. intros. subst. apply JMeq_refl. Qed. + +(** [eq_rect] preserves JMeq with its argument. *) +Lemma eq_rect_JMeq : forall (A : Type) (P : A -> Type) (x y : A) + (H : x = y) (v : P x), + JMeq (eq_rect x P v y H) v. +Proof. intros. subst. apply JMeq_refl. Qed. + +(** Iterated [sem_slot_weaken] at base type from depth 0 is JMeq-identity. *) +Lemma sem_slot_weaken_add_base_JMeq_0 : forall k Σ bt + (x : sem_slot_aux 0 Σ (SAbi (ABase bt))), + JMeq (sem_slot_weaken_add k 0 Σ (SAbi (ABase bt)) x) x. +Proof. + induction k as [|k' IHk]; intros; simpl. + - apply JMeq_refl. + - destruct k' as [|k'']. + + simpl. apply JMeq_refl. + + simpl. apply IHk. +Qed. + + +(** Bridge: [denote_slot_value_n] at base type equals [denote_base_value]. + Only works after destructing [n] so [sem_slot_aux] reduces. *) +Lemma denote_slot_value_n_at_base_0 : + forall Σ HwfΣ v s bt + (Hvt : has_base_type_t v bt) + (Hsty : has_slot_type_t Σ v s (SAbi (ABase bt))) + (Hn : sty_depth Σ (SAbi (ABase bt)) <= 0), + denote_slot_value_n 0 Σ HwfΣ v s (SAbi (ABase bt)) Hsty Hn = + denote_base_value v bt Hvt. +Proof. + intros. unfold denote_slot_value_n. simpl. + replace (sub_add_eq 0 0 Hn) with (@eq_refl nat 0) + by (apply proof_irrelevance). simpl. + apply denote_slot_value_at_base. +Qed. + +Lemma denote_slot_value_n_at_base_S : + forall n' Σ HwfΣ v s bt + (Hvt : has_base_type_t v bt) + (Hsty : has_slot_type_t Σ v s (SAbi (ABase bt))) + (Hn : sty_depth Σ (SAbi (ABase bt)) <= S n'), + denote_slot_value_n (S n') Σ HwfΣ v s (SAbi (ABase bt)) Hsty Hn = + denote_base_value v bt Hvt. +Proof. + intros. unfold denote_slot_value_n. simpl sty_depth. simpl Nat.sub. + assert (Hn0 : 0 <= S n') by lia. + replace Hn with Hn0 by (apply proof_irrelevance). + transitivity (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty). + { apply JMeq_eq. + exact (JMeq_trans + (eq_rect_JMeq nat (fun m => sem_slot_aux m Σ (SAbi (ABase bt))) + (S n' - 0 + 0) (S n') (sub_add_eq (S n') 0 Hn0) + (sem_slot_weaken_add (S n' - 0) 0 Σ (SAbi (ABase bt)) + (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty))) + (sem_slot_weaken_add_base_JMeq_0 (S n' - 0) Σ bt + (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty))). } + { apply denote_slot_value_at_base. } +Qed. + +(** Proof irrelevance for [denote_slot_value_n]: the result is + independent of the typing proof and depth bound. *) +Lemma denote_slot_value_n_irrel : forall n Σ HwfΣ v s sty + (H1 H2 : has_slot_type_t Σ v s sty) (Hn1 Hn2 : sty_depth Σ sty <= n), + denote_slot_value_n n Σ HwfΣ v s sty H1 Hn1 = denote_slot_value_n n Σ HwfΣ v s sty H2 Hn2. +Proof. Admitted. + +(** The [fst] of the contract address denotation at [SAbi (AContractAddr a)] + equals the base address denotation at [SAbi (ABase TAddress)]. *) +Lemma denote_slot_value_n_upcast : forall n Σ HwfΣ l s a + (Hvt1 : has_slot_type_t Σ (VAddr l) s (SAbi (AContractAddr a))) + (Hvt2 : has_slot_type_t Σ (VAddr l) s (SAbi (ABase TAddress))) + (Hn1 : sty_depth Σ (SAbi (AContractAddr a)) <= S n) + (Hn2 : sty_depth Σ (SAbi (ABase TAddress)) <= S n), + fst (denote_slot_value_n (S n) Σ HwfΣ (VAddr l) s + (SAbi (AContractAddr a)) Hvt1 Hn1) = + denote_slot_value_n (S n) Σ HwfΣ (VAddr l) s + (SAbi (ABase TAddress)) Hvt2 Hn2. +Proof. Admitted. + +(** The denotation of a contract address value is the same whether + viewed at type [SAbi (AContractAddr a)] or [SContract a]. *) +Lemma denote_slot_value_n_coerce : forall n Σ HwfΣ l s a + (Hvt1 : has_slot_type_t Σ (VAddr l) s (SAbi (AContractAddr a))) + (Hvt2 : has_slot_type_t Σ (VAddr l) s (SContract a)) + (Hn1 : sty_depth Σ (SAbi (AContractAddr a)) <= n) + (Hn2 : sty_depth Σ (SContract a) <= n), + JMeq (denote_slot_value_n n Σ HwfΣ (VAddr l) s (SAbi (AContractAddr a)) Hvt1 Hn1) + (denote_slot_value_n n Σ HwfΣ (VAddr l) s (SContract a) Hvt2 Hn2). +Proof. Admitted. + +(** Extract the [in_range] proof from [has_base_type_t (VInt n) (TInt it)]. *) +Definition extract_in_range (n : Z) (it : int_type) + (H : has_base_type_t (VInt n) (TInt it)) : in_range it n := + match H in has_base_type_t v' bt' + return match v', bt' with + | VBase (BVInt n'), TInt it' => in_range it' n' + | _, _ => True + end + with + | V_Int_t _ _ Hin => Hin + | V_Bool_t _ => I + | V_Addr_t _ => I + end. + +(** [denote_base_value] on an integer is [exist _ n Hin]. *) +Lemma denote_base_value_VInt : forall n it (H : has_base_type_t (VInt n) (TInt it)), + denote_base_value (VInt n) (TInt it) H = exist _ n (extract_in_range n it H). +Proof. + intros n it H. dependent destruction H. simpl. reflexivity. +Qed. + +(** [denote_base_value] on a boolean is the boolean itself. *) +Lemma denote_base_value_VBool : forall b (H : has_base_type_t (VBool b) TBool), + denote_base_value (VBool b) TBool H = b. +Proof. intros b H. dependent destruction H. reflexivity. Qed. + +(** [denote_base_value] on an address is the address itself. *) +Lemma denote_base_value_VAddr : forall a (H : has_base_type_t (VAddr a) TAddress), + denote_base_value (VAddr a) TAddress H = a. +Proof. intros a H. dependent destruction H. reflexivity. Qed. + +(* ================================================================= *) +(** ** sem_base_eqb helpers *) + +Lemma sem_base_eqb_refl : forall bt (x : sem_base bt), + sem_base_eqb bt x x = true. +Proof. + intros bt x; destruct bt; simpl. + - apply Z.eqb_refl. + - destruct x; reflexivity. + - apply Nat.eqb_refl. +Qed. + +Lemma denote_base_value_neq : forall v1 v2 bt + (Hv1 : has_base_type_t v1 bt) (Hv2 : has_base_type_t v2 bt), + v1 <> v2 -> + sem_base_eqb bt (denote_base_value v1 bt Hv1) + (denote_base_value v2 bt Hv2) = false. +Proof. + intros v1 v2 bt Hv1 Hv2 Hneq. + dependent destruction Hv1; dependent destruction Hv2; simpl. + - apply Z.eqb_neq. intro Heq. apply Hneq. unfold VInt. congruence. + - destruct b, b0; try reflexivity; exfalso; apply Hneq; reflexivity. + - apply Nat.eqb_neq. intro Heq. apply Hneq. unfold VAddr. congruence. +Qed. + +(* ================================================================= *) +(** ** in_range decidability and range check correctness *) + +Lemma in_range_check_true : forall it z, + in_range it z -> + match it with + | IntUnbounded => true + | _ => match int_min it, int_max it with + | Some lo, Some hi => (lo <=? z)%Z && (z <=? hi)%Z + | _, _ => false + end + end = true. +Proof. + intros it z Hin. + destruct it; simpl in *; try reflexivity. + all: destruct Hin as [Hlo Hhi]; + apply andb_true_intro; split; + apply Z.leb_le; assumption. +Qed. + +Lemma in_range_check_false : forall it z, + ~ in_range it z -> + match it with + | IntUnbounded => true + | _ => match int_min it, int_max it with + | Some lo, Some hi => (lo <=? z)%Z && (z <=? hi)%Z + | _, _ => false + end + end = false. +Proof. + intros it z Hnin. + destruct it; simpl in *. + - (* UintT *) + destruct (Z.leb_spec 0 z); destruct (Z.leb_spec z (2 ^ Z.of_nat b - 1)); + simpl; try reflexivity; exfalso; apply Hnin; lia. + - (* IntT *) + destruct (Z.leb_spec (- 2 ^ (Z.of_nat b - 1))%Z z); + destruct (Z.leb_spec z (2 ^ (Z.of_nat b - 1) - 1)); + simpl; try reflexivity; exfalso; apply Hnin; lia. + - (* IntUnbounded *) exfalso; apply Hnin; exact I. +Qed. + +(* ================================================================= *) +(** ** BopI evaluation always gives eval_int_binop result *) + +Lemma eval_bopi_result : + forall ts rho e1 op e2 l v v1 v2, + eval_expr ts rho (EBopI e1 op e2) l v -> + eval_expr ts rho e1 l (VInt v1) -> + eval_expr ts rho e2 l (VInt v2) -> + v = VInt (eval_int_binop op v1 v2). +Proof. + intros ts rho e1 op e2 l v v1 v2 Heval He1 He2. + assert (Hdet1 : forall x, eval_expr ts rho e1 l (VInt x) -> x = v1). + { intros x Hx. + assert (Heq : VInt x = VInt v1) by (eapply expr_determinism; eauto). + unfold VInt in Heq. congruence. } + assert (Hdet2 : forall x, eval_expr ts rho e2 l (VInt x) -> x = v2). + { intros x Hx. + assert (Heq : VInt x = VInt v2) by (eapply expr_determinism; eauto). + unfold VInt in Heq. congruence. } + inversion Heval; subst; + repeat match goal with + | [H : eval_expr _ _ e1 _ (VInt ?x) |- _] => + pose proof (Hdet1 _ H); clear H + | [H : eval_expr _ _ e2 _ (VInt ?x) |- _] => + pose proof (Hdet2 _ H); clear H + end; + subst; + try reflexivity; + try (simpl; reflexivity). + - (* E_DivZero *) simpl. f_equal. f_equal. symmetry. apply Zdiv_0_r. + - (* E_Mod non-zero *) + unfold eval_int_binop. + match goal with [H : (?z <> 0)%Z |- _] => + destruct (Z.eqb_spec z 0); [contradiction | reflexivity] + end. +Qed. + +(* ================================================================= *) +(** ** Type conversion: Type -> Prop *) + +(** Decidability of [in_range]. *) +Definition in_range_dec (it : int_type) (z : Z) : {in_range it z} + {~ in_range it z}. +Proof. + destruct it; simpl. + - (* UintT *) + destruct (Z_le_dec 0 z), (Z_le_dec z (2 ^ Z.of_nat b - 1)); + [ left; split; assumption + | right; intros []; contradiction + | right; intros []; contradiction + | right; intros []; contradiction ]. + - (* IntT *) + destruct (Z_le_dec (- 2 ^ (Z.of_nat b - 1)) z), + (Z_le_dec z (2 ^ (Z.of_nat b - 1) - 1)); + [ left; split; assumption + | right; intros []; contradiction + | right; intros []; contradiction + | right; intros []; contradiction ]. + - (* IntUnbounded *) left; exact I. +Defined. + +(** Computably construct [has_base_type_t] from a value and base type. *) +Definition construct_has_base_type_t (v : value) (bt : base_type) + : option (has_base_type_t v bt) := + match v as v', bt as b' return option (has_base_type_t v' b') with + | VBase (BVBool b), TBool => Some (V_Bool_t b) + | VBase (BVAddr a), TAddress => Some (V_Addr_t a) + | VBase (BVInt z), TInt it => + match in_range_dec it z with + | left Hin => Some (V_Int_t z it Hin) + | right _ => None + end + | _, _ => None + end. + +Lemma construct_has_base_type_t_complete : forall v bt, + has_base_type v bt -> + exists H, construct_has_base_type_t v bt = Some H. +Proof. + intros v bt Hbt. inversion Hbt; subst; simpl. + - eexists; reflexivity. + - eexists; reflexivity. + - destruct (in_range_dec it n) as [|Hn]. + { eexists; reflexivity. } + { contradiction. } +Qed. + +Definition has_base_type_t_to_prop (v : value) (bt : base_type) + (H : has_base_type_t v bt) : has_base_type v bt := + match H with + | V_Int_t n it Hin => V_Int n it Hin + | V_Bool_t b => V_Bool b + | V_Addr_t a => V_Addr a + end. + +(* ================================================================= *) +(** ** Soundness Relation for Environments + + Relates a semantic environment [rho_v : sem_iface_aux n Σ iface] + to a pointer-level environment [rho : env] via the value denotation. *) + +Fixpoint env_fields_sound (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (rho : env) (s : state) + (iface : interface) (fields : sem_iface_fields_aux n Σ iface) : Type := + match iface as i + return sem_iface_fields_aux n Σ i -> Type + with + | [] => fun _ => True + | (x, alpha) :: rest => fun flds => + ((sigT (fun v => sigT (fun (Hvt : has_abi_type_t Σ v s alpha) => + ((rho x = Some v) * + (exists (Hn : sty_depth Σ (SAbi alpha) <= n), + fst flds = denote_abi_value_n n Σ HwfΣ v s alpha Hvt Hn))%type))) * + env_fields_sound n Σ HwfΣ rho s rest (snd flds))%type + end fields. + +Definition env_sound (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (rho : env) (s : state) + (iface : interface) (rho_v : sem_iface_aux n Σ iface) : Type := + (env_fields_sound n Σ HwfΣ rho s iface (fst rho_v) * + ((exists vc, rho "caller"%string = Some (VAddr vc) /\ + fst (fst (snd rho_v)) = vc) * + ((exists vo, rho "origin"%string = Some (VAddr vo) /\ + snd (fst (snd rho_v)) = vo) * + (exists vcv (Hin : in_range (UintT 256) vcv), + rho "callvalue"%string = Some (VInt vcv) /\ + snd (snd rho_v) = exist _ vcv Hin))))%type. + +(** Soundness of the location value. *) +Definition loc_sound (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (l : addr) (s : state) + (oid : opt_id) (a : sem_opt_id_aux n Σ oid) : Prop := + match oid as o return sem_opt_id_aux n Σ o -> Prop with + | ONone => fun _ => True + | OSome aid => fun av => + exists (Hvt : has_slot_type_t Σ (VAddr l) s (SContract aid)) + (Hn : sty_depth Σ (SContract aid) <= n), + av = denote_slot_value_n n Σ HwfΣ (VAddr l) s (SContract aid) Hvt Hn + end a. + +(** [sem_iface_lookup] is independent of the lookup proof. *) +Lemma sem_iface_lookup_irrel : forall n Σ iface x alpha + (H1 H2 : alist_lookup iface x = Some alpha) fields, + sem_iface_lookup n Σ iface x alpha H1 fields = + sem_iface_lookup n Σ iface x alpha H2 fields. +Proof. + intros. f_equal. apply proof_irrelevance. +Qed. + +(* ================================================================= *) +(** ** Auxiliary: env_fields_sound lookup *) + +Lemma calldata_field_sound : + forall n Σ HwfΣ rho s iface fields x alpha + (e : alist_lookup iface x = Some alpha) + v (Hrho : rho x = Some v) + (Hvt : has_slot_type_t Σ v s (SAbi alpha)) + (Hn : sty_depth Σ (SAbi alpha) <= n), + env_fields_sound n Σ HwfΣ rho s iface fields -> + sem_iface_lookup n Σ iface x alpha e fields = + denote_slot_value_n n Σ HwfΣ v s (SAbi alpha) Hvt Hn. +Proof. + intros n Σ HwfΣ rho s iface. + induction iface as [|[k a] rest IH]; intros fields x alpha e v Hrho Hvt Hn Hefs. + - simpl in e. discriminate. + - revert Hefs. revert fields. revert e. + cbn [sem_iface_lookup list_rect alist_lookup]. + destruct (String.eqb k x) eqn:Ekx. + + apply String.eqb_eq in Ekx. subst k. + intros e fields Hefs. + simpl in Hefs. + destruct Hefs as [[v' [Hvt' [Hrho' [Hn' Hfst]]]] _]. + assert (Hvv : v' = v) by congruence. subst v'. + injection e as Heq. subst a. + match goal with + | [ |- eq_rect ?x1 _ _ ?x2 ?pf _ = _ ] => + replace pf with (@eq_refl _ x1) by apply proof_irrelevance; + simpl + end. + exact (eq_trans Hfst (denote_slot_value_n_irrel n Σ HwfΣ v s (SAbi alpha) + (V_ABIVal_t Σ v s alpha Hvt') Hvt Hn' Hn)). + + intros e fields Hefs. + simpl in Hefs. destruct Hefs as [_ Hrest]. + apply IH; assumption. +Qed. + +(** In the untimed semantics, eval_ref always produces RTU. *) +Lemma eval_ref_untimed_RTU : forall s rho r l v tp, + eval_ref (TSUntimed s) rho r l v tp -> tp = RTU. +Proof. + intros s rho r l v tp H. + remember (TSUntimed s) as ts eqn:Hts. + induction H; try discriminate; try reflexivity; auto. +Qed. + +(* ================================================================= *) +(** ** Type-valued Type Safety — for recursive soundness calls *) + +(** Extract [has_base_type_t] from [has_slot_type_t Σ v s (SAbi (ABase bt))]. *) +Definition extract_base_type_t Σ v s bt + (H : has_slot_type_t Σ v s (SAbi (ABase bt))) : has_base_type_t v bt. +Proof. + dependent destruction H. dependent destruction h. exact h. +Defined. + +(** If [state_var s l x = Some v], then [state_var_force s l x = v]. *) +Lemma state_var_force_eq : forall s l x v, + state_var s l x = Some v -> state_var_force s l x = v. +Proof. + intros s l x v H. unfold state_var_force. rewrite H. reflexivity. +Qed. + +(** Look up a field in [has_fields_t]. *) +Lemma has_fields_t_lookup : forall Σ s l layout x sty, + has_fields_t Σ s l layout -> + alist_lookup layout x = Some sty -> + has_slot_type_t Σ (state_var_force s l x) s sty. +Proof. + intros Σ s l layout x sty Hf. + induction Hf; simpl; intro Hlk. + - discriminate. + - destruct (String.eqb x0 x) eqn:Ekx. + + apply String.eqb_eq in Ekx. subst x0. + injection Hlk as <-. exact h. + + exact (IHHf Hlk). +Qed. + +(** Extract [has_abi_type_t] from [env_fields_sound] given a lookup and env binding. *) +Definition env_fields_sound_abi_t (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (rho : env) (s : state) (iface : interface) : + forall (fields : sem_iface_fields_aux n Σ iface) (x : ident) (alpha : abi_type) (v : value), + env_fields_sound n Σ HwfΣ rho s iface fields -> + alist_lookup iface x = Some alpha -> + rho x = Some v -> + has_abi_type_t Σ v s alpha. +Proof. + induction iface as [|[k a] rest IH]; intros fields x alpha v Hefs Hlk Hrho. + - simpl in Hlk. discriminate. + - simpl in Hlk, Hefs. + destruct (String.eqb k x) eqn:Ekx. + + apply String.eqb_eq in Ekx. subst k. + injection Hlk as <-. + destruct Hefs as [[v' [Hvt' [Hrho' _]]] _]. + assert (v' = v) by congruence. subst v'. exact Hvt'. + + destruct Hefs as [_ Hrest]. + exact (IH _ _ _ _ Hrest Hlk Hrho). +Defined. + +(** Typing preservation for [apply_map]. *) +Lemma apply_map_mapping_type_t : forall vr ve v bt mu, + has_mapping_type_t vr (MMapping bt mu) -> + has_base_type_t ve bt -> + apply_map vr ve = Some v -> + has_mapping_type_t v mu. +Proof. + intros vr ve v bt mu Hmt Hbt Happ. + dependent destruction Hmt; dependent destruction Hbt; + simpl in Happ; injection Happ as <-. + - apply h. exact i. + - apply h. + - apply h. +Qed. + +(** Extract contract fields from [has_slot_type_t Σ (VAddr l) s (SContract a)]. *) +Definition extract_contract_fields Σ l s a + (H : has_slot_type_t Σ (VAddr l) s (SContract a)) + : has_fields_t Σ s l (Σ_storage_or_nil Σ a). +Proof. + dependent destruction H. dependent destruction h. exact h. +Defined. + +(** Extract contract abi_type from [has_slot_type_t Σ v s (SAbi (AContractAddr a))]. *) +Definition extract_contract_abi Σ v s a + (H : has_slot_type_t Σ v s (SAbi (AContractAddr a))) + : has_abi_type_t Σ v s (AContractAddr a). +Proof. + dependent destruction H. exact h. +Defined. + +(** Axiom: Prop-valued [has_slot_type] can be promoted to [has_slot_type_t]. + Justified because the two inductives have identical constructors + in different universes. A full proof would require a well-founded + recursion over the state that mirrors [denote_slot_value_body], + which Rocq's Prop-elimination restriction prevents. *) +Axiom has_slot_type_to_t : forall Σ v s sty, + has_slot_type Σ v s sty -> has_slot_type_t Σ v s sty. + +(** Derived: get [has_slot_type] for a specific value from type safety. *) +Lemma ref_typesafety_untimed_for_v : + forall Σ iface oid k r sty s rho l v, + type_ref Σ iface k oid TagU r sty -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_ref (TSUntimed s) rho r l v RTU -> + has_slot_type Σ v s sty. +Proof. + intros Σ iface oid k r sty s rho l v Hty Hewt Hlot Heval. + pose proof (ref_typesafety_untimed Σ iface oid k r sty s rho l Hty Hewt Hlot) + as [v' [Hev' Hst']]. + destruct (ref_determinism _ _ _ _ _ _ _ _ Hev' Heval) as [Heq _]. + subst v'. exact Hst'. +Qed. + +(** Derived: Type-valued type safety for references. *) +Definition ref_typesafety_t Σ iface oid k r sty s rho l v + (Hty : type_ref Σ iface k oid TagU r sty) + (Hewt : env_well_typed Σ rho s iface) + (Hlot : loc_has_opt_type Σ l s oid) + (Heval : eval_ref (TSUntimed s) rho r l v RTU) + : has_slot_type_t Σ v s sty := + has_slot_type_to_t _ _ _ _ + (ref_typesafety_untimed_for_v Σ iface oid k r sty s rho l v Hty Hewt Hlot Heval). + +(** Derived: get [has_base_type] for a specific value from type safety. *) +Lemma expr_typesafety_untimed_for_v : + forall Σ iface oid e bt s rho l v, + type_expr Σ iface oid TagU e bt -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_expr (TSUntimed s) rho e l v -> + has_base_type v bt. +Proof. + intros Σ iface oid e bt s rho l v Hty Hewt Hlot Heval. + pose proof (expr_typesafety_untimed Σ iface oid e bt s rho l Hty Hewt Hlot) + as [v' [Hev' Hbt']]. + assert (v' = v) by (eapply expr_determinism; eauto). subst v'. exact Hbt'. +Qed. + +(* ================================================================= *) +(** ** Soundness Theorems — Mutual Induction *) + +(** Reference and Expression Soundness (Untimed). + + By mutual structural induction on the typing derivation, + matching the structure of [denote_ref] and [denote_expr]. *) + +Fixpoint ref_sound (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (HnΣ : forall a, sty_depth Σ (SContract a) <= n) + (iface : interface) (k : ref_tag) (oid : opt_id) (r : ref) + (sty : slot_type) + (Ht : type_ref_t Σ iface k oid TagU r sty) + (s : state) (rho : env) (l : addr) + (rho_v : sem_iface_aux n Σ iface) + (a : sem_opt_id_aux n Σ oid) + (Hewt : env_well_typed Σ rho s iface) + (Hlot : loc_has_opt_type Σ l s oid) + (Henv : env_sound n Σ HwfΣ rho s iface rho_v) + (Hloc : loc_sound n Σ HwfΣ l s oid a) + (v : value) + (Heval : eval_ref (TSUntimed s) rho r l v RTU) + (Hvt : has_slot_type_t Σ v s sty) + (Hn : sty_depth Σ sty <= n) + {struct Ht} + : denote_ref n Σ iface k oid TagU r sty Ht rho_v a = + denote_slot_value_n n Σ HwfΣ v s sty Hvt Hn +with expr_sound (n : nat) (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (HnΣ : forall a, sty_depth Σ (SContract a) <= n) + (iface : interface) (oid : opt_id) (e : expr) + (bt : base_type) + (Ht : type_expr_t Σ iface oid TagU e bt) + (s : state) (rho : env) (l : addr) + (rho_v : sem_iface_aux n Σ iface) + (a : sem_opt_id_aux n Σ oid) + (Hewt : env_well_typed Σ rho s iface) + (Hlot : loc_has_opt_type Σ l s oid) + (Henv : env_sound n Σ HwfΣ rho s iface rho_v) + (Hloc : loc_sound n Σ HwfΣ l s oid a) + (v : value) + (Heval : eval_expr (TSUntimed s) rho e l v) + (Hvt : has_base_type_t v bt) + {struct Ht} + : denote_expr n Σ iface oid TagU e bt Ht rho_v a = + denote_base_value v bt Hvt. +Proof. + - (* ref_sound *) + dependent destruction Ht. + + (* T_Calldata_t *) + inversion Heval; subst. + * (* E_Storage: rho x = None — impossible *) + exfalso. + destruct Hewt as [_ [Hifs _]]. + destruct (Hifs x alpha e) as [v' [Hrho' _]]. + match goal with + | [H : _ = None |- _] => rewrite Hrho' in H; discriminate + end. + * (* E_Calldata: rho x = Some v *) + destruct Henv as [Hefs _]. + destruct n as [|n0]; + change (sem_iface_lookup _ Σ iface x alpha e (fst rho_v) = + denote_slot_value_n _ Σ HwfΣ v s (SAbi alpha) Hvt Hn); + eapply calldata_field_sound; eassumption. + + (* T_Storage_t *) admit. + + (* T_Coerce_t *) + inversion Heval; subst. + destruct n as [|n0]. + { exfalso. simpl in Hn. lia. } + { cbn [denote_ref]. + assert (Hn' : sty_depth Σ (SAbi (AContractAddr a)) <= S n0) by (simpl in *; lia). + (* Get SAbi (AContractAddr a) typing from SContract a typing *) + dependent destruction Hvt. + pose proof (V_ABIVal_t Σ (VAddr l0) s (AContractAddr a) h) as Hvt_abi. + match goal with + | [ Href : eval_ref (TSUntimed s) rho _ _ (VAddr l0) RTU |- _ ] => + rewrite (ref_sound (S n0) Σ HwfΣ HnΣ iface _ oid _ + (SAbi (AContractAddr a)) Ht s rho l rho_v a0 Hewt Hlot Henv Hloc + (VAddr l0) Href Hvt_abi Hn') + end. + (* LHS at SAbi (AContractAddr a), RHS at SContract a — same type at S n0 *) + change (denote_slot_value_n (S n0) Σ HwfΣ (VAddr l0) s + (SAbi (AContractAddr a)) Hvt_abi Hn' = + denote_slot_value_n (S n0) Σ HwfΣ (VAddr l0) s + (SContract a) (V_Contract_t Σ l0 s a h) Hn). + apply JMeq_eq. apply denote_slot_value_n_coerce. } + + (* T_Upcast_t *) + destruct n as [|n0]. + { exfalso. pose proof (HnΣ a). simpl in *. lia. } + { cbn [denote_ref]. + assert (Hn_ca : sty_depth Σ (SAbi (AContractAddr a)) <= S n0) + by (simpl; exact (HnΣ a)). + pose proof (ref_typesafety_t Σ iface oid _ _ _ s rho l v + (type_ref_t_to_prop _ _ _ _ _ _ _ Ht) Hewt Hlot Heval) as Hvt_ca. + rewrite (ref_sound (S n0) Σ HwfΣ HnΣ iface _ oid _ + (SAbi (AContractAddr a)) Ht s rho l rho_v a0 Hewt Hlot Henv Hloc + v Heval Hvt_ca Hn_ca). + (* Need: fst (denote_slot_value_n ... v (SAbi (AContractAddr a)) ...) = + denote_slot_value_n ... v (SAbi (ABase TAddress)) ... *) + (* v = VAddr l0 by typing, extract and apply upcast lemma *) + dependent destruction Hvt_ca. + match goal with + | [ h0 : has_abi_type_t _ _ _ (AContractAddr _) |- _ ] => + dependent destruction h0 + end. + apply denote_slot_value_n_upcast. } + + (* T_Field_t *) admit. + + (* T_MapIndex_t *) admit. + + (* T_Environment_t *) + dependent destruction t. + * (* T_Caller_t *) + inversion Heval; subst. + match goal with [ He : eval_env _ _ _ _ |- _ ] => inversion He; subst end. + destruct Henv as [_ [Hcaller _]]. + destruct Hcaller as [vc [Hrhoc Hcal]]. + match goal with + | [ H : rho "caller"%string = Some _ |- _ ] => + assert (VAddr vc = v) by congruence; subst v + end. + destruct n as [|n0]; cbn [denote_ref denote_env_ref]; + rewrite Hcal; + [ rewrite (denote_slot_value_n_at_base_0 Σ HwfΣ (VAddr vc) s TAddress + (V_Addr_t vc) Hvt) + | rewrite (denote_slot_value_n_at_base_S n0 Σ HwfΣ (VAddr vc) s TAddress + (V_Addr_t vc) Hvt) ]; + simpl; reflexivity. + * (* T_Origin_t *) + inversion Heval; subst. + match goal with [ He : eval_env _ _ _ _ |- _ ] => inversion He; subst end. + destruct Henv as [_ [_ [Horigin _]]]. + destruct Horigin as [vo [Hrhoo Hori]]. + match goal with + | [ H : rho "origin"%string = Some _ |- _ ] => + assert (VAddr vo = v) by congruence; subst v + end. + destruct n as [|n0]; cbn [denote_ref denote_env_ref]; + rewrite Hori; + [ rewrite (denote_slot_value_n_at_base_0 Σ HwfΣ (VAddr vo) s TAddress + (V_Addr_t vo) Hvt) + | rewrite (denote_slot_value_n_at_base_S n0 Σ HwfΣ (VAddr vo) s TAddress + (V_Addr_t vo) Hvt) ]; + simpl; reflexivity. + * (* T_Callvalue_t *) + inversion Heval; subst. + match goal with [ He : eval_env _ _ _ _ |- _ ] => inversion He; subst end. + destruct Henv as [_ [_ [_ Hcallvalue]]]. + destruct Hcallvalue as [vcv [Hinr [Hrhov Hval]]]. + match goal with + | [ H : rho "callvalue"%string = Some _ |- _ ] => + assert (VInt vcv = v) by congruence; subst v + end. + destruct n as [|n0]; cbn [denote_ref denote_env_ref]; + rewrite Hval; + [ rewrite (denote_slot_value_n_at_base_0 Σ HwfΣ (VInt vcv) s + (TInt (UintT 256)) (V_Int_t vcv (UintT 256) Hinr) Hvt) + | rewrite (denote_slot_value_n_at_base_S n0 Σ HwfΣ (VInt vcv) s + (TInt (UintT 256)) (V_Int_t vcv (UintT 256) Hinr) Hvt) ]; + simpl; apply sig_eq. + * (* T_This_t *) + inversion Heval; subst. + match goal with [ He : eval_env _ _ _ _ |- _ ] => inversion He; subst end. + destruct n as [|n0]. + { exfalso. simpl in Hn. lia. } + { cbn [denote_ref denote_env_ref]. + destruct Hloc as [Hvt_c [Hn_c Hloc_eq]]. + rewrite Hloc_eq. + apply JMeq_eq. apply JMeq_sym. + apply denote_slot_value_n_coerce. } + - (* expr_sound *) + dependent destruction Ht. + + (* T_Int_t: integer literal *) + inversion Heval; subst. + simpl. rewrite (denote_base_value_VInt _ _ Hvt). + apply sig_eq. + + (* T_Bool_t: boolean literal *) + inversion Heval; subst. + simpl. rewrite (denote_base_value_VBool _ Hvt). + reflexivity. + + (* T_Ref_t *) + inversion Heval; subst. + match goal with + | [ Href : eval_ref (TSUntimed s) rho r _ v ?tp |- _ ] => + pose proof (eval_ref_untimed_RTU _ _ _ _ _ _ Href) as Htpeq; + subst tp + end. + destruct n as [|n']; simpl. + * (* n = 0 *) + pose proof (V_ABIVal_t Σ v s (ABase bt) + (V_BaseValAlpha_t Σ v s bt Hvt)) as Hsty. + assert (Hn : sty_depth Σ (SAbi (ABase bt)) <= 0) by (simpl; lia). + match goal with + | [ Href : eval_ref (TSUntimed s) rho r _ v RTU |- _ ] => + rewrite (ref_sound 0 Σ HwfΣ HnΣ iface k oid r (SAbi (ABase bt)) t0 + s rho l rho_v a Hewt Hlot Henv Hloc v Href Hsty Hn) + end. + unfold denote_slot_value_n. simpl. + replace (sub_add_eq 0 0 Hn) with (@eq_refl nat 0) + by (apply proof_irrelevance). + simpl. apply denote_slot_value_at_base. + * (* n = S n' *) + pose proof (V_ABIVal_t Σ v s (ABase bt) + (V_BaseValAlpha_t Σ v s bt Hvt)) as Hsty. + assert (Hn : sty_depth Σ (SAbi (ABase bt)) <= S n') by (simpl; lia). + match goal with + | [ Href : eval_ref (TSUntimed s) rho r _ v RTU |- _ ] => + rewrite (ref_sound (S n') Σ HwfΣ HnΣ iface k oid r (SAbi (ABase bt)) t0 + s rho l rho_v a Hewt Hlot Henv Hloc v Href Hsty Hn) + end. + unfold denote_slot_value_n. simpl sty_depth. simpl Nat.sub. + transitivity (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty). + { apply JMeq_eq. + exact (JMeq_trans + (eq_rect_JMeq nat (fun m => sem_slot_aux m Σ (SAbi (ABase bt))) + (S n' - 0 + 0) (S n') (sub_add_eq (S n') 0 Hn) + (sem_slot_weaken_add (S n' - 0) 0 Σ (SAbi (ABase bt)) + (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty))) + (sem_slot_weaken_add_base_JMeq_0 (S n' - 0) Σ bt + (denote_slot_value Σ HwfΣ v s (SAbi (ABase bt)) Hsty))). } + { apply denote_slot_value_at_base. } + + (* T_Addr_t *) admit. + + (* T_Range_t *) + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht) Hewt Hlot) as [v' [Hev' Hbt']]. + inversion Heval; subst. + * (* E_RangeTrue *) + match goal with + | [ He : eval_expr _ _ ?ei _ (VInt ?z), Hin : in_range _ ?z |- _ ] => + assert (v' = VInt z) by (eapply expr_determinism; eauto); subst v'; + inversion Hbt' as [z' it2' Hin2 | | ]; subst + end. + simpl. + match goal with + | [ He : eval_expr _ _ ?ei _ (VInt ?z), + Hin : in_range ?it1' ?z, + Hin2 : in_range ?it2' ?z |- _ ] => + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid ei (TInt it2') Ht + s rho l rho_v a Hewt Hlot Henv Hloc _ He (V_Int_t z it2' Hin2)); + rewrite (denote_base_value_VInt _ _ (V_Int_t z it2' Hin2)); + simpl; + rewrite (in_range_check_true _ _ Hin); + rewrite (denote_base_value_VBool _ Hvt); reflexivity + end. + * (* E_RangeFalse *) + match goal with + | [ He : eval_expr _ _ ?ei _ (VInt ?z), Hnin : ~ in_range _ ?z |- _ ] => + assert (v' = VInt z) by (eapply expr_determinism; eauto); subst v'; + inversion Hbt' as [z' it2' Hin2 | | ]; subst + end. + simpl. + match goal with + | [ He : eval_expr _ _ ?ei _ (VInt ?z), + Hnin : ~ in_range ?it1' ?z, + Hin2 : in_range ?it2' ?z |- _ ] => + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid ei (TInt it2') Ht + s rho l rho_v a Hewt Hlot Henv Hloc _ He (V_Int_t z it2' Hin2)); + rewrite (denote_base_value_VInt _ _ (V_Int_t z it2' Hin2)); + simpl; + rewrite (in_range_check_false _ _ Hnin); + rewrite (denote_base_value_VBool _ Hvt); reflexivity + end. + + (* T_BopI_t: e1 op e2 : IntUnbounded *) + (* Type safety for sub-expressions *) + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht1) Hewt Hlot) as [v1 [Hev1 Hbt1']]. + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht2) Hewt Hlot) as [v2 [Hev2 Hbt2']]. + inversion Hbt1' as [| |z1 ? Hin1]; subst. + inversion Hbt2' as [| |z2 ? Hin2]; subst. + (* Relate v to eval_int_binop op z1 z2 *) + pose proof (eval_bopi_result _ _ _ _ _ _ _ _ _ Heval Hev1 Hev2) as ->. + (* Apply IH *) + simpl. + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid _ (TInt it1) Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc (VInt z1) Hev1 (V_Int_t z1 it1 Hin1)). + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid _ (TInt it2) Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc (VInt z2) Hev2 (V_Int_t z2 it2 Hin2)). + rewrite (denote_base_value_VInt _ _ (V_Int_t z1 it1 Hin1)). + rewrite (denote_base_value_VInt _ _ (V_Int_t z2 it2 Hin2)). + simpl. + rewrite (denote_base_value_VInt _ _ Hvt). + apply sig_eq. + + (* T_NumConv_t: e : it → e : IntUnbounded *) + (* Get in_range it for v via type safety *) + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht) Hewt Hlot) as [v' [Hev' Hbt']]. + assert (Heq : v' = v) by (eapply expr_determinism; eauto). subst v'. + inversion Hbt' as [| |z it0 Hin]; subst. + simpl. + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e (TInt it) Ht + s rho l rho_v a Hewt Hlot Henv Hloc (VInt z) Heval + (V_Int_t z it Hin)) as IH. + rewrite IH. + rewrite (denote_base_value_VInt _ _ (V_Int_t z it Hin)). simpl. + rewrite (denote_base_value_VInt _ _ Hvt). + apply sig_eq. + + (* T_BopB_t: e1 op_b e2 *) + inversion Heval; subst. + simpl. + match goal with + | [ He1 : eval_expr _ _ e1 _ (VBool ?b1), + He2 : eval_expr _ _ e2 _ (VBool ?b2) |- _ ] => + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e1 TBool Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc (VBool b1) He1 + (V_Bool_t b1)) as IH1; + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e2 TBool Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc (VBool b2) He2 + (V_Bool_t b2)) as IH2 + end. + simpl in IH1, IH2. + rewrite IH1, IH2. + rewrite (denote_base_value_VBool _ Hvt). + reflexivity. + + (* T_Neg_t: ~e *) + inversion Heval; subst. + simpl. + match goal with + | [ He : eval_expr _ _ e _ (VBool ?b) |- _ ] => + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e TBool Ht + s rho l rho_v a Hewt Hlot Henv Hloc (VBool b) He + (V_Bool_t b)) as IH + end. + simpl in IH. + rewrite IH. + rewrite (denote_base_value_VBool _ Hvt). + reflexivity. + + (* T_Cmp_t: e1 cmp_op e2 : TBool *) + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht1) Hewt Hlot) as [v1' [Hev1' Hbt1']]. + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht2) Hewt Hlot) as [v2' [Hev2' Hbt2']]. + inversion Heval; subst. + simpl. + match goal with + | [ He1 : eval_expr _ _ ?e1' _ (VInt ?z1), + He2 : eval_expr _ _ ?e2' _ (VInt ?z2) |- _ ] => + assert (v1' = VInt z1) by (eapply expr_determinism; eauto); subst v1'; + assert (v2' = VInt z2) by (eapply expr_determinism; eauto); subst v2'; + inversion Hbt1' as [| |z1' it1' Hin1]; subst; + inversion Hbt2' as [| |z2' it2' Hin2]; subst; + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e1' (TInt it) Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc (VInt z1) He1 (V_Int_t z1 it Hin1)); + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e2' (TInt it) Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc (VInt z2) He2 (V_Int_t z2 it Hin2)); + rewrite (denote_base_value_VInt _ _ (V_Int_t z1 it Hin1)); + rewrite (denote_base_value_VInt _ _ (V_Int_t z2 it Hin2)); + simpl; + rewrite (denote_base_value_VBool _ Hvt); + reflexivity + end. + + (* T_ITE_t: if e1 then e2 else e3 *) + inversion Heval; subst. + * (* E_ITETrue *) + simpl. + match goal with + | [ Hc : eval_expr _ _ e1 _ (VBool true), + Hv : eval_expr _ _ e2 _ v |- _ ] => + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e1 TBool Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc (VBool true) Hc + (V_Bool_t true)) as IHc; + simpl in IHc; + rewrite IHc; + exact (expr_sound n Σ HwfΣ HnΣ iface oid e2 bt Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc v Hv Hvt) + end. + * (* E_ITEFalse *) + simpl. + match goal with + | [ Hc : eval_expr _ _ e1 _ (VBool false), + Hv : eval_expr _ _ e3 _ v |- _ ] => + pose proof (expr_sound n Σ HwfΣ HnΣ iface oid e1 TBool Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc (VBool false) Hc + (V_Bool_t false)) as IHc; + simpl in IHc; + rewrite IHc; + exact (expr_sound n Σ HwfΣ HnΣ iface oid e3 bt Ht3 + s rho l rho_v a Hewt Hlot Henv Hloc v Hv Hvt) + end. + + (* T_Eq_t *) + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht1) Hewt Hlot) as [v1' [Hev1' Hbt1']]. + pose proof (expr_typesafety_untimed _ _ _ _ _ _ _ _ + (type_expr_t_to_prop _ _ _ _ _ _ Ht2) Hewt Hlot) as [v2' [Hev2' Hbt2']]. + inversion Heval; subst. + * (* E_EqTrue: v1 = v2 *) + assert (Hv1eq : v1' = v2) by (eapply expr_determinism; [exact Hev1' | eassumption]). + subst v1'. + assert (Hv2eq : v2' = v2) by (eapply expr_determinism; [exact Hev2' | eassumption]). + subst v2'. + destruct (construct_has_base_type_t v2 bt) as [Hbt_t|] eqn:Hc. + { simpl. + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e1 _ Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc v2 Hev1' Hbt_t). + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e2 _ Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc v2 Hev2' Hbt_t). + rewrite sem_base_eqb_refl. + rewrite (denote_base_value_VBool _ Hvt). + reflexivity. } + { exfalso. + destruct (construct_has_base_type_t_complete _ _ Hbt1') as [? Hsome]. + rewrite Hsome in Hc. discriminate. } + * (* E_EqFalse: v1 <> v2 *) + match goal with + | [ He1 : eval_expr _ _ e1 _ ?vv1, + He2 : eval_expr _ _ e2 _ ?vv2 |- _ ] => + assert (v1' = vv1) by (eapply expr_determinism; [exact Hev1' | exact He1]); subst v1'; + assert (v2' = vv2) by (eapply expr_determinism; [exact Hev2' | exact He2]); subst v2' + end. + match goal with + | [ He1 : eval_expr _ _ e1 _ ?vv1 |- _ ] => + destruct (construct_has_base_type_t vv1 bt) as [Hbt1_t|] eqn:Hc1; + [ | exfalso; destruct (construct_has_base_type_t_complete _ _ Hbt1') as [? Hs]; rewrite Hs in Hc1; discriminate ] + end. + match goal with + | [ He2 : eval_expr _ _ e2 _ ?vv2 |- _ ] => + destruct (construct_has_base_type_t vv2 bt) as [Hbt2_t|] eqn:Hc2; + [ | exfalso; destruct (construct_has_base_type_t_complete _ _ Hbt2') as [? Hs]; rewrite Hs in Hc2; discriminate ] + end. + simpl. + match goal with + | [ He1 : eval_expr _ _ e1 _ ?vv1, + He2 : eval_expr _ _ e2 _ ?vv2, + Hneq : ?vv1 <> ?vv2 |- _ ] => + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e1 _ Ht1 + s rho l rho_v a Hewt Hlot Henv Hloc vv1 He1 Hbt1_t); + rewrite (expr_sound n Σ HwfΣ HnΣ iface oid e2 _ Ht2 + s rho l rho_v a Hewt Hlot Henv Hloc vv2 He2 Hbt2_t); + rewrite (denote_base_value_neq _ _ _ Hbt1_t Hbt2_t Hneq) + end. + rewrite (denote_base_value_VBool _ Hvt). + reflexivity. +Admitted. + +(** Mapping Expression Soundness *) +Lemma mapexpr_soundness : + forall n Σ (HwfΣ : wf_Σ Σ) iface oid s rho l + (rho_v : sem_iface_aux n Σ iface) + (a : sem_opt_id_aux n Σ oid) + (Henv : env_sound n Σ HwfΣ rho s iface rho_v) + (Hloc : loc_sound n Σ HwfΣ l s oid a) + m mu + (Ht : type_mapexpr_t Σ iface oid m mu) + v (Heval : eval_mapexpr (TSUntimed s) rho m l v) + (Hvt : has_mapping_type_t v mu), + denote_mapexpr n Σ iface oid m mu Ht rho_v a = + denote_mapping_value v mu Hvt. +Proof. +Admitted. diff --git a/theories/Syntax.v b/theories/Syntax.v new file mode 100644 index 00000000..ec55ed36 --- /dev/null +++ b/theories/Syntax.v @@ -0,0 +1,193 @@ +(** * Syntax + Formalizes Section 1 of the tech report: types, expressions, + references, slot expressions, mapping expressions, and top-level + constructs (contracts, constructors, transitions). *) + +From Stdlib Require Import String ZArith List Bool. +From Act Require Import Maps. +Import ListNotations. + +(* ================================================================= *) +(** ** Types *) + +(** Integer bit-width: M ∈ {8,16,...,256}. + We keep it abstract as a [nat] (the actual value 8*i). *) +Definition bitwidth := nat. + +(** Integer types ι *) +Inductive int_type : Type := + | UintT : bitwidth -> int_type (** uint M *) + | IntT : bitwidth -> int_type (** int M *) + | IntUnbounded : int_type. (** int (unbounded, mathematical) *) + +(** Base types β *) +Inductive base_type : Type := + | TInt : int_type -> base_type + | TBool : base_type + | TAddress : base_type. + +(** Mapping types μ *) +Inductive mapping_type : Type := + | MBase : base_type -> mapping_type + | MMapping : base_type -> mapping_type -> mapping_type. + +(** ABI types α — base types plus typed contract addresses *) +Inductive abi_type : Type := + | ABase : base_type -> abi_type + | AContractAddr : ident -> abi_type. (** address_Id *) + +(** Slot types σ — the type of storage slots *) +Inductive slot_type : Type := + | SMapping : mapping_type -> slot_type + | SAbi : abi_type -> slot_type + | SContract : ident -> slot_type. + +(** Optional slot type (⊥ or σ), used when Id may be absent *) +Inductive opt_id : Type := + | ONone : opt_id (** ⊥ *) + | OSome : ident -> opt_id. (** Id *) + +(* ================================================================= *) +(** ** Binary Operators *) + +Inductive int_binop : Type := + | OpAdd | OpSub | OpMul | OpDiv | OpMod | OpExp. + +Inductive bool_binop : Type := + | OpAnd | OpOr | OpImpl. + +Inductive cmp_op : Type := + | CmpLt | CmpLe | CmpGe | CmpGt. + +(* ================================================================= *) +(** ** Environment Variables *) + +Inductive env_var : Type := + | EnvCaller | EnvOrigin | EnvCallvalue | EnvThis. + +(* ================================================================= *) +(** ** Variable References *) + +Inductive ref : Type := + | RVar : ident -> ref (** x *) + | RPre : ident -> ref (** pre(x) *) + | RPost : ident -> ref (** post(x) *) + | RCoerce : ref -> ident -> ref (** ref as Id *) + | RField : ref -> ident -> ref (** ref.y *) + | RIndex : ref -> expr -> ref (** ref[e] *) + | REnv : env_var -> ref (** env *) + +(* ================================================================= *) +(** ** Base Expressions *) + +with expr : Type := + | EInt : Z -> expr (** integer literal *) + | EBool : bool -> expr (** boolean literal *) + | ERef : ref -> expr (** ref (with type annotation erased) *) + | EAddr : ref -> expr (** addr(ref) *) + | EBopI : expr -> int_binop -> expr -> expr (** e ○_i e *) + | EBopB : expr -> bool_binop -> expr -> expr (** e ○_b e *) + | ECmp : expr -> cmp_op -> expr -> expr (** e ⋈ e *) + | ENeg : expr -> expr (** ¬ e *) + | EInRange : int_type -> expr -> expr (** inrange(ι, e) *) + | EITE : expr -> expr -> expr -> expr (** if e then e else e *) + | EEq : expr -> expr -> expr. (** e = e *) + +(* ================================================================= *) +(** ** Mapping Expressions *) + +Inductive map_expr : Type := + | MExp : expr -> map_expr (** e *) + | MMap : list (expr * map_expr) -> mapping_type -> map_expr + (** [e₁ => m₁, ...]_{mapping(β,μ)} *) + | MMapUpd : ref -> list (expr * map_expr) -> mapping_type -> map_expr. + (** ref [e₁ => m₁, ...]_{mapping(β,μ)} *) + +(* ================================================================= *) +(** ** Slot Expressions *) + +Inductive slot_expr : Type := + | SEMap : map_expr -> slot_expr (** m *) + | SENew : ident -> option slot_expr -> list slot_expr -> slot_expr + (** new Id {value: se}?(se₁,...,seₙ) *) + | SERef : ref -> slot_expr (** ref *) + | SEAddr : slot_expr -> slot_expr. (** addr(se) *) + +(* ================================================================= *) +(** ** Creates, Updates *) + +(** A single create: σ x := se *) +Definition create := (slot_type * ident * slot_expr)%type. + +(** A single update: ref := se *) +Definition update := (ref * slot_expr)%type. + +(* ================================================================= *) +(** ** Constructor and Transition Cases *) + +(** Constructor case: case e: creates [...] *) +Definition ctor_case := (expr * list create)%type. + +(** Transition case: case e: updates [...] returns e *) +Definition trans_case := (expr * list update * expr)%type. + +(* ================================================================= *) +(** ** Constructors and Transitions *) + +(** Interface: list of (variable name, abi type) pairs *) +Definition interface := list (ident * abi_type). + +(** Constructor *) +Record constructor := mk_ctor { + ctor_iface : interface; + ctor_payable : bool; + ctor_iff : list expr; (** preconditions *) + ctor_cases : list ctor_case; (** case blocks *) + ctor_post : list expr; (** postconditions *) +}. + +(** Transition *) +Record transition := mk_trans { + trans_name : ident; + trans_iface : interface; + trans_payable : bool; + trans_rettype : option abi_type; + trans_iff : list expr; (** preconditions *) + trans_cases : list trans_case; (** case blocks *) + trans_post : list expr; (** postconditions *) +}. + +(** Invariants *) +Definition invariants := list expr. + +(** Contract *) +Record contract := mk_contract { + contract_name : ident; + contract_ctor : constructor; + contract_trans : list transition; + contract_inv : invariants; +}. + +(** Specification: a list of contracts *) +Definition spec := list contract. + +(* ================================================================= *) +(** ** Contract Storage *) + +(** Contract storage type C: maps variable names to slot types *) +Definition storage_layout := list (ident * slot_type). + +(* ================================================================= *) +(** ** More-specific relation on references (Section 5) *) + +(** ref₁ ≺_specific ref₂ *) +Inductive more_specific : ref -> ref -> Prop := + | MS_field : forall r x, + more_specific (RField r x) r + | MS_trans : forall r1 r2 x, + more_specific r1 r2 -> + more_specific (RField r1 x) r2. + +(** ref₁ ⪯_specific ref₂ (reflexive closure) *) +Definition more_specific_eq (r1 r2 : ref) : Prop := + r1 = r2 \/ more_specific r1 r2. diff --git a/theories/TypeSafety.v b/theories/TypeSafety.v new file mode 100644 index 00000000..92dbd712 --- /dev/null +++ b/theories/TypeSafety.v @@ -0,0 +1,2074 @@ +(** * Type Safety + Formalizes Section 6 of the tech report: type safety lemmas + for all syntactic categories. *) + +From Stdlib Require Import String ZArith List Bool Classical_Prop Lia. +From Act Require Import Maps Syntax Domains Semantics ValueTyping Typing. +Import ListNotations. + +Tactic Notation "inv" hyp(H) := inversion H; subst; clear H. + +(** Rewrite contract_env accessors through Σ_with_* wrappers *) +Ltac Σ_rw := + repeat first + [ rewrite Σ_storage_with_storage + | rewrite Σ_cnstr_with_storage + | rewrite Σ_trans_with_storage + | rewrite Σ_storage_with_cnstr + | rewrite Σ_cnstr_with_cnstr + | rewrite Σ_trans_with_cnstr + | rewrite Σ_storage_with_trans + | rewrite Σ_cnstr_with_trans + | rewrite Σ_trans_with_trans ]. + +Ltac Σ_rw_in H := + repeat first + [ rewrite Σ_storage_with_storage in H + | rewrite Σ_cnstr_with_storage in H + | rewrite Σ_trans_with_storage in H + | rewrite Σ_storage_with_cnstr in H + | rewrite Σ_cnstr_with_cnstr in H + | rewrite Σ_trans_with_cnstr in H + | rewrite Σ_storage_with_trans in H + | rewrite Σ_cnstr_with_trans in H + | rewrite Σ_trans_with_trans in H ]. + +Lemma int_binop_dec : forall (op1 op2 : int_binop), {op1 = op2} + {op1 <> op2}. +Proof. decide equality. Defined. + +(** slot_type_wf / abi_type_wf are covariant in Σ *) +Lemma abi_type_wf_incl : forall Σ Σ' alpha, + Σ_incl Σ Σ' -> abi_type_wf Σ alpha -> abi_type_wf Σ' alpha. +Proof. + intros Σ Σ' alpha [Hst _] Hwf. destruct Hwf; constructor; auto. + destruct H as [v Hv]. exists v. exact (Hst _ _ Hv). +Qed. + +Lemma slot_type_wf_incl : forall Σ Σ' st, + Σ_incl Σ Σ' -> slot_type_wf Σ st -> slot_type_wf Σ' st. +Proof. + intros Σ Σ' st Hincl Hwf. destruct Hwf; constructor. + - destruct H as [v Hv]. exists v. exact (proj1 Hincl _ _ Hv). + - eapply abi_type_wf_incl; eauto. +Qed. + +(* ================================================================= *) +(** ** Extending Σ Preserves Well-Typedness (Lemma 6.2 of tech report §6) *) + +(** Helper: Σ_incl from Σ to Σ'' produced by type_contract *) +Lemma type_contract_Σ_incl : forall Σ c Σ', + type_contract Σ c Σ' -> Σ_incl Σ Σ'. +Proof. + intros Σ c Σ' Htc. inv Htc. + eapply Σ_incl_trans. eapply Σ_incl_trans. + - eapply Σ_incl_with_storage_fresh; eauto. + - eapply Σ_incl_with_cnstr_fresh. Σ_rw. exact H0. + - eapply Σ_incl_with_trans_fresh. Σ_rw. exact H1. +Qed. + +(** Helper: well-typedness of intermediate contract_env *) +Lemma Σ_well_typed_intermediate : + forall Σ a layout ctor, + Σ_well_typed Σ -> + ~ dom (Σ_storage Σ) a -> + ~ dom (Σ_cnstr Σ) a -> + type_constructor Σ a ctor layout -> + Σ_well_typed (Σ_with_cnstr (Σ_with_storage Σ a layout) a ctor). +Proof. + intros Σ a layout ctor Hwt Hfs Hfc Htctor. + assert (Hincl_ext : Σ_incl Σ (Σ_with_cnstr (Σ_with_storage Σ a layout) a ctor)). + { eapply Σ_incl_trans. + eapply Σ_incl_with_storage_fresh; eauto. + eapply Σ_incl_with_cnstr_fresh. Σ_rw. exact Hfc. } + constructor. + - (* S0: storage well-formedness *) + intros a' layout' Hsto'. Σ_rw_in Hsto'. + destruct (String.eqb_spec a a'). + + subst. rewrite update_eq in Hsto'. injection Hsto' as Heql. + subst layout'. + assert (Hlwf : Forall (fun p => slot_type_wf Σ (snd p)) layout) + by (inv Htctor; assumption). + eapply Forall_impl; [|exact Hlwf]. + intros p Hp. eapply slot_type_wf_incl; eauto. + + rewrite update_neq in Hsto' by auto. + inv Hwt. + match goal with Hswf : forall a l, Σ_storage _ a = Some l -> _ |- _ => + eapply Forall_impl; [|exact (Hswf _ _ Hsto')] + end. + intros p Hp. eapply slot_type_wf_incl; eauto. + - (* S1: constructors *) + intros a' ctor' Hctor'. Σ_rw_in Hctor'. + destruct (String.eqb_spec a a'). + + subst. rewrite update_eq in Hctor'. injection Hctor' as ->. + exists Σ, layout. split; [|split; [|split; [|split; [|split]]]]. + * exact Hincl_ext. + * unfold dom in Hfc. destruct (Σ_cnstr Σ a') eqn:E; [exfalso; apply Hfc; eauto|reflexivity]. + * rewrite Σ_cnstr_size_with_cnstr, Σ_cnstr_size_with_storage. lia. + * exact Hwt. + * exact Htctor. + * Σ_rw. apply update_eq. + + rewrite update_neq in Hctor' by auto. + inv Hwt. + match goal with Hcond : forall a c, Σ_cnstr _ a = Some c -> _ |- _ => + destruct (Hcond a' ctor' Hctor') as [Σ'' [layout' [Hincl [Hnone [Hlt [Hwt' [Htc' Hsto']]]]]]] + end. + exists Σ'', layout'. split; [|split; [|split; [|split; [|split]]]]. + * eapply Σ_incl_trans; [exact Hincl|]. exact Hincl_ext. + * exact Hnone. + * rewrite Σ_cnstr_size_with_cnstr, Σ_cnstr_size_with_storage. lia. + * exact Hwt'. + * exact Htc'. + * Σ_rw. rewrite update_neq by auto. exact Hsto'. + - (* S2: transitions *) + intros a' transs' Htrans'. Σ_rw_in Htrans'. + inv Hwt. + match goal with Hcond : forall a t, Σ_trans _ a = Some t -> _ |- _ => + destruct (Hcond a' transs' Htrans') as [Σ'' [Hincl [Hwt' Htyped]]] + end. + exists Σ''. split; [|split]. + + eapply Σ_incl_trans; [exact Hincl|]. exact Hincl_ext. + + exact Hwt'. + + exact Htyped. +Qed. + +Lemma extending_Σ_well_typed : + forall Σ c Σ', + Σ_well_typed Σ -> + type_contract Σ c Σ' -> + Σ_well_typed Σ'. +Proof. + intros sg1 c1 sg1' Hwt Htc. + pose proof Htc as Htc0. + pose proof (type_contract_Σ_incl _ _ _ Htc0) as Hincl_ext. + inversion Htc; subst. subst Σ'' Σ' Σ'0. + constructor. + - (* S0: storage well-formedness *) + intros a' layout' Hsto'. + rewrite Σ_storage_with_trans, Σ_storage_with_cnstr, Σ_storage_with_storage in Hsto'. + destruct (String.eqb_spec a0 a'). + + subst. rewrite update_eq in Hsto'. injection Hsto' as Heql. subst layout'. + assert (Hlwf : Forall (fun p => slot_type_wf sg1 (snd p)) layout) + by (inv H2; assumption). + eapply Forall_impl; [|exact Hlwf]. + intros p Hp. eapply slot_type_wf_incl; eauto. + + rewrite update_neq in Hsto' by auto. + inv Hwt. + match goal with Hswf : forall a l, Σ_storage _ a = Some l -> _ |- _ => + eapply Forall_impl; [|exact (Hswf _ _ Hsto')] + end. + intros p Hp. eapply slot_type_wf_incl; eauto. + - (* S1: constructors *) + intros a' ctor' Hctor'. + rewrite Σ_cnstr_with_trans, Σ_cnstr_with_cnstr, Σ_cnstr_with_storage in Hctor'. + destruct (String.eqb_spec a0 a'). + + subst. rewrite update_eq in Hctor'. injection Hctor' as <-. + exists sg1, layout. split; [|split; [|split; [|split; [|split]]]]. + * exact Hincl_ext. + * unfold dom in H0. destruct (Σ_cnstr sg1 a0) eqn:E; [exfalso; apply H0; eauto|reflexivity]. + * rewrite Σ_cnstr_size_with_trans, Σ_cnstr_size_with_cnstr, Σ_cnstr_size_with_storage. lia. + * exact Hwt. + * exact H2. + * rewrite Σ_storage_with_trans, Σ_storage_with_cnstr, Σ_storage_with_storage. + apply update_eq. + + rewrite update_neq in Hctor' by auto. + inv Hwt. + match goal with + | [Hcond : forall a c, Σ_cnstr sg1 a = Some c -> _ |- _] => + destruct (Hcond _ _ Hctor') as [sg2 [layout' [Hincl [Hnone [Hlt [Hwt' [Htc' Hsto']]]]]]] + end. + exists sg2, layout'. split; [|split; [|split; [|split; [|split]]]]. + * eapply Σ_incl_trans; [exact Hincl|]. exact Hincl_ext. + * exact Hnone. + * eapply Nat.lt_trans; [exact Hlt|]. + rewrite Σ_cnstr_size_with_trans, Σ_cnstr_size_with_cnstr, Σ_cnstr_size_with_storage. lia. + * exact Hwt'. + * exact Htc'. + * rewrite Σ_storage_with_trans, Σ_storage_with_cnstr, Σ_storage_with_storage. + rewrite update_neq by auto. exact Hsto'. + - (* S2: transitions *) + intros a' transs' Htrans'. + rewrite Σ_trans_with_trans in Htrans'. + destruct (String.eqb_spec a0 a'). + + subst. rewrite update_eq in Htrans'. injection Htrans' as <-. + eexists. split; [|split]. + * eapply Σ_incl_with_trans_fresh. + rewrite Σ_trans_with_cnstr, Σ_trans_with_storage. exact H1. + * eapply Σ_well_typed_intermediate; eauto. + * exact H3. + + rewrite update_neq in Htrans' by auto. + rewrite Σ_trans_with_cnstr, Σ_trans_with_storage in Htrans'. + inv Hwt. + match goal with + | [Hcond : forall a t, Σ_trans sg1 a = Some t -> _ |- _] => + destruct (Hcond _ _ Htrans') as [sg2 [Hincl [Hwt' Htyped]]] + end. + exists sg2. split; [|split]. + * eapply Σ_incl_trans; [exact Hincl|]. + eapply type_contract_Σ_incl. exact Htc0. + * exact Hwt'. + * exact Htyped. +Qed. + +(* ================================================================= *) +(** ** Well-typed State is Well-founded (Theorem 7.1 of tech report §7) *) + +Theorem wf_state : + forall Σ c Σ', + type_contract Σ c Σ' -> + Σ_wf Σ -> + Σ_storage_wf Σ -> + Σ_wf Σ'. +Proof. + intros sg1 c1 sg1' Htc Hwf Hswf. + inversion Htc; subst. subst Σ'' Σ' Σ'0. + assert (Hdep_equiv : forall b d, d <> a0 -> + (contract_dep (Σ_with_trans (Σ_with_cnstr (Σ_with_storage sg1 a0 layout) + a0 (contract_ctor c1)) a0 (contract_trans c1)) b d <-> contract_dep sg1 b d)). + { intros b d Hne. unfold contract_dep. + split; intros [x Hx]; exists x; unfold Σ_storage_var in *; + rewrite Σ_storage_with_trans, Σ_storage_with_cnstr, Σ_storage_with_storage in *; + rewrite update_neq in * by auto; exact Hx. } + assert (Hno_dep_a0 : forall z, ~ contract_dep sg1 z a0). + { intros z [x Hx]. apply H. unfold Σ_storage_var in Hx. + destruct (Σ_storage sg1 a0) eqn:E; [exists s; exact E|]. + destruct Hx; discriminate. } + set (Σ_final := Σ_with_trans (Σ_with_cnstr (Σ_with_storage sg1 a0 layout) + a0 (contract_ctor c1)) a0 (contract_trans c1)) in *. + assert (Htransfer : forall z, Acc (contract_dep sg1) z -> z <> a0 -> + Acc (contract_dep Σ_final) z). + { intros z Hacc. induction Hacc as [z _ IH]. intro Hne. + constructor. intros w Hw. + apply Hdep_equiv in Hw; [|exact Hne]. + destruct (String.eqb_spec w a0). + - subst. exfalso. apply H. apply Hswf with z. exact Hw. + - apply IH; auto. } + assert (Hlayout_wf : Forall (fun p => slot_type_wf sg1 (snd p)) layout). + { inversion H2; auto. } + assert (Hlayout_dep_dom : forall w x, + (alist_lookup layout x = Some (SContract w) \/ + alist_lookup layout x = Some (SAbi (AContractAddr w))) -> + dom (Σ_storage sg1) w). + { intros w x [Hx|Hx]; + destruct (alist_lookup_In _ _ _ _ Hx) as [[pn ps] [Hin Hst]]; simpl in Hst; subst; + pose proof (proj1 (Forall_forall _ _) Hlayout_wf _ Hin) as Hwf0; simpl in Hwf0; + inversion Hwf0; subst; auto; + match goal with + | [Ha : abi_type_wf _ (AContractAddr _) |- _] => inversion Ha; subst; auto + end. } + assert (Hdep_a0_dom : forall w, + contract_dep Σ_final w a0 -> dom (Σ_storage sg1) w). + { intros w [x Hx]. unfold Σ_storage_var in Hx. unfold Σ_final in Hx. + rewrite Σ_storage_with_trans, Σ_storage_with_cnstr, Σ_storage_with_storage in Hx. + rewrite update_eq in Hx. eapply Hlayout_dep_dom. exact Hx. } + intro y. + destruct (String.eqb_spec y a0). + - subst. constructor. intros w Hw. + assert (Hne : w <> a0). + { intro Heq. subst. exact (H (Hdep_a0_dom _ Hw)). } + apply Htransfer; auto. apply Hwf. + - apply Htransfer; auto. apply Hwf. +Qed. + +(* ================================================================= *) +(** ** Σ_storage_wf is preserved by type_contract *) + +Lemma type_contract_preserves_storage_wf : + forall Σ c Σ', + type_contract Σ c Σ' -> + Σ_storage_wf Σ -> + Σ_storage_wf Σ'. +Proof. + intros sg1 c1 sg1' Htc Hswf. + inversion Htc; subst. subst Σ'' Σ' Σ'0. + intros d b Hdep. + destruct Hdep as [x Hx]. + unfold Σ_storage_var in Hx. + rewrite Σ_storage_with_trans in Hx. + rewrite Σ_storage_with_cnstr in Hx. + rewrite Σ_storage_with_storage in Hx. + assert (Hlayout_wf : Forall (fun p => slot_type_wf sg1 (snd p)) layout). + { match goal with + | [Htctor : type_constructor _ _ _ _ |- _] => inversion Htctor; auto + end. } + destruct (String.eqb_spec (contract_name c1) d). + - subst. rewrite update_eq in Hx. + assert (Hdom : dom (Σ_storage sg1) b). + { destruct Hx as [Hx|Hx]; + destruct (alist_lookup_In _ _ _ _ Hx) as [[pn ps] [Hin Hst]]; simpl in Hst; subst; + pose proof (proj1 (Forall_forall _ _) Hlayout_wf _ Hin) as Hwf0; simpl in Hwf0; + inversion Hwf0; subst; auto; + match goal with + | [Ha : abi_type_wf _ (AContractAddr _) |- _] => inversion Ha; subst; auto + end. } + destruct Hdom as [v Hv]. + unfold dom. exists v. + rewrite Σ_storage_with_trans. + rewrite Σ_storage_with_cnstr. + rewrite Σ_storage_with_storage. + destruct (String.eqb_spec (contract_name c1) b). + + subst. exfalso. + match goal with + | [Hfresh : ~ dom (Σ_storage sg1) _ |- _] => apply Hfresh; exists v; exact Hv + end. + + rewrite update_neq by auto. exact Hv. + - rewrite update_neq in Hx by auto. + assert (Hdom : dom (Σ_storage sg1) b). + { apply Hswf with d. exists x. + unfold Σ_storage_var. destruct (Σ_storage sg1 d) eqn:E. + + exact Hx. + + destruct Hx as [Hx'|Hx']; discriminate. } + destruct Hdom as [v Hv]. + unfold dom. exists v. + rewrite Σ_storage_with_trans. + rewrite Σ_storage_with_cnstr. + rewrite Σ_storage_with_storage. + destruct (String.eqb_spec (contract_name c1) b). + + subst. exfalso. + match goal with + | [Hfresh : ~ dom (Σ_storage sg1) _ |- _] => apply Hfresh; exists v; exact Hv + end. + + rewrite update_neq by auto. exact Hv. +Qed. + +Lemma type_spec_storage_wf : + forall sp Σ, + type_spec sp Σ -> + Σ_storage_wf Σ. +Proof. + intros sp Σ Hts. induction Hts. + - intros d b [x Hx]. unfold Σ_storage_var in Hx. + unfold Σ_storage, Σ_empty in Hx; simpl in Hx. + destruct Hx as [Hx|Hx]; discriminate. + - eapply type_contract_preserves_storage_wf; eauto. +Qed. + +(* ================================================================= *) +(** ** Environment References Type Safety (Lemma 6.1) *) + +Lemma ethenv_typesafety : + forall Σ iface oid ev alpha s rho l, + type_env_ref Σ iface oid ev alpha -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v, eval_env rho ev l v /\ has_abi_type Σ v s alpha. +Proof. + intros Σ iface oid ev alpha s rho l Htyp Henv Hloc. + destruct Henv as (Hdom & Hvars & [vc [Hvc Htvc]] & [vo [Hvo Htvo]] & [vcv [Hcv Htcv]]). + inv Htyp. + - exists vc. split; [constructor; auto | constructor; auto]. + - exists vo. split; [constructor; auto | constructor; auto]. + - exists vcv. split; [constructor; auto | constructor; auto]. + - exists (VAddr l). split; [constructor |]. + simpl in Hloc. inv Hloc. + match goal with [H : has_abi_type _ _ _ _ |- _] => exact H end. +Qed. + +Lemma env_rho_none : forall Σ rho s iface x, + env_well_typed Σ rho s iface -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + rho x = None. +Proof. + intros Σ rho s iface x [Hdom _] Hni Hc Ho Hcv. + destruct (rho x) eqn:E; [|reflexivity]. exfalso. + destruct (proj1 (Hdom x) (ex_intro _ v E)) as [?|[?|[?|?]]]; contradiction. +Qed. + +(* ================================================================= *) +(** ** References & Expression Type Safety (Untimed) (Lemmas 6.2/6.3) *) + +Lemma ref_expr_typesafety_untimed : + (forall Σ iface k oid t r sty, + type_ref Σ iface k oid t r sty -> t = TagU -> + forall s rho l, env_well_typed Σ rho s iface -> loc_has_opt_type Σ l s oid -> + exists v, eval_ref (TSUntimed s) rho r l v RTU /\ has_slot_type Σ v s sty) /\ + (forall Σ iface oid t e bt, + type_expr Σ iface oid t e bt -> t = TagU -> + forall s rho l, env_well_typed Σ rho s iface -> loc_has_opt_type Σ l s oid -> + exists v, eval_expr (TSUntimed s) rho e l v /\ has_base_type v bt). +Proof. + apply type_ref_expr_mutind. + { (* T_Calldata *) + intros Σ iface oid t x alpha Hlk _ s rho l Henv Hloc. + destruct Henv as (_ & Hvars & _). + destruct (Hvars _ _ Hlk) as [v [Hv Htv]]. + exists v. split; [apply E_Calldata; exact Hv | constructor; exact Htv]. } + { (* T_Storage *) + intros Σ iface a x sty layout Hsto Hlk Hni Hnc Hno Hncv _ s rho l Henv Hloc. + assert (Hrho : rho x = None) by (eapply env_rho_none; eauto). + simpl in Hloc. inv Hloc. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + assert (Hssv : Σ_storage_var Σ a x = Some sty) + by (unfold Σ_storage_var; rewrite Hsto; exact Hlk). + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [w Hw]; + exists w; split; [apply E_Storage; auto |]; + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hw in Hvars; exact Hvars + end. } + { intros; discriminate. } + { intros; discriminate. } + { (* T_Coerce *) + intros Σ iface k oid t r a _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. + exists v. split; [apply E_Coerce; exact Hev |]. + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + constructor. econstructor; eauto. } + { (* T_Upcast *) + intros Σ iface k oid t r a _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. + exists v. split; [exact Hev |]. + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + do 3 constructor. } + { (* T_Field *) + intros Σ iface k oid t r a x sty _ IH Hssv HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [fv Hfv]; + exists fv; split; [eapply E_Field; eauto |]; + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hfv in Hvars; exact Hvars + end. } + { (* T_MapIndex *) + intros Σ iface k oid t r e bt mu _ IHr _ IHe HeqU s rho l Henv Hloc. subst. + destruct (IHr eq_refl s rho l Henv Hloc) as [vr [Hevr Htvr]]. + destruct (IHe eq_refl s rho l Henv Hloc) as [ve [Heve Htve]]. + inv Htvr. match goal with [Hm : has_mapping_type _ _ |- _] => inv Hm end. + - inv Htve. exists (f n). split; + [eapply E_RefMapping; eauto; reflexivity |]. + constructor. match goal with [H : forall _, _ -> has_mapping_type _ _ |- _] => + apply H; constructor; auto end. + - inv Htve. exists (f b). split; + [eapply E_RefMapping; eauto; reflexivity |]. + constructor. match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. + - inv Htve. exists (f a). split; + [eapply E_RefMapping; eauto; reflexivity |]. + constructor. match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. } + { (* T_Environment *) + intros Σ iface oid ev alpha Htyp HeqU s rho l Henv Hloc. subst. + destruct (ethenv_typesafety _ _ _ _ _ _ _ _ Htyp Henv Hloc) as [v [Hev Htv]]. + exists v. split; [apply E_Environment; exact Hev | constructor; exact Htv]. } + { (* T_Int *) + intros Σ iface oid t n it Hin _ s rho l Henv Hloc. + exists (VInt n). split; [constructor | constructor; auto]. } + { (* T_Bool *) + intros Σ iface oid t b _ s rho l Henv Hloc. + exists (VBool b). split; [constructor | constructor]. } + { (* T_Ref *) + intros Σ iface oid t k r bt _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + eexists. split; [eapply E_Ref; eauto | auto]. } + { (* T_Addr *) + intros Σ iface oid k r a _ IH _ s rho l Henv Hloc. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + eexists. split; [eapply E_Addr; eauto | constructor]. } + { (* T_Range *) + intros Σ iface oid t e it1 it2 _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. inv Htv. + destruct (classic (in_range it1 n)). + - exists (VBool true). split; [eapply E_RangeTrue; eauto | constructor]. + - exists (VBool false). split; [eapply E_RangeFalse; eauto | constructor]. } + { (* T_BopI *) + intros Σ iface oid t e1 op e2 it1 it2 _ IH1 _ IH2 HeqU s rho l Henv Hloc. subst. + destruct (IH1 eq_refl s rho l Henv Hloc) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s rho l Henv Hloc) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + destruct (int_binop_dec op OpDiv) as [->|Hnd]. + - destruct (Z.eq_dec n0 0) as [->|Hnz]. + + exists (VInt 0). split; [eapply E_DivZero; eauto | constructor; simpl; auto]. + + exists (VInt (Z.div n n0)). split; [eapply E_Div; eauto | constructor; simpl; auto]. + - destruct (int_binop_dec op OpMod) as [->|Hnm]. + + destruct (Z.eq_dec n0 0) as [->|Hnz]. + * exists (VInt 0). split; [eapply E_ModZero; eauto | constructor; simpl; auto]. + * exists (VInt (Z.modulo n n0)). split; [eapply E_Mod; eauto | constructor; simpl; auto]. + + exists (VInt (eval_int_binop op n n0)). split; + [eapply E_BopI; eauto | constructor; simpl; auto]. } + { (* T_NumConv *) + intros Σ iface oid t e it _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. inv Htv. + exists (VInt n). split; [exact Hev | constructor; simpl; auto]. } + { (* T_BopB *) + intros Σ iface oid t e1 op e2 _ IH1 _ IH2 HeqU s rho l Henv Hloc. subst. + destruct (IH1 eq_refl s rho l Henv Hloc) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s rho l Henv Hloc) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + exists (VBool (eval_bool_binop op b b0)). split; + [eapply E_BopB; eauto | constructor]. } + { (* T_Neg *) + intros Σ iface oid t e _ IH HeqU s rho l Henv Hloc. subst. + destruct (IH eq_refl s rho l Henv Hloc) as [v [Hev Htv]]. inv Htv. + exists (VBool (negb b)). split; [eapply E_Neg; eauto | constructor]. } + { (* T_Cmp *) + intros Σ iface oid t e1 op e2 it _ IH1 _ IH2 HeqU s rho l Henv Hloc. subst. + destruct (IH1 eq_refl s rho l Henv Hloc) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s rho l Henv Hloc) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + exists (VBool (eval_cmp op n n0)). split; + [eapply E_Cmp; eauto | constructor]. } + { (* T_ITE *) + intros Σ iface oid t e1 e2 e3 bt _ IH1 _ IH2 _ IH3 HeqU s rho l Henv Hloc. subst. + destruct (IH1 eq_refl s rho l Henv Hloc) as [vc [Hevc Htvc]]. inv Htvc. + destruct b. + - destruct (IH2 eq_refl s rho l Henv Hloc) as [v2 [Hev2 Htv2]]. + exists v2. split; [eapply E_ITETrue; eauto | exact Htv2]. + - destruct (IH3 eq_refl s rho l Henv Hloc) as [v3 [Hev3 Htv3]]. + exists v3. split; [eapply E_ITEFalse; eauto | exact Htv3]. } + { (* T_Eq *) + intros Σ iface oid t e1 e2 bt _ IH1 _ IH2 HeqU s rho l Henv Hloc. subst. + destruct (IH1 eq_refl s rho l Henv Hloc) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s rho l Henv Hloc) as [v2 [Hev2 Htv2]]. + destruct (classic (v1 = v2)) as [->|Hne]. + - exists (VBool true). split; [eapply E_EqTrue; eauto | constructor]. + - exists (VBool false). split; [eapply E_EqFalse; eauto | constructor]. } +Qed. + +Lemma ref_typesafety_untimed : + forall Σ iface oid k r sty s rho l, + type_ref Σ iface k oid TagU r sty -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v, + eval_ref (TSUntimed s) rho r l v RTU /\ + has_slot_type Σ v s sty. +Proof. + intros. exact (proj1 ref_expr_typesafety_untimed _ _ _ _ _ _ _ H eq_refl _ _ _ H0 H1). +Qed. + +Lemma expr_typesafety_untimed : + forall Σ iface oid e bt s rho l, + type_expr Σ iface oid TagU e bt -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v, + eval_expr (TSUntimed s) rho e l v /\ + has_base_type v bt. +Proof. + intros. exact (proj2 ref_expr_typesafety_untimed _ _ _ _ _ _ H eq_refl _ _ _ H0 H1). +Qed. + +(* ================================================================= *) +(** ** References & Expression Type Safety (Timed) (Lemmas 6.4/6.5) *) + +Lemma ref_expr_typesafety_timed : + (forall Σ iface k oid t r sty, + type_ref Σ iface k oid t r sty -> t = TagT -> + forall s_pre s_post rho l, + env_well_typed Σ rho s_pre iface -> env_well_typed Σ rho s_post iface -> + loc_has_opt_type Σ l s_pre oid -> loc_has_opt_type Σ l s_post oid -> + exists v tp, + eval_ref (TSTimed s_pre s_post) rho r l v tp /\ + (tp = RTPre \/ tp = RTPost) /\ + (tp = RTPre -> has_slot_type Σ v s_pre sty) /\ + (tp = RTPost -> has_slot_type Σ v s_post sty)) /\ + (forall Σ iface oid t e bt, + type_expr Σ iface oid t e bt -> t = TagT -> + forall s_pre s_post rho l, + env_well_typed Σ rho s_pre iface -> env_well_typed Σ rho s_post iface -> + loc_has_opt_type Σ l s_pre oid -> loc_has_opt_type Σ l s_post oid -> + exists v, + eval_expr (TSTimed s_pre s_post) rho e l v /\ + has_base_type v bt). +Proof. + apply type_ref_expr_mutind. + { (* T_Calldata *) + intros Σ iface oid t x alpha Hlk _ s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. + destruct Henv_pre as (_ & Hvars & _). + destruct (Hvars _ _ Hlk) as [v [Hv Htv]]. + exists v, RTPre. split; [apply E_CalldataTimed; exact Hv |]. + split; [left; reflexivity |]. + split. + { intros _. constructor. exact Htv. } + { intros; discriminate. } } + { (* T_Storage *) intros; discriminate. } + { (* T_StoragePre *) + intros Σ iface a x sty layout Hsto Hlk Hni Hnc Hno Hncv _ s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. + assert (Hrho : rho x = None) by (eapply env_rho_none; eauto). + simpl in Hloc_pre. inv Hloc_pre. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + assert (Hssv : Σ_storage_var Σ a x = Some sty) + by (unfold Σ_storage_var; rewrite Hsto; exact Hlk). + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [w Hw]; + exists w, RTPre; split; [apply E_StoragePre; auto |]; + split; [left; reflexivity |]; + split + end. + { intros _. match goal with + | [Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hw in Hvars; exact Hvars end. } + { intros; discriminate. } } + { (* T_StoragePost *) + intros Σ iface a x sty layout Hsto Hlk Hni Hnc Hno Hncv _ s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. + assert (Hrho : rho x = None) by (eapply env_rho_none; eauto). + simpl in Hloc_post. inv Hloc_post. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + assert (Hssv : Σ_storage_var Σ a x = Some sty) + by (unfold Σ_storage_var; rewrite Hsto; exact Hlk). + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [w Hw]; + exists w, RTPost; split; [apply E_StoragePost; auto |]; + split; [right; reflexivity |]; + split + end. + { intros; discriminate. } + { intros _. match goal with + | [Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hw in Hvars; exact Hvars end. } } + { (* T_Coerce *) + intros Σ iface k oid t r a _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [tp [Hev [Hor [Hpre Hpost]]]]]. + exists v, tp. split; [apply E_Coerce; exact Hev |]. + split; [exact Hor |]. + split; intro Heq. + { specialize (Hpre Heq). inv Hpre. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + constructor. econstructor; eauto. } + { specialize (Hpost Heq). inv Hpost. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + constructor. econstructor; eauto. } } + { (* T_Upcast *) + intros Σ iface k oid t r a _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [tp [Hev [Hor [Hpre Hpost]]]]]. + exists v, tp. split; [exact Hev |]. + split; [exact Hor |]. + split; intro Heq. + { specialize (Hpre Heq). inv Hpre. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + do 3 constructor. } + { specialize (Hpost Heq). inv Hpost. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + do 3 constructor. } } + { (* T_Field *) + intros Σ iface k oid t r a x sty _ IH Hssv HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [tp [Hev [Hor [Hpre Hpost]]]]]. + destruct Hor as [-> | ->]. + { (* RTPre *) + assert (Htv := Hpre eq_refl). + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [fv Hfv]; + exists fv, RTPre; split; [eapply E_FieldPre; eauto |]; + split; [left; reflexivity |]; split + end. + { intros _. match goal with + | [Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hfv in Hvars; exact Hvars end. } + { intros; discriminate. } } + { (* RTPost *) + assert (Htv := Hpost eq_refl). + inv Htv. match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + match goal with + | [Hvdom : forall _, _ <-> _, + Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + destruct (proj2 (Hvdom x) (ex_intro _ sty Hssv)) as [fv Hfv]; + exists fv, RTPost; split; [eapply E_FieldPost; eauto |]; + split; [right; reflexivity |]; split + end. + { intros; discriminate. } + { intros _. match goal with + | [Hvars : forall _ _, Σ_storage_var _ _ _ = Some _ -> _ |- _] => + specialize (Hvars _ _ Hssv); + unfold state_var_force in Hvars; rewrite Hfv in Hvars; exact Hvars end. } } } + { (* T_MapIndex *) + intros Σ iface k oid t r e bt mu _ IHr _ IHe HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IHr eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [vr [tp [Hevr [Hor [Hpre_r Hpost_r]]]]]. + destruct (IHe eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [ve [Heve Htve]]. + destruct Hor as [-> | ->]. + { (* RTPre *) + assert (Htv := Hpre_r eq_refl). inv Htv. + match goal with [Hm : has_mapping_type _ _ |- _] => inv Hm end. + { inv Htve. exists (f n), RTPre. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [left; reflexivity |]. split. + { intros _. constructor. + match goal with [H : forall _, _ -> has_mapping_type _ _ |- _] => + apply H; constructor; auto end. } + { intros; discriminate. } } + { inv Htve. exists (f b), RTPre. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [left; reflexivity |]. split. + { intros _. constructor. + match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. } + { intros; discriminate. } } + { inv Htve. exists (f a), RTPre. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [left; reflexivity |]. split. + { intros _. constructor. + match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. } + { intros; discriminate. } } } + { (* RTPost *) + assert (Htv := Hpost_r eq_refl). inv Htv. + match goal with [Hm : has_mapping_type _ _ |- _] => inv Hm end. + { inv Htve. exists (f n), RTPost. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [right; reflexivity |]. split. + { intros; discriminate. } + { intros _. constructor. + match goal with [H : forall _, _ -> has_mapping_type _ _ |- _] => + apply H; constructor; auto end. } } + { inv Htve. exists (f b), RTPost. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [right; reflexivity |]. split. + { intros; discriminate. } + { intros _. constructor. + match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. } } + { inv Htve. exists (f a), RTPost. split; + [eapply E_RefMapping; eauto; reflexivity |]. + split; [right; reflexivity |]. split. + { intros; discriminate. } + { intros _. constructor. + match goal with [H : forall _, has_mapping_type _ _ |- _] => + apply H end. } } } } + { (* T_Environment: t = TagU, contradicts t = TagT *) intros; discriminate. } + { (* T_Int *) + intros Σ iface oid t n it Hin _ s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. + exists (VInt n). split; [constructor | constructor; auto]. } + { (* T_Bool *) + intros Σ iface oid t b _ s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. + exists (VBool b). split; [constructor | constructor]. } + { (* T_Ref *) + intros Σ iface oid t k r bt _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [tp [Hev [Hor [Hpre Hpost]]]]]. + destruct Hor as [-> | ->]. + { assert (Htv := Hpre eq_refl). inv Htv. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + eexists. split; [eapply E_Ref; eauto | auto]. } + { assert (Htv := Hpost eq_refl). inv Htv. + match goal with [Ha : has_abi_type _ _ _ _ |- _] => inv Ha end. + eexists. split; [eapply E_Ref; eauto | auto]. } } + { (* T_Addr: TagU only *) intros; discriminate. } + { (* T_Range *) + intros Σ iface oid t e it1 it2 _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [Hev Htv]]. inv Htv. + destruct (classic (in_range it1 n)). + { exists (VBool true). split; [eapply E_RangeTrue; eauto | constructor]. } + { exists (VBool false). split; [eapply E_RangeFalse; eauto | constructor]. } } + { (* T_BopI *) + intros Σ iface oid t e1 op e2 it1 it2 _ IH1 _ IH2 HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH1 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + destruct (int_binop_dec op OpDiv) as [->|Hnd]. + { destruct (Z.eq_dec n0 0) as [->|Hnz]. + { exists (VInt 0). split; [eapply E_DivZero; eauto | constructor; simpl; auto]. } + { exists (VInt (Z.div n n0)). split; [eapply E_Div; eauto | constructor; simpl; auto]. } } + { destruct (int_binop_dec op OpMod) as [->|Hnm]. + { destruct (Z.eq_dec n0 0) as [->|Hnz]. + { exists (VInt 0). split; [eapply E_ModZero; eauto | constructor; simpl; auto]. } + { exists (VInt (Z.modulo n n0)). split; [eapply E_Mod; eauto | constructor; simpl; auto]. } } + { exists (VInt (eval_int_binop op n n0)). split; + [eapply E_BopI; eauto | constructor; simpl; auto]. } } } + { (* T_NumConv *) + intros Σ iface oid t e it _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [Hev Htv]]. inv Htv. + exists (VInt n). split; [exact Hev | constructor; simpl; auto]. } + { (* T_BopB *) + intros Σ iface oid t e1 op e2 _ IH1 _ IH2 HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH1 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + exists (VBool (eval_bool_binop op b b0)). split; + [eapply E_BopB; eauto | constructor]. } + { (* T_Neg *) + intros Σ iface oid t e _ IH HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v [Hev Htv]]. inv Htv. + exists (VBool (negb b)). split; [eapply E_Neg; eauto | constructor]. } + { (* T_Cmp *) + intros Σ iface oid t e1 op e2 it _ IH1 _ IH2 HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH1 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v2 [Hev2 Htv2]]. + inv Htv1. inv Htv2. + exists (VBool (eval_cmp op n n0)). split; + [eapply E_Cmp; eauto | constructor]. } + { (* T_ITE *) + intros Σ iface oid t e1 e2 e3 bt _ IH1 _ IH2 _ IH3 HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH1 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [vc [Hevc Htvc]]. inv Htvc. + destruct b. + { destruct (IH2 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v2 [Hev2 Htv2]]. + exists v2. split; [eapply E_ITETrue; eauto | exact Htv2]. } + { destruct (IH3 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v3 [Hev3 Htv3]]. + exists v3. split; [eapply E_ITEFalse; eauto | exact Htv3]. } } + { (* T_Eq *) + intros Σ iface oid t e1 e2 bt _ IH1 _ IH2 HeqT s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post. subst. + destruct (IH1 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v1 [Hev1 Htv1]]. + destruct (IH2 eq_refl s_pre s_post rho l Henv_pre Henv_post Hloc_pre Hloc_post) as [v2 [Hev2 Htv2]]. + destruct (classic (v1 = v2)) as [->|Hne]. + { exists (VBool true). split; [eapply E_EqTrue; eauto | constructor]. } + { exists (VBool false). split; [eapply E_EqFalse; eauto | constructor]. } } +Qed. + +Lemma ref_typesafety_timed : + forall Σ iface oid k r sty s_pre s_post rho l, + type_ref Σ iface k oid TagT r sty -> + env_well_typed Σ rho s_pre iface -> + env_well_typed Σ rho s_post iface -> + loc_has_opt_type Σ l s_pre oid -> + loc_has_opt_type Σ l s_post oid -> + exists v tp, + eval_ref (TSTimed s_pre s_post) rho r l v tp /\ + (tp = RTPre \/ tp = RTPost) /\ + (tp = RTPre -> has_slot_type Σ v s_pre sty) /\ + (tp = RTPost -> has_slot_type Σ v s_post sty). +Proof. + intros. exact (proj1 ref_expr_typesafety_timed _ _ _ _ _ _ _ H eq_refl _ _ _ _ H0 H1 H2 H3). +Qed. + +Lemma expr_typesafety_timed : + forall Σ iface oid e bt s_pre s_post rho l, + type_expr Σ iface oid TagT e bt -> + env_well_typed Σ rho s_pre iface -> + env_well_typed Σ rho s_post iface -> + loc_has_opt_type Σ l s_pre oid -> + loc_has_opt_type Σ l s_post oid -> + exists v, + eval_expr (TSTimed s_pre s_post) rho e l v /\ + has_base_type v bt. +Proof. + intros. exact (proj2 ref_expr_typesafety_timed _ _ _ _ _ _ H eq_refl _ _ _ _ H0 H1 H2 H3). +Qed. + +(* ================================================================= *) +(** ** Mapping Expression Type Safety (Lemma 6.6) *) + +Lemma slot_mapping_inv : forall Σ v s mu, + has_slot_type Σ v s (SMapping mu) -> has_mapping_type v mu. +Proof. intros Σ v s mu H. inv H. assumption. Qed. + +Lemma lookup_or_default_typed : + forall keys vals x def mu, + has_mapping_type def mu -> + Forall (fun v => has_mapping_type v mu) vals -> + has_mapping_type (lookup_or_default keys vals x def) mu. +Proof. + intros keys. induction keys as [|k ks IH]; intros vals x def mu Hdef Hvals; simpl. + - exact Hdef. + - destruct vals as [|v vs]; [exact Hdef|]. + inv Hvals. destruct (value_eqb k x); auto. +Qed. + +Lemma lookup_or_apply_typed_Z : + forall keys vals n it mu f, + (forall n0, has_base_type (VInt n0) (TInt it) -> has_mapping_type (f n0) mu) -> + has_base_type (VInt n) (TInt it) -> + Forall (fun v => has_mapping_type v mu) vals -> + has_mapping_type (lookup_or_apply keys vals (VInt n) (VMapZ f)) mu. +Proof. + intros keys. induction keys as [|k ks IH]; intros vals n it mu f Hf Hin Hvals; simpl. + - apply Hf; exact Hin. + - destruct vals as [|v vs]; [apply Hf; exact Hin|]. + inv Hvals. destruct (value_eqb k (VInt n)); [exact H1 | apply IH with (it := it); auto]. +Qed. + +Lemma lookup_or_apply_typed_B : + forall keys vals b mu f, + (forall b0, has_mapping_type (f b0) mu) -> + Forall (fun v => has_mapping_type v mu) vals -> + has_mapping_type (lookup_or_apply keys vals (VBool b) (VMapB f)) mu. +Proof. + intros keys. induction keys as [|k ks IH]; intros vals b mu f Hf Hvals; simpl. + - apply Hf. + - destruct vals as [|v vs]; [apply Hf|]. + inv Hvals. destruct (value_eqb k (VBool b)); auto. +Qed. + +Lemma lookup_or_apply_typed_A : + forall keys vals a mu f, + (forall a0, has_mapping_type (f a0) mu) -> + Forall (fun v => has_mapping_type v mu) vals -> + has_mapping_type (lookup_or_apply keys vals (VAddr a) (VMapA f)) mu. +Proof. + intros keys. induction keys as [|k ks IH]; intros vals a mu f Hf Hvals; simpl. + - apply Hf. + - destruct vals as [|v vs]; [apply Hf|]. + inv Hvals. destruct (value_eqb k (VAddr a)); auto. +Qed. + +Lemma eval_binding_keys_typed : + forall (bindings : list (expr * map_expr)) Σ iface oid bt s rho l, + Forall (fun p => type_expr Σ iface oid TagU (fst p) bt) bindings -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists keys, + Forall2 (fun p k => eval_expr (TSUntimed s) rho (fst p) l k) bindings keys /\ + Forall (fun v => has_base_type v bt) keys. +Proof. + induction bindings as [|[e m] rest IH]; intros Σ iface oid bt s rho l Hall Henv Hloc. + - exists []. split; constructor. + - inv Hall. simpl in H1. + destruct (expr_typesafety_untimed _ _ _ _ _ _ _ _ H1 Henv Hloc) as [v [Hev Htv]]. + destruct (IH _ _ _ _ _ _ _ H2 Henv Hloc) as [ks [Heks Htks]]. + exists (v :: ks). split; constructor; auto. +Qed. + +Lemma eval_binding_vals_realized : + forall (bindings : list (expr * map_expr)) mu ts rho l, + Forall (fun p => + exists v, eval_mapexpr ts rho (snd p) l v /\ has_mapping_type v mu) bindings -> + exists vals, + Forall2 (fun p v => eval_mapexpr ts rho (snd p) l v) bindings vals /\ + Forall (fun v => has_mapping_type v mu) vals. +Proof. + induction bindings as [|[e m] rest IH]; intros mu ts rho l Hall. + - exists []. split; constructor. + - inv Hall. simpl in H1. destruct H1 as [u [Heu Htu]]. + destruct (IH _ _ _ _ H2) as [us [Heus Htus]]. + exists (u :: us). split; constructor; auto. +Qed. + +Lemma build_map_typed : + forall bt mu keys vals, + default_value_typable mu -> + Forall (fun v => has_mapping_type v mu) vals -> + exists f, + build_map_from_bindings keys vals (MMapping bt mu) = Some f /\ + has_mapping_type f (MMapping bt mu). +Proof. + intros bt mu keys vals Hdef Htvals. + assert (Hdefm : has_mapping_type (default_value mu) mu) + by (apply default_has_mapping_type; exact Hdef). + destruct bt; simpl; eexists; (split; [reflexivity|]). + - constructor. intros n Hin. apply lookup_or_default_typed; auto. + - constructor. intros b. apply lookup_or_default_typed; auto. + - constructor. intros a. apply lookup_or_default_typed; auto. +Qed. + +Lemma update_map_typed : + forall bt mu keys vals vold, + has_mapping_type vold (MMapping bt mu) -> + Forall (fun v => has_mapping_type v mu) vals -> + exists f, + update_map_from_bindings keys vals vold (MMapping bt mu) = Some f /\ + has_mapping_type f (MMapping bt mu). +Proof. + intros bt mu keys vals vold Hvold Htvals. + inv Hvold. + { simpl. eexists. split; [reflexivity|]. + constructor. intros n Hbt. + apply lookup_or_apply_typed_Z with (it := it); assumption. } + { simpl. eexists. split; [reflexivity|]. + constructor. intros b. + apply lookup_or_apply_typed_B; assumption. } + { simpl. eexists. split; [reflexivity|]. + constructor. intros a. + apply lookup_or_apply_typed_A; assumption. } +Qed. + +Lemma mapexpr_typesafety_aux : + forall Σ iface oid m mu, + type_mapexpr Σ iface oid m mu -> + forall s rho l, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v, + eval_mapexpr (TSUntimed s) rho m l v /\ + has_mapping_type v mu. +Proof. + fix IH 6. + intros Σ iface oid m mu Htyp. + destruct Htyp; intros s rho l Henv Hloc. + - (* T_Exp *) + match goal with [He : type_expr _ _ _ _ _ _ |- _] => + destruct (expr_typesafety_untimed _ _ _ _ _ _ _ _ He Henv Hloc) as [v [Hev Htv]] end. + exists v. split; [apply E_MExp; exact Hev | constructor; exact Htv]. + - (* T_Mapping *) + match goal with [H : default_value_typable _ |- _] => rename H into Hd end. + match goal with [H : Forall (fun p => type_expr _ _ _ _ (fst p) _) _ |- _] => rename H into Hkeys_ty end. + match goal with [H : Forall (fun p => type_mapexpr _ _ _ (snd p) _) _ |- _] => rename H into Hvals_ty end. + destruct (eval_binding_keys_typed _ _ _ _ _ _ _ _ Hkeys_ty Henv Hloc) as [keys [Hkeys Htkeys]]. + assert (Hvals_ih : Forall (fun p => + exists v, eval_mapexpr (TSUntimed s) rho (snd p) l v /\ has_mapping_type v mu) bindings). + { clear Hkeys_ty Hd Hkeys Htkeys keys. + induction Hvals_ty as [|p rest Hm Hrest IHF]. + { constructor. } + { constructor. + { apply (IH _ _ _ _ _ Hm _ _ _ Henv Hloc). } + { apply IHF. } } } + destruct (eval_binding_vals_realized _ _ _ _ _ Hvals_ih) as [vals [Hvals Htvals]]. + destruct (build_map_typed bt mu keys vals Hd Htvals) as [fv [Hbuild Htfv]]. + exists fv. split; [eapply E_Mapping; eauto | exact Htfv]. + - (* T_MappingUpd *) + match goal with [Hr : type_ref _ _ _ _ _ _ (SMapping (MMapping _ _)) |- _] => + destruct (ref_typesafety_untimed _ _ _ _ _ _ _ _ _ Hr Henv Hloc) as [vold [Hevold Htvold]] end. + apply slot_mapping_inv in Htvold. + match goal with [H : Forall (fun p => type_expr _ _ _ _ (fst p) _) _ |- _] => rename H into Hkeys_ty end. + match goal with [H : Forall (fun p => type_mapexpr _ _ _ (snd p) _) _ |- _] => rename H into Hvals_ty end. + destruct (eval_binding_keys_typed _ _ _ _ _ _ _ _ Hkeys_ty Henv Hloc) as [keys [Hkeys Htkeys]]. + assert (Hvals_ih : Forall (fun p => + exists v, eval_mapexpr (TSUntimed s) rho (snd p) l v /\ has_mapping_type v mu) bindings). + { clear Hkeys_ty Htvold Hkeys Htkeys keys Hevold vold. + induction Hvals_ty as [|p rest Hm Hrest IHF]. + { constructor. } + { constructor. + { apply (IH _ _ _ _ _ Hm _ _ _ Henv Hloc). } + { apply IHF. } } } + destruct (eval_binding_vals_realized _ _ _ _ _ Hvals_ih) as [vals [Hvals Htvals]]. + destruct (update_map_typed _ _ keys vals _ Htvold Htvals) as [fv [Hupd Htfv]]. + exists fv. split; [eapply E_MappingUpd; eauto | exact Htfv]. +Qed. + +Lemma mapexpr_typesafety : + forall Σ iface oid m mu s rho l, + type_mapexpr Σ iface oid m mu -> + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v, + eval_mapexpr (TSUntimed s) rho m l v /\ + has_mapping_type v mu. +Proof. + intros. eapply mapexpr_typesafety_aux; eauto. +Qed. + +(** Helper: inverting has_slot_type for SContract *) +Lemma slot_contract_inv : forall Σ v s a, + has_slot_type Σ v s (SContract a) -> + has_abi_type Σ v s (AContractAddr a). +Proof. intros. inv H. assumption. Qed. + +(** Helper: loc_has_opt_type weakening *) +Lemma loc_has_opt_type_weak : forall Σ l s s' oid, + state_incl s s' -> + loc_has_opt_type Σ l s oid -> + loc_has_opt_type Σ l s' oid. +Proof. + intros Σ l s s' oid Hincl Hloc. + unfold loc_has_opt_type in *. destruct oid. + - exact I. + - eapply valuetyp_storage_weak_slot; eauto. +Qed. + +(** Helper: inverting has_slot_type for SAbi *) +Lemma slot_abi_inv : forall Σ v s alpha, + has_slot_type Σ v s (SAbi alpha) -> + has_abi_type Σ v s alpha. +Proof. intros. inv H. assumption. Qed. + +(* ================================================================= *) +(** ** Sigma-down transfer for typing *) + +(** Key lemma: has_abi_type for AContractAddr can be transferred from + a bigger contract_env to a smaller one, given the contract is well-formed + in the smaller contract_env. Proved by Acc induction on contract_dep. *) +Lemma has_abi_type_Σ_down_contract : + forall Σ Σ', + Σ_incl Σ' Σ -> + Σ_well_typed Σ' -> + forall a, + Acc (fun b c => contract_dep Σ' b c) a -> + dom (Σ_storage Σ') a -> + forall v s, + has_abi_type Σ v s (AContractAddr a) -> + has_abi_type Σ' v s (AContractAddr a). +Proof. + intros Σ Σ' Hincl Hwt a Hacc. + induction Hacc as [a _ IH]. + intros Hdom_a v s Hab. + inversion Hab as [| ? ? ? ? Hsd Hds Hstype Hdom_eq Htyp_corr]; subst; clear Hab. + assert (Hsto_eq : Σ_storage Σ' a = Σ_storage Σ a). + { destruct Hdom_a as [layout' Hlayout']. + rewrite (proj1 Hincl _ _ Hlayout'). exact Hlayout'. } + assert (Hssv_eq : forall x, Σ_storage_var Σ' a x = Σ_storage_var Σ a x). + { intro x. unfold Σ_storage_var. rewrite Hsto_eq. reflexivity. } + assert (Hswf_a : forall layout', Σ_storage Σ' a = Some layout' -> + Forall (fun p => slot_type_wf Σ' (snd p)) layout'). + { destruct Hwt as [? Hswf0 _ _]. intros. eapply Hswf0; eassumption. } + assert (Hswf_var : forall x st, Σ_storage_var Σ a x = Some st -> slot_type_wf Σ' st). + { intros x st Hx. destruct Hdom_a as [la Hla]. + specialize (Hswf_a la Hla). unfold Σ_storage_var in Hx. + rewrite <- Hsto_eq, Hla in Hx. + apply alist_lookup_In in Hx. destruct Hx as [p [Hp1 Hp2]]. + simpl in Hp2; subst. rewrite Forall_forall in Hswf_a. exact (Hswf_a p Hp1). } + constructor. + - exact Hsd. + - exact Hdom_a. + - exact Hstype. + - intros x. rewrite Hdom_eq. + split; intros [st Hst]; exists st; rewrite Hssv_eq in *; exact Hst. + - intros x st Hssv. + rewrite Hssv_eq in Hssv. + specialize (Htyp_corr x st Hssv). + specialize (Hswf_var x st Hssv). + destruct st as [mu | alpha | c]. + + inv Htyp_corr. constructor. assumption. + + destruct alpha as [bt | c]. + * inv Htyp_corr. + match goal with [Habi : has_abi_type _ _ _ _ |- _] => inv Habi end. + constructor. constructor. assumption. + * inv Htyp_corr. + match goal with [Habi : has_abi_type _ _ _ _ |- _] => + constructor; apply (IH c) end. + { exists x. right. rewrite Hssv_eq. assumption. } + { inv Hswf_var. + match goal with [Hw : abi_type_wf _ _ |- _] => inv Hw; assumption end. } + { assumption. } + + inv Htyp_corr. + match goal with [Habi : has_abi_type _ _ _ _ |- _] => + constructor; apply (IH c) end. + { exists x. left. rewrite Hssv_eq. assumption. } + { inv Hswf_var. assumption. } + { assumption. } +Qed. + +Lemma has_slot_type_Σ_down : + forall Σ Σ' v s st, + Σ_incl Σ' Σ -> + Σ_wf Σ' -> + Σ_well_typed Σ' -> + slot_type_wf Σ' st -> + has_slot_type Σ v s st -> has_slot_type Σ' v s st. +Proof. + intros Σ Σ' v s st Hincl Hwf Hwt Hswf Hst. + destruct st as [mu | alpha | a]. + - inv Hst. constructor. assumption. + - destruct alpha as [bt | a]. + + inversion Hst as [| ? ? ? ? Habi_bt |]; subst; clear Hst. + inversion Habi_bt; subst; clear Habi_bt. + constructor. constructor. assumption. + + inversion Hst as [| ? ? ? ? Habi |]; subst; clear Hst. + constructor. eapply has_abi_type_Σ_down_contract; eauto. + { apply Hwf. } + { inv Hswf. inversion H0; subst. assumption. } + - inversion Hst as [| | ? ? ? ? Habi]; subst; clear Hst. + constructor. eapply has_abi_type_Σ_down_contract; eauto. + { apply Hwf. } + { inv Hswf. assumption. } +Qed. + +Lemma env_well_typed_Σ_down : + forall Σ Σ' rho s iface, + Σ_incl Σ' Σ -> + Σ_wf Σ' -> + Σ_well_typed Σ' -> + interface_wf Σ' iface -> + env_well_typed Σ rho s iface -> + env_well_typed Σ' rho s iface. +Proof. + intros Σ Σ' rho s iface Hincl Hwf Hwt [Hiwf _] Henv. + destruct Henv as [Hdom [Htyp [Hcaller [Horigin Hcv]]]]. + refine (conj Hdom (conj _ (conj Hcaller (conj Horigin Hcv)))). + intros x alpha Hlook. + destruct (Htyp x alpha Hlook) as [v [Hv Hav]]. + exists v. split; [exact Hv|]. + destruct alpha as [bt | a]. + - inversion Hav; subst; clear Hav. constructor. assumption. + - eapply has_abi_type_Σ_down_contract; eauto. + + apply Hwf. + + rewrite Forall_forall in Hiwf. + apply alist_lookup_In in Hlook. + destruct Hlook as [p [Hp1 Hp2]]. simpl in Hp2. subst. + specialize (Hiwf p Hp1). rewrite Hp2 in Hiwf. simpl in Hiwf. + inversion Hiwf; subst; assumption. +Qed. + +(* ================================================================= *) +(** ** Creates-typed property for store_wt *) + +(** Every location in s' either existed in s or has a contract type. *) +Definition creates_typed (Σ : contract_env) (s s' : state) : Prop := + forall l, state_dom s' l -> + state_dom s l \/ exists a, has_slot_type Σ (VAddr l) s' (SContract a). + +Lemma creates_typed_refl : forall Σ s, creates_typed Σ s s. +Proof. intros Σ s l Hd. left. exact Hd. Qed. + +Lemma creates_typed_trans : + forall Σ s1 s2 s3, + creates_typed Σ s1 s2 -> + creates_typed Σ s2 s3 -> + (forall v st, has_slot_type Σ v s2 st -> has_slot_type Σ v s3 st) -> + creates_typed Σ s1 s3. +Proof. + intros Σ s1 s2 s3 H12 H23 Hpres l Hd3. + destruct (H23 l Hd3) as [Hd2 | [a Ha]]. + - destruct (H12 l Hd2) as [Hd1 | [a Ha]]. + + left. exact Hd1. + + right. exists a. apply Hpres. exact Ha. + - right. exists a. exact Ha. +Qed. + +Lemma state_update_var_dom_back : + forall s l x v l', + state_dom (state_update_var s l x v) l' -> state_dom s l'. +Proof. + intros s l x v l' [ls Hls]. + rewrite state_update_var_store in Hls. + destruct (s l) eqn:Esl. + - destruct (Nat.eqb_spec l l'). + + subst. exists l0. exact Esl. + + exists ls. exact Hls. + - exists ls. exact Hls. +Qed. + +Lemma eval_insert_dom_back : + forall s rho r v l s', + eval_insert s rho r v l s' -> + forall l', state_dom s' l' -> state_dom s l'. +Proof. + intros s rho r v l s' Hins l' Hd'. inv Hins; + eapply state_update_var_dom_back; eauto. +Qed. + +Lemma eval_update_inserts_dom_back : + forall s rho upds vals l s', + eval_update_inserts s rho upds vals l s' -> + forall l', state_dom s' l' -> state_dom s l'. +Proof. + intros s rho upds vals l s' Hins. + induction Hins as [| s0 rho0 r se rest v vs l0 s1 s_final Hins1 Hins_rest IH]. + - auto. + - intros l' Hd'. apply (eval_insert_dom_back _ _ _ _ _ _ Hins1). + apply IH. exact Hd'. +Qed. + +Lemma creates_typed_Σ_up : + forall Σ Σ' s s', + Σ_incl Σ Σ' -> + creates_typed Σ s s' -> creates_typed Σ' s s'. +Proof. + intros Σ Σ' s s' Hincl Hct l Hd. + destruct (Hct l Hd) as [Hd0 | [a Ha]]. + - left. exact Hd0. + - right. exists a. eapply valuetyp_storetyp_weak_slot; eauto. +Qed. + +(* ================================================================= *) +(** ** Constructor Cases Evaluate (by well-founded induction) *) + +(** Abbreviation: all constructors of Σ evaluate. This is what the + tech report calls "mutual induction" between SE/create type safety. + In Rocq, we prove it by Acc induction on contract_dep, then + derive the universal statement from Σ_wf. *) +Definition ctor_eval_prop (Σ : contract_env) : Prop := + forall a ctor, + Σ_cnstr Σ a = Some ctor -> + forall s rho, + env_well_typed Σ rho s (ctor_iface ctor) -> + Forall (fun pre => eval_expr (TSUntimed s) rho pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + exists l s', + eval_ctor_cases (Σ_cnstr Σ) s rho (ctor_cases ctor) a l s' /\ + has_slot_type Σ (VAddr l) s' (SContract a) /\ + state_incl s s' /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st) /\ + creates_typed Σ s s'. + +(** Helper: extract interface_wf for a constructor from Σ_well_typed *) +Lemma ctor_iface_wf : forall Σ a ctor, + Σ_well_typed Σ -> + Σ_cnstr Σ a = Some ctor -> + ~ alist_dom (ctor_iface ctor) "caller"%string /\ + ~ alist_dom (ctor_iface ctor) "origin"%string /\ + ~ alist_dom (ctor_iface ctor) "callvalue"%string. +Proof. + intros Σ a ctor Hswt Hcl. + inversion Hswt as [? _ Hswt_c _]; subst. + destruct (Hswt_c a ctor Hcl) as [Σ' [layout' [_ [_ [_ [_ [Htc _]]]]]]]. + inversion Htc; subst. + match goal with H : interface_wf _ _ |- _ => destruct H as [_ [? [? ?]]] end. + auto. +Qed. + +(** SE type safety given that constructors evaluate. + The ctor_eval_prop hypothesis is discharged later by Acc induction. *) +Lemma se_typesafety_with_ctors : + forall Σ iface oid se sty, + ctor_eval_prop Σ -> + Σ_well_typed Σ -> + type_slotexpr Σ iface oid se sty -> + forall s rho l, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v s', + eval_slotexpr (Σ_cnstr Σ) s rho se l v s' /\ + has_slot_type Σ v s' sty /\ + state_incl s s' /\ + (forall v' st', has_slot_type Σ v' s st' -> has_slot_type Σ v' s' st') /\ + creates_typed Σ s s'. +Proof. + intros Σ iface oid se sty Hctors Hswt Htyp. + induction Htyp using type_slotexpr_ind2; + intros s rho l Henv Hloc. + - (* T_SlotMap *) + destruct (mapexpr_typesafety _ _ _ _ _ _ _ _ H Henv Hloc) as [v [Hev Htv]]. + exists v, s. refine (conj _ (conj _ (conj _ (conj _ _)))). + + apply E_SlotMap; exact Hev. + + constructor; exact Htv. + + intros l' ls' Hl'; exact Hl'. + + auto. + + apply creates_typed_refl. + - (* T_SlotRef *) + destruct (ref_typesafety_untimed _ _ _ _ _ _ _ _ _ H Henv Hloc) as [v [Hev Htv]]. + exists v, s. refine (conj _ (conj _ (conj _ (conj _ _)))). + + apply E_SlotRef with (tp := RTU); exact Hev. + + exact Htv. + + intros l' ls' Hl'; exact Hl'. + + auto. + + apply creates_typed_refl. + - (* T_SlotAddr *) + destruct (IHHtyp Hctors Hswt s rho l Henv Hloc) as [v [s' [Hev [Htv [Hincl [Hpres Hct]]]]]]. + exists v, s'. refine (conj _ (conj _ (conj Hincl (conj Hpres Hct)))). + + apply E_SlotAddr; exact Hev. + + apply slot_contract_inv in Htv. constructor. exact Htv. + - (* T_Create *) + rename H into Hcl, H0 into Hnp, H2 into HIH, H3 into HP4. + (* Evaluate each argument se using the structural IH *) + assert (Hse_eval : forall s0 rho0 l0, + env_well_typed Σ rho0 s0 iface -> + loc_has_opt_type Σ l0 s0 oid -> + exists vals s_final, + eval_slotexpr_list (Σ_cnstr Σ) s0 rho0 ses l0 vals s_final /\ + Forall2 (fun v alpha => has_abi_type Σ v s_final alpha) vals (map snd (ctor_iface ctor)) /\ + state_incl s0 s_final /\ + (forall v' st', has_slot_type Σ v' s0 st' -> has_slot_type Σ v' s_final st') /\ + creates_typed Σ s0 s_final). + { clear Hcl Hnp HP4 H1. + induction HIH as [|se0 alpha0 rses ralphas Hse0 _ IHfa]; + intros s0 rho0 l0 Henv0 Hloc0. + - exists [], s0. refine (conj _ (conj _ (conj _ (conj _ _)))). + + constructor. + + constructor. + + intros l' ls' Hl'; exact Hl'. + + auto. + + apply creates_typed_refl. + - destruct (Hse0 Hctors Hswt s0 rho0 l0 Henv0 Hloc0) + as [v0 [s1 [Hev0 [Htv0 [Hincl01 [Hpres01 Hct01]]]]]]. + assert (Henv1 : env_well_typed Σ rho0 s1 iface) + by (eapply valuetyp_storage_weak_env; eauto). + assert (Hloc1 : loc_has_opt_type Σ l0 s1 oid) + by (eapply loc_has_opt_type_weak; eauto). + destruct (IHfa s1 rho0 l0 Henv1 Hloc1) + as [vs [sf [Hevs [Htvs [Hincl1f [Hpres1f Hct1f]]]]]]. + exists (v0 :: vs), sf. refine (conj _ (conj _ (conj _ (conj _ _)))). + + eapply E_SlotListCons; eauto. + + constructor. + * apply slot_abi_inv. apply Hpres1f. exact Htv0. + * exact Htvs. + + intros l' ls' Hl'. apply Hincl1f. apply Hincl01. exact Hl'. + + intros v' st' Hv'. apply Hpres1f. apply Hpres01. exact Hv'. + + eapply creates_typed_trans; eauto. } + destruct (Hse_eval s rho l Henv Hloc) + as [vals [s_final [Hevl [Htvals [Hincl_sf [Hpres_sf Hct_sf]]]]]]. + set (rho' := build_ctor_env (ctor_iface ctor) vals l (env_origin rho) (VInt 0%Z)). + assert (Hiffs : Forall (fun pre => + eval_expr (TSUntimed s_final) rho' pre dummy_loc (VBool true)) + (ctor_iff ctor)) by (apply HP4 with (s := s); auto). + assert (Henv_rho' : env_well_typed Σ rho' s_final (ctor_iface ctor)). + { apply build_ctor_env_well_typed. + - exact Htvals. + - (* origin : address *) + destruct Henv as [_ [_ [_ [[vo [Hvo Htvo]] _]]]]. + unfold env_origin. rewrite Hvo. exact Htvo. + - (* VInt 0 : uint256 *) + constructor. simpl. lia. + - exact (proj1 (ctor_iface_wf Σ a ctor Hswt Hcl)). + - exact (proj1 (proj2 (ctor_iface_wf Σ a ctor Hswt Hcl))). + - exact (proj2 (proj2 (ctor_iface_wf Σ a ctor Hswt Hcl))). } + destruct (Hctors a ctor Hcl s_final rho' Henv_rho' Hiffs) + as [l' [s' [Heval_cc [Htloc [Hincl_s' [Hpres_s' Hct_s']]]]]]. + exists (VAddr l'), s'. split; [|split; [|split; [|split]]]. + { eapply E_Create; eauto. } + { exact Htloc. } + { intros l0 ls0 Hl0. apply Hincl_s'. apply Hincl_sf. exact Hl0. } + { intros v' st' Hv'. apply Hpres_s'. apply Hpres_sf. exact Hv'. } + { eapply creates_typed_trans; eauto. } + - (* T_CreatePayable *) + rename H into Hcl, H0 into Hpay, H2 into HIH, H3 into Hval. + (* Evaluate arguments *) + assert (Hse_eval : forall s0 rho0 l0, + env_well_typed Σ rho0 s0 iface -> + loc_has_opt_type Σ l0 s0 oid -> + exists vals s_final, + eval_slotexpr_list (Σ_cnstr Σ) s0 rho0 ses l0 vals s_final /\ + Forall2 (fun v alpha => has_abi_type Σ v s_final alpha) vals (map snd (ctor_iface ctor)) /\ + state_incl s0 s_final /\ + (forall v' st', has_slot_type Σ v' s0 st' -> has_slot_type Σ v' s_final st') /\ + creates_typed Σ s0 s_final). + { clear Hcl Hpay Hval IHHtyp H1. + induction HIH as [|se0 alpha0 rses ralphas Hse0 _ IHfa]; + intros s0 rho0 l0 Henv0 Hloc0. + - exists [], s0. refine (conj _ (conj _ (conj _ (conj _ _)))). + + constructor. + + constructor. + + intros l' ls' Hl'; exact Hl'. + + auto. + + apply creates_typed_refl. + - destruct (Hse0 Hctors Hswt s0 rho0 l0 Henv0 Hloc0) + as [v0 [s1 [Hev0 [Htv0 [Hincl01 [Hpres01 Hct01]]]]]]. + assert (Henv1 : env_well_typed Σ rho0 s1 iface) + by (eapply valuetyp_storage_weak_env; eauto). + assert (Hloc1 : loc_has_opt_type Σ l0 s1 oid) + by (eapply loc_has_opt_type_weak; eauto). + destruct (IHfa s1 rho0 l0 Henv1 Hloc1) + as [vs [sf [Hevs [Htvs [Hincl1f [Hpres1f Hct1f]]]]]]. + exists (v0 :: vs), sf. refine (conj _ (conj _ (conj _ (conj _ _)))). + + eapply E_SlotListCons; eauto. + + constructor. + * apply slot_abi_inv. apply Hpres1f. exact Htv0. + * exact Htvs. + + intros l' ls' Hl'. apply Hincl1f. apply Hincl01. exact Hl'. + + intros v' st' Hv'. apply Hpres1f. apply Hpres01. exact Hv'. + + eapply creates_typed_trans; eauto. } + destruct (Hse_eval s rho l Henv Hloc) + as [vals [s_final [Hevl [Htvals [Hincl_sf [Hpres_sf Hct_sf]]]]]]. + assert (Henv_sf : env_well_typed Σ rho s_final iface) + by (eapply valuetyp_storage_weak_env; eauto). + assert (Hloc_sf : loc_has_opt_type Σ l s_final oid) + by (eapply loc_has_opt_type_weak; eauto). + destruct (IHHtyp Hctors Hswt s_final rho l Henv_sf Hloc_sf) + as [sv [s_v [Hev_sv [Htv_sv [Hincl_sv [Hpres_sv Hct_sv]]]]]]. + set (rho' := build_ctor_env (ctor_iface ctor) vals l (env_origin rho) sv). + assert (Hiffs : Forall (fun pre => + eval_expr (TSUntimed s_v) rho' pre dummy_loc (VBool true)) + (ctor_iff ctor)). + { match goal with + | [HP4 : forall _ _ _ _ _ _ _, env_well_typed _ _ _ _ -> _ |- _] => + exact (HP4 s rho l vals s_final sv s_v Henv Hloc Hevl Hev_sv) + | _ => exact (H4 s rho l vals s_final sv s_v Henv Hloc Hevl Hev_sv) + end. } + assert (Henv_rho' : env_well_typed Σ rho' s_v (ctor_iface ctor)). + { apply build_ctor_env_well_typed. + - eapply Forall2_impl; [|exact Htvals]. intros v0 alpha0 Hv0. apply slot_abi_inv. apply Hpres_sv. constructor. exact Hv0. + - destruct Henv as [_ [_ [_ [[vo [Hvo Htvo]] _]]]]. + unfold env_origin. rewrite Hvo. exact Htvo. + - apply slot_abi_inv in Htv_sv. inv Htv_sv. assumption. + - exact (proj1 (ctor_iface_wf Σ a ctor Hswt Hcl)). + - exact (proj1 (proj2 (ctor_iface_wf Σ a ctor Hswt Hcl))). + - exact (proj2 (proj2 (ctor_iface_wf Σ a ctor Hswt Hcl))). } + destruct (Hctors a ctor Hcl s_v rho' Henv_rho' Hiffs) + as [l' [s' [Heval_cc [Htloc [Hincl_s' [Hpres_s' Hct_s']]]]]]. + exists (VAddr l'), s'. split; [|split; [|split; [|split]]]. + { eapply E_CreatePayable; eauto. } + { exact Htloc. } + { intros l0 ls0 Hl0. apply Hincl_s'. apply Hincl_sv. apply Hincl_sf. exact Hl0. } + { intros v' st' Hv'. apply Hpres_s'. apply Hpres_sv. apply Hpres_sf. exact Hv'. } + { eapply creates_typed_trans; [|eapply creates_typed_trans|]; eauto. } +Qed. + +(** Helper: Forall2 with matching keys implies alist_dom correspondence *) +Lemma forall2_alist_dom_fwd : + forall A B (xs : list (ident * A)) (ys : list (ident * B)), + Forall2 (fun p q => fst p = fst q) xs ys -> + forall x, alist_dom xs x -> alist_dom ys x. +Proof. + intros A B xs ys Hfa. + induction Hfa as [| [kx vx] [ky vy] xs' ys' Heq _ IH]; intros x [v Hv]. + - discriminate. + - simpl in Heq. subst ky. simpl in Hv. + destruct (String.eqb_spec kx x). + + exists vy. simpl. subst. rewrite String.eqb_refl. auto. + + destruct (IH x) as [w Hw]; [exists v; exact Hv |]. + exists w. simpl. destruct (String.eqb_spec kx x); [contradiction | exact Hw]. +Qed. + +Lemma forall2_alist_dom_bwd : + forall A B (xs : list (ident * A)) (ys : list (ident * B)), + Forall2 (fun p q => fst p = fst q) xs ys -> + forall x, alist_dom ys x -> alist_dom xs x. +Proof. + intros A B xs ys Hfa. + induction Hfa as [| [kx vx] [ky vy] xs' ys' Heq _ IH]; intros x [v Hv]. + - discriminate. + - simpl in Heq. subst ky. simpl in Hv. + destruct (String.eqb_spec kx x). + + exists vx. simpl. subst. rewrite String.eqb_refl. auto. + + destruct (IH x) as [w Hw]; [exists v; exact Hv |]. + exists w. simpl. destruct (String.eqb_spec kx x); [contradiction | exact Hw]. +Qed. + +(** Helper: parallel Forall2 implies parallel alist_lookup with typing *) +Lemma forall2_alist_lookup_typed : + forall A B (R : A -> B -> Prop) (xs : list (ident * A)) (ys : list (ident * B)), + Forall2 (fun p q => fst p = fst q /\ R (snd p) (snd q)) xs ys -> + forall x a, alist_lookup xs x = Some a -> + exists b, alist_lookup ys x = Some b /\ R a b. +Proof. + intros A B R xs ys Hfa. + induction Hfa as [| [kx vx] [ky vy] xs' ys' [Heq HR] _ IH]; intros x a Ha. + - discriminate. + - simpl in Heq. subst ky. simpl in Ha. + destruct (String.eqb_spec kx x). + + inv Ha. exists vy. simpl. subst. rewrite String.eqb_refl. auto. + + destruct (IH x a Ha) as [b [Hb HRab]]. + exists b. simpl. destruct (String.eqb_spec kx x); [contradiction | auto]. +Qed. + +(** Helper: evaluate a list of creates *) +Lemma creates_list_eval : + forall Σ creates iface, + ctor_eval_prop Σ -> + Σ_well_typed Σ -> + Forall (fun c : create => type_slotexpr Σ iface ONone (snd c) (fst (fst c))) creates -> + forall s rho, + env_well_typed Σ rho s iface -> + exists s_n bindings, + eval_create_list (Σ_cnstr Σ) s rho creates dummy_loc s_n bindings /\ + Forall2 (fun (b : ident * value) (c : create) => + fst b = snd (fst c) /\ has_slot_type Σ (snd b) s_n (fst (fst c))) + bindings creates /\ + state_incl s s_n /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s_n st) /\ + creates_typed Σ s s_n. +Proof. + intros Σ creates iface Hctors Hswt Hfa. + induction Hfa as [| c creates' Hse _ IH]; intros s rho Henv. + - exists s, []. refine (conj _ (conj _ (conj _ (conj _ _)))). + + constructor. + + constructor. + + intros l ls Hl; exact Hl. + + auto. + + apply creates_typed_refl. + - destruct c as [[st x] se]. simpl in Hse. + destruct (se_typesafety_with_ctors Σ iface ONone se st Hctors Hswt Hse s rho dummy_loc Henv I) + as [v [s1 [Hev [Htv [Hincl1 [Hpres1 Hct1]]]]]]. + assert (Henv1 : env_well_typed Σ rho s1 iface) + by (eapply valuetyp_storage_weak_env; eauto). + destruct (IH s1 rho Henv1) as [s_n [bs [Hevs [Hbs [Hincln [Hpresn Hctn]]]]]]. + exists s_n, ((x, v) :: bs). refine (conj _ (conj _ (conj _ (conj _ _)))). + + eapply E_CreateListCons; eauto. + + constructor. + * simpl. split; [reflexivity | apply Hpresn; exact Htv]. + * exact Hbs. + + intros l ls Hl. apply Hincln. apply Hincl1. exact Hl. + + intros v' st' Hv'. apply Hpresn. apply Hpres1. exact Hv'. + + eapply creates_typed_trans; eauto. +Qed. + +(** The key lemma: all constructors evaluate. + Proved by strong induction on Σ_cnstr_size. + Inside the induction, we use [se_typesafety_with_ctors] with the + IH providing [ctor_eval_prop] for the sub-contract_env. *) +Lemma all_ctors_evaluate : + forall Σ, + Σ_wf Σ -> + Σ_well_typed Σ -> + ctor_eval_prop Σ. +Proof. + intro Σ. + remember (Σ_cnstr_size Σ) as n. + revert Σ Heqn. + induction n as [n IHn] using lt_wf_ind. + intros Σ Hn Hwf Hwt. + unfold ctor_eval_prop. + intros a ctor Hcl s rho Henv Hiffs. + (* From Σ_well_typed, get Σ' where constructor is typed *) + assert (Hwt_copy := Hwt). + destruct Hwt as [? Hswf0 Hswt_c Hswt_t]. + destruct (Hswt_c a ctor Hcl) as [Σ' [layout [Hincl [Hfresh [Hsize [Hwt' [Htc Hsto]]]]]]]. + assert (Hwf' : Σ_wf Σ') by (eapply Σ_wf_incl; eauto). + assert (Hctors' : ctor_eval_prop Σ') by (eapply IHn; eauto; lia). + (* Extract premises from type_constructor *) + assert (Hiwf : interface_wf Σ' (ctor_iface ctor)) by (inversion Htc; assumption). + assert (Hcreates_ty : Forall (fun cc => type_creates Σ' (ctor_iface ctor) (OSome a) (snd cc) layout) + (ctor_cases ctor)) by (inversion Htc; assumption). + assert (Hcc : forall s0 rho0, + Forall (fun pre => eval_expr (TSUntimed s0) rho0 pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + exists j, j < length (ctor_cases ctor) /\ + eval_expr (TSUntimed s0) rho0 (fst (nth j (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool true) /\ + forall i, i <> j -> i < length (ctor_cases ctor) -> + eval_expr (TSUntimed s0) rho0 (fst (nth i (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool false)) + by (inversion Htc; assumption). + (* Transfer env from Σ to Σ' *) + assert (Henv' : env_well_typed Σ' rho s (ctor_iface ctor)). + { eapply env_well_typed_Σ_down; eauto. } + (* Case consistency gives active case j *) + destruct (Hcc s rho Hiffs) as [j [Hj [Hcond_j Hcond_others]]]. + set (case_j := nth j (ctor_cases ctor) (EBool false, [])) in *. + (* Get creates typing for case j *) + assert (Hcreates_j_ty : type_creates Σ' (ctor_iface ctor) (OSome a) (snd case_j) layout) + by (eapply Forall_nth; eauto). + inversion Hcreates_j_ty as [? ? ? ? ? Hlayout_eq Hbal Hswf_creates Hse_types]. + (* Evaluate creates in Σ' *) + destruct (creates_list_eval Σ' (snd case_j) (ctor_iface ctor) Hctors' Hwt' Hse_types s rho Henv') + as [s_n [bindings [Heval_cl [Hfa2 [Hincl_n [Hpres_n Hct_n]]]]]]. + (* Lift to Σ_cnstr Σ via cmap mono *) + assert (Heval_cl_Σ : eval_create_list (Σ_cnstr Σ) s rho (snd case_j) dummy_loc s_n bindings). + { eapply (proj2 (proj2 (proj2 (proj2 (cmap_mono_slotexpr_combined _))))); eauto. + exact (proj1 (proj2 Hincl)). } + set (l := state_next s_n). + set (s' := state_alloc s_n a (list_to_map bindings)). + (* Factor out Forall2 facts *) + assert (Hfa_keys : Forall2 (fun b p => fst b = fst p) bindings layout). + { rewrite Hlayout_eq. clear - Hfa2. + induction Hfa2 as [| [x0 v0] [[st0 nm0] se0] bs cs [Heq _] _ IH]. + - constructor. + - constructor; [exact Heq | exact IH]. } + assert (Hfa_typed : Forall2 (fun b p => fst b = fst p /\ has_slot_type Σ' (snd b) s_n (snd p)) + bindings layout). + { rewrite Hlayout_eq. clear - Hfa2. + induction Hfa2 as [| [x0 v0] [[st0 nm0] se0] bs cs [Heq Hty] _ IH]. + - constructor. + - constructor; [split; [exact Heq | exact Hty] | exact IH]. } + (* Factor out the has_slot_type proof for the new location *) + assert (Hloc_typed : has_slot_type Σ (VAddr l) s' (SContract a)). + { constructor. constructor. + - exists (mk_loc_store a (list_to_map bindings)). + unfold s', l. rewrite state_alloc_self. reflexivity. + - exists layout. exact Hsto. + - unfold state_type, s', l. rewrite state_alloc_self. reflexivity. + - intro x. split. + + intros [v Hv]. + unfold state_var, s', l in Hv. rewrite state_alloc_self in Hv. simpl in Hv. + destruct (forall2_alist_dom_fwd _ _ bindings layout Hfa_keys x (ex_intro _ v Hv)) + as [st Hst]. + exists st. unfold Σ_storage_var. rewrite Hsto. exact Hst. + + intros [st Hst]. + unfold Σ_storage_var in Hst. rewrite Hsto in Hst. + destruct (forall2_alist_dom_bwd _ _ bindings layout Hfa_keys x (ex_intro _ st Hst)) + as [v Hv]. + exists v. unfold state_var, s', l. rewrite state_alloc_self. simpl. exact Hv. + - intros x st Hssv. + unfold Σ_storage_var in Hssv. rewrite Hsto in Hssv. + assert (Hdom_l : alist_dom layout x) by (exists st; exact Hssv). + destruct (forall2_alist_dom_bwd _ _ bindings layout Hfa_keys x Hdom_l) as [v Hv]. + destruct (@forall2_alist_lookup_typed value slot_type + (fun v0 st0 => has_slot_type Σ' v0 s_n st0) bindings layout Hfa_typed x v Hv) + as [st' [Hst' Htv']]. + assert (Hst_eq : st' = st) by congruence. subst st'. + unfold state_var_force, state_var, s', l. rewrite state_alloc_self. simpl. + unfold list_to_map. rewrite Hv. + eapply valuetyp_storage_weak_slot; [apply state_incl_alloc |]. + eapply valuetyp_storetyp_weak_slot; [exact Hincl | exact Htv']. } + exists l, s'. refine (conj _ (conj _ (conj _ (conj _ _)))). + { econstructor; eauto. econstructor; eauto. } + { exact Hloc_typed. } + { intros l0 ls0 Hl0. unfold s'. + apply (state_incl_alloc s_n a (list_to_map bindings)). + apply Hincl_n. exact Hl0. } + { intros v' st' Hv'. + eapply valuetyp_storage_weak_slot; [apply state_incl_alloc |]. + eapply valuetyp_storage_weak_slot; [exact Hincl_n | exact Hv']. } + { (* creates_typed Σ s s' *) + assert (Hct_n_Σ : creates_typed Σ s s_n) + by (eapply creates_typed_Σ_up; eauto). + intros l0 Hdom0. unfold s' in Hdom0. + destruct Hdom0 as [ls0 Hls0]. + rewrite state_alloc_store in Hls0. + destruct (Nat.eqb_spec (state_next s_n) l0). + - subst l0. right. exists a. exact Hloc_typed. + - assert (Hdom_sn : state_dom s_n l0) by (exists ls0; exact Hls0). + destruct (Hct_n_Σ l0 Hdom_sn) as [Hdom_s | [a0 Ha0]]. + + left. exact Hdom_s. + + right. exists a0. + eapply valuetyp_storage_weak_slot; [apply state_incl_alloc | exact Ha0]. } +Qed. + +(* ================================================================= *) +(** ** Slot Expression Type Safety (Lemma 6.7) *) + +Lemma se_typesafety : + forall Σ iface oid se sty, + Σ_wf Σ -> + Σ_well_typed Σ -> + type_slotexpr Σ iface oid se sty -> + forall s rho l, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + exists v s', + eval_slotexpr (Σ_cnstr Σ) s rho se l v s' /\ + has_slot_type Σ v s' sty /\ + state_incl s s' /\ + (forall v' st', has_slot_type Σ v' s st' -> has_slot_type Σ v' s' st') /\ + creates_typed Σ s s'. +Proof. + intros Σ iface oid se sty Hwf Hwt Htyp. + exact (se_typesafety_with_ctors Σ iface oid se sty + (all_ctors_evaluate Σ Hwf Hwt) Hwt Htyp). +Qed. + +(* ================================================================= *) +(** ** Update Type Safety (Lemma 6.9) *) + +Lemma ref_storage_insert : + forall Σ iface a r sty s rho l, + Σ_wf Σ -> + type_ref Σ iface TagS (OSome a) TagU r sty -> + env_well_typed Σ rho s iface -> + has_slot_type Σ (VAddr l) s (SContract a) -> + forall v, + has_slot_type Σ v s sty -> + exists s', + eval_insert s rho r v l s' /\ + has_slot_type Σ (VAddr l) s' (SContract a) /\ + (forall l', state_dom s l' -> state_dom s' l') /\ + (forall v' st, has_slot_type Σ v' s st -> has_slot_type Σ v' s' st). +Proof. + intros Σ iface a r sty s rho l Hwf Href Henv Hloc v Hv. + remember TagS as k eqn:Hk. remember (OSome a) as oid eqn:Hoid. + remember TagU as t eqn:Ht. + induction Href; try discriminate. + - (* T_Storage: r = RVar x *) + inv Hk. inv Hoid. inv Ht. + assert (Hssv : Σ_storage_var Σ a x = Some sty) + by (unfold Σ_storage_var; rewrite H; exact H0). + assert (Hvd : state_var_dom s l x). + { inversion Hloc; subst. + match goal with [Habi : has_abi_type _ _ _ _ |- _] => inversion Habi; subst end. + match goal with [Hdom : forall x0, state_var_dom _ _ x0 <-> _ |- _] => + apply Hdom; eexists; eauto end. } + exists (state_update_var s l x v). + refine (conj _ (conj _ (conj _ _))). + { constructor. exact Hvd. } + { eapply update_preserves_typing; eauto. } + { intros l' Hl'. apply state_update_var_dom. exact Hl'. } + { intros v' st Hv'. eapply update_preserves_typing; eauto. } + - (* T_Field: r = RField r0 x *) + subst k. subst oid. subst t. + destruct (ref_typesafety_untimed _ _ _ _ _ _ _ _ _ Href Henv Hloc) + as [vr [Hevr Htvr]]. + assert (Htvr_copy := Htvr). + inv Htvr. match goal with [Habi : has_abi_type _ _ _ _ |- _] => inv Habi end. + rename l0 into l'. + match goal with + | [Hdom : forall x0, state_var_dom _ _ x0 <-> _, + Hsto : Σ_storage_var _ _ _ = Some _ |- _] => + destruct (Hdom x) as [_ Hdom_bwd]; + assert (Hvd : state_var_dom s l' x) by (apply Hdom_bwd; eexists; eauto) + end. + exists (state_update_var s l' x v). + refine (conj _ (conj _ (conj _ _))). + { eapply E_InsField; eauto. } + { eapply update_preserves_typing; eauto. } + { intros l0 Hl0. apply state_update_var_dom. exact Hl0. } + { intros v' st Hv'. eapply update_preserves_typing; eauto. } +Qed. + +Lemma update_exprs_typesafety : + forall Σ iface a upds s rho l, + Σ_wf Σ -> + Σ_well_typed Σ -> + Forall (fun u => type_update Σ iface (OSome a) u) upds -> + env_well_typed Σ rho s iface -> + has_slot_type Σ (VAddr l) s (SContract a) -> + exists vals s_n, + eval_update_exprs (Σ_cnstr Σ) s rho upds l vals s_n /\ + Forall2 (fun v u => + exists sty, + type_ref Σ iface TagS (OSome a) TagU (fst u) sty /\ + has_slot_type Σ v s_n sty) vals upds /\ + state_incl s s_n /\ + env_well_typed Σ rho s_n iface /\ + has_slot_type Σ (VAddr l) s_n (SContract a) /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s_n st) /\ + creates_typed Σ s s_n. +Proof. + intros Σ iface a upds. intros s rho l Hwf Hwt Hfa. + revert s rho l. + induction Hfa as [|u upds' Hupd _ IH]; intros s rho l Henv Hloc. + - exists [], s. + refine (conj _ (conj _ (conj _ (conj _ (conj _ (conj _ _)))))). + + constructor. + + constructor. + + intros l' ls' Hl'; exact Hl'. + + exact Henv. + + exact Hloc. + + auto. + + apply creates_typed_refl. + - destruct u as [r0 se0]. + inversion Hupd as [? ? ? ? ? st Href Hse]; subst. + destruct (se_typesafety _ _ _ _ _ Hwf Hwt Hse s rho l Henv Hloc) + as [v [s1 [Hev [Htv [Hincl1 [Hpres1 Hct1]]]]]]. + destruct (IH s1 rho l + (valuetyp_storage_weak_env _ _ _ _ _ Hincl1 Henv) + (Hpres1 _ _ Hloc)) + as [vs [sn [Hevs [Htvs [Hincln [Henvn [Hlocn [Hpresn Hctn]]]]]]]]. + exists (v :: vs), sn. + refine (conj _ (conj _ (conj _ (conj _ (conj _ (conj _ _)))))). + + eapply E_UpdExprsCons; eauto. + + constructor. + { exists st. split; [exact Href | apply Hpresn; exact Htv]. } + { exact Htvs. } + + intros l' ls' Hl'. apply Hincln. apply Hincl1. exact Hl'. + + exact Henvn. + + exact Hlocn. + + intros v' st' Hv'. apply Hpresn. apply Hpres1. exact Hv'. + + eapply creates_typed_trans; eauto. +Qed. + +Lemma update_inserts_typesafety : + forall Σ iface a upds vals s rho l, + Σ_wf Σ -> + Forall2 (fun v u => + exists sty, + type_ref Σ iface TagS (OSome a) TagU (fst u) sty /\ + has_slot_type Σ v s sty) vals upds -> + env_well_typed Σ rho s iface -> + has_slot_type Σ (VAddr l) s (SContract a) -> + exists s', + eval_update_inserts s rho upds vals l s' /\ + has_slot_type Σ (VAddr l) s' (SContract a) /\ + (forall l', state_dom s l' -> state_dom s' l') /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st). +Proof. + intros Σ iface a upds vals. + revert upds. + induction vals as [|v vs IH]; intros [|[r se] upds'] s rho l Hwf Hfa Henv Hloc; + try (inv Hfa; fail). + - exists s. refine (conj _ (conj _ (conj _ _))); auto. constructor. + - inv Hfa. + destruct H2 as [sty [Href Htv]]. simpl in Href. + destruct (ref_storage_insert _ _ _ _ _ _ _ _ Hwf Href Henv Hloc v Htv) + as [s1 [Hins [Hloc1 [Hdom1 Hpres1]]]]. + assert (Henv1 : env_well_typed Σ rho s1 iface) + by (eapply env_well_typed_pres; eauto). + assert (Hvals1 : Forall2 (fun v0 u => + exists st, type_ref Σ iface TagS (OSome a) TagU (fst u) st /\ + has_slot_type Σ v0 s1 st) vs upds'). + { eapply Forall2_impl; [|exact H4]. + intros v0 u0 [st0 [Hr0 Ht0]]. eexists; eauto. } + destruct (IH upds' s1 rho l Hwf Hvals1 Henv1 Hloc1) + as [s' [Hinserts [Hloc' [Hdom' Hpres']]]]. + exists s'. refine (conj _ (conj _ (conj _ _))). + + econstructor; eauto. + + exact Hloc'. + + intros l0 Hl0. apply Hdom'. apply Hdom1. exact Hl0. + + intros v' st' Hv'. apply Hpres'. apply Hpres1. exact Hv'. +Qed. + +Lemma update_typesafety : + forall Σ iface a upds s rho l, + Σ_wf Σ -> + Σ_well_typed Σ -> + type_updates Σ iface (OSome a) upds -> + env_well_typed Σ rho s iface -> + has_slot_type Σ (VAddr l) s (SContract a) -> + exists s', + eval_updates (Σ_cnstr Σ) s rho upds l s' /\ + has_slot_type Σ (VAddr l) s' (SContract a) /\ + (forall l', state_dom s l' -> state_dom s' l') /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st) /\ + creates_typed Σ s s'. +Proof. + intros Σ iface a upds s rho l Hwf Hwt Htyp Henv Hloc. + inv Htyp. + destruct (update_exprs_typesafety _ _ _ _ _ _ _ Hwf Hwt H Henv Hloc) + as [vals [s_n [Hevs [Htvs [Hincl_n [Henv_n [Hloc_n [Hpres_n Hct_n]]]]]]]]. + destruct (update_inserts_typesafety _ _ _ _ _ _ _ _ Hwf Htvs Henv_n Hloc_n) + as [s' [Hins [Hloc' [Hdom' Hpres']]]]. + exists s'. refine (conj _ (conj _ (conj _ (conj _ _)))). + - econstructor; eauto. + - exact Hloc'. + - intros l0 Hl0. apply Hdom'. eapply state_incl_dom; eauto. + - intros v st Hv. apply Hpres'. apply Hpres_n. exact Hv. + - (* creates_typed: compose update_exprs (creates) with update_inserts (no new locations) *) + intros l0 Hdom0. + assert (Hdom0_n : state_dom s_n l0). + { eapply eval_update_inserts_dom_back; eauto. } + destruct (Hct_n l0 Hdom0_n) as [Hds | [a0 Ha0]]. + + left. exact Hds. + + right. exists a0. apply Hpres'. exact Ha0. +Qed. + +(* ================================================================= *) +(** ** Constructor Type Safety (Lemma 6.10) *) + +Lemma constructor_typesafety : + forall Σ a ctor s rho, + Σ_wf Σ -> + Σ_well_typed Σ -> + Σ_cnstr Σ a = Some ctor -> + env_well_typed Σ rho s (ctor_iface ctor) -> + Forall (fun pre => eval_expr (TSUntimed s) rho pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + exists l s', + eval_constructor (Σ_cnstr Σ) s rho ctor a l s' /\ + has_slot_type Σ (VAddr l) s' (SContract a) /\ + state_incl s s' /\ + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st) /\ + creates_typed Σ s s'. +Proof. + intros Σ a ctor s rho Hwf Hwt Hcl Henv Hiffs. + destruct (all_ctors_evaluate Σ Hwf Hwt a ctor Hcl s rho Henv Hiffs) + as [l [s' [Heval [Htloc [Hincl [Hpres Hct]]]]]]. + exists l, s'. refine (conj _ (conj Htloc (conj Hincl (conj Hpres Hct)))). + constructor; [exact Hiffs | exact Heval]. +Qed. + +(* ================================================================= *) +(** ** Transition Type Safety (Lemma 6.11) *) + +Lemma transition_typesafety : + forall Σ a tr s rho l, + Σ_wf Σ -> + Σ_well_typed Σ -> + type_transition Σ a tr -> + env_well_typed Σ rho s (trans_iface tr) -> + has_slot_type Σ (VAddr l) s (SContract a) -> + Forall (fun pre => eval_expr (TSUntimed s) rho pre l (VBool true)) + (trans_iff tr) -> + exists v s', + eval_transition (Σ_cnstr Σ) s rho tr l v s' /\ + (forall l', state_dom s l' -> state_dom s' l') /\ + (forall v' st, has_slot_type Σ v' s st -> has_slot_type Σ v' s' st) /\ + creates_typed Σ s s'. +Proof. + intros Σ a tr s rho l Hwf Hwt Htyp Henv Hloc Hiffs. + inv Htyp. + (* Case consistency gives the active case index j *) + destruct (H5 s rho l Henv Hloc Hiffs) as [j [Hj [Hcond_j Hcond_others]]]. + (* Evaluate updates for case j *) + assert (Hupd_j : type_updates Σ (trans_iface tr) (OSome a) + (tc_updates (nth j (trans_cases tr) tc_default))). + { eapply Forall_nth; eauto. } + destruct (update_typesafety _ _ _ _ _ _ _ Hwf Hwt Hupd_j Henv Hloc) + as [s' [Heval_upd [Hloc' [Hdom' [Hpres' Hct']]]]]. + (* Evaluate return expression in timed state (s, s') *) + assert (Hret_typed : type_expr Σ (trans_iface tr) (OSome a) TagT + (tc_return (nth j (trans_cases tr) tc_default)) TAddress). + { eapply Forall_nth; eauto. } + assert (Henv' : env_well_typed Σ rho s' (trans_iface tr)) + by (eapply env_well_typed_pres; eauto). + destruct (expr_typesafety_timed _ _ _ _ _ _ _ _ _ Hret_typed Henv Henv' Hloc Hloc') + as [v [Hev_ret Htv_ret]]. + exists v, s'. split; [|split; [|split]]. + - constructor; auto. econstructor; eauto. + - exact Hdom'. + - exact Hpres'. + - exact Hct'. +Qed. + +(* ================================================================= *) +(** ** Well-formed State Transitions *) + +(** Steps where each step includes env_well_typed *) +Definition wf_step_cnstr (Σ : contract_env) (a : ident) (s : state) (l : addr) (s' : state) : Prop := + exists rho ctor, + Σ_cnstr Σ a = Some ctor /\ + env_well_typed Σ rho s (ctor_iface ctor) /\ + eval_constructor (Σ_cnstr Σ) s rho ctor a l s'. + +Definition wf_step_trans (Σ : contract_env) (a : ident) (s : state) (l : addr) (s' : state) : Prop := + exists rho tr v transs, + Σ_trans Σ a = Some transs /\ + In tr transs /\ + type_transition Σ a tr /\ + has_slot_type Σ (VAddr l) s (SContract a) /\ + env_well_typed Σ rho s (trans_iface tr) /\ + eval_transition (Σ_cnstr Σ) s rho tr l v s'. + +Definition wf_step (Σ : contract_env) (s s' : state) : Prop := + (exists a l, wf_step_cnstr Σ a s l s') \/ + (exists a l, wf_step_trans Σ a s l s'). + +Inductive wf_steps (Σ : contract_env) : state -> state -> Prop := + | WF_Steps_refl : forall s, wf_steps Σ s s + | WF_Steps_step : forall s1 s2 s3, + wf_step Σ s1 s2 -> wf_steps Σ s2 s3 -> wf_steps Σ s1 s3. + +Definition wf_possible (Σ : contract_env) (s : state) : Prop := + wf_steps Σ state_empty s. + +(* ================================================================= *) +(** ** State Transition Type Safety (Lemma 6.12) *) + +Lemma state_transition_typesafety : + forall Σ s s', + Σ_wf Σ -> + Σ_well_typed Σ -> + wf_steps Σ s s' -> + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st) /\ + (forall l, state_dom s l -> state_dom s' l). +Proof. + intros Σ s s' Hwf Hwt Hsteps. + induction Hsteps as [s0 | s1 s2 s3 Hstep Hrest IH]. + - split; auto. + - destruct IH as [IHpres IHdom]. + destruct Hstep as [[a [l' Hcnstr]] | [a [l' Htrans]]]. + + (* Constructor step *) + destruct Hcnstr as [rho [ctor [Hcl [Henv Heval]]]]. + inv Heval. + destruct (all_ctors_evaluate Σ Hwf Hwt a ctor Hcl s1 rho Henv H) + as [l2 [s2' [Heval2 [Hloc2 [Hincl2 [Hpres2 _]]]]]]. + assert (Hdet := ctor_cases_det + (Σ_cnstr Σ) s1 rho (ctor_cases ctor) a l' s2 H0 l2 s2' Heval2). + destruct Hdet as [-> ->]. + split. + * intros v st Hv. apply IHpres. apply Hpres2. exact Hv. + * intros l0 Hl0. apply IHdom. eapply state_incl_dom; eauto. + + (* Transition step *) + destruct Htrans as [rho [tr [v [transs [Htl [Hin [Httyp [Hloc [Henv Heval]]]]]]]]]. + destruct (transition_typesafety _ _ _ _ _ _ Hwf Hwt Httyp Henv Hloc) + as [v' [s2' [Heval2 [Hdom2 [Hpres2 _]]]]]. + * inv Heval. exact H. + * assert (Hdet := transition_determinism + (Σ_cnstr Σ) s1 rho tr l' v s2 v' s2' Heval Heval2). + destruct Hdet as [-> ->]. + split. + -- intros w st Hw. apply IHpres. apply Hpres2. exact Hw. + -- intros l0 Hl0. apply IHdom. apply Hdom2. exact Hl0. +Qed. + +(* ================================================================= *) +(** ** Reachable Store is Well-typed (Lemma 6.13) *) + +Lemma store_wt_aux : + forall Σ s s', + Σ_wf Σ -> + Σ_well_typed Σ -> + wf_steps Σ s s' -> + (forall l, state_dom s l -> exists a, has_slot_type Σ (VAddr l) s (SContract a)) -> + forall l, state_dom s' l -> exists a, has_slot_type Σ (VAddr l) s' (SContract a). +Proof. + intros Σ s s' Hwf Hwt Hsteps. + induction Hsteps as [s0 | s1 s2 s3 Hstep Hrest IH]; intros Hall l Hdom. + - exact (Hall l Hdom). + - apply IH; [|exact Hdom]. clear IH Hrest s3 l Hdom. + intros l Hdom2. + destruct Hstep as [[a [l' Hcnstr]] | [a [l' Htrans]]]. + + (* Constructor step *) + destruct Hcnstr as [rho [ctor [Hcl [Henv Heval]]]]. + inv Heval. + destruct (all_ctors_evaluate Σ Hwf Hwt a ctor Hcl s1 rho Henv H) + as [l2 [s2' [Heval2 [Hloc2 [Hincl2 [Hpres2 Hct2]]]]]]. + assert (Hdet := ctor_cases_det + (Σ_cnstr Σ) s1 rho (ctor_cases ctor) a l' s2 H0 l2 s2' Heval2). + destruct Hdet as [-> ->]. + destruct (Hct2 l Hdom2) as [Hds1 | [a0 Ha0]]. + * destruct (Hall l Hds1) as [a0 Ha0]. exists a0. apply Hpres2. exact Ha0. + * exists a0. exact Ha0. + + (* Transition step *) + destruct Htrans as [rho [tr [v [transs [Htl [Hin [Httyp [Hloc [Henv Heval]]]]]]]]]. + destruct (transition_typesafety _ _ _ _ _ _ Hwf Hwt Httyp Henv Hloc) + as [v' [s2' [Heval2 [Hdom2' [Hpres2 Hct2]]]]]. + { inv Heval. exact H. } + assert (Hdet := transition_determinism + (Σ_cnstr Σ) s1 rho tr l' v s2 v' s2' Heval Heval2). + destruct Hdet as [-> ->]. + destruct (Hct2 l Hdom2) as [Hds1 | [a0 Ha0]]. + * destruct (Hall l Hds1) as [a0 Ha0]. exists a0. apply Hpres2. exact Ha0. + * exists a0. exact Ha0. +Qed. + +Lemma store_wt : + forall Σ s l, + Σ_wf Σ -> + Σ_well_typed Σ -> + wf_possible Σ s -> + state_dom s l -> + exists a, has_slot_type Σ (VAddr l) s (SContract a). +Proof. + intros Σ s l Hwf Hwt Hposs Hdom. + eapply store_wt_aux; eauto. + intros l0 [ls0 Hls0]. + exfalso. simpl in Hls0. discriminate. +Qed. diff --git a/theories/Typing.v b/theories/Typing.v new file mode 100644 index 00000000..24f853e1 --- /dev/null +++ b/theories/Typing.v @@ -0,0 +1,554 @@ +(** * Typing Judgments + Formalizes Section 4 of the tech report: type well-formedness, + reference judgments, expression judgments, mapping expression + judgments, slot expression judgments, create/update judgments, + constructor/transition judgments, and spec/contract judgments. *) + +From Stdlib Require Import String ZArith List Bool. +From Act Require Import Maps Syntax Domains Semantics ValueTyping. +Import ListNotations. + +(* ================================================================= *) +(** ** S/N tags for reference judgment *) + +Inductive ref_tag : Type := + | TagS : ref_tag (** storage reference reachable without coercion *) + | TagN : ref_tag. (** calldata, coerced, or environment reference *) + +(* ================================================================= *) +(** ** Type Well-formedness *) + +(** Σ ⊢ α wf *) +Inductive abi_type_wf (Σ : contract_env) : abi_type -> Prop := + | WF_Int : forall it, + it <> IntUnbounded -> + abi_type_wf Σ (ABase (TInt it)) + | WF_Bool : + abi_type_wf Σ (ABase TBool) + | WF_Address : + abi_type_wf Σ (ABase TAddress) + | WF_ContractAddr : forall a, + dom (Σ_storage Σ) a -> + abi_type_wf Σ (AContractAddr a). + +(** Σ ⊢ σ wf *) +Inductive slot_type_wf (Σ : contract_env) : slot_type -> Prop := + | WF_Contract : forall a, + dom (Σ_storage Σ) a -> + slot_type_wf Σ (SContract a) + | WF_SAbi : forall alpha, + abi_type_wf Σ alpha -> + slot_type_wf Σ (SAbi alpha) + | WF_SMapping : forall mu, + slot_type_wf Σ (SMapping mu). + +(** Σ ⊢ I wf *) +Definition interface_wf (Σ : contract_env) (iface : interface) : Prop := + Forall (fun p => abi_type_wf Σ (snd p)) iface /\ + ~ alist_dom iface "caller"%string /\ + ~ alist_dom iface "origin"%string /\ + ~ alist_dom iface "callvalue"%string. + +(* ================================================================= *) +(** ** Environment References Judgment *) +(** Σ; I ⊢_{⊥?Id} env : α *) + +Inductive type_env_ref : contract_env -> interface -> opt_id -> env_var -> abi_type -> Prop := + | T_Caller : forall Σ iface oid, + type_env_ref Σ iface oid EnvCaller (ABase TAddress) + | T_Origin : forall Σ iface oid, + type_env_ref Σ iface oid EnvOrigin (ABase TAddress) + | T_Callvalue : forall Σ iface oid, + type_env_ref Σ iface oid EnvCallvalue (ABase (TInt (UintT 256))) + | T_This : forall Σ iface a, + type_env_ref Σ iface (OSome a) EnvThis (AContractAddr a). + +(* ================================================================= *) +(** ** Reference Judgment *) +(** Σ; I ⊢^k_{⊥?Id, t} ref : σ *) + +Inductive type_ref : contract_env -> interface -> ref_tag -> opt_id -> time_tag -> + ref -> slot_type -> Prop := + (** T-Calldata *) + | T_Calldata : forall Σ iface oid t x alpha, + alist_lookup iface x = Some alpha -> + type_ref Σ iface TagN oid t (RVar x) (SAbi alpha) + + (** T-Storage *) + | T_Storage : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref Σ iface TagS (OSome a) TagU (RVar x) sty + + (** T-StoragePre *) + | T_StoragePre : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref Σ iface TagS (OSome a) TagT (RPre x) sty + + (** T-StoragePost *) + | T_StoragePost : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref Σ iface TagS (OSome a) TagT (RPost x) sty + + (** T-Coerce *) + | T_Coerce : forall Σ iface k oid t r a, + type_ref Σ iface k oid t r (SAbi (AContractAddr a)) -> + type_ref Σ iface TagN oid t (RCoerce r a) (SContract a) + + (** T-Upcast *) + | T_Upcast : forall Σ iface k oid t r a, + type_ref Σ iface k oid t r (SAbi (AContractAddr a)) -> + type_ref Σ iface TagN oid t r (SAbi (ABase TAddress)) + + (** T-Field *) + | T_Field : forall Σ iface k oid t r a x sty, + type_ref Σ iface k oid t r (SContract a) -> + Σ_storage_var Σ a x = Some sty -> + type_ref Σ iface k oid t (RField r x) sty + + (** T-MapIndex *) + | T_MapIndex : forall Σ iface k oid t r e bt mu, + type_ref Σ iface k oid t r (SMapping (MMapping bt mu)) -> + type_expr Σ iface oid t e bt -> + type_ref Σ iface TagN oid t (RIndex r e) (SMapping mu) + + (** T-Environment *) + | T_Environment : forall Σ iface oid ev alpha, + type_env_ref Σ iface oid ev alpha -> + type_ref Σ iface TagN oid TagU (REnv ev) (SAbi alpha) + +(* ================================================================= *) +(** ** Expression Judgment *) +(** Σ; I; Φ ⊢_{⊥?Id, t} e : β *) + +with type_expr : contract_env -> interface -> opt_id -> time_tag -> + expr -> base_type -> Prop := + (** T-Int *) + | T_Int : forall Σ iface oid t n it, + in_range it n -> + type_expr Σ iface oid t (EInt n) (TInt it) + + (** T-Bool *) + | T_Bool : forall Σ iface oid t b, + type_expr Σ iface oid t (EBool b) TBool + + (** T-Ref *) + | T_Ref : forall Σ iface oid t k r bt, + type_ref Σ iface k oid t r (SAbi (ABase bt)) -> + type_expr Σ iface oid t (ERef r) bt + + (** T-Addr *) + | T_Addr : forall Σ iface oid k r a, + type_ref Σ iface k oid TagU r (SContract a) -> + type_expr Σ iface oid TagU (EAddr r) TAddress + + (** T-Range *) + | T_Range : forall Σ iface oid t e it1 it2, + type_expr Σ iface oid t e (TInt it2) -> + type_expr Σ iface oid t (EInRange it1 e) TBool + + (** T-BopI *) + | T_BopI : forall Σ iface oid t e1 op e2 it1 it2, + type_expr Σ iface oid t e1 (TInt it1) -> + type_expr Σ iface oid t e2 (TInt it2) -> + type_expr Σ iface oid t (EBopI e1 op e2) (TInt IntUnbounded) + + (** T-NumConv *) + | T_NumConv : forall Σ iface oid t e it, + type_expr Σ iface oid t e (TInt it) -> + type_expr Σ iface oid t e (TInt IntUnbounded) + + (** T-BopB *) + | T_BopB : forall Σ iface oid t e1 op e2, + type_expr Σ iface oid t e1 TBool -> + type_expr Σ iface oid t e2 TBool -> + type_expr Σ iface oid t (EBopB e1 op e2) TBool + + (** T-Neg *) + | T_Neg : forall Σ iface oid t e, + type_expr Σ iface oid t e TBool -> + type_expr Σ iface oid t (ENeg e) TBool + + (** T-Cmp *) + | T_Cmp : forall Σ iface oid t e1 op e2 it, + type_expr Σ iface oid t e1 (TInt it) -> + type_expr Σ iface oid t e2 (TInt it) -> + type_expr Σ iface oid t (ECmp e1 op e2) TBool + + (** T-ITE *) + | T_ITE : forall Σ iface oid t e1 e2 e3 bt, + type_expr Σ iface oid t e1 TBool -> + type_expr Σ iface oid t e2 bt -> + type_expr Σ iface oid t e3 bt -> + type_expr Σ iface oid t (EITE e1 e2 e3) bt + + (** T-Eq *) + | T_Eq : forall Σ iface oid t e1 e2 bt, + type_expr Σ iface oid t e1 bt -> + type_expr Σ iface oid t e2 bt -> + type_expr Σ iface oid t (EEq e1 e2) TBool. + +(** Mutual induction schemes for type_ref / type_expr *) +Scheme type_ref_ind2 := Induction for type_ref Sort Prop + with type_expr_ind2 := Induction for type_expr Sort Prop. +Combined Scheme type_ref_expr_mutind from type_ref_ind2, type_expr_ind2. + +(* ================================================================= *) +(** ** Mapping Expression Judgment *) +(** Σ; I; Φ ⊢_{⊥?Id} m : μ *) + +Inductive type_mapexpr : contract_env -> interface -> opt_id -> + map_expr -> mapping_type -> Prop := + (** T-Exp *) + | T_Exp : forall Σ iface oid e bt, + type_expr Σ iface oid TagU e bt -> + type_mapexpr Σ iface oid (MExp e) (MBase bt) + + (** T-Mapping *) + | T_Mapping : forall Σ iface oid bindings bt mu, + default_value_typable mu -> + Forall (fun p => type_expr Σ iface oid TagU (fst p) bt) bindings -> + Forall (fun p => type_mapexpr Σ iface oid (snd p) mu) bindings -> + type_mapexpr Σ iface oid (MMap bindings (MMapping bt mu)) (MMapping bt mu) + + (** T-MappingUpd *) + | T_MappingUpd : forall Σ iface oid r bindings bt mu k, + type_ref Σ iface k oid TagU r (SMapping (MMapping bt mu)) -> + Forall (fun p => type_expr Σ iface oid TagU (fst p) bt) bindings -> + Forall (fun p => type_mapexpr Σ iface oid (snd p) mu) bindings -> + type_mapexpr Σ iface oid (MMapUpd r bindings (MMapping bt mu)) (MMapping bt mu). + +(* ================================================================= *) +(** ** Slot Expression Judgment *) +(** Σ; I; Φ ⊢_{⊥?Id} se : σ *) + +Inductive type_slotexpr : contract_env -> interface -> opt_id -> + slot_expr -> slot_type -> Prop := + (** T-MapExp *) + | T_SlotMap : forall Σ iface oid m mu, + type_mapexpr Σ iface oid m mu -> + type_slotexpr Σ iface oid (SEMap m) (SMapping mu) + + (** T-SlotRef *) + | T_SlotRef : forall Σ iface oid k r a, + type_ref Σ iface k oid TagU r (SContract a) -> + type_slotexpr Σ iface oid (SERef r) (SContract a) + + (** T-SlotAddr *) + | T_SlotAddr : forall Σ iface oid se a, + type_slotexpr Σ iface oid se (SContract a) -> + type_slotexpr Σ iface oid (SEAddr se) (SAbi (AContractAddr a)) + + (** T-Create *) + | T_Create : forall Σ iface oid a ctor ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = false -> + Forall2 (fun se alpha => type_slotexpr Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + (** P4: semantic entailment of constructor preconditions *) + (forall s rho l vals s_final, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + Forall (fun pre => + eval_expr (TSUntimed s_final) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) (VInt 0%Z)) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + type_slotexpr Σ iface oid (SENew a None ses) (SContract a) + + (** T-CreatePayable *) + | T_CreatePayable : forall Σ iface oid a ctor se_val ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = true -> + Forall2 (fun se alpha => type_slotexpr Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + type_slotexpr Σ iface oid se_val (SAbi (ABase (TInt (UintT 256)))) -> + (** P4: semantic entailment of constructor preconditions *) + (forall s rho l vals s_final sv s_v, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + eval_slotexpr (Σ_cnstr Σ) s_final rho se_val l sv s_v -> + Forall (fun pre => + eval_expr (TSUntimed s_v) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) sv) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + type_slotexpr Σ iface oid (SENew a (Some se_val) ses) (SContract a). + +(** Custom induction principle for [type_slotexpr] that gives an IH + for every element in the [Forall2] premises of T_Create / T_CreatePayable. *) +Section type_slotexpr_ind. + +Variable P : contract_env -> interface -> opt_id -> slot_expr -> slot_type -> Prop. + +Hypothesis H_SlotMap : forall Σ iface oid m mu, + type_mapexpr Σ iface oid m mu -> + P Σ iface oid (SEMap m) (SMapping mu). + +Hypothesis H_SlotRef : forall Σ iface oid k r a, + type_ref Σ iface k oid TagU r (SContract a) -> + P Σ iface oid (SERef r) (SContract a). + +Hypothesis H_SlotAddr : forall Σ iface oid se a, + type_slotexpr Σ iface oid se (SContract a) -> + P Σ iface oid se (SContract a) -> + P Σ iface oid (SEAddr se) (SAbi (AContractAddr a)). + +Hypothesis H_Create : forall Σ iface oid a ctor ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = false -> + Forall2 (fun se alpha => type_slotexpr Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + Forall2 (fun se alpha => P Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + (forall s rho l vals s_final, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + Forall (fun pre => + eval_expr (TSUntimed s_final) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) (VInt 0%Z)) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + P Σ iface oid (SENew a None ses) (SContract a). + +Hypothesis H_CreatePayable : forall Σ iface oid a ctor se_val ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = true -> + Forall2 (fun se alpha => type_slotexpr Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + Forall2 (fun se alpha => P Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + type_slotexpr Σ iface oid se_val (SAbi (ABase (TInt (UintT 256)))) -> + P Σ iface oid se_val (SAbi (ABase (TInt (UintT 256)))) -> + (forall s rho l vals s_final sv s_v, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + eval_slotexpr (Σ_cnstr Σ) s_final rho se_val l sv s_v -> + Forall (fun pre => + eval_expr (TSUntimed s_v) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) sv) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + P Σ iface oid (SENew a (Some se_val) ses) (SContract a). + +Lemma type_slotexpr_ind2 : + forall Σ iface oid se st, + type_slotexpr Σ iface oid se st -> P Σ iface oid se st. +Proof. + fix IH 6. intros Σ iface oid se st Htyp. + destruct Htyp as [sg0 iface0 oid0 m mu Hm + | sg0 iface0 oid0 k r a Hr + | sg0 iface0 oid0 se0 a Hse0 + | sg0 iface0 oid0 a ctor ses Hcl Hnp Hses HP4 + | sg0 iface0 oid0 a ctor se_val ses Hcl Hpay Hses Hval HP4]. + - apply H_SlotMap; exact Hm. + - apply H_SlotRef with (k := k); exact Hr. + - apply H_SlotAddr; [exact Hse0 | exact (IH _ _ _ _ _ Hse0)]. + - assert (HIH : Forall2 (fun se alpha => P sg0 iface0 oid0 se (SAbi alpha)) + ses (map snd (ctor_iface ctor))). + { clear Hcl Hnp HP4. + induction Hses as [|se0 alpha0 rses ralphas Hse0 Hrest IHfa]. + - constructor. + - constructor; [exact (IH _ _ _ _ _ Hse0) | exact IHfa]. } + exact (H_Create _ _ _ _ _ _ Hcl Hnp Hses HIH HP4). + - assert (HIH : Forall2 (fun se alpha => P sg0 iface0 oid0 se (SAbi alpha)) + ses (map snd (ctor_iface ctor))). + { clear Hcl Hpay HP4 Hval. + induction Hses as [|se0 alpha0 rses ralphas Hse0 Hrest IHfa]. + - constructor. + - constructor; [exact (IH _ _ _ _ _ Hse0) | exact IHfa]. } + exact (H_CreatePayable _ _ _ _ _ _ _ Hcl Hpay Hses HIH Hval (IH _ _ _ _ _ Hval) HP4). +Qed. + +End type_slotexpr_ind. + +(* ================================================================= *) +(** ** Create Judgment *) +(** Σ; I; Φ ⊢_Id creates : C *) + +Inductive type_creates : contract_env -> interface -> opt_id -> + list create -> storage_layout -> Prop := + | T_Creates : forall Σ iface oid creates layout, + (* C = {x₁ : σ₁, ..., xₙ : σₙ} *) + layout = map (fun c => (snd (fst c), fst (fst c))) creates -> + (* balance : uint256 ∈ C *) + alist_lookup layout "balance"%string = Some (SAbi (ABase (TInt (UintT 256)))) -> + (* ∀ i. Σ ⊢ σᵢ wf *) + Forall (fun c => slot_type_wf Σ (fst (fst c))) creates -> + (* ∀ i. Σ; I; Φ ⊢_⊥ seᵢ : σᵢ *) + Forall (fun c => type_slotexpr Σ iface ONone (snd c) (fst (fst c))) creates -> + type_creates Σ iface oid creates layout. + +(* ================================================================= *) +(** ** Update Judgment *) +(** Σ; I; Φ ⊢_Id update *) + +Inductive type_update : contract_env -> interface -> opt_id -> + update -> Prop := + | T_Update : forall Σ iface oid r se sty, + type_ref Σ iface TagS oid TagU r sty -> + type_slotexpr Σ iface oid se sty -> + type_update Σ iface oid (r, se). + +(** Σ; I; Φ ⊢_Id updates *) +Inductive type_updates : contract_env -> interface -> opt_id -> + list update -> Prop := + | T_Updates : forall Σ iface oid upds, + Forall (fun u => type_update Σ iface oid u) upds -> + (* no-overlap condition: ¬(refⱼ ⪯_specific refᵢ) *) + (forall i j, i < length upds -> j < i -> + ~ more_specific_eq (fst (nth j upds (RVar ""%string, SEMap (MExp (EBool false))))) + (fst (nth i upds (RVar ""%string, SEMap (MExp (EBool false)))))) -> + type_updates Σ iface oid upds. + +(* ================================================================= *) +(** ** Constructor Judgment *) +(** Σ ⊢_Id cnstr : C *) + +Inductive type_constructor : contract_env -> ident -> constructor -> + storage_layout -> Prop := + | T_Ctor : forall Σ a ctor layout, + (* Σ ⊢ I wf *) + interface_wf Σ (ctor_iface ctor) -> + (* preconditions well-typed *) + Forall (fun pre => type_expr Σ (ctor_iface ctor) ONone TagU pre TBool) + (ctor_iff ctor) -> + (* case conditions well-typed *) + Forall (fun cc => type_expr Σ (ctor_iface ctor) ONone TagU (fst cc) TBool) + (ctor_cases ctor) -> + (* creates well-typed *) + Forall (fun cc => type_creates Σ (ctor_iface ctor) (OSome a) (snd cc) layout) + (ctor_cases ctor) -> + (* all slot types in C are well-formed *) + Forall (fun p => slot_type_wf Σ (snd p)) layout -> + (* dom(C) ∩ dom(I) = ∅ *) + (forall x, alist_dom layout x -> ~ alist_dom (ctor_iface ctor) x) -> + (* postconditions well-typed under Σ' = Σ with {Storage = (Σ_Storage, Id : C)} *) + let Σ' := Σ_with_storage Σ a layout in + Forall (fun post => type_expr Σ' (ctor_iface ctor) (OSome a) TagU post TBool) + (ctor_post ctor) -> + (* case consistency: exactly one case is true when preconditions hold *) + (forall s rho, + Forall (fun pre => eval_expr (TSUntimed s) rho pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + exists j, j < length (ctor_cases ctor) /\ + eval_expr (TSUntimed s) rho (fst (nth j (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool true) /\ + forall i, i <> j -> i < length (ctor_cases ctor) -> + eval_expr (TSUntimed s) rho (fst (nth i (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool false)) -> + type_constructor Σ a ctor layout. + +(* ================================================================= *) +(** ** Transition Judgment *) +(** Σ ⊢_Id trans *) + +Inductive type_transition : contract_env -> ident -> transition -> Prop := + | T_Trans : forall Σ a tr, + (* Σ ⊢ I wf *) + interface_wf Σ (trans_iface tr) -> + (* preconditions well-typed *) + Forall (fun pre => type_expr Σ (trans_iface tr) (OSome a) TagU pre TBool) + (trans_iff tr) -> + (* case conditions well-typed *) + Forall (fun tc => type_expr Σ (trans_iface tr) (OSome a) TagU (tc_cond tc) TBool) + (trans_cases tr) -> + (* updates well-typed *) + Forall (fun tc => type_updates Σ (trans_iface tr) (OSome a) (tc_updates tc)) + (trans_cases tr) -> + (* returns well-typed *) + Forall (fun tc => type_expr Σ (trans_iface tr) (OSome a) TagT + (tc_return tc) TAddress) + (trans_cases tr) -> + (* postconditions well-typed *) + Forall (fun post => type_expr Σ (trans_iface tr) (OSome a) TagT post TBool) + (trans_post tr) -> + (* case consistency: exactly one case is true when preconditions hold *) + (forall s rho l, + env_well_typed Σ rho s (trans_iface tr) -> + has_slot_type Σ (VAddr l) s (SContract a) -> + Forall (fun pre => eval_expr (TSUntimed s) rho pre l (VBool true)) + (trans_iff tr) -> + exists j, j < length (trans_cases tr) /\ + eval_expr (TSUntimed s) rho (tc_cond (nth j (trans_cases tr) tc_default)) l (VBool true) /\ + forall i, i <> j -> i < length (trans_cases tr) -> + eval_expr (TSUntimed s) rho (tc_cond (nth i (trans_cases tr) tc_default)) l (VBool false)) -> + type_transition Σ a tr. + +(* ================================================================= *) +(** ** Well-typed Σ (Definition 6.1) *) + +(** S1: for every A ∈ dom(Σ_Cnstr) exists Σ' ⊆ Σ well-typed, + such that Σ' ⊢_A Σ_Cnstr(A) : Σ_Storage(A) + S2: for every A ∈ dom(Σ_Trans) exists Σ' ⊆ Σ well-typed, + such that ∀ trans ∈ Σ_Trans(A). Σ' ⊢_A trans *) +Inductive Σ_well_typed : contract_env -> Prop := + | Σ_WT : forall Σ, + (* S0: all storage layouts have well-formed slot types *) + (forall a layout, Σ_storage Σ a = Some layout -> + Forall (fun p => slot_type_wf Σ (snd p)) layout) -> + (* S1: constructors *) + (forall a ctor, + Σ_cnstr Σ a = Some ctor -> + exists Σ' layout, + Σ_incl Σ' Σ /\ + Σ_cnstr Σ' a = None /\ + Σ_cnstr_size Σ' < Σ_cnstr_size Σ /\ + Σ_well_typed Σ' /\ + type_constructor Σ' a ctor layout /\ + Σ_storage Σ a = Some layout) -> + (* S2: transitions *) + (forall a transs, + Σ_trans Σ a = Some transs -> + exists Σ', + Σ_incl Σ' Σ /\ Σ_well_typed Σ' /\ + Forall (fun tr => type_transition Σ' a tr) transs) -> + Σ_well_typed Σ. + +(* ================================================================= *) +(** ** Contract Judgment *) +(** Σ ⊢ contract : Σ' *) + +Inductive type_contract : contract_env -> contract -> contract_env -> Prop := + | T_Contract : forall Σ c layout, + let a := contract_name c in + let ctor := contract_ctor c in + let transs := contract_trans c in + let invs := contract_inv c in + (* freshness: contract name not already in Σ *) + ~ dom (Σ_storage Σ) a -> + ~ dom (Σ_cnstr Σ) a -> + ~ dom (Σ_trans Σ) a -> + (* Σ ⊢_Id cnstr : C *) + type_constructor Σ a ctor layout -> + (* Σ' = Σ with {Storage, Cnstr} *) + let Σ' := Σ_with_cnstr (Σ_with_storage Σ a layout) a ctor in + (* ∀ trans. Σ' ⊢_Id trans *) + Forall (fun tr => type_transition Σ' a tr) transs -> + (* invariants well-typed *) + Forall (fun inv => type_expr Σ' (ctor_iface ctor) (OSome a) TagU inv TBool) invs -> + (* Σ'' = Σ' with {Trans} *) + let Σ'' := Σ_with_trans Σ' a transs in + type_contract Σ c Σ''. + +(* ================================================================= *) +(** ** Spec Judgment *) +(** ⊢ spec : Σ *) + +Inductive type_spec : spec -> contract_env -> Prop := + | T_SpecNil : + type_spec [] Σ_empty + | T_SpecCons : forall c rest Σ Σ', + type_spec rest Σ -> + type_contract Σ c Σ' -> + type_spec (c :: rest) Σ'. diff --git a/theories/TypingT.v b/theories/TypingT.v new file mode 100644 index 00000000..e9bc94da --- /dev/null +++ b/theories/TypingT.v @@ -0,0 +1,523 @@ +(** * Typing Judgments in Type + Mirror of Typing.v but with all inductives in Type instead of Prop, + enabling large elimination for defining denotation functions. + Includes correspondence lemmas: Type → Prop. *) + +From Stdlib Require Import String ZArith List Bool. +From Act Require Import Maps Syntax Domains Semantics ValueTyping Typing. +Import ListNotations. + +(* ================================================================= *) +(** ** ForallT / Forall2T — Type-valued versions of Forall / Forall2 *) + +Inductive ForallT {A : Type} (P : A -> Type) : list A -> Type := + | ForallT_nil : ForallT P [] + | ForallT_cons : forall x xs, P x -> ForallT P xs -> ForallT P (x :: xs). + +Arguments ForallT_nil {A P}. +Arguments ForallT_cons {A P x xs}. + +Inductive Forall2T {A B : Type} (R : A -> B -> Type) : list A -> list B -> Type := + | Forall2T_nil : Forall2T R [] [] + | Forall2T_cons : forall x y xs ys, + R x y -> Forall2T R xs ys -> Forall2T R (x :: xs) (y :: ys). + +Arguments Forall2T_nil {A B R}. +Arguments Forall2T_cons {A B R x y xs ys}. + +(** Correspondence: ForallT → Forall *) +Lemma ForallT_to_Forall : forall {A} {P : A -> Prop} {l}, + ForallT P l -> Forall P l. +Proof. + intros A P l H. induction H; constructor; assumption. +Qed. + +Lemma Forall2T_to_Forall2 : forall {A B} {R : A -> B -> Prop} {la lb}, + Forall2T R la lb -> Forall2 R la lb. +Proof. + intros A B R la lb H. induction H; constructor; assumption. +Qed. + +Lemma ForallT_map : forall {A} {P : A -> Type} {Q : A -> Prop} {l}, + (forall a, P a -> Q a) -> ForallT P l -> Forall Q l. +Proof. + intros A P Q l f H. induction H; constructor; auto. +Qed. + +Lemma Forall2T_map : forall {A B} {P : A -> B -> Type} {Q : A -> B -> Prop} + {la lb}, + (forall a b, P a b -> Q a b) -> Forall2T P la lb -> Forall2 Q la lb. +Proof. + intros A B P Q la lb f H. induction H; constructor; auto. +Qed. + +(* ================================================================= *) +(** ** Environment References — Type version *) + +Inductive type_env_ref_t : contract_env -> interface -> opt_id -> env_var -> abi_type -> Type := + | T_Caller_t : forall Σ iface oid, + type_env_ref_t Σ iface oid EnvCaller (ABase TAddress) + | T_Origin_t : forall Σ iface oid, + type_env_ref_t Σ iface oid EnvOrigin (ABase TAddress) + | T_Callvalue_t : forall Σ iface oid, + type_env_ref_t Σ iface oid EnvCallvalue (ABase (TInt (UintT 256))) + | T_This_t : forall Σ iface a, + type_env_ref_t Σ iface (OSome a) EnvThis (AContractAddr a). + +(* ================================================================= *) +(** ** References and Expressions — Type version (mutual) *) + +Inductive type_ref_t : contract_env -> interface -> ref_tag -> opt_id -> time_tag -> + ref -> slot_type -> Type := + | T_Calldata_t : forall Σ iface oid t x alpha, + alist_lookup iface x = Some alpha -> + type_ref_t Σ iface TagN oid t (RVar x) (SAbi alpha) + + | T_Storage_t : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref_t Σ iface TagS (OSome a) TagU (RVar x) sty + + | T_StoragePre_t : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref_t Σ iface TagS (OSome a) TagT (RPre x) sty + + | T_StoragePost_t : forall Σ iface a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + ~ alist_dom iface x -> + x <> "caller"%string -> x <> "origin"%string -> x <> "callvalue"%string -> + type_ref_t Σ iface TagS (OSome a) TagT (RPost x) sty + + | T_Coerce_t : forall Σ iface k oid t r a, + type_ref_t Σ iface k oid t r (SAbi (AContractAddr a)) -> + type_ref_t Σ iface TagN oid t (RCoerce r a) (SContract a) + + | T_Upcast_t : forall Σ iface k oid t r a, + type_ref_t Σ iface k oid t r (SAbi (AContractAddr a)) -> + type_ref_t Σ iface TagN oid t r (SAbi (ABase TAddress)) + + | T_Field_t : forall Σ iface k oid t r a x sty, + type_ref_t Σ iface k oid t r (SContract a) -> + Σ_storage_var Σ a x = Some sty -> + type_ref_t Σ iface k oid t (RField r x) sty + + | T_MapIndex_t : forall Σ iface k oid t r e bt mu, + type_ref_t Σ iface k oid t r (SMapping (MMapping bt mu)) -> + type_expr_t Σ iface oid t e bt -> + type_ref_t Σ iface TagN oid t (RIndex r e) (SMapping mu) + + | T_Environment_t : forall Σ iface oid ev alpha, + type_env_ref_t Σ iface oid ev alpha -> + type_ref_t Σ iface TagN oid TagU (REnv ev) (SAbi alpha) + +with type_expr_t : contract_env -> interface -> opt_id -> time_tag -> + expr -> base_type -> Type := + | T_Int_t : forall Σ iface oid t n it, + in_range it n -> + type_expr_t Σ iface oid t (EInt n) (TInt it) + + | T_Bool_t : forall Σ iface oid t b, + type_expr_t Σ iface oid t (EBool b) TBool + + | T_Ref_t : forall Σ iface oid t k r bt, + type_ref_t Σ iface k oid t r (SAbi (ABase bt)) -> + type_expr_t Σ iface oid t (ERef r) bt + + | T_Addr_t : forall Σ iface oid k r a, + type_ref_t Σ iface k oid TagU r (SContract a) -> + type_expr_t Σ iface oid TagU (EAddr r) TAddress + + | T_Range_t : forall Σ iface oid t e it1 it2, + type_expr_t Σ iface oid t e (TInt it2) -> + type_expr_t Σ iface oid t (EInRange it1 e) TBool + + | T_BopI_t : forall Σ iface oid t e1 op e2 it1 it2, + type_expr_t Σ iface oid t e1 (TInt it1) -> + type_expr_t Σ iface oid t e2 (TInt it2) -> + type_expr_t Σ iface oid t (EBopI e1 op e2) (TInt IntUnbounded) + + | T_NumConv_t : forall Σ iface oid t e it, + type_expr_t Σ iface oid t e (TInt it) -> + type_expr_t Σ iface oid t e (TInt IntUnbounded) + + | T_BopB_t : forall Σ iface oid t e1 op e2, + type_expr_t Σ iface oid t e1 TBool -> + type_expr_t Σ iface oid t e2 TBool -> + type_expr_t Σ iface oid t (EBopB e1 op e2) TBool + + | T_Neg_t : forall Σ iface oid t e, + type_expr_t Σ iface oid t e TBool -> + type_expr_t Σ iface oid t (ENeg e) TBool + + | T_Cmp_t : forall Σ iface oid t e1 op e2 it, + type_expr_t Σ iface oid t e1 (TInt it) -> + type_expr_t Σ iface oid t e2 (TInt it) -> + type_expr_t Σ iface oid t (ECmp e1 op e2) TBool + + | T_ITE_t : forall Σ iface oid t e1 e2 e3 bt, + type_expr_t Σ iface oid t e1 TBool -> + type_expr_t Σ iface oid t e2 bt -> + type_expr_t Σ iface oid t e3 bt -> + type_expr_t Σ iface oid t (EITE e1 e2 e3) bt + + | T_Eq_t : forall Σ iface oid t e1 e2 bt, + type_expr_t Σ iface oid t e1 bt -> + type_expr_t Σ iface oid t e2 bt -> + type_expr_t Σ iface oid t (EEq e1 e2) TBool. + +(** Mutual induction schemes are auto-generated for Type inductives. *) + +(* ================================================================= *) +(** ** Mapping Expression — Type version *) + +Inductive type_mapexpr_t : contract_env -> interface -> opt_id -> + map_expr -> mapping_type -> Type := + | T_Exp_t : forall Σ iface oid e bt, + type_expr_t Σ iface oid TagU e bt -> + type_mapexpr_t Σ iface oid (MExp e) (MBase bt) + + | T_Mapping_t : forall Σ iface oid bindings bt mu, + default_value_typable mu -> + ForallT (fun p => type_expr_t Σ iface oid TagU (fst p) bt) bindings -> + ForallT (fun p => type_mapexpr_t Σ iface oid (snd p) mu) bindings -> + type_mapexpr_t Σ iface oid (MMap bindings (MMapping bt mu)) (MMapping bt mu) + + | T_MappingUpd_t : forall Σ iface oid r bindings bt mu k, + type_ref_t Σ iface k oid TagU r (SMapping (MMapping bt mu)) -> + ForallT (fun p => type_expr_t Σ iface oid TagU (fst p) bt) bindings -> + ForallT (fun p => type_mapexpr_t Σ iface oid (snd p) mu) bindings -> + type_mapexpr_t Σ iface oid (MMapUpd r bindings (MMapping bt mu)) (MMapping bt mu). + +(* ================================================================= *) +(** ** Slot Expression — Type version *) + +Inductive type_slotexpr_t : contract_env -> interface -> opt_id -> + slot_expr -> slot_type -> Type := + | T_SlotMap_t : forall Σ iface oid m mu, + type_mapexpr_t Σ iface oid m mu -> + type_slotexpr_t Σ iface oid (SEMap m) (SMapping mu) + + | T_SlotRef_t : forall Σ iface oid k r a, + type_ref_t Σ iface k oid TagU r (SContract a) -> + type_slotexpr_t Σ iface oid (SERef r) (SContract a) + + | T_SlotAddr_t : forall Σ iface oid se a, + type_slotexpr_t Σ iface oid se (SContract a) -> + type_slotexpr_t Σ iface oid (SEAddr se) (SAbi (AContractAddr a)) + + | T_Create_t : forall Σ iface oid a ctor ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = false -> + Forall2T (fun se alpha => type_slotexpr_t Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + (** P4: semantic entailment — stays in Prop *) + (forall s rho l vals s_final, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + Forall (fun pre => + eval_expr (TSUntimed s_final) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) (VInt 0%Z)) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + type_slotexpr_t Σ iface oid (SENew a None ses) (SContract a) + + | T_CreatePayable_t : forall Σ iface oid a ctor se_val ses, + Σ_cnstr Σ a = Some ctor -> + isPayable ctor = true -> + Forall2T (fun se alpha => type_slotexpr_t Σ iface oid se (SAbi alpha)) + ses (map snd (ctor_iface ctor)) -> + type_slotexpr_t Σ iface oid se_val (SAbi (ABase (TInt (UintT 256)))) -> + (** P4: semantic entailment — stays in Prop *) + (forall s rho l vals s_final sv s_v, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + eval_slotexpr_list (Σ_cnstr Σ) s rho ses l vals s_final -> + eval_slotexpr (Σ_cnstr Σ) s_final rho se_val l sv s_v -> + Forall (fun pre => + eval_expr (TSUntimed s_v) + (build_ctor_env (ctor_iface ctor) vals l (env_origin rho) sv) + pre dummy_loc (VBool true)) + (ctor_iff ctor)) -> + type_slotexpr_t Σ iface oid (SENew a (Some se_val) ses) (SContract a). + +(* ================================================================= *) +(** ** Create — Type version *) + +Inductive type_creates_t : contract_env -> interface -> opt_id -> + list create -> storage_layout -> Type := + | T_Creates_t : forall Σ iface oid creates layout, + layout = map (fun c => (snd (fst c), fst (fst c))) creates -> + alist_lookup layout "balance"%string = Some (SAbi (ABase (TInt (UintT 256)))) -> + Forall (fun c => slot_type_wf Σ (fst (fst c))) creates -> + ForallT (fun c => type_slotexpr_t Σ iface ONone (snd c) (fst (fst c))) creates -> + type_creates_t Σ iface oid creates layout. + +(* ================================================================= *) +(** ** Update — Type version *) + +Inductive type_update_t : contract_env -> interface -> opt_id -> + update -> Type := + | T_Update_t : forall Σ iface oid r se sty, + type_ref_t Σ iface TagS oid TagU r sty -> + type_slotexpr_t Σ iface oid se sty -> + type_update_t Σ iface oid (r, se). + +Inductive type_updates_t : contract_env -> interface -> opt_id -> + list update -> Type := + | T_Updates_t : forall Σ iface oid upds, + ForallT (fun u => type_update_t Σ iface oid u) upds -> + (forall i j, i < length upds -> j < i -> + ~ more_specific_eq (fst (nth j upds (RVar ""%string, SEMap (MExp (EBool false))))) + (fst (nth i upds (RVar ""%string, SEMap (MExp (EBool false)))))) -> + type_updates_t Σ iface oid upds. + +(* ================================================================= *) +(** ** Constructor — Type version *) + +Inductive type_constructor_t : contract_env -> ident -> constructor -> + storage_layout -> Type := + | T_Ctor_t : forall Σ a ctor layout, + interface_wf Σ (ctor_iface ctor) -> + ForallT (fun pre => type_expr_t Σ (ctor_iface ctor) ONone TagU pre TBool) + (ctor_iff ctor) -> + ForallT (fun cc => type_expr_t Σ (ctor_iface ctor) ONone TagU (fst cc) TBool) + (ctor_cases ctor) -> + ForallT (fun cc => type_creates_t Σ (ctor_iface ctor) (OSome a) (snd cc) layout) + (ctor_cases ctor) -> + Forall (fun p => slot_type_wf Σ (snd p)) layout -> + (forall x, alist_dom layout x -> ~ alist_dom (ctor_iface ctor) x) -> + let Σ' := Σ_with_storage Σ a layout in + ForallT (fun post => type_expr_t Σ' (ctor_iface ctor) (OSome a) TagU post TBool) + (ctor_post ctor) -> + (forall s rho, + Forall (fun pre => eval_expr (TSUntimed s) rho pre dummy_loc (VBool true)) + (ctor_iff ctor) -> + exists j, j < length (ctor_cases ctor) /\ + eval_expr (TSUntimed s) rho (fst (nth j (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool true) /\ + forall i, i <> j -> i < length (ctor_cases ctor) -> + eval_expr (TSUntimed s) rho (fst (nth i (ctor_cases ctor) (EBool false, []))) dummy_loc (VBool false)) -> + type_constructor_t Σ a ctor layout. + +(* ================================================================= *) +(** ** Transition — Type version *) + +Inductive type_transition_t : contract_env -> ident -> transition -> Type := + | T_Trans_t : forall Σ a tr, + interface_wf Σ (trans_iface tr) -> + ForallT (fun pre => type_expr_t Σ (trans_iface tr) (OSome a) TagU pre TBool) + (trans_iff tr) -> + ForallT (fun tc => type_expr_t Σ (trans_iface tr) (OSome a) TagU (tc_cond tc) TBool) + (trans_cases tr) -> + ForallT (fun tc => type_updates_t Σ (trans_iface tr) (OSome a) (tc_updates tc)) + (trans_cases tr) -> + ForallT (fun tc => type_expr_t Σ (trans_iface tr) (OSome a) TagT + (tc_return tc) TAddress) + (trans_cases tr) -> + ForallT (fun post => type_expr_t Σ (trans_iface tr) (OSome a) TagT post TBool) + (trans_post tr) -> + (forall s rho l, + env_well_typed Σ rho s (trans_iface tr) -> + has_slot_type Σ (VAddr l) s (SContract a) -> + Forall (fun pre => eval_expr (TSUntimed s) rho pre l (VBool true)) + (trans_iff tr) -> + exists j, j < length (trans_cases tr) /\ + eval_expr (TSUntimed s) rho (tc_cond (nth j (trans_cases tr) tc_default)) l (VBool true) /\ + forall i, i <> j -> i < length (trans_cases tr) -> + eval_expr (TSUntimed s) rho (tc_cond (nth i (trans_cases tr) tc_default)) l (VBool false)) -> + type_transition_t Σ a tr. + +(* ================================================================= *) +(** ** Correspondence: Type → Prop *) + +Lemma type_env_ref_t_to_prop : forall Σ iface oid ev alpha, + type_env_ref_t Σ iface oid ev alpha -> + type_env_ref Σ iface oid ev alpha. +Proof. + intros Σ iface oid ev alpha H. destruct H; constructor. +Qed. + +Fixpoint type_ref_t_to_prop Σ iface k oid t r sty + (H : type_ref_t Σ iface k oid t r sty) + : type_ref Σ iface k oid t r sty +with type_expr_t_to_prop Σ iface oid t e bt + (H : type_expr_t Σ iface oid t e bt) + : type_expr Σ iface oid t e bt. +Proof. + - destruct H; + first [ eapply T_Calldata + | eapply T_Storage + | eapply T_StoragePre + | eapply T_StoragePost + | eapply T_Coerce; eapply type_ref_t_to_prop + | eapply T_Upcast; eapply type_ref_t_to_prop + | eapply T_Field; [eapply type_ref_t_to_prop|] + | eapply T_MapIndex; + [eapply type_ref_t_to_prop | eapply type_expr_t_to_prop] + | eapply T_Environment; eapply type_env_ref_t_to_prop + ]; eassumption. + - destruct H; + first [ eapply T_Int + | eapply T_Bool + | eapply T_Ref; eapply type_ref_t_to_prop + | eapply T_Addr; eapply type_ref_t_to_prop + | eapply T_Range; eapply type_expr_t_to_prop + | eapply T_BopI; eapply type_expr_t_to_prop + | eapply T_NumConv; eapply type_expr_t_to_prop + | eapply T_BopB; eapply type_expr_t_to_prop + | eapply T_Neg; eapply type_expr_t_to_prop + | eapply T_Cmp; eapply type_expr_t_to_prop + | eapply T_ITE; eapply type_expr_t_to_prop + | eapply T_Eq; eapply type_expr_t_to_prop + ]; eassumption. +Qed. + +Fixpoint type_mapexpr_t_to_prop Σ iface oid m mu + (H : type_mapexpr_t Σ iface oid m mu) + : type_mapexpr Σ iface oid m mu := + match H with + | T_Exp_t _ _ _ _ _ He => + T_Exp _ _ _ _ _ (type_expr_t_to_prop _ _ _ _ _ _ He) + | T_Mapping_t _ _ _ bindings _ _ Hd Hkeys Hvals => + T_Mapping _ _ _ bindings _ _ + Hd + ((fix goK l (hl : ForallT _ l) : Forall _ l := + match hl with + | ForallT_nil => Forall_nil _ + | ForallT_cons h hl' => + Forall_cons _ (type_expr_t_to_prop _ _ _ _ _ _ h) (goK _ hl') + end) _ Hkeys) + ((fix goV l (hl : ForallT _ l) : Forall _ l := + match hl with + | ForallT_nil => Forall_nil _ + | ForallT_cons h hl' => + Forall_cons _ (type_mapexpr_t_to_prop _ _ _ _ _ h) (goV _ hl') + end) _ Hvals) + | T_MappingUpd_t _ _ _ _ bindings _ _ k Hr Hkeys Hvals => + T_MappingUpd _ _ _ _ bindings _ _ k + (type_ref_t_to_prop _ _ _ _ _ _ _ Hr) + ((fix goK l (hl : ForallT _ l) : Forall _ l := + match hl with + | ForallT_nil => Forall_nil _ + | ForallT_cons h hl' => + Forall_cons _ (type_expr_t_to_prop _ _ _ _ _ _ h) (goK _ hl') + end) _ Hkeys) + ((fix goV l (hl : ForallT _ l) : Forall _ l := + match hl with + | ForallT_nil => Forall_nil _ + | ForallT_cons h hl' => + Forall_cons _ (type_mapexpr_t_to_prop _ _ _ _ _ h) (goV _ hl') + end) _ Hvals) + end. + +Fixpoint type_slotexpr_t_to_prop Σ iface oid se sty + (H : type_slotexpr_t Σ iface oid se sty) + : type_slotexpr Σ iface oid se sty := + match H with + | T_SlotMap_t _ _ _ _ _ Hm => + T_SlotMap _ _ _ _ _ (type_mapexpr_t_to_prop _ _ _ _ _ Hm) + | T_SlotRef_t _ _ _ k _ _ Hr => + T_SlotRef _ _ _ k _ _ (type_ref_t_to_prop _ _ _ _ _ _ _ Hr) + | T_SlotAddr_t _ _ _ _ _ Hse => + T_SlotAddr _ _ _ _ _ (type_slotexpr_t_to_prop _ _ _ _ _ Hse) + | T_Create_t _ _ _ _ ctor _ Hcl Hnp Hses HP4 => + T_Create _ _ _ _ ctor _ + Hcl Hnp + ((fix go ses alphas (hs : Forall2T _ ses alphas) : + Forall2 _ ses alphas := + match hs with + | Forall2T_nil => Forall2_nil _ + | Forall2T_cons h hs' => + Forall2_cons _ _ (type_slotexpr_t_to_prop _ _ _ _ _ h) + (go _ _ hs') + end) _ _ Hses) + HP4 + | T_CreatePayable_t _ _ _ _ ctor _ _ Hcl Hpay Hses Hval HP4 => + T_CreatePayable _ _ _ _ ctor _ _ + Hcl Hpay + ((fix go ses alphas (hs : Forall2T _ ses alphas) : + Forall2 _ ses alphas := + match hs with + | Forall2T_nil => Forall2_nil _ + | Forall2T_cons h hs' => + Forall2_cons _ _ (type_slotexpr_t_to_prop _ _ _ _ _ h) + (go _ _ hs') + end) _ _ Hses) + (type_slotexpr_t_to_prop _ _ _ _ _ Hval) + HP4 + end. + +Lemma type_creates_t_to_prop : forall Σ iface oid creates layout, + type_creates_t Σ iface oid creates layout -> + type_creates Σ iface oid creates layout. +Proof. + intros Σ iface oid creates layout H. destruct H. + eapply T_Creates; try eassumption. + eapply ForallT_map; [|eassumption]. + intros a Ha; exact (type_slotexpr_t_to_prop _ _ _ _ _ Ha). +Qed. + +Lemma type_update_t_to_prop : forall Σ iface oid u, + type_update_t Σ iface oid u -> + type_update Σ iface oid u. +Proof. + intros Σ iface oid u H. destruct H. + eapply T_Update; + [eapply type_ref_t_to_prop | eapply type_slotexpr_t_to_prop]; eassumption. +Qed. + +Lemma type_updates_t_to_prop : forall Σ iface oid upds, + type_updates_t Σ iface oid upds -> + type_updates Σ iface oid upds. +Proof. + intros Σ iface oid upds H. destruct H. + eapply T_Updates; try eassumption. + eapply ForallT_map; [|eassumption]. + intros a Ha; exact (type_update_t_to_prop _ _ _ _ Ha). +Qed. + +Lemma type_constructor_t_to_prop : forall Σ a ctor layout, + type_constructor_t Σ a ctor layout -> + type_constructor Σ a ctor layout. +Proof. + intros Σ a ctor layout H. destruct H. + eapply T_Ctor. + - eassumption. + - eapply ForallT_map; [|exact f]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eapply ForallT_map; [|exact f0]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eapply ForallT_map; [|exact f1]. + intros x Hx; exact (type_creates_t_to_prop _ _ _ _ _ Hx). + - eassumption. + - eassumption. + - eapply ForallT_map; [|exact f3]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eassumption. +Qed. + +Lemma type_transition_t_to_prop : forall Σ a tr, + type_transition_t Σ a tr -> + type_transition Σ a tr. +Proof. + intros Σ a tr H. destruct H. + eapply T_Trans. + - eassumption. + - eapply ForallT_map; [|exact f]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eapply ForallT_map; [|exact f0]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eapply ForallT_map; [|exact f1]. + intros x Hx; exact (type_updates_t_to_prop _ _ _ _ Hx). + - eapply ForallT_map; [|exact f2]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eapply ForallT_map; [|exact f3]. + intros x Hx; exact (type_expr_t_to_prop _ _ _ _ _ _ Hx). + - eassumption. +Qed. diff --git a/theories/ValueSemantics.v b/theories/ValueSemantics.v new file mode 100644 index 00000000..76d4d488 --- /dev/null +++ b/theories/ValueSemantics.v @@ -0,0 +1,1036 @@ +(** * Value Semantics — Semantic Domains + Formalizes Section 10.1 of the tech report: the semantic domains + of types are defined by recursion on types, mapping Act types + to actual Rocq types. + + ⟦β⟧ and ⟦μ⟧ are defined by structural recursion on types. + ⟦σ⟧_Σ is defined by recursion on the strictly decreasing + measure len(Σ, σ), bounded by the size of Σ. *) + +From Stdlib Require Import String ZArith List Bool PeanoNat Lia. +From Act Require Import Maps Syntax Domains Semantics ValueTyping Typing TypingT. +Import ListNotations. + +(* ================================================================= *) +(** ** Semantic Domain of Base Types — ⟦β⟧ *) + +Definition sem_base (bt : base_type) : Type := + match bt with + | TInt it => { n : Z | in_range it n } + | TBool => bool + | TAddress => nat + end. + +(* ================================================================= *) +(** ** Semantic Domain of Mapping Types — ⟦μ⟧ *) + +Fixpoint sem_mapping (mu : mapping_type) : Type := + match mu with + | MBase bt => sem_base bt + | MMapping bt mu' => sem_base bt -> sem_mapping mu' + end. + +(* ================================================================= *) +(** ** Semantic Domains of Slot Types — ⟦σ⟧_Σ + + Internally defined using a depth parameter [n] that bounds + the nesting of contract references. The top-level definitions + compute the depth from Σ (as [length (Σ_storage_list Σ)]), + so the depth does not appear in the public interface. *) + +Definition Σ_storage_or_nil (Σ : contract_env) (a : ident) : storage_layout := + match Σ_storage Σ a with + | Some layout => layout + | None => [] + end. + +(** Layout domain, parameterized by the slot domain function. + Used by both [sem_slot_aux] and [sem_layout_aux] so their + types are definitionally equal. *) +Fixpoint sem_layout_gen (slot_dom : slot_type -> Type) + (layout : storage_layout) : Type := + match layout with + | [] => unit + | (_, st) :: rest => prod (slot_dom st) (sem_layout_gen slot_dom rest) + end. + +(** Depth-indexed version (internal). *) +Fixpoint sem_slot_aux (n : nat) (Σ : contract_env) (st : slot_type) : Type := + match st with + | SMapping mu => sem_mapping mu + | SAbi (ABase bt) => sem_base bt + | SAbi (AContractAddr a) => + match n with + | 0 => Empty_set + | S n' => prod nat (sem_layout_gen (sem_slot_aux n' Σ) (Σ_storage_or_nil Σ a)) + end + | SContract a => + match n with + | 0 => Empty_set + | S n' => prod nat (sem_layout_gen (sem_slot_aux n' Σ) (Σ_storage_or_nil Σ a)) + end + end. + +Definition sem_layout_aux (n : nat) (Σ : contract_env) + (layout : storage_layout) : Type := + sem_layout_gen (sem_slot_aux n Σ) layout. + +(** The depth of Σ: an upper bound on the nesting of contract + references in any well-founded Σ. *) +Definition Σ_depth (Σ : contract_env) : nat := + length (Σ_storage_list Σ). + +(* ================================================================= *) +(** ** Public Definitions — no depth parameter *) + +(** ⟦σ⟧_Σ *) +Definition sem_slot (Σ : contract_env) (st : slot_type) : Type := + sem_slot_aux (Σ_depth Σ) Σ st. + +(** ⟦C⟧_Σ — semantic domain of a storage layout *) +Definition sem_layout (Σ : contract_env) (layout : storage_layout) : Type := + sem_layout_aux (Σ_depth Σ) Σ layout. + +(** ⟦α⟧_Σ — semantic domain of ABI types *) +Definition sem_abi (Σ : contract_env) (alpha : abi_type) : Type := + sem_slot Σ (SAbi alpha). + +(** ⟦σ⟧^t_Σ — timed semantic domain of slot types *) +Definition sem_slot_timed (Σ : contract_env) + (st : slot_type) (t : time_tag) : Type := + match t with + | TagU => sem_slot Σ st + | TagT => sem_slot Σ st * sem_slot Σ st + end. + +(** ⟦?Id⟧_Σ — depth-indexed *) +Definition sem_opt_id_aux (n : nat) (Σ : contract_env) (oid : opt_id) : Type := + match oid with + | ONone => unit + | OSome a => sem_slot_aux n Σ (SContract a) + end. + +(** ⟦?Id⟧^t_Σ — depth-indexed timed version *) +Definition sem_opt_id_timed_aux (n : nat) (Σ : contract_env) + (oid : opt_id) (t : time_tag) : Type := + match t with + | TagU => sem_opt_id_aux n Σ oid + | TagT => sem_opt_id_aux n Σ oid * sem_opt_id_aux n Σ oid + end. + +(** ⟦?Id⟧_Σ — public *) +Definition sem_opt_id (Σ : contract_env) (oid : opt_id) : Type := + sem_opt_id_aux (Σ_depth Σ) Σ oid. + +(** ⟦?Id⟧^t_Σ — public timed version *) +Definition sem_opt_id_timed (Σ : contract_env) + (oid : opt_id) (t : time_tag) : Type := + sem_opt_id_timed_aux (Σ_depth Σ) Σ oid t. + +(** ⟦I⟧_Σ — semantic domain of interface fields (depth-indexed) *) +Fixpoint sem_iface_fields_aux (n : nat) (Σ : contract_env) + (iface : interface) : Type := + match iface with + | [] => unit + | (_, alpha) :: rest => + sem_slot_aux n Σ (SAbi alpha) * sem_iface_fields_aux n Σ rest + end. + +(** ⟦I⟧_Σ — depth-indexed: fields × (caller, origin, callvalue) + callvalue is stored as sem_base (TInt (UintT 256)) = {n : Z | in_range (UintT 256) n} + to match the typing rule T_Callvalue which assigns type uint256. *) +Definition sem_iface_aux (n : nat) (Σ : contract_env) + (iface : interface) : Type := + sem_iface_fields_aux n Σ iface * (nat * nat * sem_base (TInt (UintT 256))). + +(** ⟦I⟧_Σ — public *) +Definition sem_iface (Σ : contract_env) + (iface : interface) : Type := + sem_iface_aux (Σ_depth Σ) Σ iface. + +(* ================================================================= *) +(** ** Default Semantic Values *) + +(** Default semantic values require that 0 is in range for integer types. + This holds for all int types used in practice (bitwidth > 0). *) + +Lemma zero_in_range_unbounded : in_range IntUnbounded 0%Z. +Proof. exact I. Qed. + +Lemma zero_in_range_uint : forall m, in_range (UintT m) 0%Z. +Proof. + intro m. simpl. split. + - lia. + - assert (0 < Z.pow 2 (Z.of_nat m))%Z. + { apply Z.pow_pos_nonneg; lia. } + lia. +Qed. + +Lemma zero_in_range_int : forall m, (m > 0)%nat -> in_range (IntT m) 0%Z. +Proof. + intros m Hm. simpl. split. + - assert (0 <= Z.pow 2 (Z.of_nat m - 1))%Z. + { apply Z.pow_nonneg. lia. } + lia. + - assert (0 < Z.pow 2 (Z.of_nat m - 1))%Z. + { apply Z.pow_pos_nonneg; lia. } + lia. +Qed. + +(** Well-formedness of int types: 0 is in the range. + This excludes pathological types like [IntT 0]. *) +Definition wf_int_type (it : int_type) : Prop := + in_range it 0%Z. + +(* ================================================================= *) +(** ** Decidable Equality on Base Semantic Values *) + +Definition sem_base_eqb (bt : base_type) + : sem_base bt -> sem_base bt -> bool := + match bt return sem_base bt -> sem_base bt -> bool with + | TInt _ => fun x y => Z.eqb (proj1_sig x) (proj1_sig y) + | TBool => Bool.eqb + | TAddress => Nat.eqb + end. + +(* ================================================================= *) +(** ** Depth Weakening + + Accessing a field of a contract at depth [S n] yields a value at + depth [n]. To maintain a uniform depth across denotation functions, + we coerce from depth [n] to depth [S n]. For non-contract types + this is the identity; for contract types it recursively weakens + each field. *) + +Fixpoint sem_layout_gen_map + (f g : slot_type -> Type) + (w : forall st, f st -> g st) + (layout : storage_layout) + : sem_layout_gen f layout -> sem_layout_gen g layout := + match layout with + | [] => id + | (_, st) :: rest => fun '(x, xs) => + (w st x, sem_layout_gen_map f g w rest xs) + end. + +Fixpoint sem_slot_weaken (n : nat) (Σ : contract_env) (st : slot_type) + {struct n} : sem_slot_aux n Σ st -> sem_slot_aux (S n) Σ st. +Proof. + destruct n as [|n']; destruct st as [mu | [bt | a] | a]; simpl; + try exact id; try exact (fun v => match v : Empty_set with end). + - intros [addr fields]. exact (addr, + sem_layout_gen_map _ _ (sem_slot_weaken n' Σ) _ fields). + - intros [addr fields]. exact (addr, + sem_layout_gen_map _ _ (sem_slot_weaken n' Σ) _ fields). +Defined. + +(* ================================================================= *) +(** ** Layout Lookup — project a field from a contract record *) + +Definition Some_inj {A : Type} {a b : A} (H : Some a = Some b) : a = b := + match H in _ = y return match y with Some b' => a = b' | None => True end with + | eq_refl => eq_refl + end. + +Fixpoint sem_layout_lookup (n : nat) (Σ : contract_env) + (layout : storage_layout) (x : ident) (sty : slot_type) + {struct layout} + : alist_lookup layout x = Some sty -> + sem_layout_aux n Σ layout -> sem_slot_aux n Σ sty := + match layout as l + return alist_lookup l x = Some sty -> + sem_layout_aux n Σ l -> sem_slot_aux n Σ sty + with + | [] => fun H _ => + match @eq_ind _ (None (A:=slot_type)) (fun o => + match o with Some _ => False | None => True end) I _ H + with end + | (k, st') :: rest => fun H fields => + match String.eqb k x as b + return (if b then Some st' else alist_lookup rest x) = Some sty -> + sem_slot_aux n Σ sty + with + | true => fun Heq => + eq_rect st' (fun s => sem_slot_aux n Σ s) (fst fields) sty (Some_inj Heq) + | false => fun Heq => + sem_layout_lookup n Σ rest x sty Heq (snd fields) + end H + end. + +(** Project a field from a contract value at depth [S n]. + Returns at depth [n]. Works directly with the inner fix type + from [sem_slot_aux], avoiding the [sem_layout_aux] convertibility issue. *) +Definition sem_contract_field (n : nat) (Σ : contract_env) (a x : ident) + (sty : slot_type) + (Hfield : Σ_storage_var Σ a x = Some sty) + (v : sem_slot_aux (S n) Σ (SContract a)) : sem_slot_aux n Σ sty. +Proof. + simpl in v. destruct v as [addr fields]. + unfold Σ_storage_var in Hfield. + destruct (Σ_storage Σ a) as [layout|] eqn:Elayout; [|discriminate]. + unfold Σ_storage_or_nil in fields. rewrite Elayout in fields. + induction layout as [|[k st'] rest IH] in fields, Hfield |- *. + - simpl in Hfield. discriminate. + - simpl in Hfield, fields. + destruct (String.eqb k x) eqn:Ekx. + + injection Hfield as <-. exact (fst fields). + + exact (IH Hfield (snd fields)). +Defined. + +(** Same for [AContractAddr] *) +Definition sem_contractaddr_field (n : nat) (Σ : contract_env) (a x : ident) + (sty : slot_type) + (Hfield : Σ_storage_var Σ a x = Some sty) + (v : sem_slot_aux (S n) Σ (SAbi (AContractAddr a))) : sem_slot_aux n Σ sty. +Proof. + simpl in v. destruct v as [addr fields]. + unfold Σ_storage_var in Hfield. + destruct (Σ_storage Σ a) as [layout|] eqn:Elayout; [|discriminate]. + unfold Σ_storage_or_nil in fields. rewrite Elayout in fields. + induction layout as [|[k st'] rest IH] in fields, Hfield |- *. + - simpl in Hfield. discriminate. + - simpl in Hfield, fields. + destruct (String.eqb k x) eqn:Ekx. + + injection Hfield as <-. exact (fst fields). + + exact (IH Hfield (snd fields)). +Defined. + +(** Extract the address from a contract value *) +Definition sem_contract_addr (n : nat) (Σ : contract_env) (a : ident) + (v : sem_slot_aux (S n) Σ (SContract a)) : nat := + fst v. + +Definition sem_contractaddr_addr (n : nat) (Σ : contract_env) (a : ident) + (v : sem_slot_aux (S n) Σ (SAbi (AContractAddr a))) : nat := + fst v. + +(** Interface field lookup *) +Definition sem_iface_lookup (n : nat) (Σ : contract_env) + (iface : interface) (x : ident) (alpha : abi_type) + (Hlookup : alist_lookup iface x = Some alpha) + (fields : sem_iface_fields_aux n Σ iface) : sem_slot_aux n Σ (SAbi alpha). +Proof. + induction iface as [|[k a] rest IH] in fields, Hlookup |- *. + - simpl in Hlookup. discriminate. + - simpl in Hlookup, fields. + destruct (String.eqb k x) eqn:Ekx. + + injection Hlookup as <-. exact (fst fields). + + exact (IH Hlookup (snd fields)). +Defined. + +(* ================================================================= *) +(** ** Denotation of Environment References — Section 10.2.1 *) + +Definition denote_env_ref (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (ev : env_var) (alpha : abi_type) + (H : type_env_ref_t Σ iface oid ev alpha) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_aux n Σ oid) + : sem_slot_aux n Σ (SAbi alpha). +Proof. + destruct H; destruct n as [|n']; simpl. + (* T_Caller: caller = fst (fst triple) *) + - exact (fst (fst (snd rho))). + - exact (fst (fst (snd rho))). + (* T_Origin: origin = snd (fst triple) *) + - exact (snd (fst (snd rho))). + - exact (snd (fst (snd rho))). + (* T_Callvalue: callvalue = snd triple *) + - exact (snd (snd rho)). + - exact (snd (snd rho)). + (* T_This: return v *) + - exact (match v : Empty_set with end). + - exact v. +Defined. + +(** Helper: combine Σ_storage and alist_lookup into Σ_storage_var *) +Lemma storage_var_from_parts : forall Σ a x sty layout, + Σ_storage Σ a = Some layout -> + alist_lookup layout x = Some sty -> + Σ_storage_var Σ a x = Some sty. +Proof. + intros Σ a x sty layout Hstor Hlook. + unfold Σ_storage_var. rewrite Hstor. exact Hlook. +Qed. + +(* ================================================================= *) +(** ** Denotation of References and Expressions — Sections 10.2.2–10.2.3 + + Mutual fixpoint on the Type-valued typing derivations. + Works at depth [n]; field access uses [sem_contract_field] + (which drops depth by 1) followed by [sem_slot_weaken]. *) + +Fixpoint denote_ref (n : nat) (Σ : contract_env) (iface : interface) + (k : ref_tag) (oid : opt_id) (t : time_tag) (r : ref) (sty : slot_type) + (H : type_ref_t Σ iface k oid t r sty) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_timed_aux n Σ oid t) + {struct H} : sem_slot_aux n Σ sty +with denote_expr (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (t : time_tag) (e : expr) (bt : base_type) + (H : type_expr_t Σ iface oid t e bt) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_timed_aux n Σ oid t) + {struct H} : sem_base bt. +Proof. + - (* denote_ref *) + destruct H. + + + (* T_Calldata_t: ρ(x) where x : α ∈ I *) + destruct n as [|n']; simpl. + { exact (sem_iface_lookup 0 Σ iface x alpha e (fst rho)). } + { exact (sem_iface_lookup (S n') Σ iface x alpha e (fst rho)). } + + + (* T_Storage_t: v.x, untimed *) + destruct n as [|n']. + { simpl in v. exact (match v : Empty_set with end). } + { exact (sem_slot_weaken n' Σ sty + (sem_contract_field n' Σ a x sty + (storage_var_from_parts Σ a x sty layout e e0) v)). } + + + (* T_StoragePre_t: v_pre.x, timed *) + destruct n as [|n']. + { simpl in v. exact (match (fst v) : Empty_set with end). } + { exact (sem_slot_weaken n' Σ sty + (sem_contract_field n' Σ a x sty + (storage_var_from_parts Σ a x sty layout e e0) (fst v))). } + + + (* T_StoragePost_t: v_post.x, timed *) + destruct n as [|n']. + { simpl in v. exact (match (snd v) : Empty_set with end). } + { exact (sem_slot_weaken n' Σ sty + (sem_contract_field n' Σ a x sty + (storage_var_from_parts Σ a x sty layout e e0) (snd v))). } + + + (* T_Coerce_t: ref as A — AContractAddr a ≡ SContract a after unfolding *) + destruct n as [|n']; simpl. + { pose (val := denote_ref 0 Σ iface k oid t r (SAbi (AContractAddr a)) H rho v). + simpl in val. exact (match val : Empty_set with end). } + { exact (denote_ref (S n') Σ iface k oid t r (SAbi (AContractAddr a)) H rho v). } + + + (* T_Upcast_t: ref : address_A → address, extract addr field *) + destruct n as [|n']; simpl. + { pose (val := denote_ref 0 Σ iface k oid t r (SAbi (AContractAddr a)) H rho v). + simpl in val. exact (match val : Empty_set with end). } + { exact (fst (denote_ref (S n') Σ iface k oid t r (SAbi (AContractAddr a)) H rho v)). } + + + (* T_Field_t: ref.x where ref : A *) + destruct n as [|n']; simpl. + { pose (val := denote_ref 0 Σ iface k oid t r (SContract a) H rho v). + simpl in val. exact (match val : Empty_set with end). } + { match goal with + | [ Hf : Σ_storage_var _ _ _ = Some _ |- _ ] => + exact (sem_slot_weaken n' Σ sty + (sem_contract_field n' Σ a x sty Hf + (denote_ref (S n') Σ iface k oid t r (SContract a) H rho v))) + end. } + + + (* T_MapIndex_t: ref[e] *) + destruct n as [|n']; simpl. + { exact (denote_ref 0 Σ iface k oid t r + (SMapping (MMapping bt mu)) H rho v + (denote_expr 0 Σ iface oid t e bt t0 rho v)). } + { exact (denote_ref (S n') Σ iface k oid t r + (SMapping (MMapping bt mu)) H rho v + (denote_expr (S n') Σ iface oid t e bt t0 rho v)). } + + + (* T_Environment_t: env ref — t specializes to TagU *) + match goal with + | [ Henv : type_env_ref_t _ _ _ _ _ |- _ ] => + destruct n as [|n']; simpl; + exact (denote_env_ref _ Σ iface oid ev alpha Henv rho v) + end. + + - (* denote_expr *) + destruct H. + + + (* T_Int_t: integer literal *) + match goal with + | [ Hi : in_range _ ?z |- sem_base (TInt _) ] => exact (exist _ z Hi) + end. + + + (* T_Bool_t: boolean literal *) + exact b. + + + (* T_Ref_t: ref — extract base value from slot *) + match goal with + | [ Hr : type_ref_t _ _ ?k' _ _ _ (SAbi (ABase ?bt')) |- sem_base ?bt' ] => + destruct n as [|n']; simpl; + exact (denote_ref _ Σ iface k' oid t r (SAbi (ABase bt')) Hr rho v) + end. + + + (* T_Addr_t: addr(ref) — contract address *) + match goal with + | [ Hr : type_ref_t _ _ ?k' _ TagU _ (SContract ?a') |- _ ] => + destruct n as [|n']; + [ simpl; pose (cv := denote_ref 0 Σ iface k' oid TagU r (SContract a') Hr rho v); + simpl in cv; exact (match cv : Empty_set with end) + | exact (fst (denote_ref (S n') Σ iface k' oid TagU r (SContract a') Hr rho v)) ] + end. + + + (* T_Range_t: inrange(ι₁, e) *) + match goal with + | [ He : type_expr_t _ _ _ _ _ (TInt ?it2') |- _ ] => + pose (val := denote_expr n Σ iface oid t e (TInt it2') He rho v); + simpl in val; destruct val as [z _]; + exact (match it1 with + | IntUnbounded => true + | _ => match int_min it1, int_max it1 with + | Some lo, Some hi => (lo <=? z)%Z && (z <=? hi)%Z + | _, _ => false + end + end) + end. + + + (* T_BopI_t: e₁ ○ᵢ e₂ *) + match goal with + | [ H1 : type_expr_t _ _ _ _ ?e1' (TInt ?it1'), + H2 : type_expr_t _ _ _ _ ?e2' (TInt ?it2') |- _ ] => + pose (z1v := denote_expr n Σ iface oid t e1' (TInt it1') H1 rho v); + pose (z2v := denote_expr n Σ iface oid t e2' (TInt it2') H2 rho v); + simpl in z1v, z2v; + destruct z1v as [z1 _]; destruct z2v as [z2 _]; + exact (exist _ (eval_int_binop op z1 z2) I) + end. + + + (* T_NumConv_t: e : ι → e : int (subsumption) *) + match goal with + | [ He : type_expr_t _ _ _ _ _ (TInt ?it') |- _ ] => + pose (val := denote_expr n Σ iface oid t e (TInt it') He rho v); + simpl in val; destruct val as [z _]; + exact (exist _ z I) + end. + + + (* T_BopB_t: e₁ ○_b e₂ *) + match goal with + | [ H1 : type_expr_t _ _ _ _ ?e1' TBool, + H2 : type_expr_t _ _ _ _ ?e2' TBool |- _ ] => + exact (eval_bool_binop op + (denote_expr n Σ iface oid t e1' TBool H1 rho v) + (denote_expr n Σ iface oid t e2' TBool H2 rho v)) + end. + + + (* T_Neg_t: ¬e *) + match goal with + | [ He : type_expr_t _ _ _ _ _ TBool |- _ ] => + exact (negb (denote_expr n Σ iface oid t e TBool He rho v)) + end. + + + (* T_Cmp_t: e₁ ⋈ e₂ *) + match goal with + | [ H1 : type_expr_t _ _ _ _ ?e1' (TInt ?it'), + H2 : type_expr_t _ _ _ _ ?e2' (TInt ?it') |- _ ] => + pose (z1v := denote_expr n Σ iface oid t e1' (TInt it') H1 rho v); + pose (z2v := denote_expr n Σ iface oid t e2' (TInt it') H2 rho v); + simpl in z1v, z2v; + destruct z1v as [z1 _]; destruct z2v as [z2 _]; + exact (eval_cmp op z1 z2) + end. + + + (* T_ITE_t: if e₁ then e₂ else e₃ *) + match goal with + | [ H1 : type_expr_t _ _ _ _ ?e1' TBool, + H2 : type_expr_t _ _ _ _ ?e2' ?bt', + H3 : type_expr_t _ _ _ _ ?e3' ?bt' |- sem_base ?bt' ] => + destruct (denote_expr n Σ iface oid t e1' TBool H1 rho v); + [ exact (denote_expr n Σ iface oid t e2' bt' H2 rho v) + | exact (denote_expr n Σ iface oid t e3' bt' H3 rho v) ] + end. + + + (* T_Eq_t: e₁ = e₂ *) + match goal with + | [ H1 : type_expr_t _ _ _ _ ?e1' ?bt', + H2 : type_expr_t _ _ _ _ ?e2' ?bt' |- _ ] => + exact (sem_base_eqb bt' + (denote_expr n Σ iface oid t e1' bt' H1 rho v) + (denote_expr n Σ iface oid t e2' bt' H2 rho v)) + end. +Defined. + +(* ================================================================= *) +(** ** Default Semantic Mapping Values + + Used by the mapping denotation to fill in unmatched keys. + Requires [default_value_typable mu] as evidence that 0 is in + range for all integer types in the mapping chain. *) + +Fixpoint sem_mapping_default (mu : mapping_type) + : default_value_typable mu -> sem_mapping mu := + match mu return default_value_typable mu -> sem_mapping mu with + | MBase (TInt it) => fun Hd => exist _ 0%Z Hd + | MBase TBool => fun _ => false + | MBase TAddress => fun _ => 0 + | MMapping bt mu' => fun Hd => fun _ => sem_mapping_default mu' Hd + end. + +(* ================================================================= *) +(** ** Denotation of Mapping Expressions — Section 10.2.4 + + Builds a function [sem_base bt → sem_mapping mu] by iterating + through bindings, comparing keys with [sem_base_eqb], and + falling through to the default (or to the base reference for updates). *) + +(** Build a mapping from a list of bindings with a fallback *) +Fixpoint sem_build_map (bt : base_type) (mu : mapping_type) + (keys : list (sem_base bt)) (vals : list (sem_mapping mu)) + (fallback : sem_base bt -> sem_mapping mu) + : sem_base bt -> sem_mapping mu := + match keys, vals with + | k :: ks, v :: vs => + fun x => if sem_base_eqb bt x k then v else sem_build_map bt mu ks vs fallback x + | _, _ => fallback + end. + +Fixpoint denote_mapexpr (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (m : map_expr) (mu : mapping_type) + (H : type_mapexpr_t Σ iface oid m mu) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_aux n Σ oid) + {struct H} : sem_mapping mu. +Proof. + destruct H. + + - (* T_Exp_t: e → MBase bt *) + exact (denote_expr n Σ iface oid TagU e bt t rho v). + + - (* T_Mapping_t: [e₁ => m₁, ...] : mapping(bt, mu) *) + simpl. + exact (sem_build_map bt mu + ((fix go l (Hk : ForallT _ l) : list (sem_base bt) := + match Hk with + | ForallT_nil => [] + | ForallT_cons he hrest => + denote_expr n Σ iface oid TagU (fst _) bt he rho v :: go _ hrest + end) _ f) + ((fix go l (Hv : ForallT _ l) : list (sem_mapping mu) := + match Hv with + | ForallT_nil => [] + | ForallT_cons hm hrest => + denote_mapexpr n Σ iface oid (snd _) mu hm rho v :: go _ hrest + end) _ f0) + (fun _ => sem_mapping_default mu d)). + + - (* T_MappingUpd_t: ref[e₁ => m₁, ...] : mapping(bt, mu) *) + simpl. + match goal with + | [ Hr : type_ref_t _ _ ?k' _ TagU _ (SMapping (MMapping bt mu)) |- _ ] => + destruct n as [|n']; + [ exact (sem_build_map bt mu + ((fix go l (Hk : ForallT _ l) : list (sem_base bt) := + match Hk with + | ForallT_nil => [] + | ForallT_cons he hrest => + denote_expr 0 Σ iface oid TagU (fst _) bt he rho v :: go _ hrest + end) _ f) + ((fix go l (Hv : ForallT _ l) : list (sem_mapping mu) := + match Hv with + | ForallT_nil => [] + | ForallT_cons hm hrest => + denote_mapexpr 0 Σ iface oid (snd _) mu hm rho v :: go _ hrest + end) _ f0) + (denote_ref 0 Σ iface k' oid TagU r (SMapping (MMapping bt mu)) Hr rho v)) + | exact (sem_build_map bt mu + ((fix go l (Hk : ForallT _ l) : list (sem_base bt) := + match Hk with + | ForallT_nil => [] + | ForallT_cons he hrest => + denote_expr (S n') Σ iface oid TagU (fst _) bt he rho v :: go _ hrest + end) _ f) + ((fix go l (Hv : ForallT _ l) : list (sem_mapping mu) := + match Hv with + | ForallT_nil => [] + | ForallT_cons hm hrest => + denote_mapexpr (S n') Σ iface oid (snd _) mu hm rho v :: go _ hrest + end) _ f0) + (denote_ref (S n') Σ iface k' oid TagU r (SMapping (MMapping bt mu)) Hr rho v)) + ] + end. +Defined. + +(* ================================================================= *) +(** ** Denotation of Slot Expressions — Section 10.2.5 + + For [T_SlotMap], [T_SlotRef], and [T_SlotAddr], the denotation is + straightforward. The [T_Create] and [T_CreatePayable] cases involve + constructor evaluation which is set-valued (Section 10.2.7) and + requires additional infrastructure. *) + +Fixpoint denote_slotexpr (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (se : slot_expr) (sty : slot_type) + (H : type_slotexpr_t Σ iface oid se sty) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_aux n Σ oid) + {struct H} : sem_slot_aux n Σ sty. +Proof. + destruct H. + + - (* T_SlotMap_t: m : μ → SMapping μ *) + match goal with + | [ Hm : type_mapexpr_t _ _ _ _ ?mu' |- _ ] => + destruct n as [|n']; simpl; + exact (denote_mapexpr _ Σ iface oid m mu' Hm rho v) + end. + + - (* T_SlotRef_t: ref : A → SContract A *) + match goal with + | [ Hr : type_ref_t _ _ ?k' _ TagU _ (SContract ?a') |- _ ] => + exact (denote_ref n Σ iface k' oid TagU r (SContract a') Hr rho v) + end. + + - (* T_SlotAddr_t: addr(se) : address_A *) + match goal with + | [ Hse : type_slotexpr_t _ _ _ _ (SContract ?a') |- _ ] => + destruct n as [|n']; simpl; + [ pose (cv := denote_slotexpr 0 Σ iface oid se (SContract a') Hse rho v); + simpl in cv; exact (match cv : Empty_set with end) + | exact (denote_slotexpr (S n') Σ iface oid se (SContract a') Hse rho v) ] + end. + + - (* T_Create_t: new A(se₁,...,seₙ) — constructor creation *) + (* The denotation of creates involves constructor case selection, + which is set-valued in the tech report (Section 10.2.7). + To be defined once the full constructor infrastructure is in place. *) + admit. + + - (* T_CreatePayable_t: new A{value: se_v}(se₁,...,seₙ) *) + admit. +Admitted. + +(* ================================================================= *) +(** ** Denotation of a Slot Expression List + + Evaluates a list of slot expressions, collecting results. *) + +Fixpoint denote_slotexpr_list (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (ses : list slot_expr) (alphas : list abi_type) + (H : Forall2T (fun se alpha => type_slotexpr_t Σ iface oid se (SAbi alpha)) + ses alphas) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_aux n Σ oid) + {struct H} : list { alpha : abi_type & sem_slot_aux n Σ (SAbi alpha) }. +Proof. + destruct H. + - exact []. + - match goal with + | [ Hse : type_slotexpr_t _ _ _ _ (SAbi ?a'), + Hrest : Forall2T _ _ _ |- _ ] => + exact (existT _ a' (denote_slotexpr n Σ iface oid _ _ Hse rho v) :: + denote_slotexpr_list n Σ iface oid _ _ Hrest rho v) + end. +Defined. + +(* ================================================================= *) +(** ** Denotation of Creates — Section 10.2.6 + + Builds a contract record from a list of creates. + Each create assigns a field of the new contract. + The result is a value of type ⟦Id⟧_{Σ, Id:C}. *) + +Fixpoint denote_creates_aux (n : nat) (Σ : contract_env) (iface : interface) + (creates : list create) + (H : ForallT (fun c => type_slotexpr_t Σ iface ONone (snd c) (fst (fst c))) creates) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_aux n Σ ONone) + {struct H} + : sem_layout_aux n Σ (map (fun c => (snd (fst c), fst (fst c))) creates). +Proof. + destruct H. + - exact tt. + - simpl. split. + + match goal with + | [ Hse : type_slotexpr_t _ _ _ (snd ?c) (fst (fst ?c)) |- _ ] => + exact (denote_slotexpr n Σ iface ONone (snd c) (fst (fst c)) Hse rho v) + end. + + exact (denote_creates_aux n Σ iface _ H rho v). +Defined. + +(* ================================================================= *) +(** ** Semantics of Constructors — Section 10.2.7 + + The constructor denotation is set-valued: given an environment ρ, + it produces the set of possible post-states of the new contract. + + ⟦Σ ⊢_Id cnstr : C⟧_ρ ⊆ ⟦Id⟧_{Σ,Id:C} + + The definition finds the unique case i whose condition evaluates + to true (guaranteed by the exhaustivity/exclusivity premise), + then evaluates creates_i to produce the contract record. *) + +(** Evaluate a list of boolean preconditions under the denotation *) +Fixpoint denote_pres_true (n : nat) (Σ : contract_env) (iface : interface) + (oid : opt_id) (t : time_tag) (pres : list expr) + (Hp : ForallT (fun pre => type_expr_t Σ iface oid t pre TBool) pres) + (rho : sem_iface_aux n Σ iface) + (v : sem_opt_id_timed_aux n Σ oid t) : Prop := + match Hp with + | ForallT_nil => True + | ForallT_cons he hrest => + denote_expr n Σ iface oid t _ TBool he rho v = true /\ + denote_pres_true n Σ iface oid t _ hrest rho v + end. + +Definition sem_constructor (n : nat) (Σ : contract_env) (a : ident) + (ctor : constructor) (layout : storage_layout) + (H : type_constructor_t Σ a ctor layout) + (rho : sem_iface_aux n Σ (ctor_iface ctor)) + (s : sem_layout_aux n Σ layout) + : Prop. +Proof. + destruct H as [? ? ? ? Hwf Hpres Hconds Hcreates Hlayout_wf Hdom Hposts Hexhaust]. + refine (exists i, i < length (ctor_cases ctor) /\ _ /\ _). + - (* All preconditions true *) + exact (denote_pres_true n Σ (ctor_iface ctor) ONone TagU _ Hpres rho tt). + - (* Case i true, others false *) + exact ((fix find (cases : list ctor_case) + (Hc : ForallT (fun cc => type_expr_t Σ (ctor_iface ctor) ONone TagU (fst cc) TBool) cases) + (idx : nat) : Prop := + match Hc with + | ForallT_nil => True + | ForallT_cons hcond hcrest => + (if Nat.eqb idx i + then denote_expr n Σ (ctor_iface ctor) ONone TagU _ TBool hcond rho tt = true + else denote_expr n Σ (ctor_iface ctor) ONone TagU _ TBool hcond rho tt = false) /\ + find _ hcrest (S idx) + end) (ctor_cases ctor) Hconds 0). +Defined. + +(* ================================================================= *) +(** ** Semantics of Transitions — Section 10.2.8 + + The transition denotation is a relation on pre- and post-states. + + ⟦Σ ⊢_Id transition⟧_ρ ⊆ ⟦Id⟧_Σ × ⟦Id⟧_Σ *) + +Definition sem_transition (n : nat) (Σ : contract_env) (a : ident) + (tr : transition) + (H : type_transition_t Σ a tr) + (rho : sem_iface_aux n Σ (trans_iface tr)) + (s s' : sem_slot_aux n Σ (SContract a)) + : Prop. +Proof. + destruct H as [? ? ? Hwf Hpres Hconds Hupds Hrets Hposts Hexhaust]. + refine (exists i, i < length (trans_cases tr) /\ _ /\ _). + - exact (denote_pres_true n Σ (trans_iface tr) (OSome a) TagU _ Hpres rho s). + - exact ((fix find (cases : list trans_case) + (Hc : ForallT (fun tc => type_expr_t Σ (trans_iface tr) (OSome a) TagU (tc_cond tc) TBool) cases) + (idx : nat) : Prop := + match Hc with + | ForallT_nil => True + | ForallT_cons hcond hcrest => + (if Nat.eqb idx i + then denote_expr n Σ (trans_iface tr) (OSome a) TagU _ TBool hcond rho s = true + else denote_expr n Σ (trans_iface tr) (OSome a) TagU _ TBool hcond rho s = false) /\ + find _ hcrest (S idx) + end) (trans_cases tr) Hconds 0). +Defined. + +(* ================================================================= *) +(** ** Type-valued Value Typing — for large elimination in Section 10.3 *) + +Inductive has_base_type_t : value -> base_type -> Type := + | V_Int_t : forall n it, in_range it n -> has_base_type_t (VInt n) (TInt it) + | V_Bool_t : forall b, has_base_type_t (VBool b) TBool + | V_Addr_t : forall a, has_base_type_t (VAddr a) TAddress. + +Inductive has_mapping_type_t : value -> mapping_type -> Type := + | V_BaseValMu_t : forall v bt, + has_base_type_t v bt -> + has_mapping_type_t v (MBase bt) + | V_MappingZ_t : forall f it mu, + (forall n, in_range it n -> has_mapping_type_t (f n) mu) -> + has_mapping_type_t (VMapZ f) (MMapping (TInt it) mu) + | V_MappingB_t : forall f mu, + (forall b, has_mapping_type_t (f b) mu) -> + has_mapping_type_t (VMapB f) (MMapping TBool mu) + | V_MappingA_t : forall f mu, + (forall a, has_mapping_type_t (f a) mu) -> + has_mapping_type_t (VMapA f) (MMapping TAddress mu). + +Inductive has_abi_type_t : contract_env -> value -> state -> abi_type -> Type := + | V_BaseValAlpha_t : forall Σ v s bt, + has_base_type_t v bt -> + has_abi_type_t Σ v s (ABase bt) + | V_AddrIsContract_t : forall Σ s (l : addr) (a : ident), + state_dom s l -> + dom (Σ_storage Σ) a -> + state_type s l = Some a -> + has_fields_t Σ s l (Σ_storage_or_nil Σ a) -> + has_abi_type_t Σ (VAddr l) s (AContractAddr a) + +with has_slot_type_t : contract_env -> value -> state -> slot_type -> Type := + | V_MappingVal_t : forall Σ v s mu, + has_mapping_type_t v mu -> + has_slot_type_t Σ v s (SMapping mu) + | V_ABIVal_t : forall Σ v s alpha, + has_abi_type_t Σ v s alpha -> + has_slot_type_t Σ v s (SAbi alpha) + | V_Contract_t : forall Σ (l : addr) s (a : ident), + has_abi_type_t Σ (VAddr l) s (AContractAddr a) -> + has_slot_type_t Σ (VAddr l) s (SContract a) + +with has_fields_t : contract_env -> state -> addr -> storage_layout -> Type := + | HF_nil : forall Σ s l, has_fields_t Σ s l [] + | HF_cons : forall Σ s l x sty rest, + has_slot_type_t Σ (state_var_force s l x) s sty -> + has_fields_t Σ s l rest -> + has_fields_t Σ s l ((x, sty) :: rest). + +(* ================================================================= *) +(** ** Denotation of Values — Section 10.3 + + Flattens pointer-values into semantic values by replacing contract + addresses with the contract records from the state. *) + +(** ⟦⊢ v : β⟧ ∈ ⟦β⟧ *) +Definition denote_base_value (v : value) (bt : base_type) + (H : has_base_type_t v bt) : sem_base bt := + match H with + | V_Int_t n it Hin => exist _ n Hin + | V_Bool_t b => b + | V_Addr_t a => a + end. + +(** ⟦⊢ v : μ⟧ ∈ ⟦μ⟧ *) +Fixpoint denote_mapping_value (v : value) (mu : mapping_type) + (H : has_mapping_type_t v mu) {struct H} : sem_mapping mu := + match H with + | V_BaseValMu_t _ bt Hb => denote_base_value _ bt Hb + | V_MappingZ_t f it mu' Hf => fun key => + denote_mapping_value (f (proj1_sig key)) mu' (Hf (proj1_sig key) (proj2_sig key)) + | V_MappingB_t f mu' Hf => fun key => denote_mapping_value (f key) mu' (Hf key) + | V_MappingA_t f mu' Hf => fun key => denote_mapping_value (f key) mu' (Hf key) + end. + +(* ----------------------------------------------------------------- *) +(** *** Depth measure — len(Σ, σ) *) + +(** Position of an identifier in a list (0-indexed from the start). + Returns [length l] if not found. *) +Fixpoint ident_index (l : list (ident * storage_layout)) (a : ident) : nat := + match l with + | [] => 0 + | (k, _) :: rest => if String.eqb k a then 0 else S (ident_index rest a) + end. + +(** len(Σ, σ) — the depth of a slot type in the store. + For contract types, this is [S (position of A in Σ)]. + For non-contract types, 0. + Strictly decreases for fields of a well-founded store. *) +Definition sty_depth (Σ : contract_env) (sty : slot_type) : nat := + match sty with + | SMapping _ => 0 + | SAbi (ABase _) => 0 + | SAbi (AContractAddr a) => S (ident_index (Σ_storage_list Σ) a) + | SContract a => S (ident_index (Σ_storage_list Σ) a) + end. + +(** Iterated depth weakening: coerce from depth [n] to depth [k + n]. *) +Fixpoint sem_slot_weaken_add (k n : nat) (Σ : contract_env) (st : slot_type) + : sem_slot_aux n Σ st -> sem_slot_aux (k + n) Σ st := + match k with + | 0 => id + | S k' => fun x => + sem_slot_weaken (k' + n) Σ st (sem_slot_weaken_add k' n Σ st x) + end. + +(** Well-foundedness of Σ: field types have strictly smaller depth. *) +Definition wf_Σ (Σ : contract_env) : Prop := + forall a x sty, + In (x, sty) (Σ_storage_or_nil Σ a) -> + sty_depth Σ sty < sty_depth Σ (SContract a). + +(** Build contract fields from a [has_fields_t] proof and a denotation function + for each field. The [rec] callback receives an [In] proof so the caller + can appeal to well-foundedness. *) +Fixpoint denote_fields (n : nat) (Σ : contract_env) (s : state) (l : addr) + (a : ident) (layout : storage_layout) (F : has_fields_t Σ s l layout) + (Hsub : incl layout (Σ_storage_or_nil Σ a)) + (rec : forall x sty, + In (x, sty) (Σ_storage_or_nil Σ a) -> + has_slot_type_t Σ (state_var_force s l x) s sty -> + sem_slot_aux n Σ sty) + {struct F} : sem_layout_aux n Σ layout. +Proof. + destruct F. + - exact tt. + - simpl. match goal with + | [Hfld : has_slot_type_t _ _ _ ?sty0, + Frest : has_fields_t _ _ _ ?rest0 |- _] => + exact (rec _ sty0 (Hsub _ (or_introl eq_refl)) Hfld, + denote_fields n Σ s l a rest0 Frest + (fun p Hp => Hsub p (or_intror Hp)) rec) + end. +Defined. + +(** ⟦Σ ⊢ v :_s σ⟧ ∈ ⟦σ⟧_Σ — by well-founded recursion on len(Σ, σ). + + The step function for the [Fix] combinator. At depth [d], + the recursive call [rec d' Hlt] is available for any [d' < d]. + Requires [wf_Σ Σ] and [sty_depth Σ sty <= d]. *) +Lemma sub_add_eq : forall n m, m <= n -> n - m + m = n. +Proof. intros. lia. Qed. + +Definition denote_slot_value_body + (Σ : contract_env) (s : state) (HwfΣ : wf_Σ Σ) + (d : nat) + (rec : forall d', d' < d -> + forall sty v, has_slot_type_t Σ v s sty -> + sty_depth Σ sty <= d' -> sem_slot_aux d' Σ sty) + (sty : slot_type) (v : value) (H : has_slot_type_t Σ v s sty) + (Hd : sty_depth Σ sty <= d) + : sem_slot_aux d Σ sty. +Proof. + destruct H; destruct d as [|d']; simpl. + - (* V_MappingVal_t, d=0 *) exact (denote_mapping_value v mu h). + - (* V_MappingVal_t, d=S d' *) exact (denote_mapping_value v mu h). + - (* V_ABIVal_t, d=0 *) + destruct h; simpl. + + exact (denote_base_value v bt h). + + exfalso. simpl in Hd. lia. + - (* V_ABIVal_t, d=S d' *) + destruct h; simpl. + + exact (denote_base_value v bt h). + + refine (l, denote_fields d' Σ s l a _ h (incl_refl _) _). + intros x0 sty0 Hin0 Hsty0. + assert (Hdepth : sty_depth Σ sty0 < sty_depth Σ (SContract a)). + { exact (HwfΣ a x0 sty0 Hin0). } + refine (eq_rect _ (fun n => sem_slot_aux n Σ sty0) + (sem_slot_weaken_add (d' - sty_depth Σ sty0) + (sty_depth Σ sty0) Σ sty0 + (rec (sty_depth Σ sty0) _ sty0 _ Hsty0 (le_n _))) + d' (sub_add_eq d' (sty_depth Σ sty0) _)). + { simpl in Hd, Hdepth. lia. } + { simpl in Hd, Hdepth. lia. } + - (* V_Contract_t, d=0 *) + exfalso. simpl in Hd. lia. + - (* V_Contract_t, d=S d' *) + simpl. + inversion h as [? ? ? ? Hbt | ? ? ? ? Hdom HdomΣ Htype Hfields]; subst. + { refine (l, denote_fields d' Σ s l a _ Hfields (incl_refl _) _). + intros x0 sty0 Hin0 Hsty0. + assert (Hdepth : sty_depth Σ sty0 < sty_depth Σ (SContract a)). + { exact (HwfΣ a x0 sty0 Hin0). } + refine (eq_rect _ (fun n => sem_slot_aux n Σ sty0) + (sem_slot_weaken_add (d' - sty_depth Σ sty0) + (sty_depth Σ sty0) Σ sty0 + (rec (sty_depth Σ sty0) _ sty0 _ Hsty0 (le_n _))) + d' (sub_add_eq d' (sty_depth Σ sty0) _)). + { simpl in Hd, Hdepth. lia. } + { simpl in Hd, Hdepth. lia. } } +Defined. + +Definition denote_slot_value (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (v : value) (s : state) + (sty : slot_type) (H : has_slot_type_t Σ v s sty) + : sem_slot_aux (sty_depth Σ sty) Σ sty := + Fix lt_wf + (fun d => forall sty v, has_slot_type_t Σ v s sty -> + sty_depth Σ sty <= d -> sem_slot_aux d Σ sty) + (denote_slot_value_body Σ s HwfΣ) + (sty_depth Σ sty) sty v H (le_n _). + +Definition denote_abi_value (Σ : contract_env) (HwfΣ : wf_Σ Σ) + (v : value) (s : state) + (alpha : abi_type) (H : has_abi_type_t Σ v s alpha) + : sem_slot_aux (sty_depth Σ (SAbi alpha)) Σ (SAbi alpha) := + denote_slot_value Σ HwfΣ v s (SAbi alpha) (V_ABIVal_t Σ v s alpha H). diff --git a/theories/ValueTyping.v b/theories/ValueTyping.v new file mode 100644 index 00000000..52438381 --- /dev/null +++ b/theories/ValueTyping.v @@ -0,0 +1,831 @@ +(** * Value Typing, Environment Typing, Entailment, Well-typed Σ, + Well-foundedness, and Helper Lemmas + Formalizes Sections 3-5 of the tech report. *) + +From Stdlib Require Import String ZArith List Bool PeanoNat Lia. +From Act Require Import Maps Syntax Domains Semantics. +Import ListNotations. + +(* ================================================================= *) +(** ** Value Typing: ⊢ v : β *) + +Inductive has_base_type : value -> base_type -> Prop := + (** V-Addr *) + | V_Addr : forall (a : addr), + has_base_type (VAddr a) TAddress + (** V-Bool *) + | V_Bool : forall (b : bool), + has_base_type (VBool b) TBool + (** V-Int *) + | V_Int : forall (n : Z) (it : int_type), + in_range it n -> + has_base_type (VInt n) (TInt it). + +(* ================================================================= *) +(** ** Value Typing: ⊢ v : μ *) + +Inductive has_mapping_type : value -> mapping_type -> Prop := + (** V-BaseValMu *) + | V_BaseValMu : forall v bt, + has_base_type v bt -> + has_mapping_type v (MBase bt) + (** V-Mapping with Z keys *) + | V_MappingZ : forall f it mu, + (forall n, has_base_type (VInt n) (TInt it) -> + has_mapping_type (f n) mu) -> + has_mapping_type (VMapZ f) (MMapping (TInt it) mu) + (** V-Mapping with bool keys *) + | V_MappingB : forall f mu, + (forall b, has_mapping_type (f b) mu) -> + has_mapping_type (VMapB f) (MMapping TBool mu) + (** V-Mapping with address keys *) + | V_MappingA : forall f mu, + (forall a, has_mapping_type (f a) mu) -> + has_mapping_type (VMapA f) (MMapping TAddress mu). + +(* ================================================================= *) +(** ** Value Typing: Σ ⊢ v :_s α and Σ ⊢ v :_s σ *) + +Inductive has_abi_type : contract_env -> value -> state -> abi_type -> Prop := + (** V-BaseValAlpha *) + | V_BaseValAlpha : forall Σ v s bt, + has_base_type v bt -> + has_abi_type Σ v s (ABase bt) + (** V-AddrIsContract *) + | V_AddrIsContract : forall Σ s (l : addr) (a : ident), + state_dom s l -> + dom (Σ_storage Σ) a -> + state_type s l = Some a -> + (forall x, state_var_dom s l x <-> + exists st, Σ_storage_var Σ a x = Some st) -> + (forall x st, Σ_storage_var Σ a x = Some st -> + has_slot_type Σ (state_var_force s l x) s st) -> + has_abi_type Σ (VAddr l) s (AContractAddr a) + +with has_slot_type : contract_env -> value -> state -> slot_type -> Prop := + (** V-MappingVal *) + | V_MappingVal : forall Σ v s mu, + has_mapping_type v mu -> + has_slot_type Σ v s (SMapping mu) + (** V-ABIVal *) + | V_ABIVal : forall Σ v s alpha, + has_abi_type Σ v s alpha -> + has_slot_type Σ v s (SAbi alpha) + (** V-Contract *) + | V_Contract : forall Σ (l : addr) s (a : ident), + has_abi_type Σ (VAddr l) s (AContractAddr a) -> + has_slot_type Σ (VAddr l) s (SContract a). + +(** Mutual induction schemes for has_abi_type / has_slot_type *) +Scheme has_abi_type_ind2 := Induction for has_abi_type Sort Prop + with has_slot_type_ind2 := Induction for has_slot_type Sort Prop. +Combined Scheme has_abi_slot_mutind from has_abi_type_ind2, has_slot_type_ind2. + +(* ================================================================= *) +(** ** Optional Slot Typing: Σ ⊢ v :_s ⊥?σ *) + +Inductive has_opt_slot_type : contract_env -> value -> state -> opt_id -> Prop := + (** V-None: ⊥ accepts any value *) + | V_None : forall Σ v s, + has_opt_slot_type Σ v s ONone + (** V-Some *) + | V_Some : forall Σ v s a, + has_slot_type Σ v s (SContract a) -> + has_opt_slot_type Σ v s (OSome a). + +(** Location typing shorthand: Σ ⊢ ℓ :_s ⊥?A *) +Definition loc_has_opt_type (Σ : contract_env) (l : addr) (s : state) (oid : opt_id) : Prop := + match oid with + | ONone => True + | OSome a => has_slot_type Σ (VAddr l) s (SContract a) + end. + +(* ================================================================= *) +(** ** Environment Typing: Σ ⊢ ρ :_s I *) + +(** V-Env *) +Definition env_well_typed (Σ : contract_env) (rho : env) (s : state) (iface : interface) : Prop := + (** domain condition: dom(ρ) = dom(I) ∪ {caller, origin, callvalue} *) + (forall x, dom rho x <-> + (alist_dom iface x \/ + x = "caller"%string \/ + x = "origin"%string \/ + x = "callvalue"%string)) /\ + (** interface variables are well-typed *) + (forall x alpha, alist_lookup iface x = Some alpha -> + exists v, rho x = Some v /\ has_abi_type Σ v s alpha) /\ + (** caller : address *) + (exists vc, rho "caller"%string = Some vc /\ has_base_type vc TAddress) /\ + (** origin : address *) + (exists vo, rho "origin"%string = Some vo /\ has_base_type vo TAddress) /\ + (** callvalue : uint256 *) + (exists vcv, rho "callvalue"%string = Some vcv /\ + has_base_type vcv (TInt (UintT 256))). + +(* ================================================================= *) +(** ** Semantic Entailment *) + +(** Σ; I; Φ ⊨_{⊥?A} es — ValidExps *) +Definition semantic_entailment (Σ : contract_env) (iface : interface) (phi : list expr) + (oid : opt_id) (es : list expr) : Prop := + forall s rho l, + env_well_typed Σ rho s iface -> + loc_has_opt_type Σ l s oid -> + Forall (fun p => eval_expr (TSUntimed s) rho p l (VBool true)) phi -> + Forall (fun e => eval_expr (TSUntimed s) rho e l (VBool true)) es. + +(** Σ; I; Φ ⊨_{⊥?A} (ses, pres) — ValidIffs *) +Definition semantic_entailment_iffs (Σ : contract_env) (iface : interface) (phi : list expr) + (oid : opt_id) (ses : list slot_expr) (pres : list expr) : Prop := + forall s0 rho l vs ss, + env_well_typed Σ rho s0 iface -> + loc_has_opt_type Σ l s0 oid -> + Forall (fun p => eval_expr (TSUntimed s0) rho p l (VBool true)) phi -> + length vs = length ses -> + length ss = length ses -> + (forall i, i < length ses -> + eval_slotexpr (Σ_cnstr Σ) (nth i ss s0) rho (nth i ses (SEMap (MExp (EBool false)))) l + (nth i vs (VInt 0%Z)) (nth (S i) ss s0)) -> + let s_n := last ss s0 in + let rho' := fold_right (fun '(x, v) r => Maps.update r x v) + empty + (combine (map fst (firstn (length ses) (ctor_iface (mk_ctor iface false [] [] [])))) vs) in + Forall (fun e => eval_expr (TSUntimed s_n) rho' e dummy_loc (VBool true)) pres. + +(* ================================================================= *) +(** ** Well-foundedness of contract dependency relation *) + +(** B ≺_Σ A iff contract B is directly accessible from contract A's storage *) +Definition contract_dep (Σ : contract_env) (b a : ident) : Prop := + exists x, (Σ_storage_var Σ a x = Some (SContract b) \/ + Σ_storage_var Σ a x = Some (SAbi (AContractAddr b))). + +(** Accessibility: standard well-founded accessibility *) +Definition Σ_accessible (Σ : contract_env) : ident -> Prop := + Acc (fun b a => contract_dep Σ b a). + +(** WF(≺_Σ) = ∀ x. Acc x *) +Definition Σ_wf (Σ : contract_env) : Prop := + forall x, Σ_accessible Σ x. + +(** Well-formedness of Σ: all storage references point to defined contracts *) +Definition Σ_storage_wf (Σ : contract_env) : Prop := + forall a b, contract_dep Σ b a -> dom (Σ_storage Σ) b. + +(** contract_dep only depends on Σ_storage *) +Lemma contract_dep_storage_eq : forall Σ Σ' b a, + Σ_storage Σ = Σ_storage Σ' -> + contract_dep Σ b a -> contract_dep Σ' b a. +Proof. + intros Σ Σ' b a Heq [x Hx]. + exists x. unfold Σ_storage_var in *. rewrite <- Heq. exact Hx. +Qed. + +Lemma contract_dep_with_storage_neq : forall Σ a layout b c, + c <> a -> + contract_dep (Σ_with_storage Σ a layout) b c <-> contract_dep Σ b c. +Proof. + intros Σ a layout b c Hne. + split; intros [x Hx]; exists x; unfold Σ_storage_var in *; + rewrite Σ_storage_with_storage in *; rewrite update_neq in * by auto; + exact Hx. +Qed. + +Lemma contract_dep_with_cnstr : forall Σ a ctor b c, + contract_dep (Σ_with_cnstr Σ a ctor) b c <-> contract_dep Σ b c. +Proof. + intros. split; intros [x Hx]; exists x; exact Hx. +Qed. + +Lemma contract_dep_with_trans : forall Σ a transs b c, + contract_dep (Σ_with_trans Σ a transs) b c <-> contract_dep Σ b c. +Proof. + intros. split; intros [x Hx]; exists x; exact Hx. +Qed. + +(* ================================================================= *) +(** ** len(Σ, A) — chain length *) + +(** We define len abstractly — in proofs we use well-foundedness directly *) +Definition Σ_len (Σ : contract_env) (a : ident) + (acc : Acc (fun b c => contract_dep Σ b c) a) : nat := 0. + +(** len extended to slot types *) +Definition Σ_len_slot (Σ : contract_env) (st : slot_type) : nat := + match st with + | SContract a => 0 (* placeholder *) + | SAbi (AContractAddr a) => 0 (* placeholder *) + | _ => 0 + end. + +(** Σ_incl helpers *) +Lemma Σ_incl_refl : forall Σ, Σ_incl Σ Σ. +Proof. + intro Σ. split; [|split]; apply includes_refl. +Qed. + +Lemma Σ_incl_trans : forall sg1 sg2 sg3, + Σ_incl sg1 sg2 -> Σ_incl sg2 sg3 -> Σ_incl sg1 sg3. +Proof. + intros sg1 sg2 sg3 [Hs1 [Hc1 Ht1]] [Hs2 [Hc2 Ht2]]. + split; [|split]; eapply includes_trans; eauto. +Qed. + +Lemma Σ_incl_storage : forall Σ Σ' a layout, + Σ_incl Σ Σ' -> Σ_storage Σ a = Some layout -> + Σ_storage Σ' a = Some layout. +Proof. + intros Σ Σ' a layout [Hs _] H. apply Hs. exact H. +Qed. + +Lemma Σ_incl_storage_var : forall Σ Σ' a x st, + Σ_incl Σ Σ' -> + Σ_storage_var Σ a x = Some st -> + Σ_storage_var Σ' a x = Some st. +Proof. + intros Σ Σ' a x st [Hs _] H. + unfold Σ_storage_var in *. + destruct (Σ_storage Σ a) eqn:E; [|discriminate]. + rewrite (Hs a s E). exact H. +Qed. + +Lemma Σ_incl_storage_dom : forall Σ Σ', + Σ_incl Σ Σ' -> + forall a, dom (Σ_storage Σ) a -> dom (Σ_storage Σ') a. +Proof. + intros Σ Σ' [Hs _] a [v Hv]. + exists v. apply Hs. exact Hv. +Qed. + +Lemma Σ_incl_with_storage_fresh : forall Σ a layout, + ~ dom (Σ_storage Σ) a -> + Σ_incl Σ (Σ_with_storage Σ a layout). +Proof. + intros Σ a layout Hfresh. + split; [|split]; simpl. + - apply includes_update_fresh. exact Hfresh. + - apply includes_refl. + - apply includes_refl. +Qed. + +Lemma Σ_incl_with_cnstr_fresh : forall Σ a ctor, + ~ dom (Σ_cnstr Σ) a -> + Σ_incl Σ (Σ_with_cnstr Σ a ctor). +Proof. + intros Σ a ctor Hfresh. + split; [|split]; simpl. + - apply includes_refl. + - apply includes_update_fresh. exact Hfresh. + - apply includes_refl. +Qed. + +Lemma Σ_incl_with_trans_fresh : forall Σ a transs, + ~ dom (Σ_trans Σ) a -> + Σ_incl Σ (Σ_with_trans Σ a transs). +Proof. + intros Σ a transs Hfresh. + split; [|split]; simpl. + - apply includes_refl. + - apply includes_refl. + - apply includes_update_fresh. exact Hfresh. +Qed. + +Lemma Σ_incl_cnstr : forall Σ Σ' a ctor, + Σ_incl Σ Σ' -> Σ_cnstr Σ a = Some ctor -> + Σ_cnstr Σ' a = Some ctor. +Proof. + intros Σ Σ' a ctor [_ [Hc _]] H. apply Hc. exact H. +Qed. + +Lemma Σ_incl_trans_lookup : forall Σ Σ' a transs, + Σ_incl Σ Σ' -> Σ_trans Σ a = Some transs -> + Σ_trans Σ' a = Some transs. +Proof. + intros Σ Σ' a transs [_ [_ Ht]] H. apply Ht. exact H. +Qed. + +Lemma contract_dep_incl : forall Σ Σ' b a, + Σ_incl Σ Σ' -> + contract_dep Σ b a -> contract_dep Σ' b a. +Proof. + intros Σ Σ' b a Hincl [x Hx]. + exists x. destruct Hx as [Hx|Hx]; [left|right]; + eapply Σ_incl_storage_var; eauto. +Qed. + +Lemma Σ_wf_incl : forall Σ Σ', + Σ_incl Σ Σ' -> Σ_wf Σ' -> Σ_wf Σ. +Proof. + intros Σ Σ' Hincl Hwf x. + induction (Hwf x) as [x _ IH]. + constructor. intros y Hd. + apply IH. eapply contract_dep_incl; eauto. +Qed. + +(* Well-formedness predicate for default value typing *) +Fixpoint default_value_typable (mu : mapping_type) : Prop := + match mu with + | MBase (TInt it) => in_range it 0%Z + | MBase _ => True + | MMapping _ mu' => default_value_typable mu' + end. + +(* ================================================================= *) +(** ** Key Lemmas *) + +(** Uniqueness of Contract Value Typing (Lemma 5.1) *) +Lemma uniqueness_of_value_typing : + forall Σ l s a b, + has_slot_type Σ (VAddr l) s (SContract a) -> + has_slot_type Σ (VAddr l) s (SContract b) -> + a = b. +Proof. + intros Σ l s a b Ha Hb. + inv Ha. inv Hb. + match goal with + | [H1 : has_abi_type _ _ _ (AContractAddr a), + H2 : has_abi_type _ _ _ (AContractAddr b) |- _] => + inv H1; inv H2; congruence + end. +Qed. + +(** default(μ) has mapping type (Lemma 5.3) + Note: requires well-formedness to ensure 0 is in range for all + integer base types appearing in μ. The paper assumes standard + Solidity types where this always holds. *) +Lemma default_has_mapping_type : + forall mu, default_value_typable mu -> has_mapping_type (default_value mu) mu. +Proof. + induction mu; simpl; intros Hwf. + - (* MBase *) + apply V_BaseValMu. + destruct b; try constructor; auto. + - (* MMapping *) + destruct b; simpl. + + (* TInt *) apply V_MappingZ. intros n _. apply IHmu. exact Hwf. + + (* TBool *) apply V_MappingB. intros b. apply IHmu. exact Hwf. + + (* TAddress *) apply V_MappingA. intros a. apply IHmu. exact Hwf. +Qed. + +(** Weakening of Storage (Typing) — Lemma 5.4 + By mutual induction on the value typing derivation. *) +Lemma valuetyp_storage_weak : + (forall Σ v s alpha, + has_abi_type Σ v s alpha -> + forall s', state_incl s s' -> has_abi_type Σ v s' alpha) /\ + (forall Σ v s st, + has_slot_type Σ v s st -> + forall s', state_incl s s' -> has_slot_type Σ v s' st). +Proof. + apply has_abi_slot_mutind; intros. + - (* V_BaseValAlpha *) constructor; auto. + - (* V_AddrIsContract *) + assert (Hdom : state_dom s l) by auto. + econstructor; eauto. + + eapply state_incl_dom; eauto. + + eapply state_incl_type; eauto. + + intro x0. rewrite <- (state_incl_var_dom s s' l x0); auto. + + intros x0 st0 Hst0. + rewrite (state_incl_var_force s s' l x0); auto. + - (* V_MappingVal *) constructor; auto. + - (* V_ABIVal *) constructor; auto. + - (* V_Contract *) constructor; auto. +Qed. + +Lemma valuetyp_storage_weak_abi : + forall Σ v s s' alpha, + state_incl s s' -> + has_abi_type Σ v s alpha -> + has_abi_type Σ v s' alpha. +Proof. intros. eapply (proj1 valuetyp_storage_weak); eauto. Qed. + +Lemma valuetyp_storage_weak_slot : + forall Σ v s s' st, + state_incl s s' -> + has_slot_type Σ v s st -> + has_slot_type Σ v s' st. +Proof. intros. eapply (proj2 valuetyp_storage_weak); eauto. Qed. + +Lemma valuetyp_storage_weak_env : + forall Σ rho s s' iface, + state_incl s s' -> + env_well_typed Σ rho s iface -> + env_well_typed Σ rho s' iface. +Proof. + intros Σ rho s s' iface Hincl H. + destruct H as (Hdom & Hvars & Hc & Ho & Hcv). + split; [exact Hdom|]. + split; [|exact (conj Hc (conj Ho Hcv))]. + intros y al Hlook. destruct (Hvars y al Hlook) as [v [Hv Htyp]]. + exists v. split; [exact Hv|]. eapply valuetyp_storage_weak_abi; eauto. +Qed. + +Lemma env_well_typed_pres : + forall Σ rho s s' iface, + (forall v st, has_slot_type Σ v s st -> has_slot_type Σ v s' st) -> + env_well_typed Σ rho s iface -> + env_well_typed Σ rho s' iface. +Proof. + intros Σ rho s s' iface Hpres H. + destruct H as (Hdom & Hvars & Hc & Ho & Hcv). + split; [exact Hdom|]. + split; [|exact (conj Hc (conj Ho Hcv))]. + intros y al Hlook. destruct (Hvars y al Hlook) as [v [Hv Htyp]]. + exists v. split; [exact Hv|]. + assert (Hs := Hpres v (SAbi al) ltac:(constructor; exact Htyp)). + inv Hs. assumption. +Qed. + +(** Weakening of Store Typing — Lemma 5.6 + By mutual induction on the value typing derivation. *) +Lemma valuetyp_storetyp_weak : + (forall Σ v s alpha, + has_abi_type Σ v s alpha -> + forall Σ', Σ_incl Σ Σ' -> has_abi_type Σ' v s alpha) /\ + (forall Σ v s st, + has_slot_type Σ v s st -> + forall Σ', Σ_incl Σ Σ' -> has_slot_type Σ' v s st). +Proof. + apply has_abi_slot_mutind; intros. + - (* V_BaseValAlpha *) constructor; auto. + - (* V_AddrIsContract *) + assert (Hssv : forall y, Σ_storage_var Σ a y = Σ_storage_var Σ' a y). + { intro y. unfold Σ_storage_var. + destruct d as [lay Hlay]. + destruct H0 as [Hst _]. + rewrite Hlay. rewrite (Hst a lay Hlay). reflexivity. } + econstructor; eauto. + + eapply Σ_incl_storage_dom; eauto. + + intro x0. rewrite (i x0). split; intros [st0 Hst0]; exists st0. + * rewrite <- Hssv. exact Hst0. + * rewrite Hssv. exact Hst0. + + intros x0 st0 Hst0. rewrite <- Hssv in Hst0. eapply H; eauto. + - (* V_MappingVal *) constructor; auto. + - (* V_ABIVal *) constructor. eauto. + - (* V_Contract *) constructor. eauto. +Qed. + +Lemma valuetyp_storetyp_weak_abi : + forall Σ Σ' v s alpha, + Σ_incl Σ Σ' -> + has_abi_type Σ v s alpha -> + has_abi_type Σ' v s alpha. +Proof. intros. eapply (proj1 valuetyp_storetyp_weak); eauto. Qed. + +Lemma valuetyp_storetyp_weak_slot : + forall Σ Σ' v s st, + Σ_incl Σ Σ' -> + has_slot_type Σ v s st -> + has_slot_type Σ' v s st. +Proof. intros. eapply (proj2 valuetyp_storetyp_weak); eauto. Qed. + +(** ** Preservation Lemmas *) + +(** Helper: state_update_var preserves dom *) +Lemma state_update_var_dom : forall s l x v l', + state_dom s l' -> state_dom (state_update_var s l x v) l'. +Proof. + intros s l x v l' [ls' Hls']. + unfold state_dom. rewrite state_update_var_store. + destruct (s l) eqn:El. + - destruct (Nat.eqb l l') eqn:Ell'. + + eexists; reflexivity. + + eexists; eauto. + - eexists; eauto. +Qed. + +(** Helper: state_update_var preserves type *) +Lemma state_update_var_type : forall s l x v l' a, + state_type s l' = Some a -> state_type (state_update_var s l x v) l' = Some a. +Proof. + intros. unfold state_type. rewrite state_update_var_store. + unfold state_type in H. + destruct (s l) eqn:El. + - destruct (Nat.eqb_spec l l'). + + subst. rewrite El in H. simpl. exact H. + + exact H. + - exact H. +Qed. + +(** Helper: state_update_var variable access *) +Lemma state_update_var_same : forall s l x v, + state_dom s l -> + state_var (state_update_var s l x v) l x = Some v. +Proof. + intros s l x v [ls Hls]. + unfold state_var. rewrite state_update_var_store. rewrite Hls. + rewrite Nat.eqb_refl. simpl. + unfold Maps.update. rewrite String.eqb_refl. auto. +Qed. + +Lemma state_update_var_other : forall s l x v l' y, + (l' <> l \/ y <> x) -> + state_var (state_update_var s l x v) l' y = state_var s l' y. +Proof. + intros. unfold state_var. rewrite state_update_var_store. + destruct (s l) eqn:El. + - destruct (Nat.eqb_spec l l'). + + subst. simpl. + unfold Maps.update. destruct (String.eqb x y) eqn:Exy. + * apply String.eqb_eq in Exy. subst. exfalso. destruct H as [Hc|Hc]; apply Hc; reflexivity. + * rewrite El. auto. + + auto. + - auto. +Qed. + +(** Helper: state_var_force preserved for other locations/variables *) +Lemma state_update_var_force_other : forall s l x v l' y, + (l' <> l \/ y <> x) -> + state_var_force (state_update_var s l x v) l' y = state_var_force s l' y. +Proof. + intros. unfold state_var_force. rewrite state_update_var_other; auto. +Qed. + +Lemma state_update_var_force_same : forall s l x v, + state_dom s l -> + state_var_force (state_update_var s l x v) l x = v. +Proof. + intros. unfold state_var_force. rewrite state_update_var_same; auto. +Qed. + +Lemma state_update_var_var_dom : forall s l x v l' y, + (l' <> l \/ y <> x) -> + state_var_dom (state_update_var s l x v) l' y <-> state_var_dom s l' y. +Proof. + intros. unfold state_var_dom. split; intros [w Hw]. + - rewrite state_update_var_other in Hw by auto. eauto. + - rewrite state_update_var_other by auto. eauto. +Qed. + +Lemma state_update_var_var_dom_same : forall s l x v, + state_dom s l -> + state_var_dom (state_update_var s l x v) l x. +Proof. + intros. exists v. apply state_update_var_same. auto. +Qed. + +(** Convert has_slot_type from s to s' for a slot type that appears in + a contract's storage, given the IH for contract dependencies *) +Lemma convert_slot_type_from_storage : + forall Σ s l a x v', + has_slot_type Σ (VAddr l) s (SContract a) -> + (exists st, Σ_storage_var Σ a x = Some st /\ + has_slot_type Σ v' s st) -> + let s' := state_update_var s l x v' in + forall c, + (forall b, contract_dep Σ b c -> + forall w, has_abi_type Σ w s (AContractAddr b) -> + has_abi_type Σ w s' (AContractAddr b)) -> + forall y st w, + Σ_storage_var Σ c y = Some st -> + has_slot_type Σ w s st -> + has_slot_type Σ w s' st. +Proof. + intros Σ s l a x v' Hloc Hv' s' c IH y st w Hst Htyp. + destruct st as [mu0 | [bt0 | b0] | b0]. + - inv Htyp. constructor. auto. + - inv Htyp. + match goal with [H : has_abi_type _ _ _ _ |- _] => inv H end. + constructor. constructor. auto. + - inv Htyp. constructor. apply (IH b0). + + exists y. right. exact Hst. + + match goal with [H : has_abi_type _ _ _ _ |- _] => exact H end. + - inv Htyp. constructor. apply (IH b0). + + exists y. left. exact Hst. + + match goal with [H : has_abi_type _ _ _ _ |- _] => exact H end. +Qed. + +(** Core preservation: by Acc induction on contract dependency *) +Lemma update_preserves_abi_contract : + forall Σ s l a x v', + has_slot_type Σ (VAddr l) s (SContract a) -> + (exists st, Σ_storage_var Σ a x = Some st /\ + has_slot_type Σ v' s st) -> + let s' := state_update_var s l x v' in + forall c, Acc (contract_dep Σ) c -> + forall w, has_abi_type Σ w s (AContractAddr c) -> + has_abi_type Σ w s' (AContractAddr c). +Proof. + intros Σ s l a x v' Hloc Hv' s' c Hacc. + induction Hacc as [c _ IH]. + intros w Hw. inversion Hw; subst. unfold s' in *. + assert (Htype_l : state_type s l = Some a). + { inv Hloc. match goal with [H : has_abi_type _ _ _ _ |- _] => inv H; auto end. } + assert (Hdom_l : state_dom s l). + { inv Hloc. match goal with [H : has_abi_type _ _ _ _ |- _] => inv H; auto end. } + econstructor; eauto using state_update_var_dom, state_update_var_type. + - (* state_var_dom equivalence *) + intro y. + destruct (Nat.eq_dec l0 l) as [Hl|Hl]; [|rewrite state_update_var_var_dom by auto; auto]. + subst l0. + destruct (String.eqb_spec y x) as [Hyx|Hyx]; [|rewrite state_update_var_var_dom by auto; auto]. + subst y. + assert (Hca : c = a) by (unfold state_type in *; destruct (s l); [congruence|discriminate]). subst c. + split. + + intros _. destruct Hv' as [st0 [Hst0 _]]. eauto. + + intros _. apply state_update_var_var_dom_same. exact Hdom_l. + - (* variable typing *) + intros y st Hst. + destruct (Nat.eq_dec l0 l) as [Hl|Hl]; + destruct (String.eqb_spec y x) as [Hyx|Hyx]. + + (* l0 = l, y = x: updated variable *) + subst. + assert (Hca : c = a) by (unfold state_type in *; destruct (s l); [congruence|discriminate]). subst c. + rewrite state_update_var_force_same by exact Hdom_l. + destruct Hv' as [st0 [Hst0 Hv'typ]]. + assert (Heq : st = st0) by (unfold Σ_storage_var in *; congruence). subst st0. + eapply convert_slot_type_from_storage; eauto. + + (* l0 = l, y <> x *) + subst l0. rewrite state_update_var_force_other by auto. + eapply convert_slot_type_from_storage; eauto. + + (* l0 <> l, y = x *) + subst y. rewrite state_update_var_force_other by auto. + eapply convert_slot_type_from_storage; eauto. + + (* l0 <> l, y <> x *) + rewrite state_update_var_force_other by auto. + eapply convert_slot_type_from_storage; eauto. +Qed. + +(** Well-typed Update Preserves Typing — Lemma 5.8 + By well-founded induction on the contract dependency relation. *) +Lemma update_preserves_typing : + forall Σ v s s' sty l a x v', + Σ_wf Σ -> + has_slot_type Σ v s sty -> + has_slot_type Σ (VAddr l) s (SContract a) -> + (exists st, Σ_storage_var Σ a x = Some st /\ + has_slot_type Σ v' s st) -> + s' = state_update_var s l x v' -> + has_slot_type Σ v s' sty. +Proof. + intros Σ v s s' sty l a x v' Hwf Hv Hloc Hv' Hs'. subst s'. + destruct sty as [mu | alpha | b]. + - inversion Hv; subst. constructor. auto. + - destruct alpha as [bt | b]. + + inversion Hv; subst. + match goal with [H : has_abi_type _ _ _ _ |- _] => inversion H; subst end. + constructor. constructor. auto. + + inversion Hv; subst. constructor. + apply (update_preserves_abi_contract Σ s l a x v' Hloc Hv' b (Hwf b)). + match goal with [H : has_abi_type _ _ _ _ |- _] => exact H end. + - inversion Hv; subst. constructor. + apply (update_preserves_abi_contract Σ s l a x v' Hloc Hv' b (Hwf b)). + match goal with [H : has_abi_type _ _ _ _ |- _] => exact H end. +Qed. + +(** Well-typed Insertion Preserves Typing — Lemma 5.9 + eval_insert always results in a state_update_var, so this + reduces to update_preserves_typing after case analysis. *) +Lemma insertion_preserves_typing : + forall Σ v s s' sty l a rho r v', + Σ_wf Σ -> + has_slot_type Σ v s sty -> + has_slot_type Σ (VAddr l) s (SContract a) -> + eval_insert s rho r v' l s' -> + (forall l' x, s' = state_update_var s l' x v' -> + has_slot_type Σ (VAddr l') s (SContract a) /\ + exists st, Σ_storage_var Σ a x = Some st /\ + has_slot_type Σ v' s st) -> + has_slot_type Σ v s' sty. +Proof. + intros Σ v s s' sty l a rho r v' Hwf Hv Hloc Hins Htarget. + inversion Hins; subst. + - (* E_InsStorage *) + destruct (Htarget l x eq_refl) as [Hloc' [st [Hst Hv'typ]]]. + eapply update_preserves_typing; eauto. + - (* E_InsField *) + destruct (Htarget l' x eq_refl) as [Hloc' [st [Hst Hv'typ]]]. + eapply update_preserves_typing; eauto. +Qed. + +(* ================================================================= *) +(** ** build_ctor_env produces a well-typed environment *) + +Lemma combine_forall2_lookup : + forall Σ s (iface : interface) (vals : list value) x alpha, + Forall2 (fun v alpha => has_abi_type Σ v s alpha) vals (map snd iface) -> + alist_lookup iface x = Some alpha -> + exists v, alist_lookup (combine (map fst iface) vals) x = Some v /\ + has_abi_type Σ v s alpha. +Proof. + intros Σ s iface. induction iface as [|[k a] rest IH]; intros vals x alpha HF Hlk. + - simpl in Hlk. discriminate. + - destruct vals as [|v vt]; [inversion HF|]. + inversion HF as [|? ? ? ? Hv HFrest]; subst. + simpl in *. destruct (String.eqb_spec k x). + + subst. injection Hlk as ->. exists v. split; [reflexivity | exact Hv]. + + exact (IH _ _ _ HFrest Hlk). +Qed. + +Lemma combine_dom_fwd : + forall (A B : Type) (iface : list (ident * A)) (vals : list B) x, + length vals = length iface -> + alist_dom (combine (map fst iface) vals) x -> alist_dom iface x. +Proof. + intros A B iface. induction iface as [|[k a] rest IH]; intros vals x Hlen [w Hw]. + - destruct vals; simpl in Hw; discriminate. + - destruct vals as [|v vt]; [simpl in Hlen; discriminate|]. + simpl in Hw. simpl in Hlen. injection Hlen as Hlen. + destruct (String.eqb_spec k x) as [->|Hne]. + + exists a. apply alist_cons_eq. + + destruct (IH vt x Hlen (ex_intro _ w Hw)) as [w' Hw']. + exists w'. rewrite alist_cons_neq by auto. exact Hw'. +Qed. + +Lemma combine_dom_bwd : + forall (A B : Type) (iface : list (ident * A)) (vals : list B) x, + length vals = length iface -> + alist_dom iface x -> alist_dom (combine (map fst iface) vals) x. +Proof. + intros A B iface. induction iface as [|[k a] rest IH]; intros vals x Hlen [w Hw]. + - simpl in Hw. discriminate. + - destruct vals as [|v vt]; [simpl in Hlen; discriminate|]. + simpl in Hw. simpl in Hlen. injection Hlen as Hlen. + destruct (String.eqb_spec k x) as [->|Hne]. + + exists v. simpl. rewrite String.eqb_refl. reflexivity. + + destruct (IH vt x Hlen (ex_intro _ w Hw)) as [w' Hw']. + exists w'. simpl. destruct (String.eqb_spec k x); [contradiction|exact Hw']. +Qed. + +Lemma build_ctor_env_well_typed : + forall Σ s (iface : interface) (vals : list value) + (caller : addr) (origin : value) (callvalue : value), + Forall2 (fun v alpha => has_abi_type Σ v s alpha) vals (map snd iface) -> + has_base_type origin TAddress -> + has_base_type callvalue (TInt (UintT 256)) -> + ~ alist_dom iface "caller"%string -> + ~ alist_dom iface "origin"%string -> + ~ alist_dom iface "callvalue"%string -> + env_well_typed Σ (build_ctor_env iface vals caller origin callvalue) s iface. +Proof. + intros Σ s iface vals caller origin callvalue HF Horigin Hcv Hnc Hno Hncv. + assert (Hlen : length vals = length iface). + { apply Forall2_length in HF. rewrite map_length in HF. exact HF. } + unfold build_ctor_env, list_to_map, env_well_typed. + split; [|split; [|split; [|split]]]. + - (* domain *) + intro x. split. + + intros [v0 Hv0]. rewrite alist_lookup_app in Hv0. + destruct (alist_lookup (combine (map fst iface) vals) x) eqn:E. + * left. exact (combine_dom_fwd _ _ _ _ _ Hlen (ex_intro _ _ E)). + * destruct (String.eqb_spec "caller"%string x) as [->|Hc1]. + { right; left; auto. } + destruct (String.eqb_spec "origin"%string x) as [->|Ho1]. + { right; right; left; auto. } + destruct (String.eqb_spec "callvalue"%string x) as [->|Hcv1]. + { right; right; right; auto. } + exfalso. + unfold alist_lookup in Hv0. fold (@alist_lookup value) in Hv0. + destruct (String.eqb_spec "caller"%string x); [contradiction|]. + destruct (String.eqb_spec "origin"%string x); [contradiction|]. + destruct (String.eqb_spec "callvalue"%string x); [contradiction|]. + discriminate. + + intros [Hdom | [-> | [-> | ->]]]. + * destruct (combine_dom_bwd _ _ _ _ _ Hlen Hdom) as [v Hv]. + exists v. apply alist_lookup_app_some. exact Hv. + * apply alist_dom_app_r. exists (VAddr caller). + apply alist_cons_eq. + * apply alist_dom_app_r. exists origin. + rewrite alist_cons_neq by discriminate. apply alist_cons_eq. + * apply alist_dom_app_r. exists callvalue. + rewrite alist_cons_neq by discriminate. + rewrite alist_cons_neq by discriminate. + apply alist_cons_eq. + - (* interface variables *) + intros x alpha Hlk. + destruct (combine_forall2_lookup _ _ _ _ _ _ HF Hlk) as [v [Hv Htv]]. + exists v. split; [apply alist_lookup_app_some; exact Hv | exact Htv]. + - (* caller — not in iface, so combine lookup is None *) + assert (Ecaller : alist_lookup (combine (map fst iface) vals) "caller"%string = None). + { destruct (alist_lookup (combine (map fst iface) vals) "caller"%string) eqn:E; [|reflexivity]. + exfalso. apply Hnc. exact (combine_dom_fwd _ _ _ _ _ Hlen (ex_intro _ _ E)). } + exists (VAddr caller). split. + + unfold build_ctor_env, list_to_map. + rewrite alist_lookup_app_none by exact Ecaller. + apply alist_cons_eq. + + constructor. + - (* origin — not in iface *) + assert (Eorigin : alist_lookup (combine (map fst iface) vals) "origin"%string = None). + { destruct (alist_lookup (combine (map fst iface) vals) "origin"%string) eqn:E; [|reflexivity]. + exfalso. apply Hno. exact (combine_dom_fwd _ _ _ _ _ Hlen (ex_intro _ _ E)). } + exists origin. split. + + unfold build_ctor_env, list_to_map. + rewrite alist_lookup_app_none by exact Eorigin. + rewrite alist_cons_neq by discriminate. apply alist_cons_eq. + + exact Horigin. + - (* callvalue — not in iface *) + assert (Ecallvalue : alist_lookup (combine (map fst iface) vals) "callvalue"%string = None). + { destruct (alist_lookup (combine (map fst iface) vals) "callvalue"%string) eqn:E; [|reflexivity]. + exfalso. apply Hncv. exact (combine_dom_fwd _ _ _ _ _ Hlen (ex_intro _ _ E)). } + exists callvalue. split. + + unfold build_ctor_env, list_to_map. + rewrite alist_lookup_app_none by exact Ecallvalue. + rewrite alist_cons_neq by discriminate. + rewrite alist_cons_neq by discriminate. + apply alist_cons_eq. + + exact Hcv. +Qed. + +(** Σ_well_typed is defined in Typing.v where the typing judgments + are available. Well-founded state and extending Σ preserves + well-typedness are stated in TypeSafety.v. *) diff --git a/theories/_CoqProject b/theories/_CoqProject new file mode 100644 index 00000000..8a5f4a6b --- /dev/null +++ b/theories/_CoqProject @@ -0,0 +1,12 @@ +-Q . Act + +Maps.v +Syntax.v +Domains.v +Semantics.v +ValueTyping.v +Typing.v +TypeSafety.v +TypingT.v +ValueSemantics.v +Soundness.v diff --git a/theories/test.v b/theories/test.v new file mode 100644 index 00000000..38b31fb8 --- /dev/null +++ b/theories/test.v @@ -0,0 +1,10 @@ + + + +Inductive foo : nat -> nat -> Type := + | OK : forall x, foo x (x + 1). + +Inductive foo_proxy : nat -> nat -> Prop := + | OK1 : forall x y, foo x y -> foo_proxy x y. + +Goal (foo 1 2 /\ foo 4 5). From 2ff334662df2b93bf1de7f55328ddbe93429ccf8 Mon Sep 17 00:00:00 2001 From: zoep Date: Wed, 1 Apr 2026 13:14:41 +0300 Subject: [PATCH 3/3] Add README --- theories/README.md | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 theories/README.md diff --git a/theories/README.md b/theories/README.md new file mode 100644 index 00000000..e8194ddc --- /dev/null +++ b/theories/README.md @@ -0,0 +1,33 @@ +# Act Metatheory Mechanization + +Rocq mechanization of the metatheory of [Act](https://github.com/ethereum/act), +a specification language for Ethereum smart contracts. + +The formalization covers the type system, pointer semantics, and type safety. +Value semantics and soundness are a work in progress. It follows the +formalization presented in the Act tech-report. + +## Building + +Requires [Rocq](https://rocq-prover.org/) >= 9.1. + +``` +make +``` + +## File Structure + +The files are listed in dependency order: + +| File | Description | +|------|-------------| +| `Maps.v` | Partial map library (identifiers, association lists, map inclusion) | +| `Syntax.v` | Types, expressions, references, and top-level constructs (contracts, constructors, transitions) | +| `Domains.v` | Semantic domains for pointer semantics: values, store, state, and environments | +| `Semantics.v` | Big-step operational semantics for pointer semantics | +| `ValueTyping.v` | Value typing, environment typing, entailment, and well-typed contract environments | +| `Typing.v` | Typing judgments for references, expressions, mappings, slots, creates, updates, constructors, transitions, and contracts | +| `TypeSafety.v` | Type safety: type preservation and progress lemmas for all syntactic categories | +| `TypingT.v` | Type-valued (`Type`) mirror of `Typing.v`, enabling large elimination for defining denotation functions | +| `ValueSemantics.v` | **(WIP)** Denotational value semantics: semantic domains of types and denotation functions mapping typed terms to Rocq values | +| `Soundness.v` | **(WIP)** Soundness of the value semantics with respect to the pointer semantics |