diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 43e8edd0..c58dc44e 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -52,9 +52,53 @@ ((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) (fn (s) (for-each (fn (op) (op s)) ops)))) + (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"))) + (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1))))))) + +(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 @@ -139,6 +183,42 @@ (let ((name (get (get s "current-def") "name"))) (forth-compile-call 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! state "VARIABLE" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 54078477..430bda2e 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -20,8 +20,27 @@ (dict-set! s "current-def" nil) (dict-set! s "base" 10) (dict-set! s "vars" (dict)) + (dict-set! s "cstack" (list)) s))) +(define + forth-cpush + (fn (state v) (dict-set! state "cstack" (cons v (get state "cstack"))))) + +(define + forth-cpop + (fn + (state) + (let + ((cs (get state "cstack"))) + (if + (= (len cs) 0) + (forth-error state "control stack underflow") + (let + ((top (first cs))) + (dict-set! state "cstack" (rest cs)) + top))))) + (define forth-error (fn (state msg) (dict-set! state "error" msg) (raise msg))) @@ -416,7 +435,7 @@ (forth-def-prim! state "EMIT" - (fn (s) (forth-emit-str s (code-char (forth-pop s))))) + (fn (s) (forth-emit-str s (char-from-code (forth-pop s))))) (forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n"))) (forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " "))) (forth-def-prim! diff --git a/lib/forth/tests/test-phase3.sx b/lib/forth/tests/test-phase3.sx new file mode 100644 index 00000000..604d0b42 --- /dev/null +++ b/lib/forth/tests/test-phase3.sx @@ -0,0 +1,123 @@ +;; Phase 3 — control flow (IF/ELSE/THEN, BEGIN/UNTIL/WHILE/REPEAT/AGAIN, +;; DO/LOOP, return stack). Grows as each control construct lands. + +(define forth-p3-passed 0) +(define forth-p3-failed 0) +(define forth-p3-failures (list)) + +(define + forth-p3-assert + (fn + (label expected actual) + (if + (= expected actual) + (set! forth-p3-passed (+ forth-p3-passed 1)) + (begin + (set! forth-p3-failed (+ forth-p3-failed 1)) + (set! + forth-p3-failures + (concat + forth-p3-failures + (list + (str label ": expected " (str expected) " got " (str actual))))))))) + +(define + forth-p3-check-stack + (fn + (label src expected) + (let ((r (forth-run src))) (forth-p3-assert label expected (nth r 2))))) + +(define + forth-p3-if-tests + (fn + () + (forth-p3-check-stack + "IF taken (-1)" + ": Q -1 IF 10 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF not taken (0)" + ": Q 0 IF 10 THEN ; Q" + (list)) + (forth-p3-check-stack + "IF with non-zero truthy" + ": Q 42 IF 10 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF ELSE — true branch" + ": Q -1 IF 10 ELSE 20 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF ELSE — false branch" + ": Q 0 IF 10 ELSE 20 THEN ; Q" + (list 20)) + (forth-p3-check-stack + "IF consumes flag" + ": Q IF 1 ELSE 2 THEN ; 0 Q" + (list 2)) + (forth-p3-check-stack + "absolute value via IF" + ": ABS2 DUP 0 < IF NEGATE THEN ; -7 ABS2" + (list 7)) + (forth-p3-check-stack + "abs leaves positive alone" + ": ABS2 DUP 0 < IF NEGATE THEN ; 7 ABS2" + (list 7)) + (forth-p3-check-stack + "sign: negative" + ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; -3 SIGN" + (list -1)) + (forth-p3-check-stack + "sign: positive" + ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; 3 SIGN" + (list 1)) + (forth-p3-check-stack + "nested IF (both true)" + ": Q 1 IF 1 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "nested IF (inner false)" + ": Q 1 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 20)) + (forth-p3-check-stack + "nested IF (outer false)" + ": Q 0 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 30)) + (forth-p3-check-stack + "IF before other ops" + ": Q 1 IF 5 ELSE 6 THEN 2 * ; Q" + (list 10)) + (forth-p3-check-stack + "IF in chained def" + ": POS? 0 > ; + : DOUBLE-IF-POS DUP POS? IF 2 * THEN ; + 3 DOUBLE-IF-POS" + (list 6)) + (forth-p3-check-stack + "empty then branch" + ": Q 1 IF THEN 99 ; Q" + (list 99)) + (forth-p3-check-stack + "empty else branch" + ": Q 0 IF 99 ELSE THEN ; Q" + (list)) + (forth-p3-check-stack + "sequential IF blocks" + ": Q -1 IF 1 THEN -1 IF 2 THEN ; Q" + (list 1 2)))) + +(define + forth-p3-run-all + (fn + () + (set! forth-p3-passed 0) + (set! forth-p3-failed 0) + (set! forth-p3-failures (list)) + (forth-p3-if-tests) + (dict + "passed" + forth-p3-passed + "failed" + forth-p3-failed + "failures" + forth-p3-failures))) diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 1a59da2a..46aa300c 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -69,7 +69,7 @@ Representation: - [x] Tests in `lib/forth/tests/test-phase2.sx` — 26/26 pass ### Phase 3 — control flow + first Hayes tests green -- [ ] `IF`, `ELSE`, `THEN` — compile to SX `if` +- [x] `IF`, `ELSE`, `THEN` — compile to SX `if` - [ ] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops - [ ] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) - [ ] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` @@ -99,6 +99,19 @@ Representation: _Newest first._ +- **Phase 3 start — `IF`/`ELSE`/`THEN` (+18).** `lib/forth/compiler.sx` + + `tests/test-phase3.sx`. Colon-def body switched from `for-each` to + a PC-driven runner so branch ops can jump: ops now include dict tags + `{"kind" "bif"|"branch" "target" cell}` alongside the existing + `(fn (s) ...)` shape. IF compiles a `bif` with a fresh target cell + pushed to `state.cstack`; ELSE emits an unconditional `branch`, + patches the IF's target to the instruction after this branch, and + pushes the new target; THEN patches the most recent target to the + current body length. Nested IF/ELSE/THEN works via the cstack. + Also fixed `EMIT`: `code-char` → `char-from-code` (spec-correct + primitive name) so Phase 1/2 tests run green on sx_server. + 152/152 (Phase 1 + 2 + 3) green. + - **Phase 2 complete — colon defs, compile mode, VARIABLE/CONSTANT/VALUE/TO, @/!/+! (+26).** `lib/forth/compiler.sx` plus `tests/test-phase2.sx`. Colon-def body is a list of ops (one per source token) wrapped in a single