139 lines
6.2 KiB
Plaintext
139 lines
6.2 KiB
Plaintext
theory ACL_Pin_Monotone
|
|
imports StarForth_Base
|
|
begin
|
|
|
|
(* =========================================================================
|
|
ACL_Pin_Monotone — acl_pinned is a set-only (monotone) field
|
|
|
|
Mirrors: include/vm.h (DictEntry.acl_pinned)
|
|
src/word_source/acl_words.c (forth_acl_pin, forth_acl_mode_store,
|
|
forth_acl_ttl_store, forth_acl_allow_store)
|
|
capsules/ACL.4th (ACL-PIN, ACL-INHERIT)
|
|
|
|
○ CODE-MUST-MATCH: The following C functions must never write acl_pinned=0
|
|
after it has been written to 1:
|
|
forth_acl_pin — sets acl_pinned=1 unconditionally
|
|
forth_acl_mode_store — no-op if acl_pinned (guard: if (e->acl_pinned) return)
|
|
forth_acl_ttl_store — no-op if acl_pinned
|
|
forth_acl_allow_store — no-op if acl_pinned
|
|
Only acl_inherit_entry() may clear acl_pinned (on the DESTINATION entry),
|
|
and that is intentional: the ACL_Inherit_Clears_Pin theory proves this is safe.
|
|
|
|
⚠ HUMAN-REVIEW: Verify no C code path writes entry->acl_pinned = 0 except
|
|
acl_inherit_entry(). grep -rn "acl_pinned = 0" src/ should show only that
|
|
one site.
|
|
======================================================================== *)
|
|
|
|
(* =========================================================================
|
|
Section 1: ACL mode constants
|
|
======================================================================== *)
|
|
|
|
(* ○ CODE-MUST-MATCH: include/vm.h
|
|
#define ACL_MODE_TTL 0
|
|
#define ACL_MODE_STRICT 1 *)
|
|
definition ACL_MODE_TTL :: nat where "ACL_MODE_TTL = 0"
|
|
definition ACL_MODE_STRICT :: nat where "ACL_MODE_STRICT = 1"
|
|
|
|
(* =========================================================================
|
|
Section 2: ACL-PIN operation
|
|
======================================================================== *)
|
|
|
|
(* ○ CODE-MUST-MATCH: src/word_source/acl_words.c forth_acl_pin():
|
|
e->acl_pinned = 1;
|
|
The function sets acl_pinned to True and touches no other field. *)
|
|
definition acl_pin :: "dict_entry \<Rightarrow> dict_entry" where
|
|
"acl_pin e = e\<lparr>de_acl_pinned := True\<rparr>"
|
|
|
|
(* =========================================================================
|
|
Section 3: Monotonicity lemmas
|
|
======================================================================== *)
|
|
|
|
(* Core monotonicity: acl_pin sets de_acl_pinned to True. *)
|
|
lemma acl_pin_sets_pinned [simp]:
|
|
"de_acl_pinned (acl_pin e) = True"
|
|
by (simp add: acl_pin_def)
|
|
|
|
(* Once pinned, stays pinned: applying acl_pin to an already-pinned entry
|
|
is idempotent. *)
|
|
lemma acl_pin_idempotent:
|
|
"acl_pin (acl_pin e) = acl_pin e"
|
|
by (simp add: acl_pin_def)
|
|
|
|
(* acl_pin does not alter any non-pinned field. *)
|
|
lemma acl_pin_preserves_name [simp]: "de_name (acl_pin e) = de_name e"
|
|
by (simp add: acl_pin_def)
|
|
lemma acl_pin_preserves_flags [simp]: "de_flags (acl_pin e) = de_flags e"
|
|
by (simp add: acl_pin_def)
|
|
lemma acl_pin_preserves_heat [simp]: "de_heat (acl_pin e) = de_heat e"
|
|
by (simp add: acl_pin_def)
|
|
lemma acl_pin_preserves_ttl [simp]: "de_acl_ttl (acl_pin e) = de_acl_ttl e"
|
|
by (simp add: acl_pin_def)
|
|
lemma acl_pin_preserves_allow [simp]: "de_acl_allow(acl_pin e) = de_acl_allow e"
|
|
by (simp add: acl_pin_def)
|
|
lemma acl_pin_preserves_mode [simp]: "de_acl_mode (acl_pin e) = de_acl_mode e"
|
|
by (simp add: acl_pin_def)
|
|
|
|
(* =========================================================================
|
|
Section 4: Guard lemmas (pinned entry resists mutation)
|
|
======================================================================== *)
|
|
|
|
(* ○ CODE-MUST-MATCH: forth_acl_mode_store() guard:
|
|
if (e->acl_pinned) return;
|
|
A pinned entry's mode is immutable. *)
|
|
definition acl_mode_store :: "nat \<Rightarrow> dict_entry \<Rightarrow> dict_entry" where
|
|
"acl_mode_store mode e =
|
|
(if de_acl_pinned e then e else e\<lparr>de_acl_mode := mode\<rparr>)"
|
|
|
|
lemma pinned_mode_immutable:
|
|
"de_acl_pinned e \<Longrightarrow> acl_mode_store mode e = e"
|
|
by (simp add: acl_mode_store_def)
|
|
|
|
(* ○ CODE-MUST-MATCH: forth_acl_ttl_store() guard:
|
|
if (e->acl_pinned) return; *)
|
|
definition acl_ttl_store :: "nat \<Rightarrow> dict_entry \<Rightarrow> dict_entry" where
|
|
"acl_ttl_store ttl e =
|
|
(if de_acl_pinned e then e else e\<lparr>de_acl_ttl := ttl\<rparr>)"
|
|
|
|
lemma pinned_ttl_immutable:
|
|
"de_acl_pinned e \<Longrightarrow> acl_ttl_store ttl e = e"
|
|
by (simp add: acl_ttl_store_def)
|
|
|
|
(* ○ CODE-MUST-MATCH: forth_acl_allow_store() guard:
|
|
if (e->acl_pinned) return; *)
|
|
definition acl_allow_store :: "bool \<Rightarrow> dict_entry \<Rightarrow> dict_entry" where
|
|
"acl_allow_store flag e =
|
|
(if de_acl_pinned e then e else e\<lparr>de_acl_allow := flag\<rparr>)"
|
|
|
|
lemma pinned_allow_immutable:
|
|
"de_acl_pinned e \<Longrightarrow> acl_allow_store flag e = e"
|
|
by (simp add: acl_allow_store_def)
|
|
|
|
(* Applying any guarded store to a pinned entry leaves it completely
|
|
unchanged — every field is preserved. *)
|
|
lemma pinned_entry_fully_immutable:
|
|
assumes "de_acl_pinned e"
|
|
shows "acl_mode_store mode e = e \<and>
|
|
acl_ttl_store ttl e = e \<and>
|
|
acl_allow_store flag e = e"
|
|
using assms
|
|
by (simp add: acl_mode_store_def acl_ttl_store_def acl_allow_store_def)
|
|
|
|
(* =========================================================================
|
|
Section 5: Monotone reachability across arbitrary store sequences
|
|
======================================================================== *)
|
|
|
|
(* Once a word is pinned, no sequence of guarded stores can un-pin it. *)
|
|
lemma pinned_stable_under_mode_store:
|
|
"de_acl_pinned e \<Longrightarrow> de_acl_pinned (acl_mode_store mode e)"
|
|
by (simp add: acl_mode_store_def)
|
|
|
|
lemma pinned_stable_under_ttl_store:
|
|
"de_acl_pinned e \<Longrightarrow> de_acl_pinned (acl_ttl_store ttl e)"
|
|
by (simp add: acl_ttl_store_def)
|
|
|
|
lemma pinned_stable_under_allow_store:
|
|
"de_acl_pinned e \<Longrightarrow> de_acl_pinned (acl_allow_store flag e)"
|
|
by (simp add: acl_allow_store_def)
|
|
|
|
end
|