;; 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 state "base"))))
          (if
            (not (nil? n))
            (forth-compile-lit state n)
            (forth-error state (str tok " ?"))))))))

(define
  forth-compile-call
  (fn
    (state name)
    (let
      ((op (fn (s) (let ((w (forth-lookup s name))) (if (nil? w) (forth-error s (str name " ? (compiled)")) (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))))))

(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))
      (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1)))))))

(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 state "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")))
            (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 "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-call 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 (nil? tok) (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 (nil? tok) (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)))
          (forth-push s (or (get (get s "vars") addr) 0)))))
    (forth-def-prim!
      state
      "!"
      (fn
        (s)
        (let
          ((addr (forth-pop s)) (v (forth-pop s)))
          (dict-set! (get s "vars") addr v))))
    (forth-def-prim!
      state
      "+!"
      (fn
        (s)
        (let
          ((addr (forth-pop s)) (v (forth-pop s)))
          (let
            ((cur (or (get (get s "vars") addr) 0)))
            (dict-set! (get s "vars") addr (+ cur v))))))
    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)))