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

forth: parsing/dictionary '/[']/EXECUTE/LITERAL/POSTPONE/WORD/FIND/>BODY (Hayes 463/638, 72%)
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 00:55:34 +00:00
parent 47f66ad1be
commit 89a879799a
6 changed files with 164 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

107
lib/forth/compiler.sx
View File

@@ -285,6 +285,7 @@
(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!
@@ -711,11 +712,115 @@
(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! s name (fn (ss) (forth-push ss addr)))
(let
((w (forth-lookup s name)))
(dict-set! w "body-addr" 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
"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 " ?")))
(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)))))
(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<"