Robert Allan JamesandClaude Sonnet 5
dfdabcc2d7
DECAY-RATE@ (physics_freeze_words.c) pushed to the data stack with no capacity check and no prior pop to make room, unlike its neighbors in the same file -- the one live, unconditional missing-guard bug the Isabelle sweep's ~15 candidate findings reduced to once checked against vm_push()'s real internal bounds check (see proof/FINDINGS.md SS2). Removed dictionary_manipulation_words.c's [ ] STATE and defining_words.c's DEFER IS DEFER@ (plus the now-orphaned defining_runtime_defer helper) -- all confirmed permanently shadowed by later dictionary registrations (defining_words.c and defer_words.c respectively), per FORTH's newest-first lookup. No behavior change: the removed code was already unreachable. Verified: hosted `make` builds clean under -Wall -Werror; the hosted self-test suite passes 965/965 implemented tests with no regressions. Three-architecture QEMU acceptance boot, all clean to ok> with an identical dict_hash=0x24b4279f0670aa3a across amd64/aarch64/riscv64 and identical 1003/965/0/0 test totals -- logs attached. Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
327 lines
15 KiB
Plaintext
327 lines
15 KiB
Plaintext
theory StarForth_Q48_Words
|
|
imports StarForth_Base StarForth_Q48_16
|
|
begin
|
|
|
|
(* =========================================================================
|
|
Mirrors: src/word_source/q48_words.c
|
|
Registers: Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.LOG Q.EXP Q.SQRT Q.SIN Q.COS
|
|
Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.= Q.< Q.> Q.0=
|
|
Q.MAX Q.MIN Q.PRINT
|
|
|
|
Thin FORTH stack wrappers around the q48_16.h math library. `q48_16_t`
|
|
is the same 64-bit representation as `cell`/`q48` (StarForth_Base.thy/
|
|
StarForth_Q48_16.thy) reinterpreted, so most of these words reduce
|
|
directly to already-modelled q48 operations.
|
|
|
|
── Build-flag stack-safety hazard, distinct from the rest of the sweep ──
|
|
Every word here pops/pushes via the `VM_POP`/`VM_PUSH` MACROS (include/
|
|
vm.h:706-719), not a direct `vm_pop`/`vm_push` call the way virtually
|
|
every other file in this sweep does. Those macros resolve to
|
|
`vm_pop_fast`/`vm_push_fast` (raw `vm->data_stack[vm->dsp--/++]`, NO
|
|
bounds check at all) when `STARFORTH_PERFORMANCE` is defined, and to
|
|
the safe, bounds-checked `vm_pop`/`vm_push` otherwise. This is a
|
|
genuinely different hazard shape from anything else in the sweep: it
|
|
isn't a missing guard in this file's own code (the missing-guard
|
|
pattern from DECAY-RATE@ onward), it's that EVERY guard in this ENTIRE
|
|
FILE is conditionally compiled away by a build flag most other word
|
|
files never consult. Modelled below assuming the safe (non-
|
|
`STARFORTH_PERFORMANCE`) path, consistent with this suite's general
|
|
assumption that stack words check bounds; the fast-path variant is
|
|
flagged, not modelled, since "no check at all" has no useful lemma to
|
|
state beyond "anything can happen." CONFIRMED 2026-08-14: repo-wide grep
|
|
shows `STARFORTH_PERFORMANCE` is never defined by any Makefile or
|
|
Kconfig target in this repo -- only referenced inside vm.h itself and
|
|
stack_words.c. So under every configuration this repo currently builds,
|
|
this file's words are on the safe path; the hazard is real but dormant,
|
|
contingent on a build flag nothing sets today.
|
|
|
|
── Q48 operations reused from StarForth_Q48_16.thy ─────────────────────
|
|
q48_add/q48_sub/q48_mul/q48_div/q48_from_u64/q48_to_u64 were already
|
|
modelled (q48_sub added there alongside this file, since it's a genuine
|
|
Q48 arithmetic primitive, not FORTH-word-specific). Q.ABS uses
|
|
`cell_abs` directly (StarForth_Base.thy) -- q48_abs's raw-bit sign-bit
|
|
test is bit-for-bit identical to `cell_abs`'s `n <s 0` test, see
|
|
StarForth_Q48_16.thy's note. Q.=/Q.</Q.>/Q.0=/Q.MAX/Q.MIN use PLAIN
|
|
(unsigned) word comparison operators, matching the C's direct
|
|
`uint64_t` `==`/`<`/`>` -- Q48.16 in this codebase is fundamentally an
|
|
unsigned fixed-point format, unlike `cell`'s general signed
|
|
two's-complement use elsewhere in this suite.
|
|
|
|
── Scope ─────────────────────────────────────────────────────────────
|
|
Fully modelled: Q.+, Q.-, Q.*, Q./, Q.ABS, Q.NEG, Q.FROM-INT, Q.TO-INT,
|
|
Q.1, Q.0, Q.SCALE, Q.=, Q.<, Q.>, Q.0=, Q.MAX, Q.MIN (17 of 23 words).
|
|
Not modelled: Q.LOG/Q.EXP/Q.SQRT/Q.SIN/Q.COS (the same transcendental
|
|
approximation functions already excluded from this sweep entirely at
|
|
q48_16_words.c -- Newton-Raphson/Taylor-series numerical algorithms
|
|
needing error-bound proofs, a different kind of work than this sweep's
|
|
plumbing-lemma style) and Q.PRINT (stdout formatting only, no vm_state
|
|
write beyond its pop).
|
|
======================================================================== *)
|
|
|
|
(* ── Q.+ / Q.- / Q.* / Q./ ( q1 q2 -- q_result ) ──────────────────────── *)
|
|
(* C pops b then a (b is TOS); data_stack list convention: b # a # xs. *)
|
|
|
|
definition forth_q_add :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_add vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := q48_add a b # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_sub :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_sub vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := q48_sub a b # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_mul :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_mul vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := q48_mul a b # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_div :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_div vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := q48_div a b # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_add_underflow_nil: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_add vm)"
|
|
by (simp add: forth_q_add_def set_error_def)
|
|
lemma q_add_underflow_one: "data_stack vm = [x] \<Longrightarrow> vm_error (forth_q_add vm)"
|
|
by (simp add: forth_q_add_def set_error_def)
|
|
lemma q_add_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_add vm) = q48_add a b # xs"
|
|
by (simp add: forth_q_add_def assms)
|
|
|
|
lemma q_sub_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_sub vm) = q48_sub a b # xs"
|
|
by (simp add: forth_q_sub_def assms)
|
|
|
|
lemma q_mul_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_mul vm) = q48_mul a b # xs"
|
|
by (simp add: forth_q_mul_def assms)
|
|
|
|
lemma q_div_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_div vm) = q48_div a b # xs"
|
|
by (simp add: forth_q_div_def assms)
|
|
|
|
lemma q_div_by_zero_is_zero:
|
|
assumes "data_stack vm = 0 # a # xs"
|
|
shows "data_stack (forth_q_div vm) = 0 # xs"
|
|
using assms by (simp add: forth_q_div_def q48_div_def)
|
|
|
|
(* ── Q.ABS / Q.NEG ( q -- q' ) ─────────────────────────────────────────── *)
|
|
|
|
definition forth_q_abs :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_abs vm =
|
|
(case data_stack vm of
|
|
a # xs \<Rightarrow> vm\<lparr>data_stack := cell_abs a # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_neg :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_neg vm =
|
|
(case data_stack vm of
|
|
a # xs \<Rightarrow> vm\<lparr>data_stack := -a # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_abs_underflow: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_abs vm)"
|
|
by (simp add: forth_q_abs_def set_error_def)
|
|
lemma q_abs_normal:
|
|
assumes "data_stack vm = a # xs"
|
|
shows "data_stack (forth_q_abs vm) = cell_abs a # xs"
|
|
by (simp add: forth_q_abs_def assms)
|
|
|
|
lemma q_neg_underflow: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_neg vm)"
|
|
by (simp add: forth_q_neg_def set_error_def)
|
|
lemma q_neg_normal:
|
|
assumes "data_stack vm = a # xs"
|
|
shows "data_stack (forth_q_neg vm) = -a # xs"
|
|
by (simp add: forth_q_neg_def assms)
|
|
lemma q_neg_involutive:
|
|
assumes "data_stack vm = a # xs"
|
|
shows "data_stack (forth_q_neg (forth_q_neg vm)) = a # xs"
|
|
by (simp add: forth_q_neg_def assms)
|
|
|
|
(* ── Q.FROM-INT ( n -- q ) / Q.TO-INT ( q -- n ) ──────────────────────── *)
|
|
(* C: Q.FROM-INT clamps negative n to 0 before q48_from_u64 (the C source
|
|
pops via bare VM_POP, a signed cell_t, then treats negative as 0). *)
|
|
|
|
definition forth_q_from_int :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_from_int vm =
|
|
(case data_stack vm of
|
|
n # xs \<Rightarrow> vm\<lparr>data_stack := q48_from_u64 (if n <s 0 then 0 else n) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_to_int :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_to_int vm =
|
|
(case data_stack vm of
|
|
q # xs \<Rightarrow> vm\<lparr>data_stack := q48_to_u64 q # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_from_int_underflow: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_from_int vm)"
|
|
by (simp add: forth_q_from_int_def set_error_def)
|
|
lemma q_from_int_negative_clamped:
|
|
assumes "data_stack vm = n # xs" "n <s 0"
|
|
shows "data_stack (forth_q_from_int vm) = 0 # xs"
|
|
using assms by (simp add: forth_q_from_int_def)
|
|
lemma q_from_int_nonneg:
|
|
assumes "data_stack vm = n # xs" "\<not> n <s 0"
|
|
shows "data_stack (forth_q_from_int vm) = q48_from_u64 n # xs"
|
|
using assms by (simp add: forth_q_from_int_def)
|
|
|
|
lemma q_to_int_underflow: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_to_int vm)"
|
|
by (simp add: forth_q_to_int_def set_error_def)
|
|
lemma q_to_int_normal:
|
|
assumes "data_stack vm = q # xs"
|
|
shows "data_stack (forth_q_to_int vm) = q48_to_u64 q # xs"
|
|
by (simp add: forth_q_to_int_def assms)
|
|
|
|
(* ── Q.1 / Q.0 / Q.SCALE ( -- q ) : constants, no capacity guard ─────────── *)
|
|
(* Like DECAY-RATE@/LOG-ERROR etc, these push with no ds_full check --
|
|
another instance of the recurring missing-overflow-guard pattern. *)
|
|
|
|
definition forth_q_one :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_one vm = vm\<lparr>data_stack := Q48_ONE # data_stack vm\<rparr>"
|
|
definition forth_q_zero :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_zero vm = vm\<lparr>data_stack := 0 # data_stack vm\<rparr>"
|
|
definition forth_q_scale :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_scale vm = vm\<lparr>data_stack := Q48_SCALE # data_stack vm\<rparr>"
|
|
|
|
lemma q_one_pushes: "data_stack (forth_q_one vm) = 65536 # data_stack vm"
|
|
by (simp add: forth_q_one_def Q48_ONE_def Q48_SCALE_def)
|
|
lemma q_zero_pushes: "data_stack (forth_q_zero vm) = 0 # data_stack vm"
|
|
by (simp add: forth_q_zero_def)
|
|
lemma q_scale_pushes: "data_stack (forth_q_scale vm) = 65536 # data_stack vm"
|
|
by (simp add: forth_q_scale_def Q48_SCALE_def)
|
|
lemma q_one_scale_agree: "forth_q_one vm = forth_q_scale vm"
|
|
by (simp add: forth_q_one_def forth_q_scale_def Q48_ONE_def Q48_SCALE_def)
|
|
|
|
(* ── Q.= / Q.< / Q.> / Q.0= ( q1 q2 -- flag ) : unsigned comparison ───────── *)
|
|
|
|
definition forth_q_eq :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_eq vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := to_forth_bool (a = b) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_lt :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_lt vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := to_forth_bool (a < b) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_gt :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_gt vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := to_forth_bool (b < a) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_zero_eq :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_zero_eq vm =
|
|
(case data_stack vm of
|
|
a # xs \<Rightarrow> vm\<lparr>data_stack := to_forth_bool (a = 0) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_eq_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_eq vm) = to_forth_bool (a = b) # xs"
|
|
by (simp add: forth_q_eq_def assms)
|
|
|
|
lemma q_lt_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_lt vm) = to_forth_bool (a < b) # xs"
|
|
by (simp add: forth_q_lt_def assms)
|
|
|
|
lemma q_gt_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_gt vm) = to_forth_bool (b < a) # xs"
|
|
by (simp add: forth_q_gt_def assms)
|
|
|
|
lemma q_zero_eq_normal:
|
|
assumes "data_stack vm = a # xs"
|
|
shows "data_stack (forth_q_zero_eq vm) = to_forth_bool (a = 0) # xs"
|
|
by (simp add: forth_q_zero_eq_def assms)
|
|
|
|
lemma q_lt_gt_antisymmetric:
|
|
assumes "data_stack vm1 = b # a # xs" "data_stack vm2 = a # b # xs"
|
|
shows "data_stack (forth_q_lt vm1) = data_stack (forth_q_gt vm2)"
|
|
using assms by (simp add: forth_q_lt_def forth_q_gt_def)
|
|
|
|
(* ── Q.MAX / Q.MIN ( q1 q2 -- q_result ) : unsigned comparison ──────────── *)
|
|
|
|
definition forth_q_max :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_max vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := (if b \<le> a then a else b) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
definition forth_q_min :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_min vm =
|
|
(case data_stack vm of
|
|
b # a # xs \<Rightarrow> vm\<lparr>data_stack := (if a \<le> b then a else b) # xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_max_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_max vm) = (if b \<le> a then a else b) # xs"
|
|
by (simp add: forth_q_max_def assms)
|
|
|
|
lemma q_min_normal:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "data_stack (forth_q_min vm) = (if a \<le> b then a else b) # xs"
|
|
by (simp add: forth_q_min_def assms)
|
|
|
|
lemma q_max_ge_both:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "a \<le> hd (data_stack (forth_q_max vm))" "b \<le> hd (data_stack (forth_q_max vm))"
|
|
using assms by (auto simp add: forth_q_max_def)
|
|
|
|
lemma q_min_le_both:
|
|
assumes "data_stack vm = b # a # xs"
|
|
shows "hd (data_stack (forth_q_min vm)) \<le> a" "hd (data_stack (forth_q_min vm)) \<le> b"
|
|
using assms by (auto simp add: forth_q_min_def)
|
|
|
|
(* ── Q.LOG / Q.EXP / Q.SQRT / Q.SIN / Q.COS -- NOT MODELLED ──────────────── *)
|
|
|
|
lemma q_log_not_modelled: True \<comment> \<open>q48_log_approx: Newton-Raphson, same excluded class as q48_16_words.c's transcendentals (see that file's sweep-skip note).\<close>
|
|
by simp
|
|
lemma q_exp_not_modelled: True \<comment> \<open>q48_exp_approx: Taylor series.\<close>
|
|
by simp
|
|
lemma q_sqrt_not_modelled: True \<comment> \<open>q48_sqrt_approx: Newton-Raphson.\<close>
|
|
by simp
|
|
lemma q_sin_not_modelled: True \<comment> \<open>q48_sin_approx: Taylor series.\<close>
|
|
by simp
|
|
lemma q_cos_not_modelled: True \<comment> \<open>q48_cos_approx: Taylor series.\<close>
|
|
by simp
|
|
|
|
(* ── Q.PRINT ( q -- ) : pop + stdout, no further vm_state effect ────────── *)
|
|
|
|
definition forth_q_print :: "vm_state \<Rightarrow> vm_state" where
|
|
"forth_q_print vm =
|
|
(case data_stack vm of
|
|
q # xs \<Rightarrow> vm\<lparr>data_stack := xs\<rparr>
|
|
| _ \<Rightarrow> set_error vm)"
|
|
|
|
lemma q_print_underflow: "data_stack vm = [] \<Longrightarrow> vm_error (forth_q_print vm)"
|
|
by (simp add: forth_q_print_def set_error_def)
|
|
lemma q_print_pops_one:
|
|
assumes "data_stack vm = q # xs"
|
|
shows "data_stack (forth_q_print vm) = xs"
|
|
by (simp add: forth_q_print_def assms)
|
|
|
|
(* ── Fast-path (STARFORTH_PERFORMANCE) variant -- NOT MODELLED ───────────── *)
|
|
|
|
lemma fast_path_variant_not_modelled: True
|
|
\<comment> \<open>See file header -- when STARFORTH_PERFORMANCE is defined, every word
|
|
above uses vm_pop_fast/vm_push_fast with NO bounds check at all, so
|
|
none of the underflow lemmas above apply; there is no meaningful
|
|
positive statement to make about that build configuration beyond
|
|
"unchecked".\<close>
|
|
by simp
|
|
|
|
end
|