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

forth: DO/LOOP/+LOOP/I/J/LEAVE + return stack words (+16)
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-24 17:58:37 +00:00
parent bb16477fd4
commit e066e14267
4 changed files with 272 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

146
lib/forth/compiler.sx
View File

@@ -88,8 +88,69 @@
(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"))))))))))
(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
@@ -285,6 +346,91 @@
(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-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"