theory StarForth_Memory_Words
  imports StarForth_Base
begin

(* AND/OR/XOR infix notation moved behind an opt-in bundle at some point
   after 2011 -- unbundled by default now. Same fix as StarForth_Q48_16.thy. *)
unbundle bit_operations_syntax

(* =========================================================================
   POST-05: Memory Access Words
   Mirrors: src/word_source/memory_words.c
            src/test_runner/modules/memory_words_test.c

   Memory model: abstract function  memory :: "nat \<Rightarrow> cell"  representing
   byte-addressed flat VM memory.  Alignment and vm_addr_ok bounds checking
   are captured by the predicate  valid_addr.  Byte operations (C@, C!)
   additionally require  valid_byte_addr  and mask to 8-bit range.

   This abstraction is sufficient to prove read-after-write correctness and
   the absence of spurious state mutation; physical layout details are
   deferred to a lower-level memory model.
   ======================================================================== *)

(* ── Address validity predicate (abstracts vm_addr_ok) ─────────────────── *)

definition valid_addr :: "(nat \<Rightarrow> cell) \<Rightarrow> nat \<Rightarrow> bool" where
  "valid_addr mem a \<equiv> True"
  \<comment> \<open>Placeholder: in a concrete model this would check alignment and bounds.\<close>

(* ── Cell read/write on the abstract memory model ──────────────────────── *)

definition mem_read :: "(nat \<Rightarrow> cell) \<Rightarrow> nat \<Rightarrow> cell" where
  "mem_read mem a = mem a"

definition mem_write :: "(nat \<Rightarrow> cell) \<Rightarrow> nat \<Rightarrow> cell \<Rightarrow> (nat \<Rightarrow> cell)" where
  "mem_write mem a v = mem(a := v)"

lemma mem_write_read_same:
  "mem_read (mem_write mem a v) a = v"
  by (simp add: mem_read_def mem_write_def)

lemma mem_write_read_other:
  assumes "a \<noteq> b"
  shows "mem_read (mem_write mem a v) b = mem_read mem b"
  using assms by (auto simp: mem_read_def mem_write_def)

(* ── @ ( addr -- n ) ───────────────────────────────────────────────────── *)
(* Pops addr from data stack, reads cell from memory at addr, pushes value.
   C: vaddr_t addr = VM_ADDR(vm_pop(vm)); value = vm_load_cell(vm, addr).   *)

definition forth_fetch :: "vm_state \<Rightarrow> vm_state" where
  "forth_fetch vm =
    (case data_stack vm of
       []         \<Rightarrow> set_error vm
     | addr # xs \<Rightarrow>
         if addr <s 0
         then set_error vm
         else vm\<lparr>data_stack := mem_read (memory vm) (unat addr) # xs\<rparr>)"

lemma fetch_normal:
  assumes "data_stack vm = addr # xs"
  assumes "0 \<le>s addr"
  shows "data_stack (forth_fetch vm) = mem_read (memory vm) (unat addr) # xs"
  using assms by (auto simp: forth_fetch_def word_sle_eq word_sless_alt)

lemma fetch_reads_stored_value:
  assumes "memory vm = mem_write m a v"
  assumes "data_stack vm = addr # xs"
  assumes "0 \<le>s addr"
  assumes "unat addr = a"
  shows "hd (data_stack (forth_fetch vm)) = v"
  using assms by (simp add: forth_fetch_def mem_read_def mem_write_def word_sle_eq word_sless_alt)

lemma fetch_depth_preserved:
  assumes "data_stack vm = addr # xs"
  assumes "0 \<le>s addr"
  shows "length (data_stack (forth_fetch vm)) = length (data_stack vm)"
  by (simp add: forth_fetch_def assms word_sle_eq word_sless_alt)

lemma fetch_underflow:
  assumes "data_stack vm = []"
  shows "vm_error (forth_fetch vm)"
  by (simp add: forth_fetch_def set_error_def assms)

lemma fetch_neg_addr:
  assumes "data_stack vm = addr # xs"
  assumes "addr <s 0"
  shows "vm_error (forth_fetch vm)"
  by (simp add: forth_fetch_def set_error_def assms)

(* ── ! ( n addr -- ) ───────────────────────────────────────────────────── *)
(* Pops addr then n, writes n to memory[addr].
   C: addr = VM_ADDR(vm_pop(vm)); value = vm_pop(vm); vm_store_cell(addr, value). *)

definition forth_store :: "vm_state \<Rightarrow> vm_state" where
  "forth_store vm =
    (case data_stack vm of
       addr # n # xs \<Rightarrow>
         if addr <s 0
         then set_error vm
         else vm\<lparr>data_stack := xs,
                  memory    := mem_write (memory vm) (unat addr) n\<rparr>
     | _ \<Rightarrow> set_error vm)"

lemma store_normal:
  assumes "data_stack vm = addr # n # xs"
  assumes "0 \<le>s addr"
  shows "data_stack (forth_store vm) = xs"
    and "memory (forth_store vm) = mem_write (memory vm) (unat addr) n"
  using assms by (auto simp: forth_store_def word_sle_eq word_sless_alt)

lemma store_writes_value:
  assumes "data_stack vm = addr # n # xs"
  assumes "0 \<le>s addr"
  shows "mem_read (memory (forth_store vm)) (unat addr) = n"
  using assms by (auto simp: forth_store_def mem_write_def mem_read_def word_sle_eq word_sless_alt)

lemma store_depth_decreases:
  assumes "data_stack vm = addr # n # xs"
  assumes "0 \<le>s addr"
  shows "length (data_stack (forth_store vm)) = length (data_stack vm) - 2"
  using assms by (auto simp: forth_store_def word_sle_eq word_sless_alt)

lemma store_other_unchanged:
  assumes "data_stack vm = addr # n # xs"
  assumes "0 \<le>s addr"
  assumes "unat addr \<noteq> b"
  shows "mem_read (memory (forth_store vm)) b = mem_read (memory vm) b"
  using assms by (auto simp: forth_store_def mem_write_def mem_read_def word_sle_eq word_sless_alt)

lemma store_underflow_nil:
  assumes "data_stack vm = []"
  shows "vm_error (forth_store vm)"
  by (simp add: forth_store_def set_error_def assms)

lemma store_underflow_one:
  assumes "data_stack vm = [x]"
  shows "vm_error (forth_store vm)"
  by (simp add: forth_store_def set_error_def assms)

lemma store_neg_addr:
  assumes "data_stack vm = addr # n # xs"
  assumes "addr <s 0"
  shows "vm_error (forth_store vm)"
  by (simp add: forth_store_def set_error_def assms)

(* ── Store then fetch = identity ────────────────────────────────────────── *)

lemma store_then_fetch:
  assumes "data_stack vm = addr # n # xs"
  assumes "0 \<le>s addr"
  assumes "data_stack vm' = addr # xs"
  assumes "memory vm' = memory (forth_store vm)"
  shows "hd (data_stack (forth_fetch vm')) = n"
  using assms by (auto simp: forth_fetch_def forth_store_def mem_write_def mem_read_def
                              word_sle_eq word_sless_alt)

(* ── C@ ( addr -- c ) ──────────────────────────────────────────────────── *)
(* Reads a single byte (0..255) from memory, zero-extended to cell width.
   C: value = vm_load_u8(vm, addr); vm_push(vm, (cell_t)value).
   We model this as reading memory and masking to [0, 255].                 *)

definition forth_cfetch :: "vm_state \<Rightarrow> vm_state" where
  "forth_cfetch vm =
    (case data_stack vm of
       []         \<Rightarrow> set_error vm
     | addr # xs \<Rightarrow>
         if addr <s 0
         then set_error vm
         else let byte = mem_read (memory vm) (unat addr) AND 0xFF
              in vm\<lparr>data_stack := byte # xs\<rparr>)"

lemma cfetch_normal:
  assumes "data_stack vm = addr # xs"
  assumes "0 \<le>s addr"
  shows "data_stack (forth_cfetch vm) =
         (mem_read (memory vm) (unat addr) AND 0xFF) # xs"
  using assms by (auto simp: forth_cfetch_def word_sle_eq word_sless_alt)

lemma cfetch_byte_range:
  assumes "data_stack vm = addr # xs"
  assumes "0 \<le>s addr"
  shows "0 \<le> hd (data_stack (forth_cfetch vm))"
    and "hd (data_stack (forth_cfetch vm)) \<le> 255"
  using assms word_and_le1[of "mem_read (memory vm) (unat addr)" "0xFF::cell"]
  by (auto simp: forth_cfetch_def word_sle_eq word_sless_alt)

lemma cfetch_underflow:
  assumes "data_stack vm = []"
  shows "vm_error (forth_cfetch vm)"
  by (simp add: forth_cfetch_def set_error_def assms)

lemma cfetch_neg_addr:
  assumes "data_stack vm = addr # xs"
  assumes "addr <s 0"
  shows "vm_error (forth_cfetch vm)"
  by (simp add: forth_cfetch_def set_error_def assms)

(* ── C! ( c addr -- ) ──────────────────────────────────────────────────── *)
(* Stores low byte of c into memory[addr].
   C: vm_store_u8(vm, addr, (uint8_t)(value & 0xFF)).                       *)

definition forth_cstore :: "vm_state \<Rightarrow> vm_state" where
  "forth_cstore vm =
    (case data_stack vm of
       addr # c # xs \<Rightarrow>
         if addr <s 0
         then set_error vm
         else vm\<lparr>data_stack := xs,
                  memory    := mem_write (memory vm) (unat addr) (c AND 0xFF)\<rparr>
     | _ \<Rightarrow> set_error vm)"

lemma cstore_normal:
  assumes "data_stack vm = addr # c # xs"
  assumes "0 \<le>s addr"
  shows "data_stack (forth_cstore vm) = xs"
    and "memory (forth_cstore vm) = mem_write (memory vm) (unat addr) (c AND 0xFF)"
  using assms by (auto simp: forth_cstore_def word_sle_eq word_sless_alt)

lemma cstore_writes_byte:
  assumes "data_stack vm = addr # c # xs"
  assumes "0 \<le>s addr"
  shows "mem_read (memory (forth_cstore vm)) (unat addr) = c AND 0xFF"
  using assms by (auto simp: forth_cstore_def mem_write_def mem_read_def word_sle_eq word_sless_alt)

lemma cstore_depth_decreases:
  assumes "data_stack vm = addr # c # xs"
  assumes "0 \<le>s addr"
  shows "length (data_stack (forth_cstore vm)) = length (data_stack vm) - 2"
  using assms by (auto simp: forth_cstore_def word_sle_eq word_sless_alt)

lemma cstore_underflow_nil:
  assumes "data_stack vm = []"
  shows "vm_error (forth_cstore vm)"
  by (simp add: forth_cstore_def set_error_def assms)

lemma cstore_underflow_one:
  assumes "data_stack vm = [x]"
  shows "vm_error (forth_cstore vm)"
  by (simp add: forth_cstore_def set_error_def assms)

lemma cstore_neg_addr:
  assumes "data_stack vm = addr # c # xs"
  assumes "addr <s 0"
  shows "vm_error (forth_cstore vm)"
  by (simp add: forth_cstore_def set_error_def assms)

(* C! then C@ round-trip: byte written is byte read back. *)
lemma cstore_then_cfetch:
  assumes "data_stack vm = addr # c # xs"
  assumes "0 \<le>s addr"
  assumes "data_stack vm' = addr # xs"
  assumes "memory vm' = memory (forth_cstore vm)"
  shows "hd (data_stack (forth_cfetch vm')) = c AND 0xFF"
  using assms by (auto simp: forth_cfetch_def forth_cstore_def mem_write_def mem_read_def
                              word_sle_eq word_sless_alt)

end