rose-ash/lib/forth/compiler.sx

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

(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!
      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)))