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

Recover agent-loop progress: lua/prolog/forth/erlang/haskell phases 1-2

Browse Source 
Salvaged from worktree-agent-* branches killed during sx-tree MCP outage:
- lua: tokenizer + parser + phase-2 transpile (~157 tests)
- prolog: tokenizer + parser + unification (72 tests, plan update lost to WIP)
- forth: phase-1 reader/interpreter + phase-2 colon/VARIABLE (134 tests)
- erlang: tokenizer + parser (114 tests)
- haskell: tokenizer + parse tests (43 tests)

Cherry-picked file contents only, not branch history, to avoid pulling in
unrelated ocaml-vm merge commits that were in those branches' bases.
This commit is contained in:
giles
2026-04-24 16:03:00 +00:00
parent e274878052
commit 99753580b4
32 changed files with 7803 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

433
lib/forth/runtime.sx Normal file
View File

@@ -0,0 +1,433 @@
;; Forth runtime — state, stacks, dictionary, output buffer.
;; Data stack: mutable SX list, TOS = first.
;; Return stack: separate mutable list.
;; Dictionary: SX dict {lowercased-name -> word-record}.
;; Word record: {"kind" "body" "immediate?"}; kind is "primitive" or "colon-def".
;; Output buffer: mutable string appended to by `.`, `EMIT`, `CR`, etc.
;; Compile-mode flag: "compiling" on the state.
(define
forth-make-state
(fn
()
(let
((s (dict)))
(dict-set! s "dstack" (list))
(dict-set! s "rstack" (list))
(dict-set! s "dict" (dict))
(dict-set! s "output" "")
(dict-set! s "compiling" false)
(dict-set! s "current-def" nil)
(dict-set! s "base" 10)
(dict-set! s "vars" (dict))
s)))
(define
forth-error
(fn (state msg) (dict-set! state "error" msg) (raise msg)))
(define
forth-push
(fn (state v) (dict-set! state "dstack" (cons v (get state "dstack")))))
(define
forth-pop
(fn
(state)
(let
((st (get state "dstack")))
(if
(= (len st) 0)
(forth-error state "stack underflow")
(let ((top (first st))) (dict-set! state "dstack" (rest st)) top)))))
(define
forth-peek
(fn
(state)
(let
((st (get state "dstack")))
(if (= (len st) 0) (forth-error state "stack underflow") (first st)))))
(define forth-depth (fn (state) (len (get state "dstack"))))
(define
forth-rpush
(fn (state v) (dict-set! state "rstack" (cons v (get state "rstack")))))
(define
forth-rpop
(fn
(state)
(let
((st (get state "rstack")))
(if
(= (len st) 0)
(forth-error state "return stack underflow")
(let ((top (first st))) (dict-set! state "rstack" (rest st)) top)))))
(define
forth-rpeek
(fn
(state)
(let
((st (get state "rstack")))
(if
(= (len st) 0)
(forth-error state "return stack underflow")
(first st)))))
(define
forth-emit-str
(fn (state s) (dict-set! state "output" (str (get state "output") s))))
(define
forth-make-word
(fn
(kind body immediate?)
(let
((w (dict)))
(dict-set! w "kind" kind)
(dict-set! w "body" body)
(dict-set! w "immediate?" immediate?)
w)))
(define
forth-def-prim!
(fn
(state name body)
(dict-set!
(get state "dict")
(downcase name)
(forth-make-word "primitive" body false))))
(define
forth-def-prim-imm!
(fn
(state name body)
(dict-set!
(get state "dict")
(downcase name)
(forth-make-word "primitive" body true))))
(define
forth-lookup
(fn (state name) (get (get state "dict") (downcase name))))
(define
forth-binop
(fn
(op)
(fn
(state)
(let
((b (forth-pop state)) (a (forth-pop state)))
(forth-push state (op a b))))))
(define
forth-unop
(fn
(op)
(fn (state) (let ((a (forth-pop state))) (forth-push state (op a))))))
(define
forth-cmp
(fn
(op)
(fn
(state)
(let
((b (forth-pop state)) (a (forth-pop state)))
(forth-push state (if (op a b) -1 0))))))
(define
forth-cmp0
(fn
(op)
(fn
(state)
(let ((a (forth-pop state))) (forth-push state (if (op a) -1 0))))))
(define
forth-trunc
(fn (x) (if (< x 0) (- 0 (floor (- 0 x))) (floor x))))
(define
forth-div
(fn
(a b)
(if (= b 0) (raise "division by zero") (forth-trunc (/ a b)))))
(define
forth-mod
(fn
(a b)
(if (= b 0) (raise "division by zero") (- a (* b (forth-div a b))))))
(define forth-bits-width 32)
(define
forth-to-unsigned
(fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))
(define
forth-from-unsigned
(fn
(n w)
(let ((half (pow 2 (- w 1)))) (if (>= n half) (- n (pow 2 w)) n))))
(define
forth-bitwise-step
(fn
(op ua ub out place i w)
(if
(>= i w)
out
(let
((da (mod ua 2)) (db (mod ub 2)))
(forth-bitwise-step
op
(floor (/ ua 2))
(floor (/ ub 2))
(+ out (* place (op da db)))
(* place 2)
(+ i 1)
w)))))
(define
forth-bitwise-uu
(fn
(op)
(fn
(a b)
(let
((ua (forth-to-unsigned a forth-bits-width))
(ub (forth-to-unsigned b forth-bits-width)))
(forth-from-unsigned
(forth-bitwise-step op ua ub 0 1 0 forth-bits-width)
forth-bits-width)))))
(define
forth-bit-and
(forth-bitwise-uu (fn (x y) (if (and (= x 1) (= y 1)) 1 0))))
(define
forth-bit-or
(forth-bitwise-uu (fn (x y) (if (or (= x 1) (= y 1)) 1 0))))
(define forth-bit-xor (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))
(define forth-bit-invert (fn (a) (- 0 (+ a 1))))
(define
forth-install-primitives!
(fn
(state)
(forth-def-prim! state "DUP" (fn (s) (forth-push s (forth-peek s))))
(forth-def-prim! state "DROP" (fn (s) (forth-pop s)))
(forth-def-prim!
state
"SWAP"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s a))))
(forth-def-prim!
state
"OVER"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s a))))
(forth-def-prim!
state
"ROT"
(fn
(s)
(let
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s c)
(forth-push s a))))
(forth-def-prim!
state
"-ROT"
(fn
(s)
(let
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
(forth-push s c)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"NIP"
(fn (s) (let ((b (forth-pop s))) (forth-pop s) (forth-push s b))))
(forth-def-prim!
state
"TUCK"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"?DUP"
(fn
(s)
(let ((a (forth-peek s))) (when (not (= a 0)) (forth-push s a)))))
(forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s))))
(forth-def-prim!
state
"PICK"
(fn
(s)
(let
((n (forth-pop s)) (st (get s "dstack")))
(if
(or (< n 0) (>= n (len st)))
(forth-error s "PICK out of range")
(forth-push s (nth st n))))))
(forth-def-prim!
state
"ROLL"
(fn
(s)
(let
((n (forth-pop s)) (st (get s "dstack")))
(if
(or (< n 0) (>= n (len st)))
(forth-error s "ROLL out of range")
(let
((taken (nth st n))
(before (take st n))
(after (drop st (+ n 1))))
(dict-set! s "dstack" (concat before after))
(forth-push s taken))))))
(forth-def-prim!
state
"2DUP"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s a)
(forth-push s b))))
(forth-def-prim! state "2DROP" (fn (s) (forth-pop s) (forth-pop s)))
(forth-def-prim!
state
"2SWAP"
(fn
(s)
(let
((d (forth-pop s))
(c (forth-pop s))
(b (forth-pop s))
(a (forth-pop s)))
(forth-push s c)
(forth-push s d)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"2OVER"
(fn
(s)
(let
((d (forth-pop s))
(c (forth-pop s))
(b (forth-pop s))
(a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s c)
(forth-push s d)
(forth-push s a)
(forth-push s b))))
(forth-def-prim! state "+" (forth-binop (fn (a b) (+ a b))))
(forth-def-prim! state "-" (forth-binop (fn (a b) (- a b))))
(forth-def-prim! state "*" (forth-binop (fn (a b) (* a b))))
(forth-def-prim! state "/" (forth-binop forth-div))
(forth-def-prim! state "MOD" (forth-binop forth-mod))
(forth-def-prim!
state
"/MOD"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s (forth-mod a b))
(forth-push s (forth-div a b)))))
(forth-def-prim! state "NEGATE" (forth-unop (fn (a) (- 0 a))))
(forth-def-prim! state "ABS" (forth-unop abs))
(forth-def-prim!
state
"MIN"
(forth-binop (fn (a b) (if (< a b) a b))))
(forth-def-prim!
state
"MAX"
(forth-binop (fn (a b) (if (> a b) a b))))
(forth-def-prim! state "1+" (forth-unop (fn (a) (+ a 1))))
(forth-def-prim! state "1-" (forth-unop (fn (a) (- a 1))))
(forth-def-prim! state "2+" (forth-unop (fn (a) (+ a 2))))
(forth-def-prim! state "2-" (forth-unop (fn (a) (- a 2))))
(forth-def-prim! state "2*" (forth-unop (fn (a) (* a 2))))
(forth-def-prim! state "2/" (forth-unop (fn (a) (floor (/ a 2)))))
(forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b))))
(forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b)))))
(forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b))))
(forth-def-prim! state ">" (forth-cmp (fn (a b) (> a b))))
(forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b))))
(forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b))))
(forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0))))
(forth-def-prim! state "0<>" (forth-cmp0 (fn (a) (not (= a 0)))))
(forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0))))
(forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0))))
(forth-def-prim! state "AND" (forth-binop forth-bit-and))
(forth-def-prim! state "OR" (forth-binop forth-bit-or))
(forth-def-prim! state "XOR" (forth-binop forth-bit-xor))
(forth-def-prim! state "INVERT" (forth-unop forth-bit-invert))
(forth-def-prim!
state
"."
(fn (s) (forth-emit-str s (str (forth-pop s) " "))))
(forth-def-prim!
state
".S"
(fn
(s)
(let
((st (reverse (get s "dstack"))))
(forth-emit-str s "<")
(forth-emit-str s (str (len st)))
(forth-emit-str s "> ")
(for-each (fn (v) (forth-emit-str s (str v " "))) st))))
(forth-def-prim!
state
"EMIT"
(fn (s) (forth-emit-str s (code-char (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!
state
"SPACES"
(fn
(s)
(let
((n (forth-pop s)))
(when
(> n 0)
(for-each (fn (_) (forth-emit-str s " ")) (range 0 n))))))
(forth-def-prim! state "BL" (fn (s) (forth-push s 32)))
state))