giles
c28333adb3
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
1319 lines
37 KiB
Plaintext
1319 lines
37 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))))))
|
|
|
|
;; 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)))
|