(*  Title:      HOL/MicroJava/BV/BVSpecTypeSafe.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{BV Type Safety Proof}\label{sec:BVSpecTypeSafe} *}

theory BVSpecTypeSafe
imports BVConform
begin

text {*
  This theory contains proof that the specification of the bytecode
  verifier only admits type safe programs.
*}

section {* Preliminaries *}

text {*
  Simp and intro setup for the type safety proof:
*}
lemmas defs1 = correct_state_def conf_f_def wt_instr_def eff_def norm_eff_def app_def xcpt_app_def

lemmas widen_rules [intro] = conf_widen confT_widen confs_widens confTs_widen

section {* Exception Handling *}

text {*
  For the @{text Invoke} instruction the BV has checked all handlers
  that guard the current @{text pc}.
*}
lemma Invoke_handlers:
  "match_ex_table P C pc xt = Some (pc',d') \<Longrightarrow>
  \<exists>(f,t,D,h,d) \<in> set (relevant_entries P (Invoke n M) pc xt).
   P \<turnstile> C \<preceq>\<^sup>* D \<and> pc \<in> {f..<t} \<and> pc' = h \<and> d' = d"
  by (induct xt) (auto simp add: relevant_entries_def matches_ex_entry_def
                                 is_relevant_entry_def split: split_if_asm)

text {*
  We can prove separately that the recursive search for exception
  handlers (@{text find_handler}) in the frame stack results in
  a conforming state (if there was no matching exception handler
  in the current frame). We require that the exception is a valid
  heap address, and that the state before the exception occured
  conforms.
*} term find_handler
lemma uncaught_xcpt_correct:
  assumes wt: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes h:  "h xcp = Some obj"
  shows "\<And>f. P,\<Phi> \<turnstile> (None, h, f#frs)\<surd> \<Longrightarrow> P,\<Phi> \<turnstile> (find_handler P xcp h frs) \<surd>"
  (is "\<And>f. ?correct (None, h, f#frs) \<Longrightarrow> ?correct (?find frs)")
(*<*)
proof (induct frs)
  -- "the base
 case is trivial as it should be"
  show "?correct (?find [])" by (simp add: correct_state_def)
next
  -- "we will need both forms @{text wf_jvm_prog} and @{text wf_prog} later"
  from wt obtain mb where wf: "wf_prog mb P" by (simp add: wf_jvm_prog_phi_def)

  -- "the assumption for the cons case:"
  fix f f' frs' assume cr: "?correct (None, h, f#f'#frs')"

  -- "the induction hypothesis:"
  assume IH: "\<And>f. ?correct (None, h, f#frs') \<Longrightarrow> ?correct (?find frs')"

  from cr have cr': "?correct (None, h, f'#frs')"
    by (fastforce simp add: correct_state_def)

  obtain stk loc C M pc where [simp]: "f' = (stk,loc,C,M,pc)" by (cases f')

  from cr obtain Ts T mxs mxl\<^sub>0 ins xt where
    meth: "P \<turnstile> C sees M:Ts \<rightarrow> T = (mxs,mxl\<^sub>0,ins,xt) in C"
    by (simp add: correct_state_def, blast)

  hence [simp]: "ex_table_of P C M = xt" by simp

  show "?correct (?find (f'#frs'))"
  proof (cases "match_ex_table P (cname_of h xcp) pc xt")
    case None with cr' IH [of f'] show ?thesis by fastforce
  next
    fix pc_d
    assume "match_ex_table P (cname_of h xcp) pc xt = Some pc_d"
    then obtain pc' d' where
      match: "match_ex_table P (cname_of h xcp) pc xt = Some (pc',d')"
      (is "?match (cname_of h xcp) = _")
      by (cases pc_d) auto

    from wt meth cr' [simplified]
    have wti: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
      by (fastforce simp add: correct_state_def conf_f_def
                   dest: sees_method_fun
                   elim!: wt_jvm_prog_impl_wt_instr)
    from cr meth
    obtain n M' ST LT where
      ins: "ins!pc = Invoke n M'" (is "_ = ?i") and
      \<Phi>: "\<Phi> C M ! pc = Some (ST, LT)"
      by (fastforce dest: sees_method_fun simp add: correct_state_def)

    from ins match obtain f t D where
      rel: "(f,t,D,pc',d') \<in> set (relevant_entries P (ins!pc) pc xt)" and
      D: "P \<turnstile> cname_of h xcp \<preceq>\<^sup>* D"
      by (fastforce dest: Invoke_handlers)

    from rel have
      "(pc', Some (Class D # drop (size ST - d') ST, LT)) \<in> set (xcpt_eff (ins!pc) P pc (ST,LT) xt)"
      (is "(_, Some (?ST',_)) \<in> _")
      by (force simp add: xcpt_eff_def image_def)
    with wti \<Phi> obtain
      pc: "pc' < size ins" and
      "P \<turnstile> Some (?ST', LT) \<le>' \<Phi> C M ! pc'"
      by (clarsimp simp add: defs1) blast
    then obtain ST' LT' where
      \<Phi>': "\<Phi> C M ! pc' = Some (ST',LT')" and
      less: "P \<turnstile> (?ST', LT) \<le>\<^sub>i (ST',LT')"
      by (auto simp add: sup_state_opt_any_Some)

    from cr' \<Phi> meth have "conf_f P h (ST, LT) ins f'"
      by (unfold correct_state_def) (fastforce dest: sees_method_fun)
    hence loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
          stk: "P,h \<turnstile> stk [:\<le>] ST" by (unfold conf_f_def) auto
    hence [simp]: "size stk = size ST" by (simp add: list_all2_lengthD)

    let ?f = "(Addr xcp # drop (length stk - d') stk, loc, C, M, pc')"
    have "conf_f P h (ST',LT') ins ?f"
    proof -
      from wf less loc have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" by simp blast
      moreover from D h have "P,h \<turnstile> Addr xcp :\<le> Class D"
        by (simp add: conf_def obj_ty_def case_prod_unfold)
      with less stk
      have "P,h \<turnstile> Addr xcp # drop (length stk - d') stk  [:\<le>] ST'"
        by (auto intro!: list_all2_dropI)
      ultimately show ?thesis using pc by (simp add: conf_f_def)
    qed

    with cr' match \<Phi>' meth pc
    show ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
  qed
qed
(*>*)

text {*
  The requirement of lemma @{text uncaught_xcpt_correct} (that
  the exception is a valid reference on the heap) is always met
  for welltyped instructions and conformant states:
*}
lemma exec_instr_xcpt_h:
  "\<lbrakk>  fst (exec_instr (ins!pc) P h stk vars Cl M pc frs) = Some xcp;
       P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
       P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
  \<Longrightarrow> \<exists>obj. h xcp = Some obj"
  (is "\<lbrakk> ?xcpt; ?wt; ?correct \<rbrakk> \<Longrightarrow> ?thesis")
(*<*)
proof -
  note [simp] = split_beta
  note [split] = split_if_asm option.split_asm

  assume wt: ?wt ?correct
  hence pre: "preallocated h" by (simp add: correct_state_def hconf_def)

  assume xcpt: ?xcpt with pre show ?thesis
  proof (cases "ins!pc")
    case Throw with xcpt wt pre show ?thesis
      by (clarsimp iff: list_all2_Cons2 simp add: defs1)
         (auto dest: non_npD simp: is_refT_def elim: preallocatedE)
  qed (auto elim: preallocatedE)
qed
(*>*)

lemma conf_sys_xcpt:
  "\<lbrakk>preallocated h; C \<in> sys_xcpts\<rbrakk> \<Longrightarrow> P,h \<turnstile> Addr (addr_of_sys_xcpt C) :\<le> Class C"
  by (auto elim: preallocatedE)

lemma match_ex_table_SomeD:
  "match_ex_table P C pc xt = Some (pc',d') \<Longrightarrow>
  \<exists>(f,t,D,h,d) \<in> set xt. matches_ex_entry P C pc (f,t,D,h,d) \<and> h = pc' \<and> d=d'"
  by (induct xt) (auto split: split_if_asm)

text {*
  Finally we can state that, whenever an exception occurs, the
  next state always conforms:
*}
lemma xcpt_correct:
  fixes \<sigma>' :: jvm_state
  assumes wtp:  "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes xp:   "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = Some xcp"
  assumes s':   "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes correct: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  from wtp obtain wfmb where wf: "wf_prog wfmb P"
    by (simp add: wf_jvm_prog_phi_def)

  note conf_sys_xcpt [elim!]
  note xp' = meth s' xp

  note wtp
  moreover
  from xp wt correct
  obtain obj where h: "h xcp = Some obj" by (blast dest: exec_instr_xcpt_h)
  moreover note correct
  ultimately
  have "P,\<Phi> \<turnstile> find_handler P xcp h frs \<surd>" by (rule uncaught_xcpt_correct)
  with xp'
  have "match_ex_table P (cname_of h xcp) pc xt = None \<Longrightarrow> ?thesis"
    (is "?m (cname_of h xcp) = _ \<Longrightarrow> _" is "?match = _ \<Longrightarrow> _")
    by (simp add: split_beta)
  moreover
  { fix pc_d assume "?match = Some pc_d"
    then obtain pc' d' where some_handler: "?match = Some (pc',d')"
      by (cases pc_d) auto

    from correct meth
    obtain ST LT where
      h_ok:  "P \<turnstile> h \<surd>" and
      \<Phi>_pc: "\<Phi> C M ! pc = Some (ST, LT)" and
      frame:  "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
      frames: "conf_fs P h \<Phi> M (size Ts) T frs"
      by (unfold correct_state_def) (fastforce dest: sees_method_fun)

    from h_ok have preh: "preallocated h" by (simp add: hconf_def)

    from frame obtain
      stk: "P,h \<turnstile> stk [:\<le>] ST" and
      loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
      pc:  "pc < size ins"
      by (unfold conf_f_def) auto

    from stk have [simp]: "size stk = size ST" ..

    from wt \<Phi>_pc have
      eff: "\<forall>(pc', s')\<in>set (xcpt_eff (ins!pc) P pc (ST,LT) xt).
             pc' < size ins \<and> P \<turnstile> s' \<le>' \<Phi> C M!pc'"
      by (auto simp add: defs1)

    let ?stk' = "Addr xcp # drop (length stk - d') stk"
    let ?f = "(?stk', loc, C, M, pc')"
    from some_handler xp'
    have \<sigma>': "\<sigma>' = (None, h, ?f#frs)"
      by (simp add: split_beta)

    from some_handler obtain f t D where
      xt: "(f,t,D,pc',d') \<in> set xt" and
      "matches_ex_entry P (cname_of h xcp) pc (f,t,D,pc',d')"
      by (auto dest: match_ex_table_SomeD)

    hence match: "P \<turnstile> cname_of h xcp \<preceq>\<^sup>* D"  "pc \<in> {f..<t}"
      by (auto simp: matches_ex_entry_def)

    from xp obtain
      "(f,t,D,pc',d') \<in> set (relevant_entries P (ins!pc) pc xt)" and
      conf: "P,h \<turnstile> Addr xcp :\<le> Class D"
    proof (cases "ins!pc")
      case Return
      with xp have False by (auto simp: split_beta split: split_if_asm)
      thus ?thesis ..
    next
      case New with xp
      have [simp]: "xcp = addr_of_sys_xcpt OutOfMemory" by simp
      with New match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Getfield with xp
      have [simp]: "xcp = addr_of_sys_xcpt NullPointer"
        by (simp add: split_beta split: split_if_asm)
      with Getfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Putfield with xp
      have [simp]: "xcp = addr_of_sys_xcpt NullPointer"
        by (simp add: split_beta split: split_if_asm)
      with Putfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Checkcast with xp
      have [simp]: "xcp = addr_of_sys_xcpt ClassCast"
        by (simp add: split_beta split: split_if_asm)
      with Checkcast match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      with match preh xt
      show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
    next
      case Invoke with xp match
      have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      moreover
      from xp wt correct obtain obj where xcp: "h xcp = Some obj"
        by (blast dest: exec_instr_xcpt_h)
      ultimately
      show ?thesis using xt match
        by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
    next
      case Throw with xp match preh
      have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
        by (simp add: is_relevant_entry_def)
      moreover
      from xp wt correct obtain obj where xcp: "h xcp = Some obj"
        by (blast dest: exec_instr_xcpt_h)
      ultimately
      show ?thesis using xt match
        by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
    qed auto

    with eff obtain ST' LT' where
      \<Phi>_pc': "\<Phi> C M ! pc' = Some (ST', LT')" and
      pc':   "pc' < size ins" and
      less:  "P \<turnstile> (Class D # drop (size ST - d') ST, LT) \<le>\<^sub>i (ST', LT')"
      by (fastforce simp add: xcpt_eff_def sup_state_opt_any_Some)

    with conf loc stk have "conf_f P h (ST',LT') ins ?f"
      by (auto simp add: defs1 intro: list_all2_dropI)
    with meth h_ok frames \<Phi>_pc' \<sigma>'
    have ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
  }
  ultimately
  show ?thesis by (cases "?match") blast+
qed
(*>*)

section {* Single Instructions *}

text {*
  In this section we prove for each single (welltyped) instruction
  that the state after execution of the instruction still conforms.
  Since we have already handled exceptions above, we can now assume that
  no exception occurs in this step.
*}

declare defs1 [simp]

lemma Invoke_correct:
  fixes \<sigma>' :: jvm_state
  assumes wtprog: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes meth_C: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes ins:    "ins ! pc = Invoke M' n"
  assumes wti:    "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes \<sigma>': "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes approx: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
  assumes no_xcp: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  note split_paired_Ex [simp del]

  from wtprog obtain wfmb where wfprog: "wf_prog wfmb P"
    by (simp add: wf_jvm_prog_phi_def)

  from ins meth_C approx obtain ST LT where
    heap_ok: "P\<turnstile> h\<surd>" and
    \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h \<Phi> M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)

  from ins wti \<Phi>_pc
  have n: "n < size ST" by simp

  { assume "stk!n = Null"
    with ins no_xcp have False by (simp add: split_beta)
    hence ?thesis ..
  }
  moreover
  { assume "ST!n = NT"
    moreover
    from frame have "P,h \<turnstile> stk [:\<le>] ST" by simp
    with n have "P,h \<turnstile> stk!n :\<le> ST!n" by (simp add: list_all2_conv_all_nth)
    ultimately
    have "stk!n = Null" by simp
    with ins no_xcp have False by (simp add: split_beta)
    hence ?thesis ..
  }
  moreover {
    assume NT: "ST!n \<noteq> NT" and Null: "stk!n \<noteq> Null"

    from NT ins wti \<Phi>_pc obtain D D' Ts T m ST' LT' where
      D:   "ST!n = Class D" and
      pc': "pc+1 < size ins" and
      m_D: "P \<turnstile> D sees M': Ts\<rightarrow>T = m in D'" and
      Ts:  "P \<turnstile> rev (take n ST) [\<le>] Ts" and
      \<Phi>':  "\<Phi> C M ! (pc+1) = Some (ST', LT')" and
      LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
      ST': "P \<turnstile> (T # drop (n+1) ST) [\<le>] ST'"
      by (clarsimp simp add: sup_state_opt_any_Some)

    from frame obtain
    stk: "P,h \<turnstile> stk [:\<le>] ST" and
    loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" by simp

    from n stk D have "P,h \<turnstile> stk!n :\<le> Class D"
      by (auto simp add: list_all2_conv_all_nth)
    with Null obtain a C' fs where
      Addr:   "stk!n = Addr a" and
      obj:    "h a = Some (C',fs)" and
      C'subD: "P \<turnstile> C' \<preceq>\<^sup>* D"
      by (fastforce dest!: conf_ClassD)

    with wfprog m_D
    obtain Ts' T' m' D'' mxs' mxl' ins' xt' where
      m_C': "P \<turnstile> C' sees M': Ts'\<rightarrow>T' = (mxs',mxl',ins',xt') in D''" and
      T':   "P \<turnstile> T' \<le> T" and
      Ts':  "P \<turnstile> Ts [\<le>] Ts'"
      by (auto dest: sees_method_mono)

    let ?loc' = "Addr a # rev (take n stk) @ replicate mxl' undefined"
    let ?f' = "([], ?loc', D'', M', 0)"
    let ?f  = "(stk, loc, C, M, pc)"

    from Addr obj m_C' ins \<sigma>' meth_C
    have s': "\<sigma>' = (None, h, ?f' # ?f # frs)" by simp

    from Ts n have [simp]: "size Ts = n"
      by (auto dest: list_all2_lengthD simp: min_def)
    with Ts' have [simp]: "size Ts' = n"
      by (auto dest: list_all2_lengthD)

    from m_C' wfprog
    obtain mD'': "P \<turnstile> D'' sees M':Ts'\<rightarrow>T'=(mxs',mxl',ins',xt') in D''"
      by (fast dest: sees_method_idemp)
    moreover
    with wtprog
    obtain start: "wt_start P D'' Ts' mxl' (\<Phi> D'' M')" and ins': "ins' \<noteq> []"
      by (auto dest: wt_jvm_prog_impl_wt_start)
    then obtain LT\<^sub>0 where LT\<^sub>0: "\<Phi> D'' M' ! 0 = Some ([], LT\<^sub>0)"
      by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
    moreover
    have "conf_f P h ([], LT\<^sub>0) ins' ?f'"
    proof -
      let ?LT = "OK (Class D'') # (map OK Ts') @ (replicate mxl' Err)"

      from stk have "P,h \<turnstile> take n stk [:\<le>] take n ST" ..
      hence "P,h \<turnstile> rev (take n stk) [:\<le>] rev (take n ST)" by simp
      also note Ts also note Ts' finally
      have "P,h \<turnstile> rev (take n stk) [:\<le>\<^sub>\<top>] map OK Ts'" by simp
      also
      have "P,h \<turnstile> replicate mxl' undefined [:\<le>\<^sub>\<top>] replicate mxl' Err"
        by simp
      also from m_C' have "P \<turnstile> C' \<preceq>\<^sup>* D''" by (rule sees_method_decl_above)
      with obj have "P,h \<turnstile> Addr a :\<le> Class D''" by (simp add: conf_def)
      ultimately
      have "P,h \<turnstile> ?loc' [:\<le>\<^sub>\<top>] ?LT" by simp
      also from start LT\<^sub>0 have "P \<turnstile> \<dots> [\<le>\<^sub>\<top>] LT\<^sub>0" by (simp add: wt_start_def)
      finally have "P,h \<turnstile> ?loc' [:\<le>\<^sub>\<top>] LT\<^sub>0" .
      thus ?thesis using ins' by simp
    qed
    ultimately
    have ?thesis using s' \<Phi>_pc approx meth_C m_D T' ins D
      by (fastforce dest: sees_method_fun [of _ C])
  }
  ultimately show ?thesis by blast
qed
(*>*)

declare list_all2_Cons2 [iff]

lemma Return_correct:
  fixes \<sigma>' :: jvm_state
  assumes wt_prog: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes ins: "ins ! pc = Return"
  assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes s': "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes correct: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"

  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  from wt_prog
  obtain wfmb where wf: "wf_prog wfmb P" by (simp add: wf_jvm_prog_phi_def)

  from meth ins s'
  have "frs = [] \<Longrightarrow> ?thesis" by (simp add: correct_state_def)
  moreover
  { fix f frs' assume frs': "frs = f#frs'"
    moreover obtain stk' loc' C' M' pc' where
      f: "f = (stk',loc',C',M',pc')" by (cases f)
    moreover note meth ins s'
    ultimately
    have \<sigma>':
      "\<sigma>' = (None,h,(hd stk#(drop (1+size Ts) stk'),loc',C',M',pc'+1)#frs')"
      (is "\<sigma>' = (None,h,?f'#frs')")
      by simp

    from correct meth
    obtain ST LT where
      h_ok:   "P \<turnstile> h \<surd>" and
      \<Phi>_pc: "\<Phi> C M ! pc = Some (ST, LT)" and
      frame:  "conf_f P h (ST, LT) ins (stk,loc,C,M,pc)" and
      frames: "conf_fs P h \<Phi> M (size Ts) T frs"
      by (auto dest: sees_method_fun simp add: correct_state_def)

    from \<Phi>_pc ins wt
    obtain U ST\<^sub>0 where "ST = U # ST\<^sub>0" "P \<turnstile> U \<le> T"
      by (simp add: wt_instr_def app_def) blast
    with wf frame
    have hd_stk: "P,h \<turnstile> hd stk :\<le> T" by (auto simp add: conf_f_def)

    from f frs' frames
    obtain ST' LT' Ts'' T'' mxs' mxl\<^sub>0' ins' xt' D Ts' T' m D' where
      \<Phi>': "\<Phi> C' M' ! pc' = Some (ST', LT')" and
      meth_C':  "P \<turnstile> C' sees M':Ts''\<rightarrow>T''=(mxs',mxl\<^sub>0',ins',xt') in C'" and
      ins': "ins' ! pc' = Invoke M (size Ts)" and
      D: "ST' ! (size Ts) = Class D" and
      meth_D: "P \<turnstile> D sees M: Ts'\<rightarrow>T' = m in D'" and
      T': "P \<turnstile> T \<le> T'" and
      frame':   "conf_f P h (ST',LT') ins' f" and
      conf_fs:  "conf_fs P h \<Phi> M' (size Ts'') T'' frs'"
      by clarsimp

    from f frame' obtain
      stk': "P,h \<turnstile> stk' [:\<le>] ST'" and
      loc': "P,h \<turnstile> loc' [:\<le>\<^sub>\<top>] LT'" and
      pc':  "pc' < size ins'"
      by (simp add: conf_f_def)

    from wt_prog meth_C' pc'
    have "P,T'',mxs',size ins',xt' \<turnstile> ins'!pc',pc' :: \<Phi> C' M'"
      by (rule wt_jvm_prog_impl_wt_instr)
    with ins' \<Phi>' D meth_D
    obtain aTs ST'' LT'' where
      \<Phi>_suc:   "\<Phi> C' M' ! Suc pc' = Some (ST'', LT'')" and
      less:    "P \<turnstile> (T' # drop (size Ts+1) ST', LT') \<le>\<^sub>i (ST'', LT'')" and
      suc_pc': "Suc pc' < size ins'"
      by (clarsimp simp add: sup_state_opt_any_Some)

    from hd_stk T' have hd_stk': "P,h \<turnstile> hd stk :\<le> T'"  ..

    have frame'':
      "conf_f P h (ST'',LT'') ins' ?f'"
    proof -
      from stk'
      have "P,h \<turnstile> drop (1+size Ts) stk' [:\<le>] drop (1+size Ts) ST'" ..
      moreover
      with hd_stk' less
      have "P,h \<turnstile> hd stk # drop (1+size Ts) stk' [:\<le>] ST''" by auto
      moreover
      from wf loc' less have "P,h \<turnstile> loc' [:\<le>\<^sub>\<top>] LT''" by auto
      moreover note suc_pc'
      ultimately show ?thesis by (simp add: conf_f_def)
    qed

    with \<sigma>' frs' f meth h_ok hd_stk \<Phi>_suc frames meth_C' \<Phi>'
    have ?thesis by (fastforce dest: sees_method_fun [of _ C'])
  }
  ultimately
  show ?thesis by (cases frs) blast+
qed
(*>*)

declare sup_state_opt_any_Some [iff]
declare not_Err_eq [iff]

lemma Load_correct:
"\<lbrakk> wf_prog wt P;
    P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
    ins!pc = Load idx;
    P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
    Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
    P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
  by (fastforce dest: sees_method_fun [of _ C] elim!: confTs_confT_sup)

declare [[simproc del: list_to_set_comprehension]]

lemma Store_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins!pc = Store idx;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
  apply clarsimp
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast intro!: list_all2_update_cong)
  done
(*>*)

lemma Push_correct:
"\<lbrakk> wf_prog wt P;
    P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
    ins!pc = Push v;
    P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
    Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
    P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
  apply clarsimp
  apply (drule (1) sees_method_fun)
  apply clarsimp
  apply (blast dest: typeof_lit_conf)
  done
(*>*)

lemma Cast_conf2:
  "\<lbrakk> wf_prog ok P; P,h \<turnstile> v :\<le> T; is_refT T; cast_ok P C h v;
     P \<turnstile> Class C \<le> T'; is_class P C\<rbrakk>
  \<Longrightarrow> P,h \<turnstile> v :\<le> T'"
(*<*)
  apply (unfold cast_ok_def is_refT_def)
  apply (frule Class_widen)
  apply (elim exE disjE)
     apply simp
    apply simp
   apply simp
  apply (clarsimp simp add: conf_def obj_ty_def)
  apply (cases v)
  apply (auto intro: rtrancl_trans)
  done
(*>*)

lemma Checkcast_correct:
"\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
    P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
    ins!pc = Checkcast D;
    P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
    Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
    P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>;
    fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
  apply (clarsimp simp add: wf_jvm_prog_phi_def split: split_if_asm)
  apply (drule (1) sees_method_fun)
  apply (blast intro: Cast_conf2)
  done
(*>*)

declare split_paired_All [simp del]

lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P

lemma Getfield_correct:
  fixes \<sigma>' :: jvm_state
  assumes wf: "wf_prog wt P"
  assumes mC: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes i:  "ins!pc = Getfield F D"
  assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes s': "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes cf: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
  assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"

  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  from mC cf obtain ST LT where
    "h\<surd>": "P \<turnstile> h \<surd>" and
    \<Phi>: "\<Phi> C M ! pc = Some (ST,LT)" and
    stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
    pc: "pc < size ins" and
    fs: "conf_fs P h \<Phi> M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)

  from i \<Phi> wt obtain oT ST'' vT ST' LT' vT' where
    oT: "P \<turnstile> oT \<le> Class D" and
    ST: "ST = oT # ST''" and
    F:  "P \<turnstile> D sees F:vT in D" and
    pc': "pc+1 < size ins"  and
    \<Phi>': "\<Phi> C M ! (pc+1) = Some (vT'#ST', LT')" and
    ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" and
    vT': "P \<turnstile> vT \<le> vT'"
    by fastforce

  from stk ST obtain ref stk' where
    stk': "stk = ref#stk'" and
    ref:  "P,h \<turnstile> ref :\<le> oT" and
    ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
    by auto

  from stk' i mC s' xc have "ref \<noteq> Null"
    by (simp add: split_beta split:split_if_asm)
  moreover from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
  ultimately obtain a D' fs where
    a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
    by (blast dest: non_npD)

  from D' F have has_field: "P \<turnstile> D' has F:vT in D"
    by (blast intro: has_field_mono has_visible_field)
  moreover from "h\<surd>" h have "P,h \<turnstile> (D', fs) \<surd>" by (rule hconfD)
  ultimately obtain v where v: "fs (F, D) = Some v" "P,h \<turnstile> v :\<le> vT"
    by (clarsimp simp add: oconf_def has_field_def)
       (blast dest: has_fields_fun)

  from a h i mC s' stk' v
  have "\<sigma>' = (None, h, (v#stk',loc,C,M,pc+1)#frs)" by simp
  moreover
  from ST'' ST' have "P,h \<turnstile> stk' [:\<le>] ST'" ..
  moreover
  from v vT' have "P,h \<turnstile> v :\<le> vT'" by blast
  moreover
  from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
  moreover
  note "h\<surd>" mC \<Phi>' pc' v fs
  ultimately
  show "P,\<Phi> \<turnstile> \<sigma>' \<surd>" by fastforce
qed
(*>*)

lemma Putfield_correct:
  fixes \<sigma>' :: jvm_state
  assumes wf: "wf_prog wt P"
  assumes mC: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes i:  "ins!pc = Putfield F D"
  assumes wt: "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes s': "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes cf: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
  assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"

  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  from mC cf obtain ST LT where
    "h\<surd>": "P \<turnstile> h \<surd>" and
    \<Phi>: "\<Phi> C M ! pc = Some (ST,LT)" and
    stk: "P,h \<turnstile> stk [:\<le>] ST" and loc: "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT" and
    pc: "pc < size ins" and
    fs: "conf_fs P h \<Phi> M (size Ts) T frs"
    by (fastforce dest: sees_method_fun)

  from i \<Phi> wt obtain vT vT' oT ST'' ST' LT' where
    ST: "ST = vT # oT # ST''" and
    field: "P \<turnstile> D sees F:vT' in D" and
    oT: "P \<turnstile> oT \<le> Class D" and vT: "P \<turnstile> vT \<le> vT'" and
    pc': "pc+1 < size ins" and
    \<Phi>': "\<Phi> C M!(pc+1) = Some (ST',LT')" and
    ST': "P \<turnstile> ST'' [\<le>] ST'" and LT': "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'"
    by clarsimp

  from stk ST obtain v ref stk' where
    stk': "stk = v#ref#stk'" and
    v:    "P,h \<turnstile> v :\<le> vT" and
    ref:  "P,h \<turnstile> ref :\<le> oT" and
    ST'': "P,h \<turnstile> stk' [:\<le>] ST''"
    by auto

  from stk' i mC s' xc have "ref \<noteq> Null" by (auto simp add: split_beta)
  moreover from ref oT have "P,h \<turnstile> ref :\<le> Class D" ..
  ultimately obtain a D' fs where
    a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P \<turnstile> D' \<preceq>\<^sup>* D"
    by (blast dest: non_npD)

  from v vT have vT': "P,h \<turnstile> v :\<le> vT'" ..

  from field D' have has_field: "P \<turnstile> D' has F:vT' in D"
    by (blast intro: has_field_mono has_visible_field)

  let ?h' = "h(a\<mapsto>(D', fs((F, D)\<mapsto>v)))" and ?f' = "(stk',loc,C,M,pc+1)"
  from h have hext: "h \<unlhd> ?h'" by (rule hext_upd_obj)

  from a h i mC s' stk'
  have "\<sigma>' = (None, ?h', ?f'#frs)" by simp
  moreover
  from "h\<surd>" h have "P,h \<turnstile> (D',fs)\<surd>" by (rule hconfD)
  with has_field vT' have "P,h \<turnstile> (D',fs((F, D)\<mapsto>v))\<surd>" ..
  with "h\<surd>" h have "P \<turnstile> ?h'\<surd>" by (rule hconf_upd_obj)
  moreover
  from ST'' ST' have "P,h \<turnstile> stk' [:\<le>] ST'" ..
  from this hext have "P,?h' \<turnstile> stk' [:\<le>] ST'" by (rule confs_hext)
  moreover
  from loc LT' have "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" ..
  from this hext have "P,?h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT'" by (rule confTs_hext)
  moreover
  from fs hext
  have "conf_fs P ?h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
  moreover
  note mC \<Phi>' pc'
  ultimately
  show "P,\<Phi> \<turnstile> \<sigma>' \<surd>" by fastforce
qed
(*>*)

(* FIXME: move *)
lemma has_fields_b_fields:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
(*<*)
  apply (unfold fields_def)
  apply (blast intro: the_equality has_fields_fun)
  done
(*>*)

(* FIXME: move *)
lemma oconf_blank [intro, simp]:
    "\<lbrakk>is_class P C; wf_prog wt P\<rbrakk> \<Longrightarrow> P,h \<turnstile> blank P C \<surd>"
(*<*)
  by (fastforce simp add: blank_def has_fields_b_fields oconf_init_fields
               dest: wf_Fields_Ex)
(*>*)

lemma obj_ty_blank [iff]: "obj_ty (blank P C) = Class C"
  by (simp add: blank_def)

lemma New_correct:
  fixes \<sigma>' :: jvm_state
  assumes wf:   "wf_prog wt P"
  assumes meth: "P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C"
  assumes ins:  "ins!pc = New X"
  assumes wt:   "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
  assumes exec: "Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
  assumes conf: "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>"
  assumes no_x: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
  shows "P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
proof -
  from ins conf meth
  obtain ST LT where
    heap_ok: "P\<turnstile> h\<surd>" and
    \<Phi>_pc:    "\<Phi> C M!pc = Some (ST,LT)" and
    frame:   "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
    frames:  "conf_fs P h \<Phi> M (size Ts) T frs"
    by (auto dest: sees_method_fun)

  from \<Phi>_pc ins wt
  obtain ST' LT' where
    is_class_X: "is_class P X" and
    mxs:       "size ST < mxs" and
    suc_pc:     "pc+1 < size ins" and
    \<Phi>_suc:      "\<Phi> C M!(pc+1) = Some (ST', LT')" and
    less:       "P \<turnstile> (Class X # ST, LT) \<le>\<^sub>i (ST', LT')"
    by auto

  from ins no_x obtain oref where new_Addr: "new_Addr h = Some oref" by auto
  hence h: "h oref = None" by (rule new_Addr_SomeD)

  with exec ins meth new_Addr have \<sigma>':
    "\<sigma>' = (None, h(oref \<mapsto> blank P X), (Addr oref#stk,loc,C,M,pc+1)#frs)"
    (is "\<sigma>' = (None, ?h', ?f # frs)")
    by simp
  moreover
  from wf h heap_ok is_class_X have h': "P \<turnstile> ?h' \<surd>"
    by (auto intro: hconf_new)
  moreover
  from h frame less suc_pc wf
  have "conf_f P ?h' (ST', LT') ins ?f"
    apply (clarsimp simp add: fun_upd_apply conf_def blank_def split_beta)
    apply (auto intro: confs_hext confTs_hext)
    done
  moreover
  from h have "h \<unlhd> ?h'" by simp
  with frames have "conf_fs P ?h' \<Phi> M (size Ts) T frs" by (rule conf_fs_hext)
  ultimately
  show ?thesis using meth \<Phi>_suc by fastforce
qed
(*>*)

lemma Goto_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = Goto branch;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma IfFalse_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = IfFalse branch;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma CmpEq_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = CmpEq;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma Pop_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = Pop;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma IAdd_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = IAdd;
  P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply (clarsimp simp add: conf_def)
apply (drule (1) sees_method_fun)
apply fastforce
done
(*>*)

lemma Throw_correct:
"\<lbrakk> wf_prog wt P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  ins ! pc = Throw;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>;
  fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
  by simp

text {*
  The next theorem collects the results of the sections above,
  i.e.~exception handling and the execution step for each
  instruction. It states type safety for single step execution:
  in welltyped programs, a conforming state is transformed
  into another conforming state when one instruction is executed.
*}
theorem instr_correct:
"\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
  P \<turnstile> C sees M:Ts\<rightarrow>T=(mxs,mxl\<^sub>0,ins,xt) in C;
  Some \<sigma>' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
  P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd> \<rbrakk>
\<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply (subgoal_tac "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M")
 prefer 2
 apply (erule wt_jvm_prog_impl_wt_instr, assumption)
 apply clarsimp
 apply (drule (1) sees_method_fun)
 apply simp
apply (cases "fst (exec_instr (ins!pc) P h stk loc C M pc frs)")
 prefer 2
 apply (erule xcpt_correct, assumption+)
apply (frule wt_jvm_progD, erule exE)
apply (cases "ins!pc")
apply (rule Load_correct, assumption+)
apply (rule Store_correct, assumption+)
apply (rule Push_correct, assumption+)
apply (rule New_correct, assumption+)
apply (rule Getfield_correct, assumption+)
apply (rule Putfield_correct, assumption+)
apply (rule Checkcast_correct, assumption+)
apply (rule Invoke_correct, assumption+)
apply (rule Return_correct, assumption+)
apply (rule Pop_correct, assumption+)
apply (rule IAdd_correct, assumption+)
apply (rule Goto_correct, assumption+)
apply (rule CmpEq_correct, assumption+)
apply (rule IfFalse_correct, assumption+)
apply (rule Throw_correct, assumption+)
done
(*>*)

section {* Main *}

lemma correct_state_impl_Some_method:
  "P,\<Phi> \<turnstile> (None, h, (stk,loc,C,M,pc)#frs)\<surd>
  \<Longrightarrow> \<exists>m Ts T. P \<turnstile> C sees M:Ts\<rightarrow>T = m in C"
  by fastforce

lemma BV_correct_1 [rule_format]:
"\<And>\<sigma>. \<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; P,\<Phi> \<turnstile> \<sigma>\<surd>\<rbrakk> \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow>\<^sub>1 \<sigma>' \<longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply (simp only: split_tupled_all exec_1_iff)
apply (rename_tac xp h frs)
apply (case_tac xp)
 apply (case_tac frs)
  apply simp
 apply (simp only: split_tupled_all)
 apply hypsubst
 apply (frule correct_state_impl_Some_method)
 apply clarify
 apply (rule instr_correct)
 apply assumption+
 apply (rule sym)
 apply assumption+
apply (case_tac frs)
apply simp_all
done
(*>*)

theorem progress:
  "\<lbrakk> xp=None; frs\<noteq>[] \<rbrakk> \<Longrightarrow> \<exists>\<sigma>'. P \<turnstile> (xp,h,frs) -jvm\<rightarrow>\<^sub>1 \<sigma>'"
  by (clarsimp simp add: exec_1_iff neq_Nil_conv split_beta
               simp del: split_paired_Ex)

lemma progress_conform:
  "\<lbrakk>wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; P,\<Phi> \<turnstile> (xp,h,frs)\<surd>; xp=None; frs\<noteq>[]\<rbrakk>
  \<Longrightarrow> \<exists>\<sigma>'. P \<turnstile> (xp,h,frs) -jvm\<rightarrow>\<^sub>1 \<sigma>' \<and> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply (drule progress)
apply assumption
apply (fast intro: BV_correct_1)
done
(*>*)

theorem BV_correct [rule_format]:
"\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>' \<rbrakk> \<Longrightarrow> P,\<Phi> \<turnstile> \<sigma>\<surd> \<longrightarrow> P,\<Phi> \<turnstile> \<sigma>'\<surd>"
(*<*)
apply (simp only: exec_all_def1)
apply (erule rtrancl_induct)
 apply simp
apply clarify
apply (erule (2) BV_correct_1)
done
(*>*)

lemma hconf_start:
  assumes wf: "wf_prog wf_mb P"
  shows "P \<turnstile> (start_heap P) \<surd>"
(*<*)
  apply (unfold hconf_def)
  apply (simp add: preallocated_start)
  apply (clarify)
  apply (drule sym)
  apply (unfold start_heap_def)
  apply (insert wf)
  apply (auto simp add: fun_upd_apply is_class_xcpt split: split_if_asm)
  done
(*>*)

lemma BV_correct_initial:
  shows "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P; P \<turnstile> C sees M:[]\<rightarrow>T = m in C \<rbrakk>
  \<Longrightarrow> P,\<Phi> \<turnstile> start_state P C M \<surd>"
(*<*)
  apply (cases m)
  apply (unfold  start_state_def)
  apply (unfold correct_state_def)
  apply (simp del: defs1)
  apply (rule conjI)
   apply (simp add: wf_jvm_prog_phi_def hconf_start)
  apply (drule wt_jvm_prog_impl_wt_start, assumption+)
  apply (unfold conf_f_def wt_start_def)
  apply fastforce
  done

declare [[simproc add: list_to_set_comprehension]]
(*>*)

theorem typesafe:
  assumes welltyped:   "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes main_method: "P \<turnstile> C sees M:[]\<rightarrow>T = m in C"
  shows "P \<turnstile> start_state P C M -jvm\<rightarrow> \<sigma>  \<Longrightarrow>  P,\<Phi> \<turnstile> \<sigma> \<surd>"
(*<*)
proof -
  from welltyped main_method
  have "P,\<Phi> \<turnstile> start_state P C M \<surd>" by (rule BV_correct_initial)
  moreover
  assume "P \<turnstile> start_state P C M -jvm\<rightarrow> \<sigma>"
  ultimately
  show "P,\<Phi> \<turnstile> \<sigma> \<surd>" using welltyped by - (rule BV_correct)
qed
(*>*)

end


(*  Title:      Jinja/J/execute_WellType.thy
    Author:     Christoph Petzinger
    Copyright   2004 Technische Universitaet Muenchen
*)
(*
  Expanded to include support for static fields and methods.
  Susannah Mansky
  2017, UIUC
*)

section \<open> Code Generation For WellType \<close>

theory execute_WellType
imports
  WellType Examples
begin

(* Replace WT_WTs.WTCond with new intros WT_WTs.WTCond1 and WT_WTs.WTCond2 *)

lemma WTCond1:
  "\<lbrakk>P,E \<turnstile> e :: Boolean;  P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2;
    P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T\<^sub>2 = T\<^sub>1 \<rbrakk> \<Longrightarrow> P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T\<^sub>2"
by (fastforce)

lemma WTCond2:
  "\<lbrakk>P,E \<turnstile> e :: Boolean;  P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T\<^sub>1 = T\<^sub>2 \<rbrakk> \<Longrightarrow> P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T\<^sub>1"
by (fastforce)

lemmas [code_pred_intro] =
  WT_WTs.WTNew
  WT_WTs.WTCast
  WT_WTs.WTVal
  WT_WTs.WTVar
  WT_WTs.WTBinOpEq
  WT_WTs.WTBinOpAdd
  WT_WTs.WTLAss
  WT_WTs.WTFAcc
  WT_WTs.WTSFAcc
  WT_WTs.WTFAss
  WT_WTs.WTSFAss
  WT_WTs.WTCall
  WT_WTs.WTSCall
  WT_WTs.WTBlock
  WT_WTs.WTSeq

declare
  WTCond1 [code_pred_intro WTCond1]
  WTCond2 [code_pred_intro WTCond2]

lemmas [code_pred_intro] =
  WT_WTs.WTWhile
  WT_WTs.WTThrow
  WT_WTs.WTTry
  WT_WTs.WTNil
  WT_WTs.WTCons

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool as type_check, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as infer_type)
  WT
proof -
  case WT
  from WT.prems show thesis
  proof(cases (no_simp))
    case (WTCond E e e1 T1 e2 T2 T)
    from `x \<turnstile> T1 \<le> T2 \<or> x \<turnstile> T2 \<le> T1` show thesis
    proof
      assume "x \<turnstile> T1 \<le> T2"
      with `x \<turnstile> T1 \<le> T2 \<longrightarrow> T = T2` have "T = T2" ..
      from `xa = E` `xb = if (e) e1 else e2` `xc = T` `x,E \<turnstile> e :: Boolean`
        `x,E \<turnstile> e1 :: T1` `x,E \<turnstile> e2 :: T2` `x \<turnstile> T1 \<le> T2` `x \<turnstile> T2 \<le> T1 \<longrightarrow> T = T1`
      show ?thesis unfolding `T = T2` by(rule WT.WTCond1[OF refl])
    next
      assume "x \<turnstile> T2 \<le> T1"
      with `x \<turnstile> T2 \<le> T1 \<longrightarrow> T = T1` have "T = T1" ..
      from `xa = E` `xb = if (e) e1 else e2` `xc = T` `x,E \<turnstile> e :: Boolean`
        `x,E \<turnstile> e1 :: T1` `x,E \<turnstile> e2 :: T2` `x \<turnstile> T2 \<le> T1` `x \<turnstile> T1 \<le> T2 \<longrightarrow> T = T2`
      show ?thesis unfolding `T = T1` by(rule WT.WTCond2[OF refl])
    qed
  qed(assumption|erule (2) WT.that[OF refl])+
next
  case WTs
  from WTs.prems show thesis
    by(cases (no_simp))(assumption|erule (2) WTs.that[OF refl])+
qed

notation infer_type ("_,_ \<turnstile> _ :: '_" [51,51,51]100)

definition test1 where "test1 = [],empty \<turnstile> testExpr1 :: _"
definition test2 where "test2 = [], empty  \<turnstile> testExpr2 :: _"
definition test3 where "test3 = [], empty(''V'' \<mapsto> Integer)  \<turnstile> testExpr3 :: _"
definition test4 where "test4 = [], empty(''V'' \<mapsto> Integer)  \<turnstile> testExpr4 :: _"
definition test5 where "test5 = [classObject, (''C'',(''Object'',[(''F'',NonStatic,Integer)],[]))], empty  \<turnstile> testExpr5 :: _"
definition test6 where "test6 = [classObject, classI], empty  \<turnstile> testExpr6 :: _"

ML_val \<open>
  val SOME(@{code Integer}, _) = Predicate.yield @{code test1};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test2};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test3};
  val SOME(@{code Void}, _) = Predicate.yield @{code test4};
  val SOME(@{code Void}, _) = Predicate.yield @{code test5};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test6};
\<close>

definition testmb_isNull where "testmb_isNull = [classObject, classA], empty([this] [\<mapsto>] [Class ''A'']) \<turnstile> mb_isNull :: _"
definition testmb_add where "testmb_add = [classObject, classA], empty([this,''i''] [\<mapsto>] [Class ''A'',Integer]) \<turnstile> mb_add :: _"
definition testmb_mult_cond where "testmb_mult_cond = [classObject, classA], empty([this,''j''] [\<mapsto>] [Class ''A'',Integer]) \<turnstile> mb_mult_cond :: _"
definition testmb_mult_block where "testmb_mult_block = [classObject, classA], empty([this,''i'',''j'',''temp''] [\<mapsto>] [Class ''A'',Integer,Integer,Integer]) \<turnstile> mb_mult_block :: _"
definition testmb_mult where "testmb_mult = [classObject, classA], empty([this,''i'',''j''] [\<mapsto>] [Class ''A'',Integer,Integer]) \<turnstile> mb_mult :: _"

ML_val \<open>
  val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_isNull};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_add};
  val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_mult_cond};
  val SOME(@{code Void}, _) = Predicate.yield @{code testmb_mult_block};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_mult};
\<close>

definition test where "test = [classObject, classA], empty \<turnstile> testExpr_ClassA :: _"

ML_val \<open>
  val SOME(@{code Integer}, _) = Predicate.yield @{code test};
\<close>

end


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
chapter \<open>Normalization\<close>
theory OCL_Normalization
  imports OCL_Typing
begin

(*** Normalization Rules ****************************************************)

section \<open>Normalization Rules\<close>

text \<open>
  The following expression normalization rules includes two kinds of an
  abstract syntax tree transformations:
\begin{itemize}
\item determination of implicit types of variables, iterators, and
      tuple elements,
\item unfolding of navigation shorthands and safe navigation operators,
      described in \autoref{tab:norm_rules}.
\end{itemize}

  The following variables are used in the table:
\begin{itemize}
\item \<^verbatim>\<open>x\<close> is a non-nullable value,
\item \<^verbatim>\<open>n\<close> is a nullable value,
\item \<^verbatim>\<open>xs\<close> is a collection of non-nullable values,
\item \<^verbatim>\<open>ns\<close> is a collection of nullable values.
\end{itemize}

\begin{table}[h!]
  \begin{center}
    \caption{Expression Normalization Rules}
    \label{tab:norm_rules}
    \begin{threeparttable}
    \begin{tabular}{c|c}
      \textbf{Orig. expr.} & \textbf{Normalized expression}\\
      \hline
      \<^verbatim>\<open>x.op()\<close> & \<^verbatim>\<open>x.op()\<close>\\
      \<^verbatim>\<open>n.op()\<close> & \<^verbatim>\<open>n.op()\<close>\tnote{*}\\
      \<^verbatim>\<open>x?.op()\<close> & ---\\
      \<^verbatim>\<open>n?.op()\<close> & \<^verbatim>\<open>if n <> null then n.oclAsType(T[1]).op() else null endif\<close>\tnote{**}\\
      \<^verbatim>\<open>x->op()\<close> & \<^verbatim>\<open>x.oclAsSet()->op()\<close>\\
      \<^verbatim>\<open>n->op()\<close> & \<^verbatim>\<open>n.oclAsSet()->op()\<close>\\
      \<^verbatim>\<open>x?->op()\<close> & ---\\
      \<^verbatim>\<open>n?->op()\<close> & ---\\
      \hline
      \<^verbatim>\<open>xs.op()\<close> & \<^verbatim>\<open>xs->collect(x | x.op())\<close>\\
      \<^verbatim>\<open>ns.op()\<close> & \<^verbatim>\<open>ns->collect(n | n.op())\<close>\tnote{*}\\
      \<^verbatim>\<open>xs?.op()\<close> & ---\\
      \<^verbatim>\<open>ns?.op()\<close> & \<^verbatim>\<open>ns->selectByKind(T[1])->collect(x | x.op())\<close>\\
      \<^verbatim>\<open>xs->op()\<close> & \<^verbatim>\<open>xs->op()\<close>\\
      \<^verbatim>\<open>ns->op()\<close> & \<^verbatim>\<open>ns->op()\<close>\\
      \<^verbatim>\<open>xs?->op()\<close> & ---\\
      \<^verbatim>\<open>ns?->op()\<close> & \<^verbatim>\<open>ns->selectByKind(T[1])->op()\<close>\\
    \end{tabular}
    \begin{tablenotes}
    \item[*] The resulting expression will be ill-typed if the operation is unsafe.
    An unsafe operation is an operation which is well-typed for
    a non-nullable source only.
    \item[**] It would be a good idea to prohibit such a transformation
    for safe operations. A safe operation is an operation which is well-typed
    for a nullable source. However, it is hard to define safe operations
    formally considering operations overloading, complex relations between
    operation parameters types (please see the typing rules for the equality
    operator), and user-defined operations.
    \end{tablenotes}
    \end{threeparttable}
  \end{center}
\end{table}

  Please take a note that name resolution of variables, types,
  attributes, and associations is out of scope of this section.
  It should be done on a previous phase during transformation
  of a concrete syntax tree to an abstract syntax tree.\<close>

fun string_of_nat :: "nat \<Rightarrow> string" where
  "string_of_nat n = (if n < 10 then [char_of (48 + n)]
      else string_of_nat (n div 10) @ [char_of (48 + (n mod 10))])"

definition "new_vname \<equiv> String.implode \<circ> string_of_nat \<circ> fcard \<circ> fmdom"

inductive normalize
    :: "('a :: ocl_object_model) type env \<Rightarrow> 'a expr \<Rightarrow> 'a expr \<Rightarrow> bool"
    ("_ \<turnstile> _ \<Rrightarrow>/ _" [51,51,51] 50) and
    normalize_call ("_ \<turnstile>\<^sub>C _ \<Rrightarrow>/ _" [51,51,51] 50) and
    normalize_expr_list ("_ \<turnstile>\<^sub>L _ \<Rrightarrow>/ _" [51,51,51] 50)
    where
 LiteralN:
  "\<Gamma> \<turnstile> Literal a \<Rrightarrow> Literal a"
|ExplicitlyTypedLetN:
  "\<Gamma> \<turnstile> init\<^sub>1 \<Rrightarrow> init\<^sub>2 \<Longrightarrow>
   \<Gamma>(v \<mapsto>\<^sub>f \<tau>) \<turnstile> body\<^sub>1 \<Rrightarrow> body\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Let v (Some \<tau>) init\<^sub>1 body\<^sub>1 \<Rrightarrow> Let v (Some \<tau>) init\<^sub>2 body\<^sub>2"
|ImplicitlyTypedLetN:
  "\<Gamma> \<turnstile> init\<^sub>1 \<Rrightarrow> init\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E init\<^sub>2 : \<tau> \<Longrightarrow>
   \<Gamma>(v \<mapsto>\<^sub>f \<tau>) \<turnstile> body\<^sub>1 \<Rrightarrow> body\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Let v None init\<^sub>1 body\<^sub>1 \<Rrightarrow> Let v (Some \<tau>) init\<^sub>2 body\<^sub>2"
|VarN:
  "\<Gamma> \<turnstile> Var v \<Rrightarrow> Var v"
|IfN:
  "\<Gamma> \<turnstile> a\<^sub>1 \<Rrightarrow> a\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> b\<^sub>1 \<Rrightarrow> b\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> c\<^sub>1 \<Rrightarrow> c\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> If a\<^sub>1 b\<^sub>1 c\<^sub>1 \<Rrightarrow> If a\<^sub>2 b\<^sub>2 c\<^sub>2"

|MetaOperationCallN:
  "\<Gamma> \<turnstile> MetaOperationCall \<tau> op \<Rrightarrow> MetaOperationCall \<tau> op"
|StaticOperationCallN:
  "\<Gamma> \<turnstile>\<^sub>L params\<^sub>1 \<Rrightarrow> params\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> StaticOperationCall \<tau> op params\<^sub>1 \<Rrightarrow> StaticOperationCall \<tau> op params\<^sub>2"

|OclAnyDotCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   \<tau> \<le> OclAny[?] \<or> \<tau> \<le> Tuple fmempty \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 DotCall call\<^sub>1 \<Rrightarrow> Call src\<^sub>2 DotCall call\<^sub>2"
|OclAnySafeDotCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   OclVoid[?] \<le> \<tau> \<Longrightarrow>
   (\<Gamma>, to_required_type \<tau>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   src\<^sub>3 = TypeOperationCall src\<^sub>2 DotCall OclAsTypeOp (to_required_type \<tau>) \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 SafeDotCall call\<^sub>1 \<Rrightarrow>
       If (OperationCall src\<^sub>2 DotCall NotEqualOp [NullLiteral])
          (Call src\<^sub>3 DotCall call\<^sub>2)
          NullLiteral"
|OclAnyArrowCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   \<tau> \<le> OclAny[?] \<or> \<tau> \<le> Tuple fmempty \<Longrightarrow>
   src\<^sub>3 = OperationCall src\<^sub>2 DotCall OclAsSetOp [] \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>3 : \<sigma> \<Longrightarrow>
   (\<Gamma>, \<sigma>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 ArrowCall call\<^sub>1 \<Rrightarrow> Call src\<^sub>3 ArrowCall call\<^sub>2"

|CollectionArrowCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   element_type \<tau> _ \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 ArrowCall call\<^sub>1 \<Rrightarrow> Call src\<^sub>2 ArrowCall call\<^sub>2"
|CollectionSafeArrowCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   element_type \<tau> \<sigma> \<Longrightarrow>
   OclVoid[?] \<le> \<sigma> \<Longrightarrow>
   src\<^sub>3 = TypeOperationCall src\<^sub>2 ArrowCall SelectByKindOp
              (to_required_type \<sigma>) \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>3 : \<rho> \<Longrightarrow>
   (\<Gamma>, \<rho>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 SafeArrowCall call\<^sub>1 \<Rrightarrow> Call src\<^sub>3 ArrowCall call\<^sub>2"
|CollectionDotCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   element_type \<tau> \<sigma> \<Longrightarrow>
   (\<Gamma>, \<sigma>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   it = new_vname \<Gamma> \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 DotCall call\<^sub>1 \<Rrightarrow>
    CollectIteratorCall src\<^sub>2 ArrowCall [it] (Some \<sigma>) (Call (Var it) DotCall call\<^sub>2)"
|CollectionSafeDotCallN:
  "\<Gamma> \<turnstile> src\<^sub>1 \<Rrightarrow> src\<^sub>2 \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E src\<^sub>2 : \<tau> \<Longrightarrow>
   element_type \<tau> \<sigma> \<Longrightarrow>
   OclVoid[?] \<le> \<sigma> \<Longrightarrow>
   \<rho> = to_required_type \<sigma> \<Longrightarrow>
   src\<^sub>3 = TypeOperationCall src\<^sub>2 ArrowCall SelectByKindOp \<rho> \<Longrightarrow>
   (\<Gamma>, \<rho>) \<turnstile>\<^sub>C call\<^sub>1 \<Rrightarrow> call\<^sub>2 \<Longrightarrow>
   it = new_vname \<Gamma> \<Longrightarrow>
   \<Gamma> \<turnstile> Call src\<^sub>1 SafeDotCall call\<^sub>1 \<Rrightarrow>
    CollectIteratorCall src\<^sub>3 ArrowCall [it] (Some \<rho>) (Call (Var it) DotCall call\<^sub>2)"

|TypeOperationN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C TypeOperation op ty \<Rrightarrow> TypeOperation op ty"
|AttributeN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Attribute attr \<Rrightarrow> Attribute attr"
|AssociationEndN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C AssociationEnd role from \<Rrightarrow> AssociationEnd role from"
|AssociationClassN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C AssociationClass \<A> from \<Rrightarrow> AssociationClass \<A> from"
|AssociationClassEndN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C AssociationClassEnd role \<Rrightarrow> AssociationClassEnd role"
|OperationN:
  "\<Gamma> \<turnstile>\<^sub>L params\<^sub>1 \<Rrightarrow> params\<^sub>2 \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C Operation op params\<^sub>1 \<Rrightarrow> Operation op params\<^sub>2"
|TupleElementN:
  "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C TupleElement elem \<Rrightarrow> TupleElement elem"

|ExplicitlyTypedIterateN:
  "\<Gamma> \<turnstile> res_init\<^sub>1 \<Rrightarrow> res_init\<^sub>2 \<Longrightarrow>
   \<Gamma> ++\<^sub>f fmap_of_list (map (\<lambda>it. (it, \<sigma>)) its) \<turnstile>
      Let res res_t\<^sub>1 res_init\<^sub>1 body\<^sub>1 \<Rrightarrow> Let res res_t\<^sub>2 res_init\<^sub>2 body\<^sub>2 \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterate its (Some \<sigma>) res res_t\<^sub>1 res_init\<^sub>1 body\<^sub>1 \<Rrightarrow>
      Iterate its (Some \<sigma>) res res_t\<^sub>2 res_init\<^sub>2 body\<^sub>2"
|ImplicitlyTypedIterateN:
  "element_type \<tau> \<sigma> \<Longrightarrow>
   \<Gamma> \<turnstile> res_init\<^sub>1 \<Rrightarrow> res_init\<^sub>2 \<Longrightarrow>
   \<Gamma> ++\<^sub>f fmap_of_list (map (\<lambda>it. (it, \<sigma>)) its) \<turnstile>
      Let res res_t\<^sub>1 res_init\<^sub>1 body\<^sub>1 \<Rrightarrow> Let res res_t\<^sub>2 res_init\<^sub>2 body\<^sub>2 \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterate its None res res_t\<^sub>1 res_init\<^sub>1 body\<^sub>1 \<Rrightarrow>
      Iterate its (Some \<sigma>) res res_t\<^sub>2 res_init\<^sub>2 body\<^sub>2"

|ExplicitlyTypedIteratorN:
  "\<Gamma> ++\<^sub>f fmap_of_list (map (\<lambda>it. (it, \<sigma>)) its) \<turnstile> body\<^sub>1 \<Rrightarrow> body\<^sub>2  \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterator iter its (Some \<sigma>) body\<^sub>1 \<Rrightarrow> Iterator iter its (Some \<sigma>) body\<^sub>2"
|ImplicitlyTypedIteratorN:
  "element_type \<tau> \<sigma> \<Longrightarrow>
   \<Gamma> ++\<^sub>f fmap_of_list (map (\<lambda>it. (it, \<sigma>)) its) \<turnstile> body\<^sub>1 \<Rrightarrow> body\<^sub>2  \<Longrightarrow>
   (\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterator iter its None body\<^sub>1 \<Rrightarrow> Iterator iter its (Some \<sigma>) body\<^sub>2"

|ExprListNilN:
  "\<Gamma> \<turnstile>\<^sub>L [] \<Rrightarrow> []"
|ExprListConsN:
  "\<Gamma> \<turnstile> x \<Rrightarrow> y \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>L xs \<Rrightarrow> ys \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>L x # xs \<Rrightarrow> y # ys"

(*** Elimination Rules ******************************************************)

section \<open>Elimination Rules\<close>

inductive_cases LiteralNE [elim]: "\<Gamma> \<turnstile> Literal a \<Rrightarrow> b"
inductive_cases LetNE [elim]: "\<Gamma> \<turnstile> Let v t init body \<Rrightarrow> b"
inductive_cases VarNE [elim]: "\<Gamma> \<turnstile> Var v \<Rrightarrow> b"
inductive_cases IfNE [elim]: "\<Gamma> \<turnstile> If a b c \<Rrightarrow> d"

inductive_cases MetaOperationCallNE [elim]: "\<Gamma> \<turnstile> MetaOperationCall \<tau> op \<Rrightarrow> b"
inductive_cases StaticOperationCallNE [elim]: "\<Gamma> \<turnstile> StaticOperationCall \<tau> op as \<Rrightarrow> b"
inductive_cases DotCallNE [elim]: "\<Gamma> \<turnstile> Call src DotCall call \<Rrightarrow> b"
inductive_cases SafeDotCallNE [elim]: "\<Gamma> \<turnstile> Call src SafeDotCall call \<Rrightarrow> b"
inductive_cases ArrowCallNE [elim]: "\<Gamma> \<turnstile> Call src ArrowCall call \<Rrightarrow> b"
inductive_cases SafeArrowCallNE [elim]: "\<Gamma> \<turnstile> Call src SafeArrowCall call \<Rrightarrow> b"

inductive_cases CallNE [elim]: "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C call \<Rrightarrow> b"
inductive_cases OperationCallNE [elim]: "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Operation op as \<Rrightarrow> call"
inductive_cases IterateCallNE [elim]: "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterate its its_ty res res_t res_init body \<Rrightarrow> call"
inductive_cases IteratorCallNE [elim]: "(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterator iter its its_ty body \<Rrightarrow> call"

inductive_cases ExprListNE [elim]: "\<Gamma> \<turnstile>\<^sub>L xs \<Rrightarrow> ys"

(*** Simplification Rules ***************************************************)

section \<open>Simplification Rules\<close>

inductive_simps normalize_alt_simps:
"\<Gamma> \<turnstile> Literal a \<Rrightarrow> b"
"\<Gamma> \<turnstile> Let v t init body \<Rrightarrow> b"
"\<Gamma> \<turnstile> Var v \<Rrightarrow> b"
"\<Gamma> \<turnstile> If a b c \<Rrightarrow> d"

"\<Gamma> \<turnstile> MetaOperationCall \<tau> op \<Rrightarrow> b"
"\<Gamma> \<turnstile> StaticOperationCall \<tau> op as \<Rrightarrow> b"
"\<Gamma> \<turnstile> Call src DotCall call \<Rrightarrow> b"
"\<Gamma> \<turnstile> Call src SafeDotCall call \<Rrightarrow> b"
"\<Gamma> \<turnstile> Call src ArrowCall call \<Rrightarrow> b"
"\<Gamma> \<turnstile> Call src SafeArrowCall call \<Rrightarrow> b"

"(\<Gamma>, \<tau>) \<turnstile>\<^sub>C call \<Rrightarrow> b"
"(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Operation op as \<Rrightarrow> call"
"(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterate its its_ty res res_t res_init body \<Rrightarrow> call"
"(\<Gamma>, \<tau>) \<turnstile>\<^sub>C Iterator iter its its_ty body \<Rrightarrow> call"

"\<Gamma> \<turnstile>\<^sub>L [] \<Rrightarrow> ys"
"\<Gamma> \<turnstile>\<^sub>L x # xs \<Rrightarrow> ys"

(*** Determinism ************************************************************)

section \<open>Determinism\<close>

lemma any_has_not_element_type:
  "element_type \<tau> \<sigma> \<Longrightarrow> \<tau> \<le> OclAny[?] \<or> \<tau> \<le> Tuple fmempty \<Longrightarrow> False"
  by (erule element_type.cases; auto)

lemma any_has_not_element_type':
  "element_type \<tau> \<sigma> \<Longrightarrow> OclVoid[?] \<le> \<tau> \<Longrightarrow> False"
  by (erule element_type.cases; auto)

lemma
  normalize_det:
    "\<Gamma> \<turnstile> expr \<Rrightarrow> expr\<^sub>1 \<Longrightarrow>
     \<Gamma> \<turnstile> expr \<Rrightarrow> expr\<^sub>2 \<Longrightarrow> expr\<^sub>1 = expr\<^sub>2" and
  normalize_call_det:
    "\<Gamma>_\<tau> \<turnstile>\<^sub>C call \<Rrightarrow> call\<^sub>1 \<Longrightarrow>
     \<Gamma>_\<tau> \<turnstile>\<^sub>C call \<Rrightarrow> call\<^sub>2 \<Longrightarrow> call\<^sub>1 = call\<^sub>2" and
  normalize_expr_list_det:
    "\<Gamma> \<turnstile>\<^sub>L xs \<Rrightarrow> ys \<Longrightarrow>
     \<Gamma> \<turnstile>\<^sub>L xs \<Rrightarrow> zs \<Longrightarrow> ys = zs"
  for \<Gamma> :: "('a :: ocl_object_model) type env"
  and \<Gamma>_\<tau> :: "('a :: ocl_object_model) type env \<times> 'a type"
proof (induct arbitrary: expr\<^sub>2 and call\<^sub>2 and zs
       rule: normalize_normalize_call_normalize_expr_list.inducts)
  case (LiteralN \<Gamma> a) thus ?case by auto
next
  case (ExplicitlyTypedLetN \<Gamma> init\<^sub>1 init\<^sub>2 v \<tau> body\<^sub>1 body\<^sub>2) thus ?case
    by blast
next
  case (ImplicitlyTypedLetN \<Gamma> init\<^sub>1 init\<^sub>2 \<tau> v body\<^sub>1 body\<^sub>2) thus ?case
    by (metis (mono_tags, lifting) LetNE option.distinct(1) typing_det)
next
  case (VarN \<Gamma> v) thus ?case by auto
next
  case (IfN \<Gamma> a\<^sub>1 a\<^sub>2 b\<^sub>1 b\<^sub>2 c\<^sub>1 c\<^sub>2) thus ?case
    apply (insert IfN.prems)
    apply (erule IfNE)
    by (simp add: IfN.hyps)
next
  case (MetaOperationCallN \<Gamma> \<tau> op) thus ?case by auto
next
  case (StaticOperationCallN \<Gamma> params\<^sub>1 params\<^sub>2 \<tau> op) thus ?case by blast
next
  case (OclAnyDotCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> call\<^sub>1 call\<^sub>2) show ?case
    apply (insert OclAnyDotCallN.prems)
    apply (erule DotCallNE)
    using OclAnyDotCallN.hyps typing_det apply metis
    using OclAnyDotCallN.hyps any_has_not_element_type typing_det by metis
next
  case (OclAnySafeDotCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> call\<^sub>1 call\<^sub>2) show ?case
    apply (insert OclAnySafeDotCallN.prems)
    apply (erule SafeDotCallNE)
    using OclAnySafeDotCallN.hyps typing_det comp_apply
    apply (metis (no_types, lifting) list.simps(8) list.simps(9))
    using OclAnySafeDotCallN.hyps typing_det any_has_not_element_type'
    by metis
next
  case (OclAnyArrowCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> src\<^sub>3 \<sigma> call\<^sub>1 call\<^sub>2) show ?case
    apply (insert OclAnyArrowCallN.prems)
    apply (erule ArrowCallNE)
    using OclAnyArrowCallN.hyps typing_det comp_apply apply metis
    using OclAnyArrowCallN.hyps typing_det any_has_not_element_type
    by metis
next
  case (CollectionArrowCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> uu call\<^sub>1 call\<^sub>2) show ?case
    apply (insert CollectionArrowCallN.prems)
    apply (erule ArrowCallNE)
    using CollectionArrowCallN.hyps typing_det any_has_not_element_type
    apply metis
    using CollectionArrowCallN.hyps typing_det by metis
next
  case (CollectionSafeArrowCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> \<sigma> src\<^sub>3 \<rho> call\<^sub>1 call\<^sub>2) show ?case
    apply (insert CollectionSafeArrowCallN.prems)
    apply (erule SafeArrowCallNE)
    using CollectionSafeArrowCallN.hyps typing_det element_type_det by metis
next
  case (CollectionDotCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> \<sigma> call\<^sub>1 call\<^sub>2 it) show ?case
    apply (insert CollectionDotCallN.prems)
    apply (erule DotCallNE)
    using CollectionDotCallN.hyps typing_det any_has_not_element_type
    apply metis
    using CollectionDotCallN.hyps typing_det element_type_det by metis
next
  case (CollectionSafeDotCallN \<Gamma> src\<^sub>1 src\<^sub>2 \<tau> \<sigma> src\<^sub>3 call\<^sub>1 call\<^sub>2 it) show ?case
    apply (insert CollectionSafeDotCallN.prems)
    apply (erule SafeDotCallNE)
    using CollectionSafeDotCallN.hyps typing_det any_has_not_element_type'
    apply metis
    using CollectionSafeDotCallN.hyps typing_det element_type_det by metis
next
  case (TypeOperationN \<Gamma> \<tau> op ty) thus ?case by auto
next
  case (AttributeN \<Gamma> \<tau> attr) thus ?case by auto
next
  case (AssociationEndN \<Gamma> \<tau> role "from") thus ?case by auto
next
  case (AssociationClassN \<Gamma> \<tau> \<A> "from") thus ?case by auto
next
  case (AssociationClassEndN \<Gamma> \<tau> role) thus ?case by auto
next
  case (OperationN \<Gamma> params\<^sub>1 params\<^sub>2 \<tau> op) thus ?case by blast
next
  case (TupleElementN \<Gamma> \<tau> elem) thus ?case by auto
next
  case (ExplicitlyTypedIterateN
    \<Gamma> res_init\<^sub>1 res_init\<^sub>2 \<sigma> its res res_t\<^sub>1 body\<^sub>1 res_t\<^sub>2 body\<^sub>2 \<tau>)
  show ?case
    apply (insert ExplicitlyTypedIterateN.prems)
    apply (erule IterateCallNE)
    using ExplicitlyTypedIterateN.hyps element_type_det by blast+
next
  case (ImplicitlyTypedIterateN
    \<tau> \<sigma> \<Gamma> res_init\<^sub>1 res_init\<^sub>2 its res res_t\<^sub>1 body\<^sub>1 res_t\<^sub>2 body\<^sub>2)
  show ?case
    apply (insert ImplicitlyTypedIterateN.prems)
    apply (erule IterateCallNE)
    using ImplicitlyTypedIterateN.hyps element_type_det by blast+
next
  case (ExplicitlyTypedIteratorN \<Gamma> \<sigma> its body\<^sub>1 body\<^sub>2 \<tau> iter)
  show ?case
    apply (insert ExplicitlyTypedIteratorN.prems)
    apply (erule IteratorCallNE)
    using ExplicitlyTypedIteratorN.hyps element_type_det by blast+
next
  case (ImplicitlyTypedIteratorN \<tau> \<sigma> \<Gamma> its body\<^sub>1 body\<^sub>2 iter)
  show ?case
    apply (insert ImplicitlyTypedIteratorN.prems)
    apply (erule IteratorCallNE)
    using ImplicitlyTypedIteratorN.hyps element_type_det by blast+
next
  case (ExprListNilN \<Gamma>) thus ?case
    using normalize_expr_list.cases by auto
next
  case (ExprListConsN \<Gamma> x y xs ys) thus ?case by blast
qed

(*** Normalized Expressions Typing ******************************************)

section \<open>Normalized Expressions Typing\<close>

text \<open>
  Here is the final typing rules.\<close>

inductive nf_typing ("(1_/ \<turnstile>/ (_ :/ _))" [51,51,51] 50) where
  "\<Gamma> \<turnstile> expr \<Rrightarrow> expr\<^sub>N \<Longrightarrow>
   \<Gamma> \<turnstile>\<^sub>E expr\<^sub>N : \<tau> \<Longrightarrow>
   \<Gamma> \<turnstile> expr : \<tau>"

lemma nf_typing_det:
  "\<Gamma> \<turnstile> expr : \<tau> \<Longrightarrow>
   \<Gamma> \<turnstile> expr : \<sigma> \<Longrightarrow> \<tau> = \<sigma>"
  by (metis nf_typing.cases normalize_det typing_det)

(*** Code Setup *************************************************************)

section \<open>Code Setup\<close>

code_pred normalize .

code_pred nf_typing .

definition "check_type \<Gamma> expr \<tau> \<equiv>
  Predicate.eval (nf_typing_i_i_i \<Gamma> expr \<tau>) ()"

definition "synthesize_type \<Gamma> expr \<equiv>
  Predicate.singleton (\<lambda>_. OclInvalid)
    (Predicate.map errorable (nf_typing_i_i_o \<Gamma> expr))"

text \<open>
  It is the only usage of the @{text OclInvalid} type.
  This type is not required to define typing rules.
  It is only required to make the typing function total.\<close>

end


(*  Title:      HOL/Auth/n_mutualEx_lemma_invs_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualEx Protocol Case Study*}

theory n_mutualEx_lemma_invs_on_rules imports n_mutualEx_lemma_inv__1_on_rules n_mutualEx_lemma_inv__2_on_rules n_mutualEx_lemma_inv__3_on_rules n_mutualEx_lemma_inv__4_on_rules n_mutualEx_lemma_inv__5_on_rules
begin
lemma invs_on_rules:
  assumes a1: "f \<in> invariants N" and a2: "r \<in> rules N"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have b1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__1  p__Inv0 p__Inv1)\<or>
    (\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__2  p__Inv0)\<or>
    (\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)\<or>
    (\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__4  p__Inv0)\<or>
    (\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__5  p__Inv0 p__Inv1)"
  apply (cut_tac a1, auto) done
    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__1  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__1_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__2  p__Inv0)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__2_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__3_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__4  p__Inv0)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__4_on_rules) done
    }

    moreover {
      assume c1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__5  p__Inv0 p__Inv1)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__5_on_rules) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end