(*  Title:      JinjaDCI/Compiler/J1WellForm.thy

    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory Compiler/J1WellForm.thy by Tobias Nipkow
*)

section \<open> Well-Formedness of Intermediate Language \<close>

theory J1WellForm
imports "../J/JWellForm" J1
begin

subsection "Well-Typedness"

type_synonym
  env\<^sub>1  = "ty list"   \<comment> \<open>type environment indexed by variable number\<close>

inductive
  WT\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1     , ty     ] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ :: _)"   [51,51,51]50)
  and WTs\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1 list, ty list] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ [::] _)" [51,51,51]50)
  for P :: J\<^sub>1_prog
where

  WTNew\<^sub>1:
  "is_class P C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 new C :: Class C"

| WTCast\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class D;  is_class P C;  P \<turnstile> C \<preceq>\<^sup>* D \<or> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Cast C e :: Class C"

| WTVal\<^sub>1:
  "typeof v = Some T \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 Val v :: T"

| WTVar\<^sub>1:
  "\<lbrakk> E!i = T; i < size E \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Var i :: T"

| WTBinOp\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T\<^sub>2;
     case bop of Eq \<Rightarrow> (P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1) \<and> T = Boolean
               | Add \<Rightarrow> T\<^sub>1 = Integer \<and> T\<^sub>2 = Integer \<and> T = Integer \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"

| WTLAss\<^sub>1:
  "\<lbrakk> E!i = T;  i < size E; P,E \<turnstile>\<^sub>1 e :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 i:=e :: Void"

| WTFAcc\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C;  P \<turnstile> C sees F,NonStatic:T in D \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"

| WTSFAcc\<^sub>1:
  "\<lbrakk> P \<turnstile> C sees F,Static:T in D \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D} :: T"

| WTFAss\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: Class C;  P \<turnstile> C sees F,NonStatic:T in D;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D} := e\<^sub>2 :: Void"

| WTSFAss\<^sub>1:
  "\<lbrakk>  P \<turnstile> C sees F,Static:T in D;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D}:=e\<^sub>2 :: Void"

| WTCall\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C; P \<turnstile> C sees M,NonStatic:Ts' \<rightarrow> T = m in D;
    P,E \<turnstile>\<^sub>1 es [::] Ts;  P \<turnstile> Ts [\<le>] Ts' \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"

| WTSCall\<^sub>1:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts \<rightarrow> T = m in D;
     P,E \<turnstile>\<^sub>1 es [::] Ts';  P \<turnstile> Ts' [\<le>] Ts; M \<noteq> clinit \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sM(es) :: T"

| WTBlock\<^sub>1:
  "\<lbrakk> is_type P T; P,E@[T] \<turnstile>\<^sub>1 e::T' \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 {i:T; e} :: T'"

| WTSeq\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"

| WTCond\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;  P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 c::T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 while (e) c :: Void"

| WTThrow\<^sub>1:
  "P,E \<turnstile>\<^sub>1 e :: Class C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 throw e :: Void"

| WTTry\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T;  P,E@[Class C] \<turnstile>\<^sub>1 e\<^sub>2 :: T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"

| WTNil\<^sub>1:
  "P,E \<turnstile>\<^sub>1 [] [::] []"

| WTCons\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: T; P,E \<turnstile>\<^sub>1 es [::] Ts \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e#es [::] T#Ts"

(*<*)
declare  WT\<^sub>1_WTs\<^sub>1.intros[intro!]
declare WTNil\<^sub>1[iff]

lemmas WT\<^sub>1_WTs\<^sub>1_induct = WT\<^sub>1_WTs\<^sub>1.induct [split_format (complete)]
  and WT\<^sub>1_WTs\<^sub>1_inducts = WT\<^sub>1_WTs\<^sub>1.inducts [split_format (complete)]

inductive_cases eee[elim!]:
  "P,E \<turnstile>\<^sub>1 Val v :: T"
  "P,E \<turnstile>\<^sub>1 Var i :: T"
  "P,E \<turnstile>\<^sub>1 Cast D e :: T"
  "P,E \<turnstile>\<^sub>1 i:=e :: T"
  "P,E \<turnstile>\<^sub>1 {i:U; e} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 while (e) c :: T"
  "P,E \<turnstile>\<^sub>1 throw e :: T"
  "P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"
  "P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D}:=e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 new C :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"
  "P,E \<turnstile>\<^sub>1 C\<bullet>\<^sub>sM(es) :: T"
  "P,E \<turnstile>\<^sub>1 [] [::] Ts"
  "P,E \<turnstile>\<^sub>1 e#es [::] Ts"
(*>*)

lemma init_nWT\<^sub>1 [simp]:"\<not>P,E \<turnstile>\<^sub>1 INIT C (Cs,b) \<leftarrow> e :: T"
 by(auto elim:WT\<^sub>1.cases)
lemma rinit_nWT\<^sub>1 [simp]:"\<not>P,E \<turnstile>\<^sub>1 RI(C,e);Cs \<leftarrow> e' :: T"
 by(auto elim:WT\<^sub>1.cases)

lemma WTs\<^sub>1_same_size: "\<And>Ts. P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> size es = size Ts"
(*<*)by (induct es type:list) auto(*>*)

lemma WT\<^sub>1_unique:
  "P,E \<turnstile>\<^sub>1 e :: T\<^sub>1 \<Longrightarrow> (\<And>T\<^sub>2. P,E \<turnstile>\<^sub>1 e :: T\<^sub>2 \<Longrightarrow> T\<^sub>1 = T\<^sub>2)" and
  WTs\<^sub>1_unique: "P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>1 \<Longrightarrow> (\<And>Ts\<^sub>2. P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>2 \<Longrightarrow> Ts\<^sub>1 = Ts\<^sub>2)"
(*<*)
proof(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
  case WTVal\<^sub>1 then show ?case by clarsimp
next
  case (WTBinOp\<^sub>1 E e\<^sub>1 T\<^sub>1 e\<^sub>2 T\<^sub>2 bop T)
  then show ?case by(case_tac bop) force+
next
  case WTFAcc\<^sub>1 then show ?case
    by (blast dest:sees_field_idemp sees_field_fun)
next
  case WTSFAcc\<^sub>1 then show ?case by (blast dest:sees_field_fun)
next
  case WTSFAss\<^sub>1 then show ?case by (blast dest:sees_field_fun)
next
  case WTCall\<^sub>1 then show ?case
    by (blast dest:sees_method_idemp sees_method_fun)
next
  case WTSCall\<^sub>1 then show ?case by (blast dest:sees_method_fun)
qed blast+
(*>*)

lemma assumes wf: "wf_prog p P"
shows WT\<^sub>1_is_type: "P,E \<turnstile>\<^sub>1 e :: T \<Longrightarrow> set E \<subseteq> types P \<Longrightarrow> is_type P T"
and "P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> True"
(*<*)
proof(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
  case WTVal\<^sub>1 then show ?case by (simp add:typeof_lit_is_type)
next
  case WTVar\<^sub>1 then show ?case by (blast intro:nth_mem)
next
  case WTBinOp\<^sub>1 then show ?case by (simp split:bop.splits)
next
  case WTFAcc\<^sub>1 then show ?case
    by (simp add:sees_field_is_type[OF _ wf])
next
  case WTSFAcc\<^sub>1 then show ?case
    by (simp add:sees_field_is_type[OF _ wf])
next
  case WTCall\<^sub>1 then show ?case
    by (fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
next
  case WTSCall\<^sub>1 then show ?case
    by (fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
next
  case WTCond\<^sub>1 then show ?case by blast
qed simp+
(*>*)

lemma WT\<^sub>1_nsub_RI: "P,E \<turnstile>\<^sub>1 e :: T \<Longrightarrow> \<not>sub_RI e"
 and WTs\<^sub>1_nsub_RIs: "P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> \<not>sub_RIs es"
proof(induct rule: WT\<^sub>1_WTs\<^sub>1.inducts) qed(simp_all)

subsection\<open> Runtime Well-Typedness \<close>

inductive
  WTrt\<^sub>1 :: "J\<^sub>1_prog \<Rightarrow> heap \<Rightarrow> sheap \<Rightarrow> env\<^sub>1 \<Rightarrow> expr\<^sub>1 \<Rightarrow> ty \<Rightarrow> bool"
  and WTrts\<^sub>1 :: "J\<^sub>1_prog \<Rightarrow> heap \<Rightarrow> sheap \<Rightarrow> env\<^sub>1 \<Rightarrow> expr\<^sub>1 list \<Rightarrow> ty list \<Rightarrow> bool"
  and WTrt2\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1,heap,sheap,expr\<^sub>1,ty] \<Rightarrow> bool"
        ("_,_,_,_ \<turnstile>\<^sub>1 _ : _"   [51,51,51,51]50)
  and WTrts2\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1,heap,sheap,expr\<^sub>1 list, ty list] \<Rightarrow> bool"
        ("_,_,_,_ \<turnstile>\<^sub>1 _ [:] _" [51,51,51,51]50)
  for P :: J\<^sub>1_prog and h :: heap and sh :: sheap
where

  "P,E,h,sh \<turnstile>\<^sub>1 e : T \<equiv> WTrt\<^sub>1 P h sh E e T"
| "P,E,h,sh \<turnstile>\<^sub>1 es[:]Ts \<equiv> WTrts\<^sub>1 P h sh E es Ts"

| WTrtNew\<^sub>1:
  "is_class P C  \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 new C : Class C"

| WTrtCast\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 Cast C e : Class C"

| WTrtVal\<^sub>1:
  "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 Val v : T"

| WTrtVar\<^sub>1:
  "\<lbrakk> E!i = T; i < size E \<rbrakk>  \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 Var i : T"

| WTrtBinOpEq\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 : T\<^sub>1;  P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2 : T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>Eq\<guillemotright> e\<^sub>2 : Boolean"

| WTrtBinOpAdd\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 : Integer;  P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2 : Integer \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>Add\<guillemotright> e\<^sub>2 : Integer"

| WTrtLAss\<^sub>1:
  "\<lbrakk> E!i = T; i < size E; P,E,h,sh \<turnstile>\<^sub>1 e : T';  P \<turnstile> T' \<le> T \<rbrakk>
   \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 i:=e : Void"

| WTrtFAcc\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : Class C; P \<turnstile> C has F,NonStatic:T in D \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>F{D} : T"

| WTrtFAccNT\<^sub>1:
  "P,E,h,sh \<turnstile>\<^sub>1 e : NT \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>F{D} : T"

| WTrtSFAcc\<^sub>1:
  "\<lbrakk> P \<turnstile> C has F,Static:T in D \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D} : T"

| WTrtFAss\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 : Class C;  P \<turnstile> C has F,NonStatic:T in D; P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2 : T\<^sub>2;  P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D}:=e\<^sub>2 : Void"

| WTrtFAssNT\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1:NT; P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2 : T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D}:=e\<^sub>2 : Void"

| WTrtSFAss\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2 : T\<^sub>2; P \<turnstile> C has F,Static:T in D; P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D}:=e\<^sub>2 : Void"

| WTrtCall\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : Class C; P \<turnstile> C sees M,NonStatic:Ts \<rightarrow> T = m in D;
     P,E,h,sh \<turnstile>\<^sub>1 es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>M(es) : T"

| WTrtCallNT\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : NT; P,E,h,sh \<turnstile>\<^sub>1 es [:] Ts \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>M(es) : T"

| WTrtSCall\<^sub>1:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts \<rightarrow> T = m in D;
     P,E,h,sh \<turnstile>\<^sub>1 es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts;
     M = clinit \<longrightarrow> sh D = \<lfloor>(sfs,Processing)\<rfloor> \<and> es = map Val vs \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sM(es) : T"

| WTrtBlock\<^sub>1:
  "P,E@[T],h,sh \<turnstile>\<^sub>1 e : T'  \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 {i:T; e} : T'"

| WTrtSeq\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1:T\<^sub>1;  P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2:T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 : T\<^sub>2"

| WTrtCond\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : Boolean;  P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1:T\<^sub>1;  P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>2:T\<^sub>2;
     P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 : T"

| WTrtWhile\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : Boolean;  P,E,h,sh \<turnstile>\<^sub>1 c:T \<rbrakk>
  \<Longrightarrow>  P,E,h,sh \<turnstile>\<^sub>1 while(e) c : Void"

| WTrtThrow\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : T\<^sub>r; is_refT T\<^sub>r \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile>\<^sub>1 throw e : T"

| WTrtTry\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 : T\<^sub>1;  P,E@[Class C],h,sh \<turnstile>\<^sub>1 e\<^sub>2 : T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 : T\<^sub>2"

| WTrtInit\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : T; \<forall>C' \<in> set (C#Cs). is_class P C'; \<not>sub_RI e;
     \<forall>C' \<in> set (tl Cs). \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>;
     b \<longrightarrow> (\<forall>C' \<in> set Cs. \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>);
     distinct Cs; supercls_lst P Cs \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 INIT C (Cs, b) \<leftarrow> e : T"

| WTrtRI\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : T; P,E,h,sh \<turnstile>\<^sub>1 e' : T'; \<forall>C' \<in> set (C#Cs). is_class P C'; \<not>sub_RI e';
     \<forall>C' \<in> set (C#Cs). not_init C' e;
     \<forall>C' \<in> set Cs. \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>;
     \<exists>sfs. sh C = \<lfloor>(sfs, Processing)\<rfloor> \<or> (sh C = \<lfloor>(sfs, Error)\<rfloor> \<and> e = THROW NoClassDefFoundError);
     distinct (C#Cs); supercls_lst P (C#Cs) \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 RI(C, e);Cs \<leftarrow> e' : T'"

\<comment> \<open>well-typed expression lists\<close>

| WTrtNil\<^sub>1:
  "P,E,h,sh \<turnstile>\<^sub>1 [] [:] []"

| WTrtCons\<^sub>1:
  "\<lbrakk> P,E,h,sh \<turnstile>\<^sub>1 e : T;  P,E,h,sh \<turnstile>\<^sub>1 es [:] Ts \<rbrakk>
  \<Longrightarrow>  P,E,h,sh \<turnstile>\<^sub>1 e#es [:] T#Ts"

(*<*)
declare WTrt\<^sub>1_WTrts\<^sub>1.intros[intro!] WTrtNil\<^sub>1[iff]
declare
  WTrtFAcc\<^sub>1[rule del] WTrtFAccNT\<^sub>1[rule del] WTrtSFAcc\<^sub>1[rule del]
  WTrtFAss\<^sub>1[rule del] WTrtFAssNT\<^sub>1[rule del] WTrtSFAss\<^sub>1[rule del]
  WTrtCall\<^sub>1[rule del] WTrtCallNT\<^sub>1[rule del] WTrtSCall\<^sub>1[rule del]

lemmas WTrt\<^sub>1_induct = WTrt\<^sub>1_WTrts\<^sub>1.induct [split_format (complete)]
  and WTrt\<^sub>1_inducts = WTrt\<^sub>1_WTrts\<^sub>1.inducts [split_format (complete)]
(*>*)

(*<*)
inductive_cases WTrt\<^sub>1_elim_cases[elim!]:
  "P,E,h,sh \<turnstile>\<^sub>1 Val v : T"
  "P,E,h,sh \<turnstile>\<^sub>1 Var i : T"
  "P,E,h,sh \<turnstile>\<^sub>1 v :=e : T"
  "P,E,h,sh \<turnstile>\<^sub>1 {i:U; e} : T"
  "P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 : T\<^sub>2"
  "P,E,h,sh \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 : T"
  "P,E,h,sh \<turnstile>\<^sub>1 while(e) c : T"
  "P,E,h,sh \<turnstile>\<^sub>1 throw e : T"
  "P,E,h,sh \<turnstile>\<^sub>1 try e\<^sub>1 catch(C V) e\<^sub>2 : T"
  "P,E,h,sh \<turnstile>\<^sub>1 Cast D e : T"
  "P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>F{D} : T"
  "P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D} : T"
  "P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>F{D} := v : T"
  "P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sF{D} := v : T"
  "P,E,h,sh \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T"
  "P,E,h,sh \<turnstile>\<^sub>1 new C : T"
  "P,E,h,sh \<turnstile>\<^sub>1 e\<bullet>M{D}(es) : T"
  "P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sM{D}(es) : T"
  "P,E,h,sh \<turnstile>\<^sub>1 INIT C (Cs,b) \<leftarrow> e : T"
  "P,E,h,sh \<turnstile>\<^sub>1 RI(C,e);Cs \<leftarrow> e' : T"
  "P,E,h,sh \<turnstile>\<^sub>1 [] [:] Ts"
  "P,E,h,sh \<turnstile>\<^sub>1 e#es [:] Ts"
(*>*)

lemma WT\<^sub>1_implies_WTrt\<^sub>1: "P,E \<turnstile>\<^sub>1 e :: T \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 e : T"
and WTs\<^sub>1_implies_WTrts\<^sub>1: "P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> P,E,h,sh \<turnstile>\<^sub>1 es [:] Ts"
(*<*)
proof(induct rule: WT\<^sub>1_WTs\<^sub>1_inducts)
  case WTVal\<^sub>1 then show ?case by (fastforce dest:typeof_lit_typeof)
next
  case (WTBinOp\<^sub>1 E e\<^sub>1 T\<^sub>1 e\<^sub>2 T\<^sub>2 bop T)
  then show ?case by (case_tac bop) fastforce+
next
  case WTFAcc\<^sub>1 then show ?case
    by (fastforce simp: WTrtFAcc\<^sub>1 has_visible_field)
next
  case WTSFAcc\<^sub>1 then show ?case
    by (fastforce simp: WTrtSFAcc\<^sub>1 has_visible_field)
next
  case WTFAss\<^sub>1 then show ?case by (meson WTrtFAss\<^sub>1 has_visible_field)
next
  case WTSFAss\<^sub>1 then show ?case by (meson WTrtSFAss\<^sub>1 has_visible_field)
next
  case WTCall\<^sub>1 then show ?case by (fastforce simp: WTrtCall\<^sub>1)
next
  case WTSCall\<^sub>1 then show ?case by (fastforce simp: WTrtSCall\<^sub>1)
qed fastforce+
(*>*)

subsection\<open> Well-formedness\<close>

\<comment> \<open>Indices in blocks increase by 1\<close>

primrec \<B> :: "expr\<^sub>1 \<Rightarrow> nat \<Rightarrow> bool"
  and \<B>s :: "expr\<^sub>1 list \<Rightarrow> nat \<Rightarrow> bool" where
"\<B> (new C) i = True" |
"\<B> (Cast C e) i = \<B> e i" |
"\<B> (Val v) i = True" |
"\<B> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (Var j) i = True" |
"\<B> (e\<bullet>F{D}) i = \<B> e i" |
"\<B> (C\<bullet>\<^sub>sF{D}) i = True" |
"\<B> (j:=e) i = \<B> e i" |
"\<B> (e\<^sub>1\<bullet>F{D} := e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (C\<bullet>\<^sub>sF{D} := e\<^sub>2) i = \<B> e\<^sub>2 i" |
"\<B> (e\<bullet>M(es)) i = (\<B> e i \<and> \<B>s es i)" |
"\<B> (C\<bullet>\<^sub>sM(es)) i = \<B>s es i" |
"\<B> ({j:T ; e}) i = (i = j \<and> \<B> e (i+1))" |
"\<B> (e\<^sub>1;;e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (if (e) e\<^sub>1 else e\<^sub>2) i = (\<B> e i \<and> \<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (throw e) i = \<B> e i" |
"\<B> (while (e) c) i = (\<B> e i \<and> \<B> c i)" |
"\<B> (try e\<^sub>1 catch(C j) e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> i=j \<and> \<B> e\<^sub>2 (i+1))" |
"\<B> (INIT C (Cs,b) \<leftarrow> e) i = \<B> e i" |
"\<B> (RI(C,e);Cs \<leftarrow> e') i = (\<B> e i \<and> \<B> e' i)" |

"\<B>s [] i = True" |
"\<B>s (e#es) i = (\<B> e i \<and> \<B>s es i)"

definition wf_J\<^sub>1_mdecl :: "J\<^sub>1_prog \<Rightarrow> cname \<Rightarrow> expr\<^sub>1 mdecl \<Rightarrow> bool"
where
  "wf_J\<^sub>1_mdecl P C  \<equiv>  \<lambda>(M,b,Ts,T,body).
    \<not>sub_RI body \<and>
 (case b of
    NonStatic \<Rightarrow>
        (\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
        \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1)
  | Static \<Rightarrow> (\<exists>T'. P,Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
        \<D> body \<lfloor>{..<size Ts}\<rfloor> \<and> \<B> body (size Ts))"

lemma wf_J\<^sub>1_mdecl_NonStatic[simp]:
  "wf_J\<^sub>1_mdecl P C (M,NonStatic,Ts,T,body) \<equiv>
    (\<not>sub_RI body \<and>
    (\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
     \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1))"
(*<*)by (simp add:wf_J\<^sub>1_mdecl_def)(*>*)

lemma wf_J\<^sub>1_mdecl_Static[simp]:
  "wf_J\<^sub>1_mdecl P C (M,Static,Ts,T,body) \<equiv>
    (\<not>sub_RI body \<and>
    (\<exists>T'. P,Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
     \<D> body \<lfloor>{..<size Ts}\<rfloor> \<and> \<B> body (size Ts))"
(*<*)by (simp add:wf_J\<^sub>1_mdecl_def)(*>*)

abbreviation "wf_J\<^sub>1_prog == wf_prog wf_J\<^sub>1_mdecl"

lemma sees_wf\<^sub>1_nsub_RI:
assumes wf: "wf_J\<^sub>1_prog P" and cM: "P \<turnstile> C sees M,b : Ts\<rightarrow>T = body in D"
shows "\<not>sub_RI body"
using sees_wf_mdecl[OF wf cM] by(simp add: wf_J\<^sub>1_mdecl_def wf_mdecl_def)

lemma wf\<^sub>1_types_clinit:
assumes wf:"wf_prog wf_md P" and ex: "class P C = Some a" and proc: "sh C = \<lfloor>(sfs, Processing)\<rfloor>"
shows "P,E,h,sh \<turnstile>\<^sub>1 C\<bullet>\<^sub>sclinit([]) : Void"
proof -
  from ex obtain D fs ms where "a = (D,fs,ms)" by(cases a)
  then have sP: "(C, D, fs, ms) \<in> set P" using ex map_of_SomeD[of P C a] by(simp add: class_def)
  then have "wf_clinit ms" using assms by(unfold wf_prog_def wf_cdecl_def, auto)
  then obtain m where sm: "(clinit, Static, [], Void, m) \<in> set ms"
    by(unfold wf_clinit_def) auto
  then have "P \<turnstile> C sees clinit,Static:[] \<rightarrow> Void = m in C"
    using mdecl_visible[OF wf sP sm] by simp
  then show ?thesis using WTrtSCall\<^sub>1 proc by blast
qed

lemma assumes wf: "wf_J\<^sub>1_prog P"
shows eval\<^sub>1_proc_pres: "P \<turnstile>\<^sub>1 \<langle>e,(h,l,sh)\<rangle> \<Rightarrow> \<langle>e',(h',l',sh')\<rangle>
  \<Longrightarrow> not_init C e \<Longrightarrow> \<exists>sfs. sh C = \<lfloor>(sfs, Processing)\<rfloor> \<Longrightarrow> \<exists>sfs'. sh' C = \<lfloor>(sfs', Processing)\<rfloor>"
  and evals\<^sub>1_proc_pres: "P \<turnstile>\<^sub>1 \<langle>es,(h,l,sh)\<rangle> [\<Rightarrow>] \<langle>es',(h',l',sh')\<rangle>
  \<Longrightarrow> not_inits C es \<Longrightarrow> \<exists>sfs. sh C = \<lfloor>(sfs, Processing)\<rfloor> \<Longrightarrow> \<exists>sfs'. sh' C = \<lfloor>(sfs', Processing)\<rfloor>"
(*<*)
proof(induct rule:eval\<^sub>1_evals\<^sub>1_inducts)
  case Call\<^sub>1 then show ?case using sees_wf\<^sub>1_nsub_RI[OF wf Call\<^sub>1.hyps(6)] nsub_RI_not_init by auto
next
  case (SCallInit\<^sub>1 ps h l sh vs h\<^sub>1 l\<^sub>1 sh\<^sub>1 C' M Ts T body D v' h\<^sub>2 l\<^sub>2 sh\<^sub>2 l\<^sub>2' e' h\<^sub>3 l\<^sub>3 sh\<^sub>3)
  then show ?case
    using SCallInit\<^sub>1 sees_wf\<^sub>1_nsub_RI[OF wf SCallInit\<^sub>1.hyps(3)] nsub_RI_not_init[of body] by auto
next
  case SCall\<^sub>1 then show ?case using sees_wf\<^sub>1_nsub_RI[OF wf SCall\<^sub>1.hyps(3)] nsub_RI_not_init by auto
next
  case (InitNone\<^sub>1 sh C1 C' Cs h l e' a a b) then show ?case by(cases "C = C1") auto
next
  case (InitDone\<^sub>1 sh C sfs C' Cs h l e' a a b) then show ?case by(cases Cs, auto)
next
  case (InitProcessing\<^sub>1 sh C sfs C' Cs h l e' a a b) then show ?case by(cases Cs, auto)
next
  case (InitError\<^sub>1 sh C1 sfs Cs h l e' a a b C') then show ?case by(cases "C = C1") auto
next
  case (InitObject\<^sub>1 sh C1 sfs sh' C' Cs h l e' a a b) then show ?case by(cases "C = C1") auto
next
  case (InitNonObject\<^sub>1 sh C1 sfs D a b sh' C' Cs h l e' a a b)
  then show ?case by(cases "C = C1") auto
next
  case (RInit\<^sub>1 e a a b v h' l' sh' C sfs i sh'' C' Cs e\<^sub>1 a a b) then show ?case by(cases Cs, auto)
next
  case (RInitInitFail\<^sub>1 e h l sh a h' l' sh' C1 sfs i sh'' D Cs e\<^sub>1 h1 l1 sh1)
  then show ?case using eval\<^sub>1_final by fastforce
qed(auto)
(*>*)

lemma clinit\<^sub>1_proc_pres:
  "\<lbrakk> wf_J\<^sub>1_prog P; P \<turnstile>\<^sub>1 \<langle>C\<^sub>0\<bullet>\<^sub>sclinit([]),(h,l,sh)\<rangle> \<Rightarrow> \<langle>e',(h',l',sh')\<rangle>;
     sh C' = \<lfloor>(sfs,Processing)\<rfloor> \<rbrakk>
  \<Longrightarrow> \<exists>sfs. sh' C' = \<lfloor>(sfs,Processing)\<rfloor>"
 by(auto dest: eval\<^sub>1_proc_pres)

end


(*

 Licensed under the Apache License, Version 2.0 (the "License");
 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

 Unless required by applicable law or agreed to in writing, software
 distributed under the License is distributed on an "AS IS" BASIS,
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.

 *)

theory AbstractFloat
  imports reassembly_machine.Machine
begin

definition signed_greater_than :: "'a :: len word \<Rightarrow> 'a :: len word \<Rightarrow> bool" ("(_/ >s _)" [50, 51] 50)
  where "a >s b \<equiv> a \<noteq> b \<and> \<not>(a <s b)"
declare signed_greater_than_def[symmetric,simp add]

definition signed_le :: "'a :: len word \<Rightarrow> 'a :: len word \<Rightarrow> bool" ("(_/ \<le>s _)" [50, 51] 50)
  where "a \<le>s b \<equiv> a = b \<or> a <s b"
declare signed_le_def[symmetric,simp add]

lemma signed_not_le[simp]:
  shows "\<not> a \<le>s b \<longleftrightarrow> a >s b"
  unfolding signed_le_def signed_greater_than_def
  by metis

subsection "Making a float"

text \<open> Make a float from a sign-bit, an exponent and a mantissa. \<close>
fun mk_float :: "bool \<times> nat \<times> nat \<Rightarrow> 64 word"
  where "mk_float (s,e,m) = ((if s then 1 else 0) << 63) OR (of_nat e AND mask 11 << 52) OR (of_nat m AND mask 52)"

text \<open> Simplify @{term mk_float} only when it is given concrete values. \<close>
lemmas mk_float_simps_numeral[simp] =
  mk_float.simps[of True 0 0]
  mk_float.simps[of True 0 1]
  mk_float.simps[of True 0 "numeral m"]
  mk_float.simps[of True 1 0]
  mk_float.simps[of True 1 1]
  mk_float.simps[of True 1 "numeral m"]
  mk_float.simps[of True "numeral n" 0]
  mk_float.simps[of True "numeral n" 1]
  mk_float.simps[of True "numeral n" "numeral m"]
  mk_float.simps[of False 0 0]
  mk_float.simps[of False 0 1]
  mk_float.simps[of False 0 "numeral m"]
  mk_float.simps[of False 1 0]
  mk_float.simps[of False 1 1]
  mk_float.simps[of False 1 "numeral m"]
  mk_float.simps[of False "numeral n" 0]
  mk_float.simps[of False "numeral n" 1]
  mk_float.simps[of False "numeral n" "numeral m"]
  for n m
declare mk_float.simps[simp del]

text \<open>Constants and Accessor Functions\<close>

definition plus_zero :: "64 word" ("0\<^sup>+")
  where "plus_zero \<equiv> mk_float (False,0,0)"

definition minus_zero :: "64 word" ("0\<^sup>-")
  where "minus_zero \<equiv> mk_float (True,0,0)"

definition plus_infty :: "64 word" ("\<infinity>\<^sup>+")
  where "plus_infty \<equiv> mk_float (False,2^11 - 1,0)"

definition minus_infty :: "64 word" ("\<infinity>\<^sup>-")
  where "minus_infty \<equiv> mk_float (True,2^11 - 1,0)"

definition exp :: "64 word \<Rightarrow> 64 word"
  where "exp w \<equiv> \<langle>62,52\<rangle>w"

definition mant :: "64 word \<Rightarrow> 64 word"
  where "mant w \<equiv> \<langle>51,0\<rangle>w"

definition sign :: "64 word \<Rightarrow> bool"
  where "sign \<equiv> msb"

definition isNaN :: "64 word \<Rightarrow> bool"
  where "isNaN w \<equiv> exp w = 2^11-1"

definition float_abs :: "'a::len0 word \<Rightarrow> 'a::len0 word" ("\<bar>_\<bar>\<^sup>f")
  where "\<bar>w\<bar>\<^sup>f \<equiv> set_bit w (LENGTH('a) - 1)  False"

(*
lemma sign_mk_float:
  shows "sign (mk_float (s,e,m)) = s"
  unfolding sign_def
  by (auto simp add: msb_nth mk_float.simps test_bit_of_take_bits word_ao_nth nth_shiftl)

lemma exp_mk_float:
  shows "exp (mk_float (s,e,m)) = ((of_nat e)::64 word) AND mask 11"
  unfolding exp_def
  apply word_bitwise
  by (auto simp add: mk_float.simps test_bit_of_take_bits word_ao_nth nth_shiftl)

lemma mant_mk_float:
  shows "mant (mk_float (s,e,m)) = ((of_nat m)::64 word) AND mask 52"
  unfolding mant_def
  apply word_bitwise
  apply (auto simp add: mk_float.simps test_bit_of_take_bits word_ao_nth nth_shiftl simp del: take_bits_bitAND)
  by (simp only: numeral_2_eq_2)+
*)

datatype float_cmp = Unordered | GT | LT | EQ

text \<open>
  For the following functions, we do not yet have an implementation.
  We constraint them according the IEEE 754 standard.
\<close>

locale abstract_float =
  fixes float_plus :: "64 word \<Rightarrow> 64 word \<Rightarrow> 64 word" (infixl "+\<^sup>f" 65)
    and float_minus :: "64 word \<Rightarrow> 64 word \<Rightarrow> 64 word" (infixl "-\<^sup>f" 65)
    and float_times:: "64 word \<Rightarrow> 64 word \<Rightarrow> 64 word" (infixl "*\<^sup>f" 65)
    and float_div :: "64 word \<Rightarrow> 64 word \<Rightarrow> 64 word" (infixl "div\<^sup>f" 65)
    and float_mod :: "64 word \<Rightarrow> 64 word \<Rightarrow> 64 word" (infixl "mod\<^sup>f" 70)
    and float_ucmp :: "64 word \<Rightarrow> 64 word \<Rightarrow> float_cmp"
    and cvttsd2si :: "64 word \<Rightarrow> 32 word"
assumes plus_plus_zero [simp]: "x +\<^sup>f 0\<^sup>+ = x"
    and plus_minus_zero[simp]: "x +\<^sup>f 0\<^sup>- = x"
    and isNan_div_0_0: "x \<in> {0\<^sup>-,0\<^sup>+} \<Longrightarrow> y \<in> {0\<^sup>-,0\<^sup>+} \<Longrightarrow> isNaN (x div\<^sup>f y)"
    and div_by_plus_zero:  "x \<notin> {0\<^sup>-,0\<^sup>+} \<Longrightarrow> x div\<^sup>f 0\<^sup>+ = (if sign x then \<infinity>\<^sup>- else \<infinity>\<^sup>+)"
    and div_by_minus_zero: "x \<notin> {0\<^sup>-,0\<^sup>+} \<Longrightarrow> x div\<^sup>f 0\<^sup>- = (if sign x then \<infinity>\<^sup>+ else \<infinity>\<^sup>-)"
    and times_by_plus_zero [simp]: "x *\<^sup>f 0\<^sup>+ = (if sign x then 0\<^sup>- else 0\<^sup>+)"
    and time_by_neg_zero [simp]: "x *\<^sup>f 0\<^sup>- = (if sign x then 0\<^sup>+ else 0\<^sup>-)"
    and times_plus_zero: "0\<^sup>+ *\<^sup>f x = (if sign x then 0\<^sup>- else 0\<^sup>+)"
    and times_neg_zero: "0\<^sup>- *\<^sup>f x = (if sign x then 0\<^sup>+ else 0\<^sup>-)"
begin

end

interpretation abstract_float
  "\<lambda> x y . x"
  "\<lambda> x y . x"
  "\<lambda> x y . if y = 0\<^sup>+ then (if sign x then 0\<^sup>- else 0\<^sup>+) else if y = 0\<^sup>- then (if sign x then 0\<^sup>+ else 0\<^sup>-) else
           if x = 0\<^sup>+ then (if sign y then 0\<^sup>- else 0\<^sup>+) else if x = 0\<^sup>- then (if sign y then 0\<^sup>+ else 0\<^sup>-)
           else x"
  "\<lambda> x y . if x \<in> {0\<^sup>-,0\<^sup>+} then mk_float(False,2^11-1,0)
           else if x = 0\<^sup>- then 0\<^sup>-
           else if y = 0\<^sup>+ then (if sign x then \<infinity>\<^sup>- else \<infinity>\<^sup>+)
           else if y = 0\<^sup>- then (if sign x then \<infinity>\<^sup>+ else \<infinity>\<^sup>-)
           else 0\<^sup>-"
  apply (unfold_locales)
  by (auto simp add: isNaN_def exp_def take_bits_def plus_zero_def minus_zero_def sign_def)

lemma bit_AND_bit_pattern_is_float_abs_bit32[simp]:
  fixes w :: "32 word"
  shows "w AND 2147483647 = \<bar>w\<bar>\<^sup>f"
  apply (word_bitwise)
  by (auto simp add: word_ao_nth float_abs_def test_bit_set_gen)
lemma bit_AND_bit_pattern_is_float_abs_bit64[simp]:
  fixes a :: "64 word"
  shows "a AND 9223372036854775807 = \<bar>a\<bar>\<^sup>f"
  unfolding float_abs_def
  apply word_bitwise
  by (auto simp add: test_bit_set_gen del: )

end


subsection \<open>Bottom-Up Computation\<close>

theory Bottom_Up_Computation
  imports "../state_monad/Memory" "../state_monad/DP_CRelVS"
begin

fun iterate_state where
  "iterate_state f [] = State_Monad.return ()" |
  "iterate_state f (x # xs) = do {f x; iterate_state f xs}"

locale iterator_defs =
  fixes cnt :: "'a \<Rightarrow> bool" and nxt :: "'a \<Rightarrow> 'a"
begin

definition
  "iter_state f \<equiv>
    wfrec
      {(nxt x, x) | x. cnt x}
      (\<lambda> rec x. if cnt x then do {f x; rec (nxt x)} else State_Monad.return ())"

definition
  "iterator_to_list \<equiv>
    wfrec {(nxt x, x) | x. cnt x} (\<lambda> rec x. if cnt x then x # rec (nxt x) else [])
  "

end

locale iterator = iterator_defs +
  fixes sizef :: "'a \<Rightarrow> nat"
  assumes terminating:
    "finite {x. cnt x}" "\<forall> x. cnt x \<longrightarrow> sizef x < sizef (nxt x)"
begin

lemma admissible:
  "adm_wf
      {(nxt x, x) | x. cnt x}
      (\<lambda> rec x. if cnt x then do {f x; rec (nxt x)} else State_Monad.return ())"
  unfolding adm_wf_def by auto

lemma wellfounded:
  "wf {(nxt x, x) | x. cnt x}" (is "wf ?S")
proof -
  from terminating have "acyclic ?S"
    by (auto intro: acyclicI_order[where f = sizef])
  moreover have "finite ?S"
    using [[simproc add: finite_Collect]] terminating(1) by auto
  ultimately show ?thesis
    by - (rule finite_acyclic_wf)
qed

lemma iter_state_unfold:
  "iter_state f x = (if cnt x then do {f x; iter_state f (nxt x)} else State_Monad.return ())"
  unfolding iter_state_def by (simp add: wfrec_fixpoint[OF wellfounded admissible])

lemma iterator_to_list_unfold:
  "iterator_to_list x = (if cnt x then x # iterator_to_list (nxt x) else [])"
  unfolding iterator_to_list_def by (simp add: adm_wf_def wfrec_fixpoint[OF wellfounded])

lemma iter_state_iterate_state:
  "iter_state f x = iterate_state f (iterator_to_list x)"
  apply (induction "iterator_to_list x" arbitrary: x)
   apply (simp add: iterator_to_list_unfold split: if_split_asm)
   apply (simp add: iter_state_unfold)
  apply (subst (asm) (3) iterator_to_list_unfold)
  apply (simp split: if_split_asm)
  apply (auto simp: iterator_to_list_unfold iter_state_unfold)
  done

end (* Termination *)

context dp_consistency
begin

context
  includes lifting_syntax
begin

lemma crel_vs_iterate_state:
  "crel_vs (=) () (iterate_state f xs)" if "((=) ===>\<^sub>T R) g f"
proof (induction xs)
  case Nil
  then show ?case
    by (simp; rule crel_vs_return_ext[unfolded Transfer.Rel_def]; simp; fail)
next
  case (Cons x xs)
  have unit_expand: "() = (\<lambda> a f. f a) () (\<lambda> _. ())" ..
  from Cons show ?case
    by simp
      (rule
        bind_transfer[unfolded rel_fun_def, rule_format, unfolded unit_expand]
        that[unfolded rel_fun_def, rule_format] HOL.refl
      )+
qed

lemma crel_vs_bind_ignore:
  "crel_vs R a (do {d; b})" if "crel_vs R a b" "crel_vs S c d"
proof -
  have unit_expand: "a = (\<lambda> a f. f a) () (\<lambda> _. a)" ..
  show ?thesis
    by (subst unit_expand)
       (rule bind_transfer[unfolded rel_fun_def, rule_format, unfolded unit_expand] that)+
qed

lemma crel_vs_iterate_and_compute:
  assumes "((=) ===>\<^sub>T R) g f"
  shows "crel_vs R (g x) (do {iterate_state f xs; f x})"
  by (rule
        crel_vs_bind_ignore crel_vs_iterate_state HOL.refl
        assms[unfolded rel_fun_def, rule_format] assms
     )+

end (* Lifting Syntax *)

end (* DP Consistency *)

locale dp_consistency_iterator =
  dp_consistency lookup update + iterator cnt nxt sizef
  for lookup :: "'a \<Rightarrow> ('b, 'c option) state" and update
    and cnt :: "'a \<Rightarrow> bool" and nxt and sizef
begin

lemma crel_vs_iter_and_compute:
  assumes "((=) ===>\<^sub>T R) g f"
  shows "crel_vs R (g x) (do {iter_state f y; f x})"
  unfolding iter_state_iterate_state using crel_vs_iterate_and_compute[OF assms] .

lemma consistentDP_iter_and_compute:
  assumes "consistentDP f"
  shows "crel_vs (=) (dp x) (do {iter_state f y; f x})"
  using assms unfolding consistentDP_def by (rule crel_vs_iter_and_compute)

end (* Consistency + Iterator *)

locale dp_consistency_iterator_empty =
  dp_consistency_iterator + dp_consistency_empty
begin

lemma memoized:
  "dp x = fst (run_state (do {iter_state f y; f x}) empty)" if "consistentDP f"
  using consistentDP_iter_and_compute[OF that, of x y]
  by (auto elim!: crel_vs_elim intro: P_empty cmem_empty)

lemma cmem_result:
  "cmem (snd (run_state (do {iter_state f y; f x}) empty))" if "consistentDP f"
  using consistentDP_iter_and_compute[OF that, of x y]
  by (auto elim!: crel_vs_elim intro: P_empty cmem_empty)

end (* Consistency + Iterator *)

lemma dp_consistency_iterator_emptyI:
  "dp_consistency_iterator_empty P lookup update cnt
    nxt sizef empty"
  if "dp_consistency_empty lookup update P empty"
     "iterator cnt nxt sizef"
   for empty
  by (meson
      dp_consistency_empty.axioms(1) dp_consistency_iterator_def
      dp_consistency_iterator_empty_def that
     )

context
  fixes m :: nat \<comment> \<open>Width of a row\<close>
    and n :: nat \<comment> \<open>Number of rows\<close>
begin

lemma table_iterator_up:
  "iterator
    (\<lambda> (x, y). x \<le> n \<and> y \<le> m)
    (\<lambda> (x, y). if y < m then (x, y + 1) else (x + 1, 0))
    (\<lambda> (x, y). x * (m + 1) + y)"
  by standard auto

lemma table_iterator_down:
  "iterator
    (\<lambda> (x, y). x \<le> n \<and> y \<le> m \<and> x > 0)
    (\<lambda> (x, y). if y > 0 then (x, y - 1) else (x - 1, m))
    (\<lambda> (x, y). (n - x) * (m + 1) + (m - y))"
  using [[simproc add: finite_Collect]]  by standard (auto simp: Suc_diff_le)

end (* Table *)

end (* Theory *)


(*  Title:      Native_Word_Test_Emu.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

theory Native_Word_Test_Emu imports
  Native_Word_Test
  Code_Target_Int_Bit
begin

section \<open>Test cases for emulation of native words\<close>

subsection \<open>Tests for @{typ uint16}\<close>

text \<open>
  Test that @{typ uint16} is emulated for PolyML and OCaml via @{typ "16 word"}
  if @{theory Native_Word.Code_Target_Int_Bit} is imported.
\<close>

definition test_uint16_emulation :: bool where
  "test_uint16_emulation \<longleftrightarrow> (0xFFFFF - 0x1000 = (0xEFFF :: uint16))"

export_code test_uint16_emulation checking SML OCaml?
  \<comment> \<open>test the other target languages as well\<close> Haskell? Scala

notepad begin
have test_uint16 by eval
have test_uint16_emulation by eval
have test_uint16_emulation by normalization
have test_uint16_emulation by code_simp
end

ML_val \<open>
  val true = @{code test_uint16};
  val true = @{code test_uint16_emulation};
\<close>

lemma "x AND y = x OR (y :: uint16)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

subsection \<open>Tests for @{typ uint8}\<close>

text \<open>
  Test that @{typ uint8} is emulated for OCaml via @{typ "8 word"}
  if @{theory Native_Word.Code_Target_Int_Bit} is imported.
\<close>

definition test_uint8_emulation :: bool where
  "test_uint8_emulation \<longleftrightarrow> (0xFFF - 0x10 = (0xEF :: uint8))"

export_code test_uint8_emulation checking OCaml?
  \<comment> \<open>test the other target languages as well\<close> SML Haskell? Scala

end