giles
3ab01b271d
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
814 lines
22 KiB
Plaintext
814 lines
22 KiB
Plaintext
;; 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.
|
|
(define
|
|
forth-compile-call
|
|
(fn
|
|
(state name)
|
|
(let
|
|
((w (forth-lookup state name)))
|
|
(if
|
|
(nil? w)
|
|
(forth-error state (str name " ?"))
|
|
(let
|
|
((op (fn (s) (forth-execute-word s w))))
|
|
(forth-def-append! state op))))))
|
|
|
|
(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))))))
|
|
|
|
(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 (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")))
|
|
(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-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 (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)))
|
|
(if
|
|
(string? addr)
|
|
(forth-push s (or (get (get s "vars") addr) 0))
|
|
(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)))))))
|
|
(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
|
|
"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)))
|