coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

forth: \, POSTPONE-imm split, >NUMBER, DOES> — Hayes 486→618 (97%)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-25 03:33:13 +00:00
parent 1b2935828c
commit c28333adb3
7 changed files with 213 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

135
lib/forth/compiler.sx
View File

@@ -101,6 +101,23 @@
(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
@@ -124,8 +141,41 @@
(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
@@ -281,15 +331,17 @@
(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 "last-defined" (get def "name"))
(dict-set! s "current-def" nil)
(dict-set! s "compiling" false))))))
(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"
@@ -492,7 +544,9 @@
(s)
(let
((tok (forth-next-token! s)))
(when (nil? tok) (forth-error s "CHAR expects a word"))
(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
@@ -501,7 +555,9 @@
(s)
(let
((tok (forth-next-token! s)))
(when (nil? tok) (forth-error s "[CHAR] expects a word"))
(when
(or (nil? tok) (= (len tok) 0))
(forth-error s "[CHAR] expects a word"))
(let
((c (char-code (substr tok 0 1))))
(if
@@ -720,7 +776,8 @@
(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! 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))
@@ -778,13 +835,16 @@
(let
((w (forth-lookup s name)))
(when (nil? w) (forth-error s (str name " ?")))
(forth-def-append!
s
(fn
(ss)
(forth-def-append!
ss
(fn (sss) (forth-execute-word sss w)))))))))
(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"
@@ -793,6 +853,13 @@
(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"
@@ -807,6 +874,24 @@
(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"
@@ -1062,6 +1147,18 @@
((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"