admin/LithosAnanake
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

proof/: migrate cell from int to 64-bit signed word, full suite verifies

Browse Source 
cell_t is a 64-bit signed C long; the formal model previously used
unbounded HOL int, hiding wraparound and signed/unsigned distinctions
entirely. Switches cell to "64 word" throughout and fixes every proof
site that assumed int semantics:

- StarForth_Base.thy: cell_safe/cell_abs/cell_sdiv/cell_smod plus the
  sint-bridging lemmas used across the suite
- StarForth_Loop1_Heat.thy, StarForth_Loop3_Decay.thy: heat tracking
  converted to signed word comparisons (<s/\<le>s)
- StarForth_Stack_Words.thy: PICK/ROLL against real C ground truth
- StarForth_Arithmetic_Words.thy: ABS/MIN/MAX/div/mod rebuilt on signed
  word semantics (cell_sdiv/cell_smod match C99 truncating division;
  2/ uses signed_drop_bit to match "n >> 1"); documents a genuine
  ABS(INT64_MIN) wraparound hazard mirroring the real C behavior
- StarForth_Memory_Words.thy: @/!/C@/C! address checks converted to
  the signed order

All 23 theory files verify with zero errors, including
StarForth_Concurrent and StarForth_Correctness.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
This commit is contained in:
Robert Allan James
2026-08-13 13:37:07 -04:00
co-authored by Claude Sonnet 5
parent 9b4bbc9de6
commit fe6e705867
6 changed files with 438 additions and 143 deletions
Download Patch File Download Diff File Expand all files Collapse all files
proof/StarForth_Stack_Words.thy
+25 -24
View File
@@ -295,11 +295,11 @@ definition forth_depth :: "vm_state \<Rightarrow> vm_state" where
"forth_depth vm =
(if ds_full vm
then set_error vm
else vm\<lparr>data_stack := int (length (data_stack vm)) # data_stack vm\<rparr>)"
else vm\<lparr>data_stack := word_of_nat (length (data_stack vm)) # data_stack vm\<rparr>)"
lemma depth_pushes_count:
assumes "\<not> ds_full vm"
shows "hd (data_stack (forth_depth vm)) = int (length (data_stack vm))"
shows "hd (data_stack (forth_depth vm)) = word_of_nat (length (data_stack vm))"
by (simp add: forth_depth_def assms)
lemma depth_rest_preserved:
@@ -327,7 +327,7 @@ lemma depth_overflow:
val = data_stack[dsp - n]
data_stack[dsp] = val (replace TOS with val)
Bounds check: n \<ge> 0 and n < length (data_stack vm) *)
Bounds check: 0 \<le>s n and n < length (data_stack vm) *)
(* CORRECTED 2026-08-13, against src/word_source/stack_words.c:265-282 and
its passing tests (test_runner/modules/stack_words_test.c: pick_0,
@@ -338,7 +338,7 @@ lemma depth_overflow:
convention. The theory's original definition indexed into
"data_stack vm" (the PRE-pop stack, still containing n as its own head)
instead of "xs" (post-pop) -- off by one position, and its bound check
"nat n \<ge> length (data_stack vm)" used the pre-pop length too, one too
"unat n \<ge> length (data_stack vm)" used the pre-pop length too, one too
permissive (C's own bound is against post-pop depth, vm->dsp+1 = length
xs). Confirmed against the real test vectors: "1 2 3 0 PICK" expects
TOS=3 (xs!0), "1 2 3 1 PICK" expects 2 (xs!1), "1 2 3 2 PICK" expects 1
@@ -348,37 +348,37 @@ definition forth_pick :: "vm_state \<Rightarrow> vm_state" where
(case data_stack vm of
[] \<Rightarrow> set_error vm
| n # xs \<Rightarrow>
if n < 0 \<or> nat n \<ge> length xs
if n <s 0 \<or> unat n \<ge> length xs
then set_error vm
else vm\<lparr>data_stack := xs ! nat n # xs\<rparr>)"
else vm\<lparr>data_stack := xs ! unat n # xs\<rparr>)"
lemma pick_normal:
assumes "data_stack vm = n # xs"
assumes "n \<ge> 0"
assumes "nat n < length xs"
shows "data_stack (forth_pick vm) = xs ! nat n # xs"
assumes "0 \<le>s n"
assumes "unat n < length xs"
shows "data_stack (forth_pick vm) = xs ! unat n # xs"
using assms by (auto simp: forth_pick_def)
lemma pick_depth_unchanged:
assumes "data_stack vm = n # xs"
assumes "n \<ge> 0"
assumes "nat n < length xs"
assumes "0 \<le>s n"
assumes "unat n < length xs"
shows "length (data_stack (forth_pick vm)) = length (data_stack vm)"
using assms by (auto simp: forth_pick_def)
using assms by (auto simp: forth_pick_def word_sless_alt word_sle_eq)
(* 0 PICK: pushes a copy of the post-pop TOS (xs!0) -- equivalent to DUP.
Matches the real test vector "1 2 3 0 PICK" => prints 3. *)
lemma pick_zero_dup:
assumes "data_stack vm = 0 # x # xs"
shows "data_stack (forth_pick vm) = x # x # xs"
using assms by (auto simp: forth_pick_def)
using assms by (auto simp: forth_pick_def word_sless_alt word_sle_eq)
(* 1 PICK: pushes a copy of the item one below TOS (xs!1).
Matches the real test vector "1 2 3 1 PICK" => prints 2. *)
lemma pick_one:
assumes "data_stack vm = 1 # x # y # xs"
shows "data_stack (forth_pick vm) = y # x # y # xs"
using assms by (auto simp: forth_pick_def)
using assms by (auto simp: forth_pick_def word_sless_alt word_sle_eq)
lemma pick_underflow:
assumes "data_stack vm = []"
@@ -387,13 +387,13 @@ lemma pick_underflow:
lemma pick_bounds_neg:
assumes "data_stack vm = n # xs"
assumes "n < 0"
assumes "n <s 0"
shows "vm_error (forth_pick vm)"
by (simp add: forth_pick_def set_error_def assms)
lemma pick_bounds_high:
assumes "data_stack vm = n # xs"
assumes "nat n \<ge> length xs"
assumes "unat n \<ge> length xs"
shows "vm_error (forth_pick vm)"
using assms by (auto simp: forth_pick_def set_error_def)
@@ -434,11 +434,11 @@ definition forth_roll :: "vm_state \<Rightarrow> vm_state" where
(case data_stack vm of
[] \<Rightarrow> set_error vm
| n # xs \<Rightarrow>
if n < 0 \<or> nat n > length xs
if n <s 0 \<or> unat n > length xs
then set_error vm
else if n = 0
then vm\<lparr>data_stack := xs\<rparr>
else let i = length xs - nat n;
else let i = length xs - unat n;
item = xs ! i;
rest = take i xs @ drop (i + 1) xs
in vm\<lparr>data_stack := item # rest\<rparr>)"
@@ -456,10 +456,11 @@ lemma roll_one_moves_bottom:
assumes "xs \<noteq> []"
shows "data_stack (forth_roll vm) = last xs # butlast xs"
proof -
have i: "length xs - nat (1::int) = length xs - 1" by simp
have i: "length xs - unat (1::cell) = length xs - 1" by simp
show ?thesis
using assms
by (simp add: forth_roll_def Let_def i last_conv_nth butlast_conv_take)
by (simp add: forth_roll_def Let_def i last_conv_nth butlast_conv_take
word_sless_alt word_sle_eq)
qed
(* Ground-truth test vectors, proved symbolically (no need to construct a
@@ -470,14 +471,14 @@ qed
lemma roll_test_vector_1:
assumes "data_stack vm = [1, 3, 2, 1]"
shows "data_stack (forth_roll vm) = [1, 3, 2]"
using assms by (simp add: forth_roll_def)
using assms by (simp add: forth_roll_def word_sless_alt word_sle_eq)
(* "1 2 3 2 ROLL . . . CR" => prints "2 3 1": xs=[3,2,1] after popping the
count 2; 2 ROLL moves the 2nd-from-bottom item (2) to top. *)
lemma roll_test_vector_2:
assumes "data_stack vm = [2, 3, 2, 1]"
shows "data_stack (forth_roll vm) = [2, 3, 1]"
using assms by (simp add: forth_roll_def)
using assms by (simp add: forth_roll_def word_sless_alt word_sle_eq)
lemma roll_underflow:
assumes "data_stack vm = []"
@@ -486,13 +487,13 @@ lemma roll_underflow:
lemma roll_bounds_neg:
assumes "data_stack vm = n # xs"
assumes "n < 0"
assumes "n <s 0"
shows "vm_error (forth_roll vm)"
by (simp add: forth_roll_def set_error_def assms)
lemma roll_bounds_high:
assumes "data_stack vm = n # xs"
assumes "nat n > length xs"
assumes "unat n > length xs"
shows "vm_error (forth_roll vm)"
by (simp add: forth_roll_def set_error_def assms)