;; Forth runtime — state, stacks, dictionary, output buffer.
;; Data stack: mutable SX list, TOS = first.
;; Return stack: separate mutable list.
;; Dictionary: SX dict {lowercased-name -> word-record}.
;; Word record: {"kind" "body" "immediate?"}; kind is "primitive" or "colon-def".
;; Output buffer: mutable string appended to by `.`, `EMIT`, `CR`, etc.
;; Compile-mode flag: "compiling" on the state.

(define
  forth-make-state
  (fn
    ()
    (let
      ((s (dict)))
      (dict-set! s "dstack" (list))
      (dict-set! s "rstack" (list))
      (dict-set! s "dict" (dict))
      (dict-set! s "output" "")
      (dict-set! s "compiling" false)
      (dict-set! s "current-def" nil)
      (dict-set! s "vars" (dict))
      (dict-set! (get s "vars") "base" 10)
      (dict-set! s "cstack" (list))
      (dict-set! s "mem" (dict))
      (dict-set! s "here" 0)
      (dict-set! s "hold" (list))
      (dict-set! s "files" (dict))
      (dict-set! s "by-path" (dict))
      (dict-set! s "next-fileid" 1)
      s)))

(define
  forth-mem-write!
  (fn (state addr u) (dict-set! (get state "mem") (str addr) u)))

(define
  forth-mem-read
  (fn
    (state addr)
    (or (get (get state "mem") (str addr)) 0)))

(define
  forth-alloc-bytes!
  (fn
    (state n)
    (let
      ((addr (get state "here")))
      (dict-set! state "here" (+ addr n))
      addr)))

(define
  forth-mem-write-string!
  (fn
    (state addr s)
    (let
      ((n (len s)))
      (forth-mem-write-string-loop! state addr s 0 n))))

(define
  forth-mem-write-string-loop!
  (fn
    (state addr s i n)
    (when
      (< i n)
      (begin
        (forth-mem-write! state (+ addr i) (char-code (substr s i 1)))
        (forth-mem-write-string-loop! state addr s (+ i 1) n)))))

(define
  forth-mem-read-string
  (fn
    (state addr n)
    (forth-mem-read-string-loop state addr 0 n "")))

(define
  forth-mem-read-string-loop
  (fn
    (state addr i n acc)
    (if
      (>= i n)
      acc
      (forth-mem-read-string-loop
        state
        addr
        (+ i 1)
        n
        (str acc (char-from-code (forth-mem-read state (+ addr i))))))))

(define
  forth-fill-loop
  (fn
    (state addr u char i)
    (when
      (< i u)
      (begin
        (forth-mem-write! state (+ addr i) char)
        (forth-fill-loop state addr u char (+ i 1))))))

(define
  forth-cmove-loop
  (fn
    (state src dst u i)
    (when
      (< i u)
      (begin
        (forth-mem-write! state (+ dst i) (forth-mem-read state (+ src i)))
        (forth-cmove-loop state src dst u (+ i 1))))))

(define
  forth-cmove-loop-desc
  (fn
    (state src dst u i)
    (when
      (>= i 0)
      (begin
        (forth-mem-write! state (+ dst i) (forth-mem-read state (+ src i)))
        (forth-cmove-loop-desc state src dst u (- i 1))))))

(define
  forth-cpush
  (fn (state v) (dict-set! state "cstack" (cons v (get state "cstack")))))

(define
  forth-cpop
  (fn
    (state)
    (let
      ((cs (get state "cstack")))
      (if
        (= (len cs) 0)
        (forth-error state "control stack underflow")
        (let
          ((top (first cs)))
          (dict-set! state "cstack" (rest cs))
          top)))))

(define
  forth-error
  (fn (state msg) (dict-set! state "error" msg) (raise msg)))

(define
  forth-push
  (fn (state v) (dict-set! state "dstack" (cons v (get state "dstack")))))

(define
  forth-pop
  (fn
    (state)
    (let
      ((st (get state "dstack")))
      (if
        (= (len st) 0)
        (forth-error state "stack underflow")
        (let ((top (first st))) (dict-set! state "dstack" (rest st)) top)))))

(define
  forth-peek
  (fn
    (state)
    (let
      ((st (get state "dstack")))
      (if (= (len st) 0) (forth-error state "stack underflow") (first st)))))

(define forth-depth (fn (state) (len (get state "dstack"))))

(define
  forth-rpush
  (fn (state v) (dict-set! state "rstack" (cons v (get state "rstack")))))

(define
  forth-rpop
  (fn
    (state)
    (let
      ((st (get state "rstack")))
      (if
        (= (len st) 0)
        (forth-error state "return stack underflow")
        (let ((top (first st))) (dict-set! state "rstack" (rest st)) top)))))

(define
  forth-rpeek
  (fn
    (state)
    (let
      ((st (get state "rstack")))
      (if
        (= (len st) 0)
        (forth-error state "return stack underflow")
        (first st)))))

(define
  forth-emit-str
  (fn (state s) (dict-set! state "output" (str (get state "output") s))))

;; The body is always a plain SX lambda — primitives and colon-def
;; bodies alike — which means the SX VM's JIT-on-first-call can lift
;; the body directly into bytecode. We tag every word `:vm-eligible?
;; true` so downstream JIT cooperation (a tracing layer, a hot-call
;; counter) can pick out the JIT-friendly entries by metadata rather
;; than by inspecting the body shape.
(define
  forth-make-word
  (fn
    (kind body immediate?)
    (let
      ((w (dict)))
      (dict-set! w "kind" kind)
      (dict-set! w "body" body)
      (dict-set! w "immediate?" immediate?)
      (dict-set! w "vm-eligible?" true)
      (dict-set! w "call-count" 0)
      w)))

(define
  forth-def-prim!
  (fn
    (state name body)
    (dict-set!
      (get state "dict")
      (downcase name)
      (forth-make-word "primitive" body false))
    (dict-set! state "last-defined" name)))

(define
  forth-def-prim-imm!
  (fn
    (state name body)
    (dict-set!
      (get state "dict")
      (downcase name)
      (forth-make-word "primitive" body true))
    (dict-set! state "last-defined" name)))

(define
  forth-lookup
  (fn (state name) (get (get state "dict") (downcase name))))

(define
  forth-binop
  (fn
    (op)
    (fn
      (state)
      (let
        ((b (forth-pop state)) (a (forth-pop state)))
        (forth-push state (op a b))))))

(define
  forth-unop
  (fn
    (op)
    (fn (state) (let ((a (forth-pop state))) (forth-push state (op a))))))

(define
  forth-cmp
  (fn
    (op)
    (fn
      (state)
      (let
        ((b (forth-pop state)) (a (forth-pop state)))
        (forth-push state (if (op a b) -1 0))))))

(define
  forth-cmp0
  (fn
    (op)
    (fn
      (state)
      (let ((a (forth-pop state))) (forth-push state (if (op a) -1 0))))))

(define
  forth-trunc
  (fn (x) (if (< x 0) (- 0 (floor (- 0 x))) (floor x))))

(define
  forth-div
  (fn
    (a b)
    (if (= b 0) (raise "division by zero") (forth-trunc (/ a b)))))

(define
  forth-mod
  (fn
    (a b)
    (if (= b 0) (raise "division by zero") (- a (* b (forth-div a b))))))

(define forth-bits-width 32)

;; Truncate a number to the Forth 32-bit signed range (two's-complement).
;; Used by arithmetic primitives so wrap-around matches ANS semantics and
;; loop idioms that rely on MSB becoming 0 after enough shifts terminate.
(define
  forth-clip
  (fn
    (n)
    (forth-from-unsigned
      (forth-to-unsigned n forth-bits-width)
      forth-bits-width)))

;; Double-cell helpers. Single = 32-bit signed, double = 64-bit signed
;; represented on the data stack as (lo, hi) where hi is on top.
;; Reassembly converts the low cell as unsigned and the high cell as
;; signed (signed) or as unsigned (unsigned), then combines.
(define forth-2pow32 (pow 2 32))
(define forth-2pow64 (pow 2 64))

(define
  forth-double-from-cells-u
  (fn
    (lo hi)
    (+ (forth-to-unsigned lo 32) (* (forth-to-unsigned hi 32) forth-2pow32))))

(define
  forth-double-from-cells-s
  (fn (lo hi) (+ (forth-to-unsigned lo 32) (* hi forth-2pow32))))

(define
  forth-umul32
  (fn
    (a b)
    (let
      ((alo (mod a 65536))
        (ahi (floor (/ a 65536)))
        (blo (mod b 65536))
        (bhi (floor (/ b 65536))))
      (let
        ((pll (* alo blo))
          (plh (* alo bhi))
          (phl (* ahi blo))
          (phh (* ahi bhi)))
        (let
          ((mid (+ plh phl)))
          (let
            ((mid-lo (mod mid 65536)) (mid-hi (floor (/ mid 65536))))
            (let
              ((lo-raw (+ pll (* mid-lo 65536))))
              (let
                ((lo-carry (floor (/ lo-raw forth-2pow32)))
                  (lo-fin (mod lo-raw forth-2pow32)))
                {:lo lo-fin :hi (+ phh mid-hi lo-carry)}))))))))

(define
  forth-double-push-u
  (fn
    (state d)
    (let
      ((lo (mod d forth-2pow32)) (hi (floor (/ d forth-2pow32))))
      (forth-push state (forth-from-unsigned lo 32))
      (forth-push state (forth-from-unsigned hi 32)))))

(define
  forth-num-to-string-loop
  (fn
    (u base acc)
    (if
      (= u 0)
      acc
      (let
        ((dig (mod u base)) (rest (floor (/ u base))))
        (let
          ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
          (forth-num-to-string-loop rest base (str ch acc)))))))

(define
  forth-num-to-string
  (fn
    (u base)
    (if (= u 0) "0" (forth-num-to-string-loop u base ""))))

(define
  forth-spaces-str
  (fn
    (n)
    (if (<= n 0) "" (str " " (forth-spaces-str (- n 1))))))

(define forth-join-hold (fn (parts) (forth-join-hold-loop parts "")))

(define
  forth-join-hold-loop
  (fn
    (parts acc)
    (if
      (= (len parts) 0)
      acc
      (forth-join-hold-loop (rest parts) (str acc (first parts))))))

(define
  forth-pic-step
  (fn
    (state)
    (let
      ((hi (forth-pop state)) (lo (forth-pop state)))
      (let
        ((b (get (get state "vars") "base"))
          (hi-u (forth-to-unsigned hi 32))
          (lo-u (forth-to-unsigned lo 32)))
        (let
          ((q-hi (floor (/ hi-u b))) (r-hi (mod hi-u b)))
          (let
            ((combined (+ (* r-hi forth-2pow32) lo-u)))
            (let
              ((dig (mod combined b)) (q-lo (floor (/ combined b))))
              (let
                ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
                (dict-set! state "hold" (cons ch (get state "hold")))
                (forth-push state (forth-from-unsigned q-lo 32))
                (forth-push state (forth-from-unsigned q-hi 32))))))))))

(define
  forth-compare-bytes-loop
  (fn
    (state a1 u1 a2 u2 i)
    (cond
      ((and (= i u1) (= i u2)) 0)
      ((= i u1) -1)
      ((= i u2) 1)
      (else
        (let
          ((b1 (forth-mem-read state (+ a1 i)))
            (b2 (forth-mem-read state (+ a2 i))))
          (cond
            ((< b1 b2) -1)
            ((> b1 b2) 1)
            (else
              (forth-compare-bytes-loop state a1 u1 a2 u2 (+ i 1)))))))))

(define
  forth-match-at
  (fn
    (state a1 start a2 u2 j)
    (cond
      ((= j u2) true)
      ((not (= (forth-mem-read state (+ a1 (+ start j))) (forth-mem-read state (+ a2 j))))
        false)
      (else (forth-match-at state a1 start a2 u2 (+ j 1))))))

(define
  forth-search-bytes
  (fn
    (state a1 u1 a2 u2 i)
    (cond
      ((= u2 0) 0)
      ((> (+ i u2) u1) -1)
      ((forth-match-at state a1 i a2 u2 0) i)
      (else (forth-search-bytes state a1 u1 a2 u2 (+ i 1))))))

(define
  forth-digit-of-byte
  (fn
    (c base)
    (let
      ((v (cond ((and (>= c 48) (<= c 57)) (- c 48)) ((and (>= c 65) (<= c 90)) (- c 55)) ((and (>= c 97) (<= c 122)) (- c 87)) (else -1))))
      (if (or (< v 0) (>= v base)) -1 v))))

(define
  forth-numparse-loop
  (fn
    (s addr u d-lo d-hi b)
    (if
      (= u 0)
      (list d-lo d-hi addr 0)
      (let
        ((byte (forth-mem-read s addr)))
        (let
          ((dv (forth-digit-of-byte byte b)))
          (if
            (= dv -1)
            (list d-lo d-hi addr u)
            (let
              ((lo-u (forth-to-unsigned d-lo 32))
                (hi-u (forth-to-unsigned d-hi 32)))
              (let
                ((lo-new-full (+ (* lo-u b) dv)))
                (let
                  ((carry (floor (/ lo-new-full forth-2pow32)))
                    (lo-new (mod lo-new-full forth-2pow32)))
                  (let
                    ((hi-new (+ (* hi-u b) carry)))
                    (if
                      (>= hi-new forth-2pow32)
                      (list d-lo d-hi addr u)
                      (forth-numparse-loop
                        s
                        (+ addr 1)
                        (- u 1)
                        (forth-from-unsigned lo-new 32)
                        (forth-from-unsigned hi-new 32)
                        b))))))))))))

(define
  forth-pic-S-loop
  (fn
    (state)
    (forth-pic-step state)
    (let
      ((hi (forth-pop state)) (lo (forth-pop state)))
      (if
        (and (= lo 0) (= hi 0))
        (begin (forth-push state 0) (forth-push state 0))
        (begin
          (forth-push state lo)
          (forth-push state hi)
          (forth-pic-S-loop state))))))

(define
  forth-double-push-s
  (fn
    (state d)
    (if
      (>= d 0)
      (forth-double-push-u state d)
      (let
        ((q (- 0 d)))
        (let
          ((qlo (mod q forth-2pow32)) (qhi (floor (/ q forth-2pow32))))
          (if
            (= qlo 0)
            (begin
              (forth-push state 0)
              (forth-push
                state
                (forth-from-unsigned (- forth-2pow32 qhi) 32)))
            (begin
              (forth-push
                state
                (forth-from-unsigned (- forth-2pow32 qlo) 32))
              (forth-push
                state
                (forth-from-unsigned
                  (- (- forth-2pow32 qhi) 1)
                  32)))))))))

(define
  forth-to-unsigned
  (fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))

(define
  forth-from-unsigned
  (fn
    (n w)
    (let
      ((half (pow 2 (- w 1))))
      (if (>= n half) (- n (pow 2 w)) n))))

(define
  forth-bitwise-step
  (fn
    (op ua ub out place i w)
    (if
      (>= i w)
      out
      (let
        ((da (mod ua 2)) (db (mod ub 2)))
        (forth-bitwise-step
          op
          (floor (/ ua 2))
          (floor (/ ub 2))
          (+ out (* place (op da db)))
          (* place 2)
          (+ i 1)
          w)))))

(define
  forth-bitwise-uu
  (fn
    (op)
    (fn
      (a b)
      (let
        ((ua (forth-to-unsigned a forth-bits-width))
          (ub (forth-to-unsigned b forth-bits-width)))
        (forth-from-unsigned
          (forth-bitwise-step
            op
            ua
            ub
            0
            1
            0
            forth-bits-width)
          forth-bits-width)))))

(define
  forth-bit-and
  (forth-bitwise-uu
    (fn
      (x y)
      (if (and (= x 1) (= y 1)) 1 0))))

(define
  forth-bit-or
  (forth-bitwise-uu
    (fn
      (x y)
      (if (or (= x 1) (= y 1)) 1 0))))

(define
  forth-bit-xor
  (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))

(define forth-bit-invert (fn (a) (- 0 (+ a 1))))

(define
  forth-install-primitives!
  (fn
    (state)
    (forth-def-prim! state "DUP" (fn (s) (forth-push s (forth-peek s))))
    (forth-def-prim! state "DROP" (fn (s) (forth-pop s)))
    (forth-def-prim!
      state
      "SWAP"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-push s b)
          (forth-push s a))))
    (forth-def-prim!
      state
      "OVER"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-push s a)
          (forth-push s b)
          (forth-push s a))))
    (forth-def-prim!
      state
      "ROT"
      (fn
        (s)
        (let
          ((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
          (forth-push s b)
          (forth-push s c)
          (forth-push s a))))
    (forth-def-prim!
      state
      "-ROT"
      (fn
        (s)
        (let
          ((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
          (forth-push s c)
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim!
      state
      "NIP"
      (fn (s) (let ((b (forth-pop s))) (forth-pop s) (forth-push s b))))
    (forth-def-prim!
      state
      "TUCK"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-push s b)
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim!
      state
      "?DUP"
      (fn
        (s)
        (let
          ((a (forth-peek s)))
          (when (not (= a 0)) (forth-push s a)))))
    (forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s))))
    (forth-def-prim! state "SP@" (fn (s) (forth-push s (forth-depth s))))
    (forth-def-prim!
      state
      "SP!"
      (fn
        (s)
        (let
          ((n (forth-pop s)))
          (let
            ((cur (forth-depth s)))
            (when
              (> cur n)
              (dict-set! s "dstack" (drop (get s "dstack") (- cur n))))))))
    (forth-def-prim!
      state
      "PICK"
      (fn
        (s)
        (let
          ((n (forth-pop s)) (st (get s "dstack")))
          (if
            (or (< n 0) (>= n (len st)))
            (forth-error s "PICK out of range")
            (forth-push s (nth st n))))))
    (forth-def-prim!
      state
      "ROLL"
      (fn
        (s)
        (let
          ((n (forth-pop s)) (st (get s "dstack")))
          (if
            (or (< n 0) (>= n (len st)))
            (forth-error s "ROLL out of range")
            (let
              ((taken (nth st n))
                (before (take st n))
                (after (drop st (+ n 1))))
              (dict-set! s "dstack" (concat before after))
              (forth-push s taken))))))
    (forth-def-prim!
      state
      "2DUP"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-push s a)
          (forth-push s b)
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim! state "2DROP" (fn (s) (forth-pop s) (forth-pop s)))
    (forth-def-prim!
      state
      "2SWAP"
      (fn
        (s)
        (let
          ((d (forth-pop s))
            (c (forth-pop s))
            (b (forth-pop s))
            (a (forth-pop s)))
          (forth-push s c)
          (forth-push s d)
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim!
      state
      "2OVER"
      (fn
        (s)
        (let
          ((d (forth-pop s))
            (c (forth-pop s))
            (b (forth-pop s))
            (a (forth-pop s)))
          (forth-push s a)
          (forth-push s b)
          (forth-push s c)
          (forth-push s d)
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim!
      state
      "+"
      (forth-binop (fn (a b) (forth-clip (+ a b)))))
    (forth-def-prim!
      state
      "-"
      (forth-binop (fn (a b) (forth-clip (- a b)))))
    (forth-def-prim!
      state
      "*"
      (forth-binop (fn (a b) (forth-clip (* a b)))))
    (forth-def-prim!
      state
      "/"
      (forth-binop (fn (a b) (forth-clip (forth-div a b)))))
    (forth-def-prim!
      state
      "MOD"
      (forth-binop (fn (a b) (forth-clip (forth-mod a b)))))
    (forth-def-prim!
      state
      "/MOD"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-push s (forth-mod a b))
          (forth-push s (forth-div a b)))))
    (forth-def-prim!
      state
      "NEGATE"
      (forth-unop (fn (a) (forth-clip (- 0 a)))))
    (forth-def-prim!
      state
      "ABS"
      (forth-unop (fn (a) (forth-clip (abs a)))))
    (forth-def-prim!
      state
      "MIN"
      (forth-binop (fn (a b) (if (< a b) a b))))
    (forth-def-prim!
      state
      "MAX"
      (forth-binop (fn (a b) (if (> a b) a b))))
    (forth-def-prim!
      state
      "1+"
      (forth-unop (fn (a) (forth-clip (+ a 1)))))
    (forth-def-prim!
      state
      "1-"
      (forth-unop (fn (a) (forth-clip (- a 1)))))
    (forth-def-prim!
      state
      "2+"
      (forth-unop (fn (a) (forth-clip (+ a 2)))))
    (forth-def-prim!
      state
      "2-"
      (forth-unop (fn (a) (forth-clip (- a 2)))))
    (forth-def-prim!
      state
      "2*"
      (forth-unop (fn (a) (forth-clip (* a 2)))))
    (forth-def-prim!
      state
      "2/"
      (forth-unop (fn (a) (forth-clip (floor (/ a 2))))))
    (forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b))))
    (forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b)))))
    (forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b))))
    (forth-def-prim! state ">" (forth-cmp (fn (a b) (> a b))))
    (forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b))))
    (forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b))))
    (forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0))))
    (forth-def-prim!
      state
      "0<>"
      (forth-cmp0 (fn (a) (not (= a 0)))))
    (forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0))))
    (forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0))))
    (forth-def-prim! state "AND" (forth-binop forth-bit-and))
    (forth-def-prim! state "OR" (forth-binop forth-bit-or))
    (forth-def-prim! state "XOR" (forth-binop forth-bit-xor))
    (forth-def-prim! state "INVERT" (forth-unop forth-bit-invert))
    (forth-def-prim!
      state
      "LSHIFT"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (x (forth-pop s)))
          (let
            ((ux (forth-to-unsigned x forth-bits-width)))
            (let
              ((res (mod (* ux (pow 2 u)) (pow 2 forth-bits-width))))
              (forth-push s (forth-from-unsigned res forth-bits-width)))))))
    (forth-def-prim!
      state
      "RSHIFT"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (x (forth-pop s)))
          (let
            ((ux (forth-to-unsigned x forth-bits-width)))
            (let
              ((res (floor (/ ux (pow 2 u)))))
              (forth-push s (forth-from-unsigned res forth-bits-width)))))))
    (forth-def-prim!
      state
      "."
      (fn (s) (forth-emit-str s (str (forth-pop s) " "))))
    (forth-def-prim!
      state
      ".S"
      (fn
        (s)
        (let
          ((st (reverse (get s "dstack"))))
          (forth-emit-str s "<")
          (forth-emit-str s (str (len st)))
          (forth-emit-str s "> ")
          (for-each (fn (v) (forth-emit-str s (str v " "))) st))))
    (forth-def-prim!
      state
      "EMIT"
      (fn (s) (forth-emit-str s (char-from-code (forth-pop s)))))
    (forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n")))
    (forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " ")))
    (forth-def-prim!
      state
      "SPACES"
      (fn
        (s)
        (let
          ((n (forth-pop s)))
          (when
            (> n 0)
            (for-each (fn (_) (forth-emit-str s " ")) (range 0 n))))))
    (forth-def-prim! state "BL" (fn (s) (forth-push s 32)))
    (forth-def-prim!
      state
      "DECIMAL"
      (fn (s) (dict-set! (get s "vars") "base" 10)))
    (forth-def-prim!
      state
      "HEX"
      (fn (s) (dict-set! (get s "vars") "base" 16)))
    (forth-def-prim!
      state
      "OCTAL"
      (fn (s) (dict-set! (get s "vars") "base" 8)))
    (forth-def-prim! state "BASE" (fn (s) (forth-push s "base")))
    (forth-def-prim! state "I" (fn (s) (forth-push s (forth-rpeek s))))
    (forth-def-prim!
      state
      "J"
      (fn (s) (forth-push s (nth (get s "rstack") 2))))
    (forth-def-prim! state ">R" (fn (s) (forth-rpush s (forth-pop s))))
    (forth-def-prim! state "R>" (fn (s) (forth-push s (forth-rpop s))))
    (forth-def-prim! state "R@" (fn (s) (forth-push s (forth-rpeek s))))
    (forth-def-prim!
      state
      "2>R"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (forth-rpush s a)
          (forth-rpush s b))))
    (forth-def-prim!
      state
      "2R>"
      (fn
        (s)
        (let
          ((b (forth-rpop s)) (a (forth-rpop s)))
          (forth-push s a)
          (forth-push s b))))
    (forth-def-prim!
      state
      "2R@"
      (fn
        (s)
        (let
          ((rs (get s "rstack")))
          (when
            (< (len rs) 2)
            (forth-error s "return stack underflow"))
          (forth-push s (nth rs 1))
          (forth-push s (nth rs 0)))))
    (forth-def-prim!
      state
      "C@"
      (fn
        (s)
        (let
          ((addr (forth-pop s)))
          (forth-push s (forth-mem-read s addr)))))
    (forth-def-prim!
      state
      "C!"
      (fn
        (s)
        (let
          ((addr (forth-pop s)) (v (forth-pop s)))
          (forth-mem-write! s addr v))))
    (forth-def-prim!
      state
      "CHAR+"
      (fn (s) (forth-push s (+ (forth-pop s) 1))))
    (forth-def-prim! state "CHARS" (fn (s) nil))
    (forth-def-prim!
      state
      "TYPE"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (addr (forth-pop s)))
          (forth-emit-str s (forth-mem-read-string s addr u)))))
    (forth-def-prim!
      state
      "COUNT"
      (fn
        (s)
        (let
          ((addr (forth-pop s)))
          (let
            ((u (forth-mem-read s addr)))
            (forth-push s (+ addr 1))
            (forth-push s u)))))
    (forth-def-prim!
      state
      "FILL"
      (fn
        (s)
        (let
          ((char (forth-pop s)) (u (forth-pop s)) (addr (forth-pop s)))
          (forth-fill-loop s addr u char 0))))
    (forth-def-prim!
      state
      "BLANK"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (addr (forth-pop s)))
          (forth-fill-loop s addr u 32 0))))
    (forth-def-prim!
      state
      "CMOVE"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s)))
          (forth-cmove-loop s src dst u 0))))
    (forth-def-prim!
      state
      "CMOVE>"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s)))
          (forth-cmove-loop-desc s src dst u (- u 1)))))
    (forth-def-prim!
      state
      "MOVE"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s)))
          (if
            (or (<= dst src) (>= dst (+ src u)))
            (forth-cmove-loop s src dst u 0)
            (forth-cmove-loop-desc s src dst u (- u 1))))))
    (forth-def-prim!
      state
      "S>D"
      (fn
        (s)
        (let
          ((n (forth-pop s)))
          (forth-push s n)
          (forth-push s (if (< n 0) -1 0)))))
    (forth-def-prim! state "D>S" (fn (s) (forth-pop s)))
    (forth-def-prim!
      state
      "M*"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (let
            ((neg (if (>= a 0) (< b 0) (>= b 0))))
            (let
              ((au (forth-to-unsigned (if (< a 0) (- 0 a) a) 32))
                (bu
                  (forth-to-unsigned
                    (if (< b 0) (- 0 b) b)
                    32)))
              (let
                ((r (forth-umul32 au bu)))
                (let
                  ((lo (get r "lo")) (hi (get r "hi")))
                  (if
                    neg
                    (let
                      ((neg-lo (mod (- forth-2pow32 lo) forth-2pow32)))
                      (let
                        ((borrow (if (> lo 0) 1 0)))
                        (let
                          ((neg-hi (mod (- (- forth-2pow32 hi) borrow) forth-2pow32)))
                          (forth-push
                            s
                            (forth-from-unsigned neg-lo 32))
                          (forth-push
                            s
                            (forth-from-unsigned neg-hi 32)))))
                    (begin
                      (forth-push s (forth-from-unsigned lo 32))
                      (forth-push s (forth-from-unsigned hi 32)))))))))))
    (forth-def-prim!
      state
      "UM*"
      (fn
        (s)
        (let
          ((b (forth-pop s)) (a (forth-pop s)))
          (let
            ((r (forth-umul32 (forth-to-unsigned a 32) (forth-to-unsigned b 32))))
            (forth-push s (forth-from-unsigned (get r "lo") 32))
            (forth-push s (forth-from-unsigned (get r "hi") 32))))))
    (forth-def-prim!
      state
      "UM/MOD"
      (fn
        (s)
        (let
          ((u1 (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
          (let
            ((divisor (forth-to-unsigned u1 32))
              (hi-u (forth-to-unsigned hi 32))
              (lo-u (forth-to-unsigned lo 32)))
            (when (= divisor 0) (forth-error s "division by zero"))
            (let
              ((lo-hi (floor (/ lo-u 65536))) (lo-lo (mod lo-u 65536)))
              (let
                ((t1 (+ (* hi-u 65536) lo-hi)))
                (let
                  ((q1 (floor (/ t1 divisor))))
                  (let
                    ((r1 (- t1 (* q1 divisor))))
                    (let
                      ((t2 (+ (* r1 65536) lo-lo)))
                      (let
                        ((q2 (floor (/ t2 divisor))))
                        (let
                          ((r2 (- t2 (* q2 divisor))))
                          (forth-push s (forth-from-unsigned r2 32))
                          (forth-push
                            s
                            (forth-from-unsigned (+ (* q1 65536) q2) 32)))))))))))))
    (forth-def-prim!
      state
      "FM/MOD"
      (fn
        (s)
        (let
          ((n (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
          (let
            ((d (forth-double-from-cells-s lo hi)))
            (when (= n 0) (forth-error s "division by zero"))
            (let
              ((q (floor (/ d n))))
              (let
                ((r (- d (* q n))))
                (forth-push s (forth-clip r))
                (forth-push s (forth-clip q))))))))
    (forth-def-prim!
      state
      "SM/REM"
      (fn
        (s)
        (let
          ((n (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
          (let
            ((d (forth-double-from-cells-s lo hi)))
            (when (= n 0) (forth-error s "division by zero"))
            (let
              ((q (forth-trunc (/ d n))))
              (let
                ((r (- d (* q n))))
                (forth-push s (forth-clip r))
                (forth-push s (forth-clip q))))))))
    (forth-def-prim!
      state
      "*/"
      (fn
        (s)
        (let
          ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s)))
          (when (= n3 0) (forth-error s "division by zero"))
          (forth-push s (forth-clip (forth-trunc (/ (* n1 n2) n3)))))))
    (forth-def-prim!
      state
      "*/MOD"
      (fn
        (s)
        (let
          ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s)))
          (when (= n3 0) (forth-error s "division by zero"))
          (let
            ((d (* n1 n2)))
            (let
              ((q (forth-trunc (/ d n3))))
              (let
                ((r (- d (* q n3))))
                (forth-push s (forth-clip r))
                (forth-push s (forth-clip q))))))))
    (forth-def-prim!
      state
      "D+"
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (forth-double-push-s
            s
            (+
              (forth-double-from-cells-s lo1 hi1)
              (forth-double-from-cells-s lo2 hi2))))))
    (forth-def-prim!
      state
      "D-"
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (forth-double-push-s
            s
            (-
              (forth-double-from-cells-s lo1 hi1)
              (forth-double-from-cells-s lo2 hi2))))))
    (forth-def-prim!
      state
      "DNEGATE"
      (fn
        (s)
        (let
          ((hi (forth-pop s)) (lo (forth-pop s)))
          (forth-double-push-s
            s
            (- 0 (forth-double-from-cells-s lo hi))))))
    (forth-def-prim!
      state
      "DABS"
      (fn
        (s)
        (let
          ((hi (forth-pop s)) (lo (forth-pop s)))
          (forth-double-push-s s (abs (forth-double-from-cells-s lo hi))))))
    (forth-def-prim!
      state
      "D="
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (forth-push
            s
            (if (and (= lo1 lo2) (= hi1 hi2)) -1 0)))))
    (forth-def-prim!
      state
      "D<"
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (forth-push
            s
            (if
              (<
                (forth-double-from-cells-s lo1 hi1)
                (forth-double-from-cells-s lo2 hi2))
              -1
              0)))))
    (forth-def-prim!
      state
      "D0="
      (fn
        (s)
        (let
          ((hi (forth-pop s)) (lo (forth-pop s)))
          (forth-push
            s
            (if
              (and (= lo 0) (= hi 0))
              -1
              0)))))
    (forth-def-prim!
      state
      "D0<"
      (fn
        (s)
        (let
          ((hi (forth-pop s)) (lo (forth-pop s)))
          (forth-push s (if (< hi 0) -1 0)))))
    (forth-def-prim!
      state
      "DMAX"
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (let
            ((d1 (forth-double-from-cells-s lo1 hi1))
              (d2 (forth-double-from-cells-s lo2 hi2)))
            (forth-double-push-s s (if (> d1 d2) d1 d2))))))
    (forth-def-prim!
      state
      "DMIN"
      (fn
        (s)
        (let
          ((hi2 (forth-pop s))
            (lo2 (forth-pop s))
            (hi1 (forth-pop s))
            (lo1 (forth-pop s)))
          (let
            ((d1 (forth-double-from-cells-s lo1 hi1))
              (d2 (forth-double-from-cells-s lo2 hi2)))
            (forth-double-push-s s (if (< d1 d2) d1 d2))))))
    (forth-def-prim! state "<#" (fn (s) (dict-set! s "hold" (list))))
    (forth-def-prim!
      state
      "HOLD"
      (fn
        (s)
        (let
          ((c (forth-pop s)))
          (dict-set! s "hold" (cons (char-from-code c) (get s "hold"))))))
    (forth-def-prim!
      state
      "SIGN"
      (fn
        (s)
        (let
          ((n (forth-pop s)))
          (when
            (< n 0)
            (dict-set! s "hold" (cons "-" (get s "hold")))))))
    (forth-def-prim!
      state
      "#"
      (fn
        (s)
        (let
          ((hi (forth-pop s)) (lo (forth-pop s)))
          (let
            ((b (get (get s "vars") "base"))
              (hi-u (forth-to-unsigned hi 32))
              (lo-u (forth-to-unsigned lo 32)))
            (let
              ((q-hi (floor (/ hi-u b))) (r-hi (mod hi-u b)))
              (let
                ((combined (+ (* r-hi forth-2pow32) lo-u)))
                (let
                  ((dig (mod combined b)) (q-lo (floor (/ combined b))))
                  (let
                    ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
                    (dict-set! s "hold" (cons ch (get s "hold")))
                    (forth-push s (forth-from-unsigned q-lo 32))
                    (forth-push s (forth-from-unsigned q-hi 32))))))))))
    (forth-def-prim! state "#S" (fn (s) (forth-pic-S-loop s)))
    (forth-def-prim!
      state
      "#>"
      (fn
        (s)
        (forth-pop s)
        (forth-pop s)
        (let
          ((str-out (forth-join-hold (get s "hold"))))
          (let
            ((addr (forth-alloc-bytes! s (len str-out))))
            (forth-mem-write-string! s addr str-out)
            (forth-push s addr)
            (forth-push s (len str-out))))))
    (forth-def-prim!
      state
      "U."
      (fn
        (s)
        (let
          ((u (forth-to-unsigned (forth-pop s) 32))
            (b (get (get s "vars") "base")))
          (forth-emit-str s (str (forth-num-to-string u b) " ")))))
    (forth-def-prim!
      state
      "U.R"
      (fn
        (s)
        (let
          ((width (forth-pop s))
            (u (forth-to-unsigned (forth-pop s) 32))
            (b (get (get s "vars") "base")))
          (let
            ((digits (forth-num-to-string u b)))
            (forth-emit-str s (forth-spaces-str (- width (len digits))))
            (forth-emit-str s digits)))))
    (forth-def-prim!
      state
      ".R"
      (fn
        (s)
        (let
          ((width (forth-pop s))
            (n (forth-pop s))
            (b (get (get s "vars") "base")))
          (let
            ((sign-prefix (if (< n 0) "-" ""))
              (abs-digits
                (forth-num-to-string
                  (forth-to-unsigned (abs n) 32)
                  b)))
            (let
              ((digits (str sign-prefix abs-digits)))
              (forth-emit-str s (forth-spaces-str (- width (len digits))))
              (forth-emit-str s digits))))))
    state))
