;; Phase 2 — colon definitions, compile mode, VARIABLE/CONSTANT/VALUE/TO, @/!/+!.
;;
;; Compile-mode representation:
;;   A colon-definition body is a list of "ops", each an SX lambda (fn (s) ...).
;;   : FOO 1 2 + ;    -> body = (push-1 push-2 call-plus)
;;   References to other words are compiled as late-binding thunks so that
;;   self-reference works and redefinitions take effect for future runs.
;;
;; State additions used in Phase 2:
;;   "compiling"   : bool — are we inside :..; ?
;;   "current-def" : dict {:name "..." :body (list)} during compile
;;   "vars"        : dict {"addr-name" -> cell-value} for VARIABLE storage

(define
  forth-compile-token
  (fn
    (state tok)
    (let
      ((w (forth-lookup state tok)))
      (if
        (not (nil? w))
        (if
          (get w "immediate?")
          (forth-execute-word state w)
          (forth-compile-call state tok))
        (let
          ((n (forth-parse-number tok (get (get state "vars") "base"))))
          (if
            (not (nil? n))
            (forth-compile-lit state n)
            (forth-error state (str tok " ?"))))))))

;; Resolve the word NOW (early binding) so that `: X X ;` compiles a call
;; to the prior X — matching standard Forth redefinition semantics.
;; RECURSE is the one exception: it stays late-bound against the not-yet-
;; installed current definition.
;; Inline primitive calls: skip the `forth-execute-word` indirection by
;; appending the word's body fn directly (forth-execute-word body
;; reduces to `((get w "body") state)`, which is exactly what the body
;; fn already is). Saves one frame per call op in every colon-def.
(define
  forth-compile-call
  (fn
    (state name)
    (let
      ((w (forth-lookup state name)))
      (if
        (nil? w)
        (forth-error state (str name " ?"))
        (forth-def-append! state (get w "body"))))))

(define
  forth-compile-recurse
  (fn
    (state name)
    (let
      ((op
        (fn
          (s)
          (let
            ((w (forth-lookup s name)))
            (if
              (nil? w)
              (forth-error s (str "RECURSE: " name " not yet installed"))
              (forth-execute-word s w))))))
      (forth-def-append! state op))))

(define
  forth-compile-lit
  (fn
    (state n)
    (let ((op (fn (s) (forth-push s n)))) (forth-def-append! state op))))

(define
  forth-def-append!
  (fn
    (state op)
    (let
      ((def (get state "current-def")))
      (dict-set! def "body" (concat (get def "body") (list op))))))

(define
  forth-def-length
  (fn (state) (len (get (get state "current-def") "body"))))

(define
  forth-make-branch
  (fn
    (kind target)
    (let ((b (dict))) (dict-set! b "kind" kind) (dict-set! b "target" target) b)))

(define
  forth-make-target
  (fn () (let ((t (dict))) (dict-set! t "v" 0) t)))

(define
  forth-make-colon-body
  (fn
    (ops)
    (let
      ((n (len ops)))
      (fn
        (s)
        (let ((pc (dict))) (dict-set! pc "v" 0) (forth-run-body s ops pc n))))))

;; After `;` finalizes a body, walk it and attach to each does-rebind op
;; the slice of ops that follow it — that slice becomes the runtime body
;; of the just-CREATE'd word when the rebind fires.
(define
  forth-fixup-does!
  (fn
    (ops i n)
    (when
      (< i n)
      (begin
        (let
          ((op (nth ops i)))
          (when
            (and (dict? op) (= (get op "kind") "does-rebind"))
            (dict-set! op "deferred" (drop ops (+ i 1)))))
        (forth-fixup-does! ops (+ i 1) n)))))

(define
  forth-step-op
  (fn
    (s op pc)
    (cond
      ((and (dict? op) (= (get op "kind") "bif"))
        (if
          (= (forth-pop s) 0)
          (dict-set! pc "v" (get (get op "target") "v"))
          (dict-set! pc "v" (+ (get pc "v") 1))))
      ((and (dict? op) (= (get op "kind") "branch"))
        (dict-set! pc "v" (get (get op "target") "v")))
      ((and (dict? op) (= (get op "kind") "leave"))
        (begin
          (forth-rpop s)
          (forth-rpop s)
          (dict-set! pc "v" (get (get op "target") "v"))))
      ((and (dict? op) (= (get op "kind") "loop"))
        (forth-loop-step s op pc))
      ((and (dict? op) (= (get op "kind") "+loop"))
        (forth-plusloop-step s op pc))
      ((and (dict? op) (= (get op "kind") "exit"))
        (dict-set! pc "v" 1000000000))
      ((and (dict? op) (= (get op "kind") "does-rebind"))
        (forth-do-does-rebind s op pc))
      (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1)))))))

(define
  forth-do-does-rebind
  (fn
    (s op pc)
    (let
      ((target (get s "last-creator"))
        (deferred (get op "deferred")))
      (when
        (nil? target)
        (forth-error s "DOES>: no recent CREATE"))
      (let
        ((addr (get target "body-addr")))
        (let
          ((new-body (forth-make-does-body addr deferred)))
          (dict-set! target "body" new-body)))
      (dict-set! pc "v" 1000000000))))

(define
  forth-make-does-body
  (fn
    (addr deferred)
    (let
      ((n (len deferred)))
      (fn
        (s)
        (forth-push s addr)
        (let
          ((pc2 (dict)))
          (dict-set! pc2 "v" 0)
          (forth-run-body s deferred pc2 n))))))

(define
  forth-loop-step
  (fn
    (s op pc)
    (let
      ((idx (forth-rpop s)))
      (let
        ((lim (forth-rpeek s)))
        (let
          ((next (+ idx 1)))
          (if
            (>= next lim)
            (begin
              (forth-rpop s)
              (dict-set! pc "v" (+ (get pc "v") 1)))
            (begin
              (forth-rpush s next)
              (dict-set! pc "v" (get (get op "target") "v")))))))))

(define
  forth-plusloop-step
  (fn
    (s op pc)
    (let
      ((inc (forth-pop s)))
      (let
        ((idx (forth-rpop s)))
        (let
          ((lim (forth-rpeek s)))
          (let
            ((next (+ idx inc)))
            (if
              (if (>= inc 0) (>= next lim) (< next lim))
              (begin
                (forth-rpop s)
                (dict-set! pc "v" (+ (get pc "v") 1)))
              (begin
                (forth-rpush s next)
                (dict-set! pc "v" (get (get op "target") "v"))))))))))

;; Parse input tokens until one ends in `"`. Returns joined content with
;; single spaces between tokens (emulating standard Forth S"-style parse).
(define
  forth-parse-quote
  (fn
    (state)
    (forth-parse-quote-loop state (list))))

(define
  forth-parse-quote-loop
  (fn
    (state parts)
    (let
      ((tok (forth-next-token! state)))
      (if
        (nil? tok)
        (forth-error state "unterminated string")
        (let
          ((n (len tok)))
          (if
            (and (> n 0) (= (substr tok (- n 1) 1) "\""))
            (let
              ((final (substr tok 0 (- n 1))))
              (forth-join-parts (concat parts (list final)) " "))
            (forth-parse-quote-loop state (concat parts (list tok)))))))))

(define
  forth-join-parts
  (fn
    (parts sep)
    (if
      (= (len parts) 0)
      ""
      (forth-join-loop (rest parts) sep (first parts)))))

(define
  forth-join-loop
  (fn
    (xs sep acc)
    (if
      (= (len xs) 0)
      acc
      (forth-join-loop (rest-of xs) sep (str acc sep (first xs))))))

(define
  forth-find-do
  (fn
    (cs)
    (if
      (= (len cs) 0)
      nil
      (if
        (and (dict? (first cs)) (= (get (first cs) "kind") "do"))
        (first cs)
        (forth-find-do (rest cs))))))

(define
  forth-run-body
  (fn
    (s ops pc n)
    (when
      (< (get pc "v") n)
      (begin
        (forth-step-op s (nth ops (get pc "v")) pc)
        (forth-run-body s ops pc n)))))

;; Override forth-interpret-token to branch on compile mode.
(define
  forth-interpret-token
  (fn
    (state tok)
    (if
      (get state "compiling")
      (forth-compile-token state tok)
      (let
        ((w (forth-lookup state tok)))
        (if
          (not (nil? w))
          (forth-execute-word state w)
          (let
            ((n (forth-parse-number tok (get (get state "vars") "base"))))
            (if
              (not (nil? n))
              (forth-push state n)
              (forth-error state (str tok " ?")))))))))

;; Install `:` and `;` plus VARIABLE, CONSTANT, VALUE, TO, @, !, +!, RECURSE.
(define
  forth-install-compiler!
  (fn
    (state)
    (forth-def-prim!
      state
      ":"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s ": expects name"))
          (let
            ((def (dict)))
            (dict-set! def "name" name)
            (dict-set! def "body" (list))
            (dict-set! s "current-def" def)
            (dict-set! s "compiling" true)))))
    (forth-def-prim-imm!
      state
      ";"
      (fn
        (s)
        (let
          ((def (get s "current-def")))
          (when (nil? def) (forth-error s "; outside definition"))
          (let
            ((ops (get def "body")))
            (begin
              (forth-fixup-does! ops 0 (len ops))
              (let
                ((body-fn (forth-make-colon-body ops)))
                (dict-set!
                  (get s "dict")
                  (downcase (get def "name"))
                  (forth-make-word "colon-def" body-fn false))
                (dict-set! s "last-defined" (get def "name"))
                (dict-set! s "current-def" nil)
                (dict-set! s "compiling" false)))))))
    (forth-def-prim-imm!
      state
      "IMMEDIATE"
      (fn
        (s)
        (let
          ((def-name (get (get s "current-def") "name"))
            (target
              (if
                (nil? (get s "current-def"))
                (forth-last-defined s)
                (get (get s "current-def") "name"))))
          (let
            ((w (forth-lookup s target)))
            (when (not (nil? w)) (dict-set! w "immediate?" true))))))
    (forth-def-prim-imm!
      state
      "RECURSE"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "RECURSE only in definition"))
        (let
          ((name (get (get s "current-def") "name")))
          (forth-compile-recurse s name))))
    (forth-def-prim-imm!
      state
      "IF"
      (fn
        (s)
        (when (not (get s "compiling")) (forth-error s "IF outside definition"))
        (let
          ((target (forth-make-target)))
          (forth-def-append! s (forth-make-branch "bif" target))
          (forth-cpush s target))))
    (forth-def-prim-imm!
      state
      "ELSE"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "ELSE outside definition"))
        (let
          ((new-target (forth-make-target)))
          (forth-def-append! s (forth-make-branch "branch" new-target))
          (let
            ((if-target (forth-cpop s)))
            (dict-set! if-target "v" (forth-def-length s)))
          (forth-cpush s new-target))))
    (forth-def-prim-imm!
      state
      "THEN"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "THEN outside definition"))
        (let
          ((target (forth-cpop s)))
          (dict-set! target "v" (forth-def-length s)))))
    (forth-def-prim-imm!
      state
      "BEGIN"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "BEGIN outside definition"))
        (forth-cpush s (forth-def-length s))))
    (forth-def-prim-imm!
      state
      "UNTIL"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "UNTIL outside definition"))
        (let
          ((back-pc (forth-cpop s)))
          (let
            ((target (forth-make-target)))
            (dict-set! target "v" back-pc)
            (forth-def-append! s (forth-make-branch "bif" target))))))
    (forth-def-prim-imm!
      state
      "AGAIN"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "AGAIN outside definition"))
        (let
          ((back-pc (forth-cpop s)))
          (let
            ((target (forth-make-target)))
            (dict-set! target "v" back-pc)
            (forth-def-append! s (forth-make-branch "branch" target))))))
    (forth-def-prim-imm!
      state
      "WHILE"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "WHILE outside definition"))
        (let
          ((target (forth-make-target)))
          (forth-def-append! s (forth-make-branch "bif" target))
          (forth-cpush s target))))
    (forth-def-prim-imm!
      state
      "REPEAT"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "REPEAT outside definition"))
        (let
          ((while-target (forth-cpop s)))
          (let
            ((back-pc (forth-cpop s)))
            (let
              ((b-target (forth-make-target)))
              (dict-set! b-target "v" back-pc)
              (forth-def-append! s (forth-make-branch "branch" b-target))
              (dict-set! while-target "v" (forth-def-length s)))))))
    (forth-def-prim-imm!
      state
      "DO"
      (fn
        (s)
        (when (not (get s "compiling")) (forth-error s "DO outside definition"))
        (let
          ((op
            (fn
              (ss)
              (let
                ((start (forth-pop ss)))
                (let
                  ((limit (forth-pop ss)))
                  (forth-rpush ss limit)
                  (forth-rpush ss start))))))
          (forth-def-append! s op))
        (let
          ((marker (dict)))
          (dict-set! marker "kind" "do")
          (dict-set! marker "back" (forth-def-length s))
          (dict-set! marker "leaves" (list))
          (forth-cpush s marker))))
    (forth-def-prim-imm!
      state
      "LOOP"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "LOOP outside definition"))
        (let
          ((marker (forth-cpop s)))
          (when
            (or (not (dict? marker)) (not (= (get marker "kind") "do")))
            (forth-error s "LOOP without DO"))
          (let
            ((target (forth-make-target)))
            (dict-set! target "v" (get marker "back"))
            (forth-def-append! s (forth-make-branch "loop" target)))
          (let
            ((exit-pc (forth-def-length s)))
            (for-each
              (fn (t) (dict-set! t "v" exit-pc))
              (get marker "leaves"))))))
    (forth-def-prim-imm!
      state
      "+LOOP"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "+LOOP outside definition"))
        (let
          ((marker (forth-cpop s)))
          (when
            (or (not (dict? marker)) (not (= (get marker "kind") "do")))
            (forth-error s "+LOOP without DO"))
          (let
            ((target (forth-make-target)))
            (dict-set! target "v" (get marker "back"))
            (forth-def-append! s (forth-make-branch "+loop" target)))
          (let
            ((exit-pc (forth-def-length s)))
            (for-each
              (fn (t) (dict-set! t "v" exit-pc))
              (get marker "leaves"))))))
    (forth-def-prim!
      state
      "CHAR"
      (fn
        (s)
        (let
          ((tok (forth-next-token! s)))
          (when
            (or (nil? tok) (= (len tok) 0))
            (forth-error s "CHAR expects a word"))
          (forth-push s (char-code (substr tok 0 1))))))
    (forth-def-prim-imm!
      state
      "[CHAR]"
      (fn
        (s)
        (let
          ((tok (forth-next-token! s)))
          (when
            (or (nil? tok) (= (len tok) 0))
            (forth-error s "[CHAR] expects a word"))
          (let
            ((c (char-code (substr tok 0 1))))
            (if
              (get s "compiling")
              (forth-def-append! s (fn (ss) (forth-push ss c)))
              (forth-push s c))))))
    (forth-def-prim!
      state
      "KEY"
      (fn
        (s)
        (let
          ((kb (or (get s "keybuf") "")))
          (if
            (= (len kb) 0)
            (forth-error s "KEY: no input available")
            (begin
              (forth-push s (char-code (substr kb 0 1)))
              (dict-set! s "keybuf" (substr kb 1 (- (len kb) 1))))))))
    (forth-def-prim!
      state
      "ACCEPT"
      (fn
        (s)
        (let
          ((n1 (forth-pop s)) (addr (forth-pop s)))
          (let
            ((kb (or (get s "keybuf") "")))
            (let
              ((n (if (< n1 (len kb)) n1 (len kb))))
              (forth-mem-write-string! s addr (substr kb 0 n))
              (dict-set! s "keybuf" (substr kb n (- (len kb) n)))
              (forth-push s n))))))
    (forth-def-prim-imm!
      state
      "S\""
      (fn
        (s)
        (let
          ((content (forth-parse-quote s)))
          (if
            (get s "compiling")
            (let
              ((addr (forth-alloc-bytes! s (len content))))
              (forth-mem-write-string! s addr content)
              (forth-def-append! s (fn (ss) (forth-push ss addr)))
              (forth-def-append! s (fn (ss) (forth-push ss (len content)))))
            (let
              ((addr (forth-alloc-bytes! s (len content))))
              (forth-mem-write-string! s addr content)
              (forth-push s addr)
              (forth-push s (len content)))))))
    (forth-def-prim-imm!
      state
      "C\""
      (fn
        (s)
        (let
          ((content (forth-parse-quote s)))
          (let
            ((addr (forth-alloc-bytes! s (+ 1 (len content)))))
            (forth-mem-write! s addr (len content))
            (forth-mem-write-string! s (+ addr 1) content)
            (if
              (get s "compiling")
              (forth-def-append! s (fn (ss) (forth-push ss addr)))
              (forth-push s addr))))))
    (forth-def-prim-imm!
      state
      ".\""
      (fn
        (s)
        (let
          ((content (forth-parse-quote s)))
          (if
            (get s "compiling")
            (forth-def-append! s (fn (ss) (forth-emit-str ss content)))
            (forth-emit-str s content)))))
    (forth-def-prim-imm!
      state
      "LEAVE"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "LEAVE outside definition"))
        (let
          ((marker (forth-find-do (get s "cstack"))))
          (when (nil? marker) (forth-error s "LEAVE without DO"))
          (let
            ((target (forth-make-target)))
            (forth-def-append! s (forth-make-branch "leave" target))
            (dict-set!
              marker
              "leaves"
              (concat (get marker "leaves") (list target)))))))
    (forth-def-prim!
      state
      "VARIABLE"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s "VARIABLE expects name"))
          (dict-set! (get s "vars") (downcase name) 0)
          (forth-def-prim!
            s
            name
            (fn (ss) (forth-push ss (downcase name)))))))
    (forth-def-prim!
      state
      "CONSTANT"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)) (v (forth-pop s)))
          (when (nil? name) (forth-error s "CONSTANT expects name"))
          (forth-def-prim! s name (fn (ss) (forth-push ss v))))))
    (forth-def-prim!
      state
      "VALUE"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)) (v (forth-pop s)))
          (when (nil? name) (forth-error s "VALUE expects name"))
          (dict-set! (get s "vars") (downcase name) v)
          (forth-def-prim!
            s
            name
            (fn
              (ss)
              (forth-push ss (get (get ss "vars") (downcase name))))))))
    (forth-def-prim!
      state
      "TO"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)) (v (forth-pop s)))
          (when (nil? name) (forth-error s "TO expects name"))
          (dict-set! (get s "vars") (downcase name) v))))
    (forth-def-prim!
      state
      "@"
      (fn
        (s)
        (let
          ((addr (forth-pop s)))
          (cond
            ((= addr "@@state")
              (forth-push s (if (get s "compiling") -1 0)))
            ((= addr "@@in") (forth-push s 0))
            ((string? addr)
              (forth-push s (or (get (get s "vars") addr) 0)))
            (else (forth-push s (forth-mem-read s addr)))))))
    (forth-def-prim!
      state
      "!"
      (fn
        (s)
        (let
          ((addr (forth-pop s)) (v (forth-pop s)))
          (if
            (string? addr)
            (dict-set! (get s "vars") addr v)
            (forth-mem-write! s addr v)))))
    (forth-def-prim!
      state
      "+!"
      (fn
        (s)
        (let
          ((addr (forth-pop s)) (v (forth-pop s)))
          (if
            (string? addr)
            (let
              ((cur (or (get (get s "vars") addr) 0)))
              (dict-set! (get s "vars") addr (+ cur v)))
            (forth-mem-write! s addr (+ (forth-mem-read s addr) v))))))
    (forth-def-prim! state "HERE" (fn (s) (forth-push s (get s "here"))))
    (forth-def-prim!
      state
      "ALLOT"
      (fn
        (s)
        (let
          ((n (forth-pop s)))
          (dict-set! s "here" (+ (get s "here") n)))))
    (forth-def-prim!
      state
      ","
      (fn
        (s)
        (let
          ((v (forth-pop s)) (addr (forth-alloc-bytes! s 1)))
          (forth-mem-write! s addr v))))
    (forth-def-prim!
      state
      "C,"
      (fn
        (s)
        (let
          ((v (forth-pop s)) (addr (forth-alloc-bytes! s 1)))
          (forth-mem-write! s addr v))))
    (forth-def-prim!
      state
      "CREATE"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s "CREATE expects name"))
          (let
            ((addr (get s "here")))
            (forth-def-prim! s name (fn (ss) (forth-push ss addr)))
            (let
              ((w (forth-lookup s name)))
              (dict-set! w "body-addr" addr)
              (dict-set! s "last-creator" w))))))
    (forth-def-prim! state "CELL+" (fn (s) (forth-push s (+ (forth-pop s) 1))))
    (forth-def-prim! state "CELLS" (fn (s) nil))
    (forth-def-prim! state "ALIGN" (fn (s) nil))
    (forth-def-prim! state "ALIGNED" (fn (s) nil))
    (forth-def-prim!
      state
      "EXECUTE"
      (fn (s) (let ((w (forth-pop s))) (forth-execute-word s w))))
    (forth-def-prim!
      state
      "'"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s "' expects name"))
          (let
            ((w (forth-lookup s name)))
            (when (nil? w) (forth-error s (str name " ?")))
            (forth-push s w)))))
    (forth-def-prim-imm!
      state
      "[']"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s "['] expects name"))
          (let
            ((w (forth-lookup s name)))
            (when (nil? w) (forth-error s (str name " ?")))
            (if
              (get s "compiling")
              (forth-def-append! s (fn (ss) (forth-push ss w)))
              (forth-push s w))))))
    (forth-def-prim-imm!
      state
      "LITERAL"
      (fn
        (s)
        (let
          ((v (forth-pop s)))
          (when
            (not (get s "compiling"))
            (forth-error s "LITERAL outside compile mode"))
          (forth-def-append! s (fn (ss) (forth-push ss v))))))
    (forth-def-prim-imm!
      state
      "POSTPONE"
      (fn
        (s)
        (let
          ((name (forth-next-token! s)))
          (when (nil? name) (forth-error s "POSTPONE expects name"))
          (let
            ((w (forth-lookup s name)))
            (when (nil? w) (forth-error s (str name " ?")))
            (if
              (get w "immediate?")
              (forth-def-append! s (fn (ss) (forth-execute-word ss w)))
              (forth-def-append!
                s
                (fn
                  (ss)
                  (forth-def-append!
                    ss
                    (fn (sss) (forth-execute-word sss w))))))))))
    (forth-def-prim!
      state
      ">BODY"
      (fn
        (s)
        (let
          ((w (forth-pop s)))
          (forth-push s (or (get w "body-addr") 0)))))
    ;; `\` would normally consume the rest of the parse line; we have no
    ;; line concept so we make it a no-op. Conformance.sh already strips
    ;; standalone `\ ...` comments at preprocess time — `\` here only
    ;; appears as `POSTPONE \` (Hayes' IFFLOORED/IFSYM trick), so we
    ;; mark it IMMEDIATE per ANS so `POSTPONE \` resolves to a call-`\`
    ;; in the outer body rather than a current-def append.
    (forth-def-prim-imm! state "\\" (fn (s) nil))
    (forth-def-prim-imm!
      state
      "SLITERAL"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (c-addr (forth-pop s)))
          (let
            ((content (forth-mem-read-string s c-addr u)))
            (let
              ((new-addr (forth-alloc-bytes! s u)))
              (forth-mem-write-string! s new-addr content)
              (forth-def-append! s (fn (ss) (forth-push ss new-addr)))
              (forth-def-append! s (fn (ss) (forth-push ss u))))))))
    (forth-def-prim!
      state
      ">NUMBER"
      (fn
        (s)
        (let
          ((u (forth-pop s))
            (addr (forth-pop s))
            (hi (forth-pop s))
            (lo (forth-pop s)))
          (let
            ((d (forth-double-from-cells-u lo hi))
              (b (get (get s "vars") "base")))
            (let
              ((result (forth-numparse-loop s addr u d b)))
              (forth-double-push-u s (nth result 0))
              (forth-push s (nth result 1))
              (forth-push s (nth result 2)))))))
    (forth-def-prim!
      state
      "COMPARE"
      (fn
        (s)
        (let
          ((u2 (forth-pop s))
            (a2 (forth-pop s))
            (u1 (forth-pop s))
            (a1 (forth-pop s)))
          (forth-push s (forth-compare-bytes-loop s a1 u1 a2 u2 0)))))
    (forth-def-prim!
      state
      "SEARCH"
      (fn
        (s)
        (let
          ((u2 (forth-pop s))
            (a2 (forth-pop s))
            (u1 (forth-pop s))
            (a1 (forth-pop s)))
          (let
            ((idx (forth-search-bytes s a1 u1 a2 u2 0)))
            (if
              (< idx 0)
              (begin
                (forth-push s a1)
                (forth-push s u1)
                (forth-push s 0))
              (begin
                (forth-push s (+ a1 idx))
                (forth-push s (- u1 idx))
                (forth-push s -1)))))))
    (forth-def-prim! state "R/O" (fn (s) (forth-push s 0)))
    (forth-def-prim! state "W/O" (fn (s) (forth-push s 1)))
    (forth-def-prim! state "R/W" (fn (s) (forth-push s 2)))
    (forth-def-prim! state "BIN" (fn (s) (forth-push s (+ (forth-pop s) 4))))
    (forth-def-prim!
      state
      "OPEN-FILE"
      (fn
        (s)
        (let
          ((fam (forth-pop s))
            (u (forth-pop s))
            (addr (forth-pop s)))
          (let
            ((path (forth-mem-read-string s addr u)))
            (let
              ((existing (get (get s "by-path") path)))
              (if
                (nil? existing)
                (begin (forth-push s 0) (forth-push s 1))
                (let
                  ((fid (get s "next-fileid")))
                  (let
                    ((entry (dict)))
                    (dict-set! entry "content" (get existing "content"))
                    (dict-set! entry "pos" 0)
                    (dict-set! entry "path" path)
                    (dict-set! (get s "files") (str fid) entry)
                    (dict-set! s "next-fileid" (+ fid 1))
                    (forth-push s fid)
                    (forth-push s 0)))))))))
    (forth-def-prim!
      state
      "CREATE-FILE"
      (fn
        (s)
        (let
          ((fam (forth-pop s))
            (u (forth-pop s))
            (addr (forth-pop s)))
          (let
            ((path (forth-mem-read-string s addr u)))
            (let
              ((fid (get s "next-fileid")))
              (let
                ((entry (dict)))
                (dict-set! entry "content" "")
                (dict-set! entry "pos" 0)
                (dict-set! entry "path" path)
                (dict-set! (get s "files") (str fid) entry)
                (dict-set! (get s "by-path") path entry)
                (dict-set! s "next-fileid" (+ fid 1))
                (forth-push s fid)
                (forth-push s 0)))))))
    (forth-def-prim!
      state
      "CLOSE-FILE"
      (fn
        (s)
        (let ((fid (forth-pop s))) (forth-push s 0))))
    (forth-def-prim!
      state
      "READ-FILE"
      (fn
        (s)
        (let
          ((fid (forth-pop s))
            (u1 (forth-pop s))
            (addr (forth-pop s)))
          (let
            ((entry (get (get s "files") (str fid))))
            (if
              (nil? entry)
              (begin (forth-push s 0) (forth-push s 1))
              (let
                ((content (get entry "content")) (pos (get entry "pos")))
                (let
                  ((avail (- (len content) pos)))
                  (let
                    ((n (if (< u1 avail) u1 avail)))
                    (when
                      (> n 0)
                      (forth-mem-write-string! s addr (substr content pos n)))
                    (dict-set! entry "pos" (+ pos n))
                    (forth-push s n)
                    (forth-push s 0)))))))))
    (forth-def-prim!
      state
      "WRITE-FILE"
      (fn
        (s)
        (let
          ((fid (forth-pop s))
            (u (forth-pop s))
            (addr (forth-pop s)))
          (let
            ((entry (get (get s "files") (str fid))))
            (if
              (nil? entry)
              (forth-push s 1)
              (begin
                (dict-set!
                  entry
                  "content"
                  (str
                    (get entry "content")
                    (forth-mem-read-string s addr u)))
                (forth-push s 0)))))))
    (forth-def-prim!
      state
      "FILE-POSITION"
      (fn
        (s)
        (let
          ((fid (forth-pop s)))
          (let
            ((entry (get (get s "files") (str fid))))
            (if
              (nil? entry)
              (begin (forth-push s 0) (forth-push s 0) (forth-push s 1))
              (begin
                (forth-push s (get entry "pos"))
                (forth-push s 0)
                (forth-push s 0)))))))
    (forth-def-prim!
      state
      "FILE-SIZE"
      (fn
        (s)
        (let
          ((fid (forth-pop s)))
          (let
            ((entry (get (get s "files") (str fid))))
            (if
              (nil? entry)
              (begin (forth-push s 0) (forth-push s 0) (forth-push s 1))
              (begin
                (forth-push s (len (get entry "content")))
                (forth-push s 0)
                (forth-push s 0)))))))
    (forth-def-prim!
      state
      "REPOSITION-FILE"
      (fn
        (s)
        (let
          ((fid (forth-pop s))
            (hi (forth-pop s))
            (lo (forth-pop s)))
          (let
            ((entry (get (get s "files") (str fid))))
            (if
              (nil? entry)
              (forth-push s 1)
              (begin
                (dict-set! entry "pos" lo)
                (forth-push s 0)))))))
    (forth-def-prim!
      state
      "DELETE-FILE"
      (fn
        (s)
        (let ((u (forth-pop s)) (addr (forth-pop s))) (forth-push s 1))))
    (forth-def-prim!
      state
      "WITHIN"
      (fn
        (s)
        (let
          ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s)))
          (let
            ((a (forth-to-unsigned (- n1 n2) 32))
              (b (forth-to-unsigned (- n3 n2) 32)))
            (forth-push s (if (< a b) -1 0))))))
    (forth-def-prim!
      state
      "ABORT"
      (fn
        (s)
        (dict-set! s "dstack" (list))
        (dict-set! s "rstack" (list))
        (dict-set! s "cstack" (list))
        (forth-error s "ABORT")))
    (forth-def-prim-imm!
      state
      "ABORT\""
      (fn
        (s)
        (let
          ((msg (forth-parse-quote s)))
          (if
            (get s "compiling")
            (forth-def-append!
              s
              (fn
                (ss)
                (when
                  (not (= (forth-pop ss) 0))
                  (begin
                    (dict-set! ss "dstack" (list))
                    (dict-set! ss "rstack" (list))
                    (dict-set! ss "cstack" (list))
                    (forth-error ss (str "ABORT: " msg))))))
            (when
              (not (= (forth-pop s) 0))
              (begin
                (dict-set! s "dstack" (list))
                (dict-set! s "rstack" (list))
                (dict-set! s "cstack" (list))
                (forth-error s (str "ABORT: " msg))))))))
    (forth-def-prim-imm!
      state
      "EXIT"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "EXIT outside definition"))
        (let
          ((op (dict)))
          (dict-set! op "kind" "exit")
          (forth-def-append! s op))))
    (forth-def-prim-imm!
      state
      "DOES>"
      (fn
        (s)
        (when
          (not (get s "compiling"))
          (forth-error s "DOES> outside definition"))
        (let
          ((op (dict)))
          (dict-set! op "kind" "does-rebind")
          (forth-def-append! s op))))
    (forth-def-prim!
      state
      "UNLOOP"
      (fn (s) (forth-rpop s) (forth-rpop s)))
    (forth-def-prim-imm!
      state
      "["
      (fn (s) (dict-set! s "compiling" false)))
    (forth-def-prim! state "]" (fn (s) (dict-set! s "compiling" true)))
    (forth-def-prim! state "STATE" (fn (s) (forth-push s "@@state")))
    (forth-def-prim!
      state
      "EVALUATE"
      (fn
        (s)
        (let
          ((u (forth-pop s)) (addr (forth-pop s)))
          (let
            ((src (forth-mem-read-string s addr u)))
            (let
              ((saved-input (get s "input")))
              (dict-set! s "input" (forth-tokens src))
              (forth-interpret-loop s)
              (dict-set! s "input" saved-input))))))
    (forth-def-prim!
      state
      "SOURCE"
      (fn (s) (forth-push s 0) (forth-push s 0)))
    (forth-def-prim! state ">IN" (fn (s) (forth-push s "@@in")))
    (forth-def-prim!
      state
      "WORD"
      (fn
        (s)
        (let
          ((delim (forth-pop s)) (tok (forth-next-token! s)))
          (let
            ((str-out (or tok "")))
            (let
              ((addr (forth-alloc-bytes! s (+ 1 (len str-out)))))
              (forth-mem-write! s addr (len str-out))
              (forth-mem-write-string! s (+ addr 1) str-out)
              (forth-push s addr))))))
    (forth-def-prim!
      state
      "FIND"
      (fn
        (s)
        (let
          ((c-addr (forth-pop s)))
          (let
            ((u (forth-mem-read s c-addr)))
            (let
              ((str-name (forth-mem-read-string s (+ c-addr 1) u)))
              (let
                ((w (forth-lookup s str-name)))
                (if
                  (nil? w)
                  (begin (forth-push s c-addr) (forth-push s 0))
                  (begin
                    (forth-push s w)
                    (forth-push s (if (get w "immediate?") 1 -1))))))))))
    (forth-def-prim!
      state
      "U<"
      (forth-cmp
        (fn (a b) (< (forth-to-unsigned a 32) (forth-to-unsigned b 32)))))
    (forth-def-prim!
      state
      "U>"
      (forth-cmp
        (fn (a b) (> (forth-to-unsigned a 32) (forth-to-unsigned b 32)))))
    (forth-def-prim!
      state
      "2@"
      (fn
        (s)
        (let
          ((addr (forth-pop s)))
          (if
            (string? addr)
            (forth-error s "2@ on var unsupported")
            (begin
              (forth-push s (forth-mem-read s (+ addr 1)))
              (forth-push s (forth-mem-read s addr)))))))
    (forth-def-prim!
      state
      "2!"
      (fn
        (s)
        (let
          ((addr (forth-pop s))
            (a (forth-pop s))
            (b (forth-pop s)))
          (forth-mem-write! s addr a)
          (forth-mem-write! s (+ addr 1) b))))
    state))

;; Track the most recently defined word name for IMMEDIATE.
(define forth-last-defined (fn (state) (get state "last-defined")))

;; forth-next-token!: during `:`, VARIABLE, CONSTANT, etc. we need to pull
;; the next token from the *input stream* (not the dict/stack). Phase-1
;; interpreter fed tokens one at a time via for-each, so a parsing word
;; can't reach ahead. We rework `forth-interpret` to keep the remaining
;; token list on the state so parsing words can consume from it.

(define
  forth-next-token!
  (fn
    (state)
    (let
      ((rest (get state "input")))
      (if
        (or (nil? rest) (= (len rest) 0))
        nil
        (let
          ((tok (first rest)))
          (dict-set! state "input" (rest-of rest))
          tok)))))

(define rest-of (fn (l) (rest l)))

;; Rewritten forth-interpret: drives a token list stored in state so that
;; parsing words like `:`, `VARIABLE`, `CONSTANT`, `TO` can consume the
;; following token.
(define
  forth-interpret
  (fn
    (state src)
    (dict-set! state "input" (forth-tokens src))
    (forth-interpret-loop state)
    state))

(define
  forth-interpret-loop
  (fn
    (state)
    (let
      ((tok (forth-next-token! state)))
      (if
        (nil? tok)
        state
        (begin
          (forth-interpret-token state tok)
          (forth-interpret-loop state))))))

;; Re-export forth-boot to include the compiler primitives too.
(define
  forth-boot
  (fn
    ()
    (let
      ((s (forth-make-state)))
      (forth-install-primitives! s)
      (forth-install-compiler! s)
      s)))