(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
 * CapDL Types
 *
 * This file introduces many of the high-level types used in this
 * specification.
 *)

theory Types_D
imports
  "ASpec.VMRights_A"
  Intents_D
  "Lib.Lib"
  "Lib.SplitRule"
  "HOL-Combinatorics.Transposition" (* for Fun.swap *)
begin

(* A hardware IRQ number. *)
type_synonym cdl_irq = "10 word"

(*
 * How objects are named within the kernel.
 *
 * Objects are named by 32 bit words.
 * This name may correspond to the memory address of the object.
 *)
type_synonym cdl_object_id = word32

type_synonym cdl_object_set = "(cdl_object_id set)"

(* The badge of an endpoint *)
type_synonym cdl_badge = word32

(* The guard of a CNode cap, and the number of bits the guard uses. *)
type_synonym cdl_cap_guard = word32
type_synonym cdl_cap_guard_size = nat

(* The type we use to represent object sizes. *)
type_synonym cdl_size_bits = nat

(* A single IA32 IO port. *)
type_synonym cdl_io_port = nat

(* The depth of a particular IA32 pagetable. *)
type_synonym cdl_io_pagetable_level = nat

(* An index into a CNode, TCB, or other kernel object that contains caps. *)
type_synonym cdl_cnode_index = nat

(* A reference to a capability slot. *)
type_synonym cdl_cap_ref = "cdl_object_id \<times> cdl_cnode_index"

(* A virtual ASID. *)
type_synonym cdl_asid = "cdl_cnode_index \<times> cdl_cnode_index"

(* mapped address  *)
type_synonym cdl_mapped_addr = "(cdl_asid \<times> word32)"

(* Number of bits of a badge we can use. *)
definition
  badge_bits :: nat
where
  "badge_bits \<equiv> 28"

(* FrameCaps, PageTableCaps and PageDirectoryCaps can either be
 * "real" cap or "fake" cap. Real caps are installed in CNodes,
 * and fake caps represent a page table mapping.
 *)
datatype cdl_frame_cap_type = Real | Fake

(*
 * Kernel capabilities.
 *
 * Such capabilities (or "caps") give the holder particular rights to
 * a kernel object or system hardware.
 *
 * Caps have attributes such as the object they point to, the rights
 * they give the holder, or how the holder is allowed to interact with
 * the target object.
 *)

datatype cdl_cap =
    NullCap

  (* Kernel object capabilities *)
  | UntypedCap bool cdl_object_set cdl_object_set
  | EndpointCap cdl_object_id cdl_badge "cdl_right set"
  | NotificationCap cdl_object_id cdl_badge "cdl_right set"
  | ReplyCap cdl_object_id "cdl_right set" (* The id of the tcb of the target thread *)
  | MasterReplyCap cdl_object_id
  | CNodeCap cdl_object_id cdl_cap_guard cdl_cap_guard_size cdl_size_bits
  | TcbCap cdl_object_id
  | DomainCap

  (*
   * Capabilities representing threads waiting in endpoint queues.
   *)
  (* thread, badge, is call, can grant, can grant reply, is fault ipc *)
  | PendingSyncSendCap cdl_object_id cdl_badge bool bool bool bool
  (* thread, is waiting for reply, can grant *)
  | PendingSyncRecvCap cdl_object_id bool bool
  | PendingNtfnRecvCap cdl_object_id

  (* Indicate that the thread is ready for Reschedule *)
  | RestartCap
  | RunningCap

  (* Interrupt capabilities *)
  | IrqControlCap
  | IrqHandlerCap cdl_irq

  (* Virtual memory capabilties *)
  | FrameCap bool cdl_object_id "cdl_right set" nat cdl_frame_cap_type "cdl_mapped_addr option"
  | PageTableCap cdl_object_id cdl_frame_cap_type "cdl_mapped_addr option"
  | PageDirectoryCap cdl_object_id cdl_frame_cap_type "cdl_asid option"
  | AsidControlCap
  | AsidPoolCap cdl_object_id "cdl_cnode_index"

  (* x86-specific capabilities *)
  | IOPortsCap cdl_object_id "cdl_io_port set"
  | IOSpaceMasterCap
  | IOSpaceCap cdl_object_id
  | IOPageTableCap cdl_object_id

  (* Zombie caps (representing objects mid-deletion) *)
  | ZombieCap cdl_object_id

  (* Bound NTFN caps signifying when a tcb is bound to an NTFN *)
  | BoundNotificationCap cdl_object_id

(* A mapping from capability identifiers to capabilities. *)

type_synonym cdl_cap_map = "cdl_cnode_index \<Rightarrow> cdl_cap option"

(*
 * The cap derivation tree (CDT).
 *
 * This tree records how certain caps are derived from others. This
 * information is important because it affects how caps are revoked; if an
 * entity revokes a particular cap, all of the cap's children (as
 * recorded in the CDT) are also revoked.
 *
 * At this point in time, we leave the definition of the CDT quite
 * abstract. This may be made more concrete in the future allowing us to
 * reason about revocation.
 *)
type_synonym cdl_cdt = "cdl_cap_ref \<Rightarrow> cdl_cap_ref option"

translations
  (type) "cdl_cap_map" <=(type) "nat \<Rightarrow> cdl_cap option"
  (type) "cdl_cap_ref" <=(type) "cdl_object_id \<times> nat"
  (type) "cdl_cap_ref" <=(type) "word32 \<times> nat"
  (type) "cdl_cdt"     <=(type) "cdl_cap_ref \<Rightarrow> cdl_cap_ref option"

(* Kernel objects *)
record cdl_tcb =
  cdl_tcb_caps           :: cdl_cap_map
  cdl_tcb_fault_endpoint :: cdl_cptr
  cdl_tcb_intent         :: cdl_full_intent
  cdl_tcb_has_fault      :: bool
  cdl_tcb_domain         :: word8

record cdl_cnode =
  cdl_cnode_caps :: cdl_cap_map
  cdl_cnode_size_bits :: cdl_size_bits

record cdl_asid_pool =
  cdl_asid_pool_caps :: cdl_cap_map

record cdl_page_table =
  cdl_page_table_caps :: cdl_cap_map

record cdl_page_directory =
  cdl_page_directory_caps :: cdl_cap_map

record cdl_frame =
  cdl_frame_size_bits :: cdl_size_bits

record cdl_irq_node =
  cdl_irq_node_caps :: cdl_cap_map

(*
 * Kernel objects.
 *
 * These are in-memory objects that may, over the course of the system
 * execution, be created or deleted by users.
 *)
datatype cdl_object =
    Endpoint
  | Notification
  | Tcb cdl_tcb
  | CNode cdl_cnode
  | AsidPool cdl_asid_pool
  | PageTable cdl_page_table
  | PageDirectory cdl_page_directory
  | Frame cdl_frame
  | Untyped
  | IRQNode cdl_irq_node

(* The architecture that we are modelling. *)
datatype cdl_arch = IA32 | ARM11

(* The map of objects that are in the system. *)
type_synonym cdl_heap = "cdl_object_id \<Rightarrow> cdl_object option"

translations
  (type) "cdl_heap" <=(type) "32 word \<Rightarrow> cdl_object option"

(*
 * The current state of the system.
 *
 * The state record contains the following primary pieces of information:
 *
 * arch:
 *   The architecture of the system. This affects what capabilities and
 *   kernel objects could possibly be present. In the current kernel
 *   arch will not change at runtime.
 *
 * objects:
 *   The objects that currently exist in the system.
 *
 * cdt:
 *   The cap derivation tree of the system.
 *
 * current_thread:
 *   The currently running thread. Operations will always be performed
 *   on behalf of this thread.
 *
 * irq_node:
 *   Which IRQs are mapped to which notifications.
 *
 * asid_table:
 *   The first level of the asid table, containing capabilities to all
 *   of the ASIDPools.
 *
 * current_domain:
 *   The currently running domain.
 *)
record cdl_state =
  cdl_arch           :: cdl_arch
  cdl_objects        :: cdl_heap
  cdl_cdt            :: cdl_cdt
  cdl_current_thread :: "cdl_object_id option"
  cdl_irq_node       :: "cdl_irq \<Rightarrow> cdl_object_id"
  cdl_asid_table     :: cdl_cap_map
  cdl_current_domain :: word8

(* Return the type of an object. *)
definition
  object_type :: "cdl_object \<Rightarrow> cdl_object_type"
where
  "object_type x \<equiv>
    case x of
        Untyped \<Rightarrow> UntypedType
      | Endpoint \<Rightarrow> EndpointType
      | Notification \<Rightarrow> NotificationType
      | Tcb _ \<Rightarrow> TcbType
      | CNode _ \<Rightarrow> CNodeType
      | IRQNode _ \<Rightarrow> IRQNodeType
      | AsidPool _ \<Rightarrow> AsidPoolType
      | PageTable _ \<Rightarrow> PageTableType
      | PageDirectory _ \<Rightarrow> PageDirectoryType
      | Frame f \<Rightarrow> FrameType (cdl_frame_size_bits f)"

lemmas object_type_simps = object_type_def[split_simps cdl_object.split]

definition
  asid_high_bits :: nat where
  "asid_high_bits \<equiv> 7"
definition
  asid_low_bits :: nat where
  "asid_low_bits \<equiv> 10 :: nat"
definition
  asid_bits :: nat where
  "asid_bits \<equiv> 17 :: nat"

(*
 * Each TCB contains a number of cap slots, each with a specific
 * purpose. These constants define the purpose of each slot.
 *)
definition "tcb_cspace_slot     = (0 :: cdl_cnode_index)"
definition "tcb_vspace_slot     = (1 :: cdl_cnode_index)"
definition "tcb_replycap_slot   = (2 :: cdl_cnode_index)"
definition "tcb_caller_slot     = (3 :: cdl_cnode_index)"
definition "tcb_ipcbuffer_slot  = (4 :: cdl_cnode_index)"
definition "tcb_pending_op_slot = (5 :: cdl_cnode_index)"
definition "tcb_boundntfn_slot  = (6 :: cdl_cnode_index)"

lemmas tcb_slot_defs =
  tcb_cspace_slot_def
  tcb_vspace_slot_def
  tcb_replycap_slot_def
  tcb_caller_slot_def
  tcb_ipcbuffer_slot_def
  tcb_pending_op_slot_def
  tcb_boundntfn_slot_def

(*
 * Getters and setters for various data types.
 *)

(* Capability getters / setters *)

primrec (nonexhaustive)
  cap_objects :: "cdl_cap \<Rightarrow> cdl_object_id set"
where
    "cap_objects (IOPageTableCap x) = {x}"
  | "cap_objects (IOSpaceCap x) = {x}"
  | "cap_objects (IOPortsCap x _) = {x}"
  | "cap_objects (AsidPoolCap x _) = {x}"
  | "cap_objects (PageDirectoryCap x _ _) = {x}"
  | "cap_objects (PageTableCap x _ _) = {x}"
  | "cap_objects (FrameCap _ x _ _ _ _) = {x}"
  | "cap_objects (TcbCap x) = {x}"
  | "cap_objects (CNodeCap x _ _ _) = {x}"
  | "cap_objects (MasterReplyCap x) = {x}"
  | "cap_objects (ReplyCap x _) = {x}"
  | "cap_objects (NotificationCap x _ _) = {x}"
  | "cap_objects (EndpointCap x _ _) = {x}"
  | "cap_objects (UntypedCap _ x a) = x"
  | "cap_objects (ZombieCap x) = {x}"
  | "cap_objects (PendingSyncSendCap x _ _ _ _ _) = {x}"
  | "cap_objects (PendingSyncRecvCap x _ _) = {x}"
  | "cap_objects (PendingNtfnRecvCap x) = {x}"
  | "cap_objects (BoundNotificationCap x) = {x}"

definition
  cap_has_object :: "cdl_cap \<Rightarrow> bool"
where
  "cap_has_object cap \<equiv> case cap of
     NullCap          \<Rightarrow> False
  | IrqControlCap    \<Rightarrow> False
  | IrqHandlerCap _  \<Rightarrow> False
  | AsidControlCap   \<Rightarrow> False
  | IOSpaceMasterCap \<Rightarrow> False
  | RestartCap       \<Rightarrow> False
  | RunningCap       \<Rightarrow> False
  | DomainCap        \<Rightarrow> False
  | _                \<Rightarrow> True"

definition
  cap_object :: "cdl_cap \<Rightarrow> cdl_object_id"
where
  "cap_object cap \<equiv>
     if cap_has_object cap
     then (THE c. c \<in> cap_objects cap)
     else undefined"

lemma cap_object_simps[simp]:
  "cap_object (IOPageTableCap x) = x"
  "cap_object (IOSpaceCap x) = x"
  "cap_object (IOPortsCap x a) = x"
  "cap_object (AsidPoolCap x b) = x"
  "cap_object (PageDirectoryCap x c d) = x"
  "cap_object (PageTableCap x e f) = x"
  "cap_object (FrameCap dev x g h i j) = x"
  "cap_object (TcbCap x) = x"
  "cap_object (CNodeCap x k l sz) = x"
  "cap_object (MasterReplyCap x) = x"
  "cap_object (ReplyCap x q) = x"
  "cap_object (NotificationCap x m n) = x"
  "cap_object (EndpointCap x p q) = x"
  "cap_object (ZombieCap x) = x"
  "cap_object (PendingSyncSendCap x s t u v w) = x"
  "cap_object (PendingSyncRecvCap x t u) = x"
  "cap_object (PendingNtfnRecvCap x) = x"
  "cap_object (BoundNotificationCap x) = x"
  by (simp_all add:cap_object_def Nitpick.The_psimp cap_has_object_def)

primrec (nonexhaustive) cap_badge :: "cdl_cap \<Rightarrow> cdl_badge"
where
    "cap_badge (NotificationCap _ x _) = x"
  | "cap_badge (EndpointCap _ x _) = x"

definition
  update_cap_badge :: "cdl_badge \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_badge x c \<equiv> case c of
      NotificationCap f1 _ f3 \<Rightarrow> NotificationCap f1 x f3
    | EndpointCap f1 _ f3      \<Rightarrow> EndpointCap f1 x f3
    | _ \<Rightarrow> c"

definition all_cdl_rights :: "cdl_right set" where
  "all_cdl_rights = {Read, Write, Grant, GrantReply}"

definition
  cap_rights :: "cdl_cap \<Rightarrow> cdl_right set"
where
  "cap_rights c \<equiv> case c of
      FrameCap _ _ x _ _ _ \<Rightarrow> x
    | NotificationCap _ _ x \<Rightarrow> x
    | EndpointCap _ _ x \<Rightarrow> x
    | ReplyCap _ x \<Rightarrow> x
    | _ \<Rightarrow> all_cdl_rights"

definition
  update_cap_rights :: "cdl_right set \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_rights r c \<equiv> case c of
      FrameCap dev f1 _ f2 f3 f4 \<Rightarrow> FrameCap dev f1 (validate_vm_rights r) f2 f3 f4
    | NotificationCap f1 f2 _ \<Rightarrow> NotificationCap f1 f2 (r - {Grant, GrantReply})
    | EndpointCap f1 f2 _ \<Rightarrow> EndpointCap f1 f2 r
    | ReplyCap f1 _ \<Rightarrow> ReplyCap f1 (r - {Read, GrantReply} \<union> {Write})
    | _ \<Rightarrow> c"

definition
  update_mapping_cap_status :: "cdl_frame_cap_type \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
 "update_mapping_cap_status r c \<equiv> case c of
      FrameCap dev f1 f2 f3 _ f4 \<Rightarrow> FrameCap dev f1 f2 f3 r f4
    | PageTableCap pt1 _ pt2 \<Rightarrow> PageTableCap pt1 r pt2
    | _ \<Rightarrow> c"

primrec (nonexhaustive) cap_guard :: "cdl_cap \<Rightarrow> cdl_cap_guard"
where
  "cap_guard (CNodeCap _ x _ _) = x"

definition
  update_cap_guard :: "cdl_cap_guard \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_guard x c \<equiv> case c of
      CNodeCap f1 _ f3 f4 \<Rightarrow> CNodeCap f1 x f3 f4
    | _ \<Rightarrow> c"

primrec (nonexhaustive) cap_guard_size :: "cdl_cap \<Rightarrow> cdl_cap_guard_size"
where
  "cap_guard_size (CNodeCap _ _ x _ ) = x"

definition
  cnode_cap_size :: "cdl_cap \<Rightarrow> cdl_size_bits"
where
  "cnode_cap_size cap \<equiv> case cap of
      CNodeCap _ _ _ x \<Rightarrow> x
    | _ \<Rightarrow> 0"

definition
  update_cap_guard_size :: "cdl_cap_guard_size \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_guard_size x c \<equiv> case c of
      CNodeCap f1 f2 _ f3 \<Rightarrow> CNodeCap f1 f2 x f3
    | _ \<Rightarrow> c"

(* Kernel object getters / setters *)
definition
  object_slots :: "cdl_object \<Rightarrow> cdl_cap_map"
where
  "object_slots obj \<equiv> case obj of
    PageDirectory x \<Rightarrow> cdl_page_directory_caps x
  | PageTable x \<Rightarrow> cdl_page_table_caps x
  | AsidPool x \<Rightarrow> cdl_asid_pool_caps x
  | CNode x \<Rightarrow> cdl_cnode_caps x
  | Tcb x \<Rightarrow> cdl_tcb_caps x
  | IRQNode x \<Rightarrow> cdl_irq_node_caps x
  | _ \<Rightarrow> Map.empty"

definition
  update_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "update_slots new_val obj \<equiv> case obj of
    PageDirectory x \<Rightarrow> PageDirectory (x\<lparr>cdl_page_directory_caps := new_val\<rparr>)
  | PageTable x \<Rightarrow> PageTable (x\<lparr>cdl_page_table_caps := new_val\<rparr>)
  | AsidPool x \<Rightarrow> AsidPool (x\<lparr>cdl_asid_pool_caps := new_val\<rparr>)
  | CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_caps := new_val\<rparr>)
  | Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_caps := new_val\<rparr>)
  | IRQNode x \<Rightarrow> IRQNode (x\<lparr>cdl_irq_node_caps := new_val\<rparr>)
  | _ \<Rightarrow> obj"

definition
  has_slots :: "cdl_object \<Rightarrow> bool"
where
  "has_slots obj \<equiv> case obj of
    PageDirectory _ \<Rightarrow> True
  | PageTable _ \<Rightarrow> True
  | AsidPool _ \<Rightarrow> True
  | CNode _ \<Rightarrow> True
  | Tcb _ \<Rightarrow> True
  | IRQNode _ \<Rightarrow> True
  | _ \<Rightarrow> False"

definition
  cap_free_ids :: "cdl_cap \<Rightarrow> cdl_object_id set"
where
  "cap_free_ids cap \<equiv> (case cap of
     UntypedCap _ _ free_ids \<Rightarrow> free_ids
   | _ \<Rightarrow> {})"

definition
  remove_free_ids :: "cdl_cap \<Rightarrow> cdl_object_id set \<Rightarrow> cdl_cap"
where
  "remove_free_ids cap obj_ids \<equiv> case cap of
     UntypedCap dev c a \<Rightarrow> UntypedCap dev c (a - obj_ids)
   | _ \<Rightarrow> cap"

definition cap_irq :: "cdl_cap \<Rightarrow> cdl_irq"
where
  "cap_irq cap \<equiv> case cap of
      IrqHandlerCap x \<Rightarrow> x
    | _ \<Rightarrow> undefined"

(*************
 * Cap types *
 *************)

definition cap_type :: "cdl_cap \<Rightarrow> cdl_object_type option"
where
  "cap_type x \<equiv> case x of
    UntypedCap _ _ _         \<Rightarrow> Some UntypedType
  | EndpointCap _ _ _      \<Rightarrow> Some EndpointType
  | NotificationCap _ _ _ \<Rightarrow> Some NotificationType
  | TcbCap _               \<Rightarrow> Some TcbType
  | CNodeCap _ _ _ _       \<Rightarrow> Some CNodeType
  | AsidPoolCap _ _        \<Rightarrow> Some AsidPoolType
  | PageTableCap _ _ _     \<Rightarrow> Some PageTableType
  | PageDirectoryCap _ _ _ \<Rightarrow> Some PageDirectoryType
  | FrameCap _ _ _ f _ _     \<Rightarrow> Some (FrameType f)
  | IrqHandlerCap _        \<Rightarrow> Some IRQNodeType
  | _                      \<Rightarrow> None "

abbreviation "is_untyped_cap cap    \<equiv> (cap_type cap = Some UntypedType)"
abbreviation "is_ep_cap cap         \<equiv> (cap_type cap = Some EndpointType)"
abbreviation "is_ntfn_cap cap        \<equiv> (cap_type cap = Some NotificationType)"
abbreviation "is_tcb_cap cap        \<equiv> (cap_type cap = Some TcbType)"
abbreviation "is_cnode_cap cap      \<equiv> (cap_type cap = Some CNodeType)"
abbreviation "is_asidpool_cap cap   \<equiv> (cap_type cap = Some AsidPoolType)"
abbreviation "is_pt_cap cap         \<equiv> (cap_type cap = Some PageTableType)"
abbreviation "is_pd_cap cap         \<equiv> (cap_type cap = Some PageDirectoryType)"
abbreviation "is_frame_cap cap      \<equiv> (\<exists>sz. cap_type cap = Some (FrameType sz))"
abbreviation "is_irqhandler_cap cap \<equiv> (cap_type cap = Some IRQNodeType)"
definition   "is_irqcontrol_cap cap \<equiv> (cap = IrqControlCap)"

lemma cap_type_simps [simp]:
  "is_untyped_cap    (UntypedCap dev a a')"
  "is_ep_cap         (EndpointCap b c d)"
  "is_ntfn_cap        (NotificationCap e f g)"
  "is_tcb_cap        (TcbCap h)"
  "is_cnode_cap      (CNodeCap j k l m)"
  "is_asidpool_cap   (AsidPoolCap n p)"
  "is_pd_cap         (PageDirectoryCap r s t)"
  "is_pt_cap         (PageTableCap u v w)"
  "is_frame_cap      (FrameCap dev a1 a2 a3 a4 a5)"
  "is_irqhandler_cap (IrqHandlerCap a6)"
  "cap_type (FrameCap dev obj_id rights sz rs asid) = Some (FrameType sz)"
  by (clarsimp simp: cap_type_def)+

abbreviation "cap_has_type cap \<equiv> (\<exists>type. cap_type cap = Some type)"

lemma cap_type_update_cap_badge [simp]:
  "cap_type (update_cap_badge x cap) = cap_type cap"
  by (clarsimp simp: update_cap_badge_def cap_type_def split: cdl_cap.splits)

lemma cap_type_update_cap_rights [simp]:
  "cap_type (update_cap_rights x cap) = cap_type cap"
  by (clarsimp simp: update_cap_rights_def cap_type_def split: cdl_cap.splits)

lemma cap_type_update_mapping_cap_status [simp]:
  "cap_type (update_mapping_cap_status x cap) = cap_type cap"
  by (clarsimp simp: update_mapping_cap_status_def cap_type_def split: cdl_cap.splits)

lemma cap_type_update_cap_guard [simp]:
  "cap_type (update_cap_guard x cap) = cap_type cap"
  by (clarsimp simp: update_cap_guard_def cap_type_def split: cdl_cap.splits)

lemma update_cap_guard_size [simp]:
  "cap_type (update_cap_guard_size x cap) = cap_type cap"
  by (clarsimp simp: update_cap_guard_size_def cap_type_def split: cdl_cap.splits)

definition is_pending_cap :: "cdl_cap \<Rightarrow> bool"
where "is_pending_cap c \<equiv> case c of
  PendingSyncRecvCap _ _ _ \<Rightarrow> True
  | PendingNtfnRecvCap _ \<Rightarrow> True
  | PendingSyncSendCap _ _ _ _ _ _ \<Rightarrow> True
  | _ \<Rightarrow> False"

(*
 * Object constructors.
 *)

(* Create a capability map that contains no caps. *)
definition
  empty_cap_map :: "nat \<Rightarrow> cdl_cap_map"
where
  "empty_cap_map sz \<equiv> (\<lambda>a. if a < 2^sz then (Some NullCap) else None)"

(* Create an empty CNode. *)
definition
  empty_cnode :: "nat \<Rightarrow> cdl_cnode"
where
  "empty_cnode sz = \<lparr> cdl_cnode_caps = empty_cap_map sz, cdl_cnode_size_bits = sz \<rparr>"

definition
  empty_irq_node :: cdl_irq_node
where
  "empty_irq_node \<equiv> \<lparr> cdl_irq_node_caps = empty_cap_map 0 \<rparr>"

(* Standard empty TCB object. *)
definition
  default_tcb :: "word8 \<Rightarrow> cdl_tcb"
where
  "default_tcb current_domain = \<lparr>
    cdl_tcb_caps = \<lambda>n. if n \<le> tcb_boundntfn_slot then Some NullCap else None,
    cdl_tcb_fault_endpoint = 0,
    cdl_tcb_intent = \<lparr>
      cdl_intent_op = None,
      cdl_intent_error = False,
      cdl_intent_cap = 0,
      cdl_intent_extras = [],
      cdl_intent_recv_slot = None
      \<rparr>,
    cdl_tcb_has_fault = False,
    cdl_tcb_domain = current_domain
    \<rparr>"

(* Return a newly constructed object of the given type. *)
definition
  default_object :: "cdl_object_type \<Rightarrow> nat \<Rightarrow> word8 \<Rightarrow> cdl_object option"
where
  "default_object x y current_domain \<equiv>
    case x of
        UntypedType \<Rightarrow> Some Untyped
      | EndpointType \<Rightarrow> Some Endpoint
      | NotificationType \<Rightarrow> Some Notification
      | TcbType \<Rightarrow> Some (Tcb (default_tcb current_domain))
      | CNodeType \<Rightarrow> Some (CNode (empty_cnode y))
      | AsidPoolType \<Rightarrow> Some (AsidPool \<lparr> cdl_asid_pool_caps = empty_cap_map asid_low_bits \<rparr>)
      | PageTableType \<Rightarrow> Some (PageTable \<lparr> cdl_page_table_caps = empty_cap_map 8 \<rparr>)
      | PageDirectoryType \<Rightarrow> Some (PageDirectory \<lparr> cdl_page_directory_caps = empty_cap_map 12 \<rparr>)
      | FrameType sz \<Rightarrow> Some (Frame \<lparr> cdl_frame_size_bits = sz \<rparr>)
      | IRQNodeType \<Rightarrow> Some (IRQNode empty_irq_node)"

abbreviation "pick a \<equiv> SOME x. x\<in> a"

(* Construct a cap for a new object. *)
definition
  default_cap :: "cdl_object_type \<Rightarrow> cdl_object_id set \<Rightarrow> cdl_size_bits \<Rightarrow> bool \<Rightarrow> cdl_cap"
where
  "default_cap t id_set sz dev \<equiv>
    case t of
        EndpointType \<Rightarrow> EndpointCap (pick id_set) 0 UNIV
      | NotificationType \<Rightarrow> NotificationCap (THE i. i \<in> id_set) 0 {Read,Write}
      | TcbType \<Rightarrow> TcbCap (pick id_set)
      | CNodeType \<Rightarrow> CNodeCap (pick id_set) 0 0 sz
      | IRQNodeType \<Rightarrow> IrqHandlerCap undefined
      | UntypedType \<Rightarrow> UntypedCap dev id_set id_set
      | AsidPoolType \<Rightarrow> AsidPoolCap (pick id_set) 0
      | PageTableType \<Rightarrow> PageTableCap (pick id_set) Real None
      | PageDirectoryType \<Rightarrow> PageDirectoryCap (pick id_set) Real None
      | FrameType frame_size \<Rightarrow> FrameCap dev (pick id_set) {Read, Write} frame_size Real None"

end


(*  Title:      Jinja/J/BigStep.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

header {* \isaheader{Big Step Semantics} *}

theory BigStep imports Expr State begin

inductive
  eval :: "J_prog \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> bool"
          ("_ \<turnstile> ((1\<langle>_,/_\<rangle>) \<Rightarrow>/ (1\<langle>_,/_\<rangle>))" [51,0,0,0,0] 81)
  and evals :: "J_prog \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> bool"
           ("_ \<turnstile> ((1\<langle>_,/_\<rangle>) [\<Rightarrow>]/ (1\<langle>_,/_\<rangle>))" [51,0,0,0,0] 81)
  for P :: J_prog
where

  New:
  "\<lbrakk> new_Addr h = Some a; P \<turnstile> C has_fields FDTs; h' = h(a\<mapsto>(C,init_fields FDTs)) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>new C,(h,l)\<rangle> \<Rightarrow> \<langle>addr a,(h',l)\<rangle>"

| NewFail:
  "new_Addr h = None \<Longrightarrow>
  P \<turnstile> \<langle>new C, (h,l)\<rangle> \<Rightarrow> \<langle>THROW OutOfMemory,(h,l)\<rangle>"

| Cast:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,(h,l)\<rangle>; h a = Some(D,fs); P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>Cast C e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,(h,l)\<rangle>"

| CastNull:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>Cast C e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle>"

| CastFail:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle>\<Rightarrow> \<langle>addr a,(h,l)\<rangle>; h a = Some(D,fs); \<not> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>Cast C e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>THROW ClassCast,(h,l)\<rangle>"

| CastThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>Cast C e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| Val:
  "P \<turnstile> \<langle>Val v,s\<rangle> \<Rightarrow> \<langle>Val v,s\<rangle>"

| BinOp:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v\<^sub>1,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>Val v\<^sub>2,s\<^sub>2\<rangle>; binop(bop,v\<^sub>1,v\<^sub>2) = Some v \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2,s\<^sub>0\<rangle>\<Rightarrow>\<langle>Val v,s\<^sub>2\<rangle>"

| BinOpThrow1:
  "P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2, s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e,s\<^sub>1\<rangle>"

| BinOpThrow2:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v\<^sub>1,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>throw e,s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e,s\<^sub>2\<rangle>"

| Var:
  "l V = Some v \<Longrightarrow>
  P \<turnstile> \<langle>Var V,(h,l)\<rangle> \<Rightarrow> \<langle>Val v,(h,l)\<rangle>"

| LAss:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,(h,l)\<rangle>; l' = l(V\<mapsto>v) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>V:=e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>unit,(h,l')\<rangle>"

| LAssThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>V:=e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| FAcc:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,(h,l)\<rangle>; h a = Some(C,fs); fs(F,D) = Some v \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<bullet>F{D},s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,(h,l)\<rangle>"

| FAccNull:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>F{D},s\<^sub>0\<rangle> \<Rightarrow> \<langle>THROW NullPointer,s\<^sub>1\<rangle>"

| FAccThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>F{D},s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| FAss:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>Val v,(h\<^sub>2,l\<^sub>2)\<rangle>;
     h\<^sub>2 a = Some(C,fs); fs' = fs((F,D)\<mapsto>v); h\<^sub>2' = h\<^sub>2(a\<mapsto>(C,fs')) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<^sub>1\<bullet>F{D}:=e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>unit,(h\<^sub>2',l\<^sub>2)\<rangle>"

| FAssNull:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle>;  P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>Val v,s\<^sub>2\<rangle> \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>e\<^sub>1\<bullet>F{D}:=e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>THROW NullPointer,s\<^sub>2\<rangle>"

| FAssThrow1:
  "P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<^sub>1\<bullet>F{D}:=e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| FAssThrow2:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<^sub>1\<bullet>F{D}:=e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>2\<rangle>"

| CallObjThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>M(ps),s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| CallParamsThrow:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,s\<^sub>1\<rangle>; P \<turnstile> \<langle>es,s\<^sub>1\<rangle> [\<Rightarrow>] \<langle>map Val vs @ throw ex # es',s\<^sub>2\<rangle> \<rbrakk>
   \<Longrightarrow> P \<turnstile> \<langle>e\<bullet>M(es),s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw ex,s\<^sub>2\<rangle>"

| CallNull:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle>;  P \<turnstile> \<langle>ps,s\<^sub>1\<rangle> [\<Rightarrow>] \<langle>map Val vs,s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<bullet>M(ps),s\<^sub>0\<rangle> \<Rightarrow> \<langle>THROW NullPointer,s\<^sub>2\<rangle>"

| Call:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,s\<^sub>1\<rangle>;  P \<turnstile> \<langle>ps,s\<^sub>1\<rangle> [\<Rightarrow>] \<langle>map Val vs,(h\<^sub>2,l\<^sub>2)\<rangle>;
     h\<^sub>2 a = Some(C,fs);  P \<turnstile> C sees M:Ts\<rightarrow>T = (pns,body) in D;
     length vs = length pns;  l\<^sub>2' = [this\<mapsto>Addr a, pns[\<mapsto>]vs];
     P \<turnstile> \<langle>body,(h\<^sub>2,l\<^sub>2')\<rangle> \<Rightarrow> \<langle>e',(h\<^sub>3,l\<^sub>3)\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<bullet>M(ps),s\<^sub>0\<rangle> \<Rightarrow> \<langle>e',(h\<^sub>3,l\<^sub>2)\<rangle>"

| Block:
  "P \<turnstile> \<langle>e\<^sub>0,(h\<^sub>0,l\<^sub>0(V:=None))\<rangle> \<Rightarrow> \<langle>e\<^sub>1,(h\<^sub>1,l\<^sub>1)\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>{V:T; e\<^sub>0},(h\<^sub>0,l\<^sub>0)\<rangle> \<Rightarrow> \<langle>e\<^sub>1,(h\<^sub>1,l\<^sub>1(V:=l\<^sub>0 V))\<rangle>"

| Seq:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>0,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>1,s\<^sub>1\<rangle> \<Rightarrow> \<langle>e\<^sub>2,s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e\<^sub>0;;e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>e\<^sub>2,s\<^sub>2\<rangle>"

| SeqThrow:
  "P \<turnstile> \<langle>e\<^sub>0,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<^sub>0;;e\<^sub>1,s\<^sub>0\<rangle>\<Rightarrow>\<langle>throw e,s\<^sub>1\<rangle>"

| CondT:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>true,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>1,s\<^sub>1\<rangle> \<Rightarrow> \<langle>e',s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>if (e) e\<^sub>1 else e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>e',s\<^sub>2\<rangle>"

| CondF:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>false,s\<^sub>1\<rangle>; P \<turnstile> \<langle>e\<^sub>2,s\<^sub>1\<rangle> \<Rightarrow> \<langle>e',s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>if (e) e\<^sub>1 else e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>e',s\<^sub>2\<rangle>"

| CondThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>if (e) e\<^sub>1 else e\<^sub>2, s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| WhileF:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>false,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>while (e) c,s\<^sub>0\<rangle> \<Rightarrow> \<langle>unit,s\<^sub>1\<rangle>"

| WhileT:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>true,s\<^sub>1\<rangle>; P \<turnstile> \<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>Val v\<^sub>1,s\<^sub>2\<rangle>; P \<turnstile> \<langle>while (e) c,s\<^sub>2\<rangle> \<Rightarrow> \<langle>e\<^sub>3,s\<^sub>3\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>while (e) c,s\<^sub>0\<rangle> \<Rightarrow> \<langle>e\<^sub>3,s\<^sub>3\<rangle>"

| WhileCondThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle> throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>while (e) c,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| WhileBodyThrow:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>true,s\<^sub>1\<rangle>; P \<turnstile> \<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>2\<rangle>\<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>while (e) c,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>2\<rangle>"

| Throw:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>addr a,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>throw e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Throw a,s\<^sub>1\<rangle>"

| ThrowNull:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>null,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>throw e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>THROW NullPointer,s\<^sub>1\<rangle>"

| ThrowThrow:
  "P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>throw e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e',s\<^sub>1\<rangle>"

| Try:
  "P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v\<^sub>1,s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>try e\<^sub>1 catch(C V) e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v\<^sub>1,s\<^sub>1\<rangle>"

| TryCatch:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Throw a,(h\<^sub>1,l\<^sub>1)\<rangle>;  h\<^sub>1 a = Some(D,fs);  P \<turnstile> D \<preceq>\<^sup>* C;
     P \<turnstile> \<langle>e\<^sub>2,(h\<^sub>1,l\<^sub>1(V\<mapsto>Addr a))\<rangle> \<Rightarrow> \<langle>e\<^sub>2',(h\<^sub>2,l\<^sub>2)\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>try e\<^sub>1 catch(C V) e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>e\<^sub>2',(h\<^sub>2,l\<^sub>2(V:=l\<^sub>1 V))\<rangle>"

| TryThrow:
  "\<lbrakk> P \<turnstile> \<langle>e\<^sub>1,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Throw a,(h\<^sub>1,l\<^sub>1)\<rangle>;  h\<^sub>1 a = Some(D,fs);  \<not> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>try e\<^sub>1 catch(C V) e\<^sub>2,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Throw a,(h\<^sub>1,l\<^sub>1)\<rangle>"

| Nil:
  "P \<turnstile> \<langle>[],s\<rangle> [\<Rightarrow>] \<langle>[],s\<rangle>"

| Cons:
  "\<lbrakk> P \<turnstile> \<langle>e,s\<^sub>0\<rangle> \<Rightarrow> \<langle>Val v,s\<^sub>1\<rangle>; P \<turnstile> \<langle>es,s\<^sub>1\<rangle> [\<Rightarrow>] \<langle>es',s\<^sub>2\<rangle> \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>e#es,s\<^sub>0\<rangle> [\<Rightarrow>] \<langle>Val v # es',s\<^sub>2\<rangle>"

| ConsThrow:
  "P \<turnstile> \<langle>e, s\<^sub>0\<rangle> \<Rightarrow> \<langle>throw e', s\<^sub>1\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e#es, s\<^sub>0\<rangle> [\<Rightarrow>] \<langle>throw e' # es, s\<^sub>1\<rangle>"

(*<*)
lemmas eval_evals_induct = eval_evals.induct [split_format (complete)]
  and eval_evals_inducts = eval_evals.inducts [split_format (complete)]

inductive_cases eval_cases [cases set]:
 "P \<turnstile> \<langle>Cast C e,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>Val v,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>V:=e,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e\<bullet>F{D},s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e\<^sub>1\<bullet>F{D}:=e\<^sub>2,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e\<bullet>M{D}(es),s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>{V:T;e\<^sub>1},s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e\<^sub>1;;e\<^sub>2,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>if (e) e\<^sub>1 else e\<^sub>2,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>while (b) c,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>throw e,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>try e\<^sub>1 catch(C V) e\<^sub>2,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle>"

inductive_cases evals_cases [cases set]:
 "P \<turnstile> \<langle>[],s\<rangle> [\<Rightarrow>] \<langle>e',s'\<rangle>"
 "P \<turnstile> \<langle>e#es,s\<rangle> [\<Rightarrow>] \<langle>e',s'\<rangle>"
(*>*)

subsection"Final expressions"

definition final :: "'a exp \<Rightarrow> bool"
where
  "final e  \<equiv>  (\<exists>v. e = Val v) \<or> (\<exists>a. e = Throw a)"

definition finals:: "'a exp list \<Rightarrow> bool"
where
  "finals es  \<equiv>  (\<exists>vs. es = map Val vs) \<or> (\<exists>vs a es'. es = map Val vs @ Throw a # es')"

lemma [simp]: "final(throw e) = (\<exists>a. e = addr a)"
(*<*)by(simp add:final_def)(*>*)

lemma finalE: "\<lbrakk> final e;  \<And>v. e = Val v \<Longrightarrow> R;  \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def)(*>*)

lemma [iff]: "finals (Val v # es) = finals es"
(*<*)
apply(clarsimp simp add: finals_def)
apply(rule iffI)
 apply(erule disjE)
  apply simp
 apply(rule disjI2)
 apply clarsimp
 apply(case_tac vs)
  apply simp
 apply fastforce
apply(erule disjE)
 apply clarsimp
apply(rule disjI2)
apply clarsimp
apply(rule_tac x = "v#vs" in exI)
apply simp
done
(*>*)

lemma finals_app_map[iff]: "finals (map Val vs @ es) = finals es"
(*<*)by(induct_tac vs, auto)(*>*)

lemma [iff]: "finals (map Val vs)"
(*<*)using finals_app_map[of vs "[]"]by(simp)(*>*)

lemma [iff]: "finals (throw e # es) = (\<exists>a. e = addr a)"
(*<*)
apply(simp add:finals_def)
apply(rule iffI)
 apply clarsimp
 apply(case_tac vs)
  apply simp
 apply fastforce
apply clarsimp
apply(rule_tac x = "[]" in exI)
apply simp
done
(*>*)

lemma not_finals_ConsI: "\<not> final e \<Longrightarrow> \<not> finals(e#es)"
 (*<*)
apply(clarsimp simp add:finals_def final_def)
apply(case_tac vs)
apply auto
done
(*>*)

lemma eval_final: "P \<turnstile> \<langle>e,s\<rangle> \<Rightarrow> \<langle>e',s'\<rangle> \<Longrightarrow> final e'"
 and evals_final: "P \<turnstile> \<langle>es,s\<rangle> [\<Rightarrow>] \<langle>es',s'\<rangle> \<Longrightarrow> finals es'"
(*<*)by(induct rule:eval_evals.inducts, simp_all)(*>*)

lemma eval_lcl_incr: "P \<turnstile> \<langle>e,(h\<^sub>0,l\<^sub>0)\<rangle> \<Rightarrow> \<langle>e',(h\<^sub>1,l\<^sub>1)\<rangle> \<Longrightarrow> dom l\<^sub>0 \<subseteq> dom l\<^sub>1"
 and evals_lcl_incr: "P \<turnstile> \<langle>es,(h\<^sub>0,l\<^sub>0)\<rangle> [\<Rightarrow>] \<langle>es',(h\<^sub>1,l\<^sub>1)\<rangle> \<Longrightarrow> dom l\<^sub>0 \<subseteq> dom l\<^sub>1"
(*<*)
proof (induct rule: eval_evals_inducts)
  case BinOp show ?case by(rule subset_trans)(rule BinOp.hyps)+
next
  case Call thus ?case
    by(simp del: fun_upd_apply)
next
  case Seq show ?case by(rule subset_trans)(rule Seq.hyps)+
next
  case CondT show ?case by(rule subset_trans)(rule CondT.hyps)+
next
  case CondF show ?case by(rule subset_trans)(rule CondF.hyps)+
next
  case WhileT thus ?case by(blast)
next
  case TryCatch thus ?case by(clarsimp simp:dom_def split:split_if_asm) blast
next
  case Cons show ?case by(rule subset_trans)(rule Cons.hyps)+
next
  case Block thus ?case by(auto simp del:fun_upd_apply)
qed auto
(*>*)

text{* Only used later, in the small to big translation, but is already a
good sanity check: *}

lemma eval_finalsId:
assumes finals: "finals es" shows "P \<turnstile> \<langle>es,s\<rangle> [\<Rightarrow>] \<langle>es,s\<rangle>"
(*<*)
  using finals
proof (induct es type: list)
  case Nil show ?case by (rule eval_evals.intros)
next
  case (Cons e es)
  have hyp: "finals es \<Longrightarrow> P \<turnstile> \<langle>es,s\<rangle> [\<Rightarrow>] \<langle>es,s\<rangle>"
   and finals: "finals (e # es)" by fact+
  show "P \<turnstile> \<langle>e # es,s\<rangle> [\<Rightarrow>] \<langle>e # es,s\<rangle>"
  proof cases
    assume "final e"
    thus ?thesis
    proof (cases rule: finalE)
      fix v assume e: "e = Val v"
      have "P \<turnstile> \<langle>Val v,s\<rangle> \<Rightarrow> \<langle>Val v,s\<rangle>" by (simp add: eval_finalId)
      moreover from finals e have "P \<turnstile> \<langle>es,s\<rangle> [\<Rightarrow>] \<langle>es,s\<rangle>" by(fast intro:hyp)
      ultimately have "P \<turnstile> \<langle>Val v#es,s\<rangle> [\<Rightarrow>] \<langle>Val v#es,s\<rangle>"
        by (rule eval_evals.intros)
      with e show ?thesis by simp
    next
      fix a assume e: "e = Throw a"
      have "P \<turnstile> \<langle>Throw a,s\<rangle> \<Rightarrow> \<langle>Throw a,s\<rangle>" by (simp add: eval_finalId)
      hence "P \<turnstile> \<langle>Throw a#es,s\<rangle> [\<Rightarrow>] \<langle>Throw a#es,s\<rangle>" by (rule eval_evals.intros)
      with e show ?thesis by simp
    qed
  next
    assume "\<not> final e"
    with not_finals_ConsI finals have False by blast
    thus ?thesis ..
  qed
qed
(*>*)

theorem eval_hext: "P \<turnstile> \<langle>e,(h,l)\<rangle> \<Rightarrow> \<langle>e',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"
and evals_hext:  "P \<turnstile> \<langle>es,(h,l)\<rangle> [\<Rightarrow>] \<langle>es',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"
(*<*)
proof (induct rule: eval_evals_inducts)
  case New thus ?case
    by(fastforce intro!: hext_new intro:LeastI simp:new_Addr_def
                split:split_if_asm simp del:fun_upd_apply)
next
  case BinOp thus ?case by (fast elim!:hext_trans)
next
  case BinOpThrow2 thus ?case by(fast elim!: hext_trans)
next
  case FAss thus ?case
    by(auto simp:sym[THEN hext_upd_obj] simp del:fun_upd_apply
            elim!: hext_trans)
next
  case FAssNull thus ?case by (fast elim!:hext_trans)
next
  case FAssThrow2 thus ?case by (fast elim!:hext_trans)
next
  case CallParamsThrow thus ?case by(fast elim!: hext_trans)
next
  case CallNull thus ?case by(fast elim!: hext_trans)
next
  case Call thus ?case by(fast elim!: hext_trans)
next
  case Seq thus ?case by(fast elim!: hext_trans)
next
  case CondT thus ?case by(fast elim!: hext_trans)
next
  case CondF thus ?case by(fast elim!: hext_trans)
next
  case WhileT thus ?case by(fast elim!: hext_trans)
next
  case WhileBodyThrow thus ?case by (fast elim!: hext_trans)
next
  case TryCatch thus ?case  by(fast elim!: hext_trans)
next
  case Cons thus ?case by (fast intro: hext_trans)
qed auto
(*>*)

end


(*  Title:      HOL/Auth/n_german_lemma_inv__30_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_german Protocol Case Study*}

theory n_german_lemma_inv__30_on_rules imports n_german_lemma_on_inv__30
begin
section{*All lemmas on causal relation between inv__30*}
lemma lemma_inv__30_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqEIVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqES  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqESVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReq N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvEVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__30) done
    }

    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__30) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__18_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_german Protocol Case Study*}

theory n_german_lemma_inv__18_on_rules imports n_german_lemma_on_inv__18
begin
section{*All lemmas on causal relation between inv__18*}
lemma lemma_inv__18_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__18  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqEIVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqES  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqESVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReq N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvEVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__18) done
    }

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

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section {* The Typing Framework for the JVM \label{sec:JVM} *}

theory Typing_Framework_JVM
imports "../DFA/Abstract_BV" JVMType EffectMono BVSpec
begin

definition exec :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow> instr list \<Rightarrow> JVMType.state step_type" where
  "exec G maxs rT et bs ==
  err_step (size bs) (\<lambda>pc. app (bs!pc) G maxs rT pc et) (\<lambda>pc. eff (bs!pc) G pc et)"

definition opt_states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (ty list \<times> ty err list) option set" where
  "opt_states G maxs maxr \<equiv> opt (\<Union>{list n (types G) |n. n \<le> maxs} \<times> list maxr (err (types G)))"

subsection {*  Executability of @{term check_bounded} *}

primrec list_all'_rec :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_all'_rec P n []     = True"
| "list_all'_rec P n (x#xs) = (P x n \<and> list_all'_rec P (Suc n) xs)"

definition list_all' :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_all' P xs \<equiv> list_all'_rec P 0 xs"

lemma list_all'_rec:
  "list_all'_rec P n xs = (\<forall>p < size xs. P (xs!p) (p+n))"
  apply (induct xs arbitrary: n)
  apply auto
  apply (case_tac p)
  apply auto
  done

lemma list_all' [iff]:
  "list_all' P xs = (\<forall>n < size xs. P (xs!n) n)"
  by (unfold list_all'_def) (simp add: list_all'_rec)

subsection {* Connecting JVM and Framework *}

lemma check_bounded_is_bounded:
  "check_bounded ins et \<Longrightarrow> bounded (\<lambda>pc. eff (ins!pc) G pc et) (length ins)"
  by (unfold bounded_def) (blast dest: check_boundedD)

lemma special_ex_swap_

lemmas [iff del] = not_None_eq

theorem exec_pres_type:
  "wf_prog wf_mb S \<Longrightarrow>
  pres_type (exec S maxs rT et bs) (size bs) (states S maxs maxr)"
  apply (unfold exec_def JVM_states_unfold)
  apply (rule pres_type_lift)
  apply clarify
  apply (case_tac s)
   apply simp
   apply (drule effNone)
   apply simp
  apply (simp add: eff_def xcpt_eff_def norm_eff_def)
  apply (case_tac "bs!p")

  apply clarsimp
  apply (drule listE_nth_in, assumption)
  apply fastforce

  apply (fastforce simp add: not_None_eq)

  apply (fastforce simp add: not_None_eq typeof_empty_is_type)

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x="1" in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply (fastforce dest: field_fields fields_is_type)
  apply (simp add: match_some_entry image_iff)
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply (simp add: match_some_entry image_iff)
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce

  defer

  apply fastforce
  apply fastforce

  apply clarsimp
  apply (rule_tac x="n'+2" in exI)
  apply simp

  apply clarsimp
  apply (rule_tac x="Suc (Suc (Suc (length ST)))" in exI)
  apply simp

  apply clarsimp
  apply (rule_tac x="Suc (Suc (Suc (Suc (length ST))))" in exI)
  apply simp

  apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce

  apply clarsimp
  apply (erule disjE)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce

  apply (erule disjE)
   apply clarsimp
   apply (drule method_wf_mdecl, assumption+)
   apply (clarsimp simp add: wf_mdecl_def wf_mhead_def)
   apply fastforce
  apply clarsimp
  apply (rule_tac x=1 in exI)
  apply fastforce
  done

lemmas [iff] = not_None_eq

lemma sup_state_opt_unfold:
  "sup_state_opt G \<equiv> Opt.le (Product.le (Listn.le (subtype G)) (Listn.le (Err.le (subtype G))))"
  by (simp add: sup_state_opt_def sup_state_def sup_loc_def sup_ty_opt_def)

lemma app_mono:
  "app_mono (sup_state_opt G) (\<lambda>pc. app (bs!pc) G maxs rT pc et) (length bs) (opt_states G maxs maxr)"
  by (unfold app_mono_def lesub_def) (blast intro: EffectMono.app_mono)

lemma list_appendI:
  "\<lbrakk>a \<in> list x A; b \<in> list y A\<rbrakk> \<Longrightarrow> a @ b \<in> list (x+y) A"
  apply (unfold list_def)
  apply (simp (no_asm))
  apply blast
  done

lemma list_map [simp]:
  "(map f xs \<in> list (length xs) A) = (f ` set xs \<subseteq> A)"
  apply (unfold list_def)
  apply simp
  done

lemma [iff]:
  "(OK ` A \<subseteq> err B) = (A \<subseteq> B)"
  apply (unfold err_def)
  apply blast
  done

lemma [intro]:
  "x \<in> A \<Longrightarrow> replicate n x \<in> list n A"
  by (induct n, auto)

lemma lesubstep_type_simple:
  "a <=[Product.le (op =) r] b \<Longrightarrow> a <=|r| b"
  apply (unfold lesubstep_type_def)
  apply clarify
  apply (simp add: set_conv_nth)
  apply clarify
  apply (drule le_listD, assumption)
  apply (clarsimp simp add: lesub_def Product.le_def)
  apply (rule exI)
  apply (rule conjI)
   apply (rule exI)
   apply (rule conjI)
    apply (rule sym)
    apply assumption
   apply assumption
  apply assumption
  done

lemma eff_mono:
  "\<lbrakk>p < length bs; s <=_(sup_state_opt G) t; app (bs!p) G maxs rT pc et t\<rbrakk>
  \<Longrightarrow> eff (bs!p) G p et s <=|sup_state_opt G| eff (bs!p) G p et t"
  apply (unfold eff_def)
  apply (rule lesubstep_type_simple)
  apply (rule le_list_appendI)
   apply (simp add: norm_eff_def)
   apply (rule le_listI)
    apply simp
   apply simp
   apply (simp add: lesub_def)
   apply (case_tac s)
    apply simp
   apply (simp del: split_paired_All split_paired_Ex)
   apply (elim exE conjE)
   apply simp
   apply (drule eff'_mono, assumption)
   apply assumption
  apply (simp add: xcpt_eff_def)
  apply (rule le_listI)
    apply simp
  apply simp
  apply (simp add: lesub_def)
  apply (case_tac s)
   apply simp
  apply simp
  apply (case_tac t)
   apply simp
  apply (clarsimp simp add: sup_state_conv)
  done

lemma order_sup_state_opt:
  "ws_prog G \<Longrightarrow> order (sup_state_opt G)"
  by (unfold sup_state_opt_unfold) (blast dest: acyclic_subcls1 order_widen)

theorem exec_mono:
  "ws_prog G \<Longrightarrow> bounded (exec G maxs rT et bs) (size bs) \<Longrightarrow>
  mono (JVMType.le G maxs maxr) (exec G maxs rT et bs) (size bs) (states G maxs maxr)"
  apply (unfold exec_def JVM_le_unfold JVM_states_unfold)
  apply (rule mono_lift)
     apply (fold sup_state_opt_unfold opt_states_def)
     apply (erule order_sup_state_opt)
    apply (rule app_mono)
   apply assumption
  apply clarify
  apply (rule eff_mono)
  apply assumption+
  done

theorem semilat_JVM_slI:
  "ws_prog G \<Longrightarrow> semilat (JVMType.sl G maxs maxr)"
  apply (unfold JVMType.sl_def stk_esl_def reg_sl_def)
  apply (rule semilat_opt)
  apply (rule err_semilat_Product_esl)
  apply (rule err_semilat_upto_esl)
  apply (rule err_semilat_JType_esl, assumption+)
  apply (rule err_semilat_eslI)
  apply (rule Listn_sl)
  apply (rule err_semilat_JType_esl, assumption+)
  done

lemma sl_triple_conv:
  "JVMType.sl G maxs maxr ==
  (states G maxs maxr, JVMType.le G maxs maxr, JVMType.sup G maxs maxr)"
  by (simp (no_asm) add: states_def JVMType.le_def JVMType.sup_def)

lemma is_type_pTs:
  "\<lbrakk> wf_prog wf_mb G; (C,S,fs,mdecls) \<in> set G; ((mn,pTs),rT,code) \<in> set mdecls \<rbrakk>
  \<Longrightarrow> set pTs \<subseteq> types G"
proof
  assume "wf_prog wf_mb G"
         "(C,S,fs,mdecls) \<in> set G"
         "((mn,pTs),rT,code) \<in> set mdecls"
  hence "wf_mdecl wf_mb G C ((mn,pTs),rT,code)"
    by (rule wf_prog_wf_mdecl)
  hence "\<forall>t \<in> set pTs. is_type G t"
    by (unfold wf_mdecl_def wf_mhead_def) auto
  moreover
  fix t assume "t \<in> set pTs"
  ultimately
  have "is_type G t" by blast
  thus "t \<in> types G" ..
qed

lemma jvm_prog_lift:
  assumes wf:
  "wf_prog (\<lambda>G C bd. P G C bd) G"

  assumes rule:
  "\<And>wf_mb C mn pTs C rT maxs maxl b et bd.
   wf_prog wf_mb G \<Longrightarrow>
   method (G,C) (mn,pTs) = Some (C,rT,maxs,maxl,b,et) \<Longrightarrow>
   is_class G C \<Longrightarrow>
   set pTs \<subseteq> types G \<Longrightarrow>
   bd = ((mn,pTs),rT,maxs,maxl,b,et) \<Longrightarrow>
   P G C bd \<Longrightarrow>
   Q G C bd"

  shows
  "wf_prog (\<lambda>G C bd. Q G C bd) G"
  using wf
  apply (unfold wf_prog_def wf_cdecl_def)
  apply clarsimp
  apply (drule bspec, assumption)
  apply (unfold wf_cdecl_mdecl_def)
  apply clarsimp
  apply (drule bspec, assumption)
  apply (frule methd [OF wf [THEN wf_prog_ws_prog]], assumption+)
  apply (frule is_type_pTs [OF wf], assumption+)
  apply clarify
  apply (drule rule [OF wf], assumption+)
  apply (rule HOL.refl)
  apply assumption+
  done

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__18_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_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__18_on_rules imports n_germanSimp_lemma_on_inv__18
begin
section{*All lemmas on causal relation between inv__18*}
lemma lemma_inv__18_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__18  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__0Vsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__1Vsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__18) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__18) done
    }

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

end