src/HOL/Bali/State.thy
changeset 35067 af4c18c30593
parent 33965 f57c11db4ad4
child 35416 d8d7d1b785af
equal deleted inserted replaced
35066:894e82be8d05 35067:af4c18c30593
   252 
   252 
   253 lemma heap_def2 [simp]:  "heap s a=globs s (Heap a)"
   253 lemma heap_def2 [simp]:  "heap s a=globs s (Heap a)"
   254 by (simp add: heap_def)
   254 by (simp add: heap_def)
   255 
   255 
   256 
   256 
   257 syntax
   257 abbreviation val_this :: "st \<Rightarrow> val"
   258   val_this     :: "st \<Rightarrow> val"
   258   where "val_this s == the (locals s This)"
   259   lookup_obj   :: "st \<Rightarrow> val \<Rightarrow> obj"
   259 
   260 
   260 abbreviation lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
   261 translations
   261   where "lookup_obj s a' == the (heap s (the_Addr a'))"
   262  "val_this s"       == "CONST the (locals s This)" 
       
   263  "lookup_obj s a'"  == "CONST the (heap s (the_Addr a'))"
       
   264 
   262 
   265 subsection "memory allocation"
   263 subsection "memory allocation"
   266 
   264 
   267 constdefs
   265 constdefs
   268   new_Addr     :: "heap \<Rightarrow> loc option"
   266   new_Addr     :: "heap \<Rightarrow> loc option"
   284 done
   282 done
   285 
   283 
   286 
   284 
   287 subsection "initialization"
   285 subsection "initialization"
   288 
   286 
   289 syntax
   287 abbreviation init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
   290 
   288   where "init_vals vs == Option.map default_val \<circ> vs"
   291   init_vals     :: "('a, ty) table \<Rightarrow> ('a, val) table"
       
   292 
       
   293 translations
       
   294  "init_vals vs"    == "CONST Option.map default_val \<circ> vs"
       
   295 
   289 
   296 lemma init_arr_comps_base [simp]: "init_vals (arr_comps T 0) = empty"
   290 lemma init_arr_comps_base [simp]: "init_vals (arr_comps T 0) = empty"
   297 apply (unfold arr_comps_def in_bounds_def)
   291 apply (unfold arr_comps_def in_bounds_def)
   298 apply (rule ext)
   292 apply (rule ext)
   299 apply auto
   293 apply auto
   323  "set_locals l \<equiv> st_case (\<lambda>g l'. st g l)"
   317  "set_locals l \<equiv> st_case (\<lambda>g l'. st g l)"
   324 
   318 
   325   init_obj    :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> st \<Rightarrow> st"
   319   init_obj    :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> st \<Rightarrow> st"
   326  "init_obj G oi r \<equiv> gupd(r\<mapsto>\<lparr>tag=oi, values=init_vals (var_tys G oi r)\<rparr>)"
   320  "init_obj G oi r \<equiv> gupd(r\<mapsto>\<lparr>tag=oi, values=init_vals (var_tys G oi r)\<rparr>)"
   327 
   321 
   328 syntax
   322 abbreviation
   329   init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
   323   init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
   330 
   324   where "init_class_obj G C == init_obj G undefined (Inr C)"
   331 translations
       
   332  "init_class_obj G C" == "init_obj G CONST undefined (CONST Inr C)"
       
   333 
   325 
   334 lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
   326 lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
   335 apply (unfold gupd_def)
   327 apply (unfold gupd_def)
   336 apply (simp (no_asm))
   328 apply (simp (no_asm))
   337 done
   329 done
   511 apply (unfold abrupt_if_def)
   503 apply (unfold abrupt_if_def)
   512 apply (split split_if)
   504 apply (split split_if)
   513 apply auto
   505 apply auto
   514 done
   506 done
   515 
   507 
   516 syntax
   508 abbreviation raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
   517 
   509   where "raise_if c xn == abrupt_if c (Some (Xcpt (Std xn)))"
   518   raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
   510 
   519   np       :: "val  \<spacespace>        \<Rightarrow> abopt \<Rightarrow> abopt"
   511 abbreviation np :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
   520   check_neg:: "val  \<spacespace>        \<Rightarrow> abopt \<Rightarrow> abopt"
   512   where "np v == raise_if (v = Null) NullPointer"
   521   error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
   513 
   522   
   514 abbreviation check_neg :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
   523 translations
   515   where "check_neg i' == raise_if (the_Intg i'<0) NegArrSize"
   524 
   516 
   525  "raise_if c xn" == "abrupt_if c (Some (Xcpt (Std xn)))"
   517 abbreviation error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
   526  "np v"          == "raise_if (v = Null)      NullPointer"
   518   where "error_if c e == abrupt_if c (Some (Error e))"
   527  "check_neg i'"  == "raise_if (the_Intg i'<0) NegArrSize"
       
   528  "error_if c e"  == "abrupt_if c (Some (Error e))"
       
   529 
   519 
   530 lemma raise_if_None [simp]: "(raise_if c x y = None) = (\<not>c \<and> y = None)"
   520 lemma raise_if_None [simp]: "(raise_if c x y = None) = (\<not>c \<and> y = None)"
   531 apply (simp add: abrupt_if_def)
   521 apply (simp add: abrupt_if_def)
   532 by auto
   522 by auto
   533 declare raise_if_None [THEN iffD1, dest!]
   523 declare raise_if_None [THEN iffD1, dest!]
   590 section "full program state"
   580 section "full program state"
   591 
   581 
   592 types
   582 types
   593   state = "abopt \<times> st"          --{* state including abruption information *}
   583   state = "abopt \<times> st"          --{* state including abruption information *}
   594 
   584 
   595 syntax 
       
   596   Norm   :: "st \<Rightarrow> state"
       
   597   abrupt :: "state \<Rightarrow> abopt"
       
   598   store  :: "state \<Rightarrow> st"
       
   599 
       
   600 translations
   585 translations
   601    
       
   602   "Norm s"     == "(None,s)" 
       
   603   "abrupt"     => "fst"
       
   604   "store"      => "snd"
       
   605   "abopt"       <= (type) "State.abrupt option"
   586   "abopt"       <= (type) "State.abrupt option"
   606   "abopt"       <= (type) "abrupt option"
   587   "abopt"       <= (type) "abrupt option"
   607   "state"      <= (type) "abopt \<times> State.st"
   588   "state"      <= (type) "abopt \<times> State.st"
   608   "state"      <= (type) "abopt \<times> st"
   589   "state"      <= (type) "abopt \<times> st"
   609 
   590 
   610 
   591 abbreviation
       
   592   Norm :: "st \<Rightarrow> state"
       
   593   where "Norm s == (None, s)"
       
   594 
       
   595 abbreviation (input)
       
   596   abrupt :: "state \<Rightarrow> abopt"
       
   597   where "abrupt == fst"
       
   598 
       
   599 abbreviation (input)
       
   600   store :: "state \<Rightarrow> st"
       
   601   where "store == snd"
   611 
   602 
   612 lemma single_stateE: "\<forall>Z. Z = (s::state) \<Longrightarrow> False"
   603 lemma single_stateE: "\<forall>Z. Z = (s::state) \<Longrightarrow> False"
   613 apply (erule_tac x = "(Some k,y)" in all_dupE)
   604 apply (erule_tac x = "(Some k,y)" in all_dupE)
   614 apply (erule_tac x = "(None,y)" in allE)
   605 apply (erule_tac x = "(None,y)" in allE)
   615 apply clarify
   606 apply clarify
   681   by (cases s) simp
   672   by (cases s) simp
   682 
   673 
   683 lemma supd_abrupt_invariant [simp]: "abrupt (supd f s) = abrupt s"
   674 lemma supd_abrupt_invariant [simp]: "abrupt (supd f s) = abrupt s"
   684   by (cases s) simp
   675   by (cases s) simp
   685 
   676 
   686 syntax
   677 abbreviation set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
   687 
   678   where "set_lvars l == supd (set_locals l)"
   688   set_lvars     :: "locals \<Rightarrow> state \<Rightarrow> state"
   679 
   689   restore_lvars :: "state  \<Rightarrow> state \<Rightarrow> state"
   680 abbreviation restore_lvars :: "state  \<Rightarrow> state \<Rightarrow> state"
   690   
   681   where "restore_lvars s' s == set_lvars (locals (store s')) s"
   691 translations
       
   692 
       
   693  "set_lvars l" == "supd (set_locals l)"
       
   694  "restore_lvars s' s" == "set_lvars (locals (store s')) s"
       
   695 
   682 
   696 lemma set_set_lvars [simp]: "\<And> s. set_lvars l (set_lvars l' s) = set_lvars l s"
   683 lemma set_set_lvars [simp]: "\<And> s. set_lvars l (set_lvars l' s) = set_lvars l s"
   697 apply (simp (no_asm_simp) only: split_tupled_all)
   684 apply (simp (no_asm_simp) only: split_tupled_all)
   698 apply (simp (no_asm))
   685 apply (simp (no_asm))
   699 done
   686 done