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-make-colon-body
  (fn (ops) (fn (s) (for-each (fn (op) (op s)) ops))))

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