Recover agent-loop progress: lua/prolog/forth/erlang/haskell phases 1-2
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:
274
lib/forth/compiler.sx
Normal file
274
lib/forth/compiler.sx
Normal file
@@ -0,0 +1,274 @@
|
||||
;; Phase 2 — colon definitions, compile mode, VARIABLE/CONSTANT/VALUE/TO, @/!/+!.
|
||||
;;
|
||||
;; Compile-mode representation:
|
||||
;; A colon-definition body is a list of "ops", each an SX lambda (fn (s) ...).
|
||||
;; : FOO 1 2 + ; -> body = (push-1 push-2 call-plus)
|
||||
;; References to other words are compiled as late-binding thunks so that
|
||||
;; self-reference works and redefinitions take effect for future runs.
|
||||
;;
|
||||
;; State additions used in Phase 2:
|
||||
;; "compiling" : bool — are we inside :..; ?
|
||||
;; "current-def" : dict {:name "..." :body (list)} during compile
|
||||
;; "vars" : dict {"addr-name" -> cell-value} for VARIABLE storage
|
||||
|
||||
(define
|
||||
forth-compile-token
|
||||
(fn
|
||||
(state tok)
|
||||
(let
|
||||
((w (forth-lookup state tok)))
|
||||
(if
|
||||
(not (nil? w))
|
||||
(if
|
||||
(get w "immediate?")
|
||||
(forth-execute-word state w)
|
||||
(forth-compile-call state tok))
|
||||
(let
|
||||
((n (forth-parse-number tok (get state "base"))))
|
||||
(if
|
||||
(not (nil? n))
|
||||
(forth-compile-lit state n)
|
||||
(forth-error state (str tok " ?"))))))))
|
||||
|
||||
(define
|
||||
forth-compile-call
|
||||
(fn
|
||||
(state name)
|
||||
(let
|
||||
((op (fn (s) (let ((w (forth-lookup s name))) (if (nil? w) (forth-error s (str name " ? (compiled)")) (forth-execute-word s w))))))
|
||||
(forth-def-append! state op))))
|
||||
|
||||
(define
|
||||
forth-compile-lit
|
||||
(fn
|
||||
(state n)
|
||||
(let ((op (fn (s) (forth-push s n)))) (forth-def-append! state op))))
|
||||
|
||||
(define
|
||||
forth-def-append!
|
||||
(fn
|
||||
(state op)
|
||||
(let
|
||||
((def (get state "current-def")))
|
||||
(dict-set! def "body" (concat (get def "body") (list op))))))
|
||||
|
||||
(define
|
||||
forth-make-colon-body
|
||||
(fn (ops) (fn (s) (for-each (fn (op) (op s)) ops))))
|
||||
|
||||
;; Override forth-interpret-token to branch on compile mode.
|
||||
(define
|
||||
forth-interpret-token
|
||||
(fn
|
||||
(state tok)
|
||||
(if
|
||||
(get state "compiling")
|
||||
(forth-compile-token state tok)
|
||||
(let
|
||||
((w (forth-lookup state tok)))
|
||||
(if
|
||||
(not (nil? w))
|
||||
(forth-execute-word state w)
|
||||
(let
|
||||
((n (forth-parse-number tok (get state "base"))))
|
||||
(if
|
||||
(not (nil? n))
|
||||
(forth-push state n)
|
||||
(forth-error state (str tok " ?")))))))))
|
||||
|
||||
;; Install `:` and `;` plus VARIABLE, CONSTANT, VALUE, TO, @, !, +!, RECURSE.
|
||||
(define
|
||||
forth-install-compiler!
|
||||
(fn
|
||||
(state)
|
||||
(forth-def-prim!
|
||||
state
|
||||
":"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((name (forth-next-token! s)))
|
||||
(when (nil? name) (forth-error s ": expects name"))
|
||||
(let
|
||||
((def (dict)))
|
||||
(dict-set! def "name" name)
|
||||
(dict-set! def "body" (list))
|
||||
(dict-set! s "current-def" def)
|
||||
(dict-set! s "compiling" true)))))
|
||||
(forth-def-prim-imm!
|
||||
state
|
||||
";"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((def (get s "current-def")))
|
||||
(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 "current-def" nil)
|
||||
(dict-set! s "compiling" false))))))
|
||||
(forth-def-prim-imm!
|
||||
state
|
||||
"IMMEDIATE"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((def-name (get (get s "current-def") "name"))
|
||||
(target
|
||||
(if
|
||||
(nil? (get s "current-def"))
|
||||
(forth-last-defined s)
|
||||
(get (get s "current-def") "name"))))
|
||||
(let
|
||||
((w (forth-lookup s target)))
|
||||
(when (not (nil? w)) (dict-set! w "immediate?" true))))))
|
||||
(forth-def-prim-imm!
|
||||
state
|
||||
"RECURSE"
|
||||
(fn
|
||||
(s)
|
||||
(when
|
||||
(not (get s "compiling"))
|
||||
(forth-error s "RECURSE only in definition"))
|
||||
(let
|
||||
((name (get (get s "current-def") "name")))
|
||||
(forth-compile-call s name))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"VARIABLE"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((name (forth-next-token! s)))
|
||||
(when (nil? name) (forth-error s "VARIABLE expects name"))
|
||||
(dict-set! (get s "vars") (downcase name) 0)
|
||||
(forth-def-prim!
|
||||
s
|
||||
name
|
||||
(fn (ss) (forth-push ss (downcase name)))))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"CONSTANT"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||
(when (nil? name) (forth-error s "CONSTANT expects name"))
|
||||
(forth-def-prim! s name (fn (ss) (forth-push ss v))))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"VALUE"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||
(when (nil? name) (forth-error s "VALUE expects name"))
|
||||
(dict-set! (get s "vars") (downcase name) v)
|
||||
(forth-def-prim!
|
||||
s
|
||||
name
|
||||
(fn
|
||||
(ss)
|
||||
(forth-push ss (get (get ss "vars") (downcase name))))))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"TO"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((name (forth-next-token! s)) (v (forth-pop s)))
|
||||
(when (nil? name) (forth-error s "TO expects name"))
|
||||
(dict-set! (get s "vars") (downcase name) v))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"@"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((addr (forth-pop s)))
|
||||
(forth-push s (or (get (get s "vars") addr) 0)))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"!"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((addr (forth-pop s)) (v (forth-pop s)))
|
||||
(dict-set! (get s "vars") addr v))))
|
||||
(forth-def-prim!
|
||||
state
|
||||
"+!"
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((addr (forth-pop s)) (v (forth-pop s)))
|
||||
(let
|
||||
((cur (or (get (get s "vars") addr) 0)))
|
||||
(dict-set! (get s "vars") addr (+ cur v))))))
|
||||
state))
|
||||
|
||||
;; Track the most recently defined word name for IMMEDIATE.
|
||||
(define forth-last-defined (fn (state) (get state "last-defined")))
|
||||
|
||||
;; forth-next-token!: during `:`, VARIABLE, CONSTANT, etc. we need to pull
|
||||
;; the next token from the *input stream* (not the dict/stack). Phase-1
|
||||
;; interpreter fed tokens one at a time via for-each, so a parsing word
|
||||
;; can't reach ahead. We rework `forth-interpret` to keep the remaining
|
||||
;; token list on the state so parsing words can consume from it.
|
||||
|
||||
(define
|
||||
forth-next-token!
|
||||
(fn
|
||||
(state)
|
||||
(let
|
||||
((rest (get state "input")))
|
||||
(if
|
||||
(or (nil? rest) (= (len rest) 0))
|
||||
nil
|
||||
(let
|
||||
((tok (first rest)))
|
||||
(dict-set! state "input" (rest-of rest))
|
||||
tok)))))
|
||||
|
||||
(define rest-of (fn (l) (rest l)))
|
||||
|
||||
;; Rewritten forth-interpret: drives a token list stored in state so that
|
||||
;; parsing words like `:`, `VARIABLE`, `CONSTANT`, `TO` can consume the
|
||||
;; following token.
|
||||
(define
|
||||
forth-interpret
|
||||
(fn
|
||||
(state src)
|
||||
(dict-set! state "input" (forth-tokens src))
|
||||
(forth-interpret-loop state)
|
||||
state))
|
||||
|
||||
(define
|
||||
forth-interpret-loop
|
||||
(fn
|
||||
(state)
|
||||
(let
|
||||
((tok (forth-next-token! state)))
|
||||
(if
|
||||
(nil? tok)
|
||||
state
|
||||
(begin
|
||||
(forth-interpret-token state tok)
|
||||
(forth-interpret-loop state))))))
|
||||
|
||||
;; Re-export forth-boot to include the compiler primitives too.
|
||||
(define
|
||||
forth-boot
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((s (forth-make-state)))
|
||||
(forth-install-primitives! s)
|
||||
(forth-install-compiler! s)
|
||||
s)))
|
||||
48
lib/forth/interpreter.sx
Normal file
48
lib/forth/interpreter.sx
Normal file
@@ -0,0 +1,48 @@
|
||||
;; Forth interpreter loop — interpret mode only (Phase 1).
|
||||
;; Reads whitespace-delimited words, looks them up, executes.
|
||||
;; Numbers (parsed via BASE) push onto the data stack.
|
||||
;; Unknown words raise "?".
|
||||
|
||||
(define
|
||||
forth-execute-word
|
||||
(fn (state word) (let ((body (get word "body"))) (body state))))
|
||||
|
||||
(define
|
||||
forth-interpret-token
|
||||
(fn
|
||||
(state tok)
|
||||
(let
|
||||
((w (forth-lookup state tok)))
|
||||
(if
|
||||
(not (nil? w))
|
||||
(forth-execute-word state w)
|
||||
(let
|
||||
((n (forth-parse-number tok (get state "base"))))
|
||||
(if
|
||||
(not (nil? n))
|
||||
(forth-push state n)
|
||||
(forth-error state (str tok " ?"))))))))
|
||||
|
||||
(define
|
||||
forth-interpret
|
||||
(fn
|
||||
(state src)
|
||||
(for-each
|
||||
(fn (tok) (forth-interpret-token state tok))
|
||||
(forth-tokens src))
|
||||
state))
|
||||
|
||||
;; Convenience: build a fresh state with primitives loaded.
|
||||
(define
|
||||
forth-boot
|
||||
(fn () (let ((s (forth-make-state))) (forth-install-primitives! s) s)))
|
||||
|
||||
;; Run source on a fresh state and return (state, output, stack-top-to-bottom).
|
||||
(define
|
||||
forth-run
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((s (forth-boot)))
|
||||
(forth-interpret s src)
|
||||
(list s (get s "output") (reverse (get s "dstack"))))))
|
||||
104
lib/forth/reader.sx
Normal file
104
lib/forth/reader.sx
Normal file
@@ -0,0 +1,104 @@
|
||||
;; Forth reader — whitespace-delimited tokens.
|
||||
|
||||
(define
|
||||
forth-whitespace?
|
||||
(fn (ch) (or (= ch " ") (or (= ch "\t") (or (= ch "\n") (= ch "\r"))))))
|
||||
|
||||
(define
|
||||
forth-tokens-loop
|
||||
(fn
|
||||
(src n i buf out)
|
||||
(if
|
||||
(>= i n)
|
||||
(if (> (len buf) 0) (concat out (list buf)) out)
|
||||
(let
|
||||
((ch (char-at src i)))
|
||||
(if
|
||||
(forth-whitespace? ch)
|
||||
(if
|
||||
(> (len buf) 0)
|
||||
(forth-tokens-loop src n (+ i 1) "" (concat out (list buf)))
|
||||
(forth-tokens-loop src n (+ i 1) buf out))
|
||||
(forth-tokens-loop src n (+ i 1) (str buf ch) out))))))
|
||||
|
||||
(define
|
||||
forth-tokens
|
||||
(fn (src) (forth-tokens-loop src (len src) 0 "" (list))))
|
||||
|
||||
(define
|
||||
forth-digit-value
|
||||
(fn
|
||||
(ch base)
|
||||
(let
|
||||
((code (char-code ch)) (cc (char-code (downcase ch))))
|
||||
(let
|
||||
((v (if (and (>= code 48) (<= code 57)) (- code 48) (if (and (>= cc 97) (<= cc 122)) (+ 10 (- cc 97)) -1))))
|
||||
(if (and (>= v 0) (< v base)) v nil)))))
|
||||
|
||||
(define
|
||||
forth-parse-digits-loop
|
||||
(fn
|
||||
(src n i base acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((d (forth-digit-value (char-at src i) base)))
|
||||
(if
|
||||
(nil? d)
|
||||
nil
|
||||
(forth-parse-digits-loop src n (+ i 1) base (+ (* acc base) d)))))))
|
||||
|
||||
(define
|
||||
forth-parse-digits
|
||||
(fn
|
||||
(src base)
|
||||
(if
|
||||
(= (len src) 0)
|
||||
nil
|
||||
(forth-parse-digits-loop src (len src) 0 base 0))))
|
||||
|
||||
(define
|
||||
forth-strip-prefix
|
||||
(fn
|
||||
(s)
|
||||
(if
|
||||
(<= (len s) 1)
|
||||
(list s 0)
|
||||
(let
|
||||
((c (char-at s 0)))
|
||||
(if
|
||||
(= c "$")
|
||||
(list (substring s 1 (len s)) 16)
|
||||
(if
|
||||
(= c "%")
|
||||
(list (substring s 1 (len s)) 2)
|
||||
(if (= c "#") (list (substring s 1 (len s)) 10) (list s 0))))))))
|
||||
|
||||
(define
|
||||
forth-parse-number
|
||||
(fn
|
||||
(tok base)
|
||||
(let
|
||||
((n (len tok)))
|
||||
(if
|
||||
(= n 0)
|
||||
nil
|
||||
(if
|
||||
(and
|
||||
(= n 3)
|
||||
(and (= (char-at tok 0) "'") (= (char-at tok 2) "'")))
|
||||
(char-code (char-at tok 1))
|
||||
(let
|
||||
((neg? (and (> n 1) (= (char-at tok 0) "-"))))
|
||||
(let
|
||||
((s1 (if neg? (substring tok 1 n) tok)))
|
||||
(let
|
||||
((pair (forth-strip-prefix s1)))
|
||||
(let
|
||||
((s (first pair)) (b-override (nth pair 1)))
|
||||
(let
|
||||
((b (if (= b-override 0) base b-override)))
|
||||
(let
|
||||
((v (forth-parse-digits s b)))
|
||||
(if (nil? v) nil (if neg? (- 0 v) v)))))))))))))
|
||||
433
lib/forth/runtime.sx
Normal file
433
lib/forth/runtime.sx
Normal 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))
|
||||
224
lib/forth/tests/test-phase1.sx
Normal file
224
lib/forth/tests/test-phase1.sx
Normal file
@@ -0,0 +1,224 @@
|
||||
;; Phase 1 — reader + interpret mode + core words.
|
||||
;; Simple assertion driver: (forth-test label input expected-stack)
|
||||
;; forth-run returns (state, output, stack-bottom-to-top).
|
||||
|
||||
(define forth-tests-passed 0)
|
||||
(define forth-tests-failed 0)
|
||||
(define forth-tests-failures (list))
|
||||
|
||||
(define
|
||||
forth-assert
|
||||
(fn
|
||||
(label expected actual)
|
||||
(if
|
||||
(= expected actual)
|
||||
(set! forth-tests-passed (+ forth-tests-passed 1))
|
||||
(begin
|
||||
(set! forth-tests-failed (+ forth-tests-failed 1))
|
||||
(set!
|
||||
forth-tests-failures
|
||||
(concat
|
||||
forth-tests-failures
|
||||
(list
|
||||
(str label ": expected " (str expected) " got " (str actual)))))))))
|
||||
|
||||
(define
|
||||
forth-check-stack
|
||||
(fn
|
||||
(label src expected)
|
||||
(let ((r (forth-run src))) (forth-assert label expected (nth r 2)))))
|
||||
|
||||
(define
|
||||
forth-check-output
|
||||
(fn
|
||||
(label src expected)
|
||||
(let ((r (forth-run src))) (forth-assert label expected (nth r 1)))))
|
||||
|
||||
(define
|
||||
forth-reader-tests
|
||||
(fn
|
||||
()
|
||||
(forth-assert
|
||||
"tokens split"
|
||||
(list "1" "2" "+")
|
||||
(forth-tokens " 1 2 + "))
|
||||
(forth-assert "tokens empty" (list) (forth-tokens ""))
|
||||
(forth-assert
|
||||
"tokens tab/newline"
|
||||
(list "a" "b" "c")
|
||||
(forth-tokens "a\tb\nc"))
|
||||
(forth-assert "number decimal" 42 (forth-parse-number "42" 10))
|
||||
(forth-assert "number negative" -7 (forth-parse-number "-7" 10))
|
||||
(forth-assert "number hex prefix" 255 (forth-parse-number "$ff" 10))
|
||||
(forth-assert "number binary prefix" 10 (forth-parse-number "%1010" 10))
|
||||
(forth-assert
|
||||
"number decimal override under hex base"
|
||||
123
|
||||
(forth-parse-number "#123" 16))
|
||||
(forth-assert "number none" nil (forth-parse-number "abc" 10))
|
||||
(forth-assert "number in hex base" 255 (forth-parse-number "ff" 16))
|
||||
(forth-assert
|
||||
"number negative hex prefix"
|
||||
-16
|
||||
(forth-parse-number "-$10" 10))
|
||||
(forth-assert "char literal" 65 (forth-parse-number "'A'" 10))
|
||||
(forth-assert
|
||||
"mixed-case digit in base 10"
|
||||
nil
|
||||
(forth-parse-number "1A" 10))
|
||||
(forth-assert
|
||||
"mixed-case digit in base 16"
|
||||
26
|
||||
(forth-parse-number "1a" 16))))
|
||||
|
||||
(define
|
||||
forth-stack-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "push literal" "42" (list 42))
|
||||
(forth-check-stack "push multiple" "1 2 3" (list 1 2 3))
|
||||
(forth-check-stack "DUP" "7 DUP" (list 7 7))
|
||||
(forth-check-stack "DROP" "1 2 DROP" (list 1))
|
||||
(forth-check-stack "SWAP" "1 2 SWAP" (list 2 1))
|
||||
(forth-check-stack "OVER" "1 2 OVER" (list 1 2 1))
|
||||
(forth-check-stack "ROT" "1 2 3 ROT" (list 2 3 1))
|
||||
(forth-check-stack "-ROT" "1 2 3 -ROT" (list 3 1 2))
|
||||
(forth-check-stack "NIP" "1 2 NIP" (list 2))
|
||||
(forth-check-stack "TUCK" "1 2 TUCK" (list 2 1 2))
|
||||
(forth-check-stack "?DUP non-zero" "5 ?DUP" (list 5 5))
|
||||
(forth-check-stack "?DUP zero" "0 ?DUP" (list 0))
|
||||
(forth-check-stack "DEPTH empty" "DEPTH" (list 0))
|
||||
(forth-check-stack "DEPTH non-empty" "1 2 3 DEPTH" (list 1 2 3 3))
|
||||
(forth-check-stack "PICK 0" "10 20 30 0 PICK" (list 10 20 30 30))
|
||||
(forth-check-stack "PICK 1" "10 20 30 1 PICK" (list 10 20 30 20))
|
||||
(forth-check-stack "PICK 2" "10 20 30 2 PICK" (list 10 20 30 10))
|
||||
(forth-check-stack "ROLL 0 is no-op" "10 20 30 0 ROLL" (list 10 20 30))
|
||||
(forth-check-stack "ROLL 2" "10 20 30 2 ROLL" (list 20 30 10))
|
||||
(forth-check-stack "2DUP" "1 2 2DUP" (list 1 2 1 2))
|
||||
(forth-check-stack "2DROP" "1 2 3 4 2DROP" (list 1 2))
|
||||
(forth-check-stack "2SWAP" "1 2 3 4 2SWAP" (list 3 4 1 2))
|
||||
(forth-check-stack "2OVER" "1 2 3 4 2OVER" (list 1 2 3 4 1 2))))
|
||||
|
||||
(define
|
||||
forth-arith-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "+" "3 4 +" (list 7))
|
||||
(forth-check-stack "-" "10 3 -" (list 7))
|
||||
(forth-check-stack "*" "6 7 *" (list 42))
|
||||
(forth-check-stack "/ positive" "7 2 /" (list 3))
|
||||
(forth-check-stack "/ negative numerator" "-7 2 /" (list -3))
|
||||
(forth-check-stack "/ both negative" "-7 -2 /" (list 3))
|
||||
(forth-check-stack "MOD positive" "7 3 MOD" (list 1))
|
||||
(forth-check-stack "MOD negative" "-7 3 MOD" (list -1))
|
||||
(forth-check-stack "/MOD positive" "7 3 /MOD" (list 1 2))
|
||||
(forth-check-stack "NEGATE" "5 NEGATE" (list -5))
|
||||
(forth-check-stack "ABS negative" "-5 ABS" (list 5))
|
||||
(forth-check-stack "ABS positive" "5 ABS" (list 5))
|
||||
(forth-check-stack "MIN a<b" "3 5 MIN" (list 3))
|
||||
(forth-check-stack "MIN a>b" "5 3 MIN" (list 3))
|
||||
(forth-check-stack "MAX a<b" "3 5 MAX" (list 5))
|
||||
(forth-check-stack "MAX a>b" "5 3 MAX" (list 5))
|
||||
(forth-check-stack "1+" "5 1+" (list 6))
|
||||
(forth-check-stack "1-" "5 1-" (list 4))
|
||||
(forth-check-stack "2+" "5 2+" (list 7))
|
||||
(forth-check-stack "2-" "5 2-" (list 3))
|
||||
(forth-check-stack "2*" "5 2*" (list 10))
|
||||
(forth-check-stack "2/" "7 2/" (list 3))))
|
||||
|
||||
(define
|
||||
forth-cmp-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "= true" "5 5 =" (list -1))
|
||||
(forth-check-stack "= false" "5 6 =" (list 0))
|
||||
(forth-check-stack "<> true" "5 6 <>" (list -1))
|
||||
(forth-check-stack "<> false" "5 5 <>" (list 0))
|
||||
(forth-check-stack "< true" "3 5 <" (list -1))
|
||||
(forth-check-stack "< false" "5 3 <" (list 0))
|
||||
(forth-check-stack "> true" "5 3 >" (list -1))
|
||||
(forth-check-stack "> false" "3 5 >" (list 0))
|
||||
(forth-check-stack "<= equal" "5 5 <=" (list -1))
|
||||
(forth-check-stack "<= less" "3 5 <=" (list -1))
|
||||
(forth-check-stack ">= equal" "5 5 >=" (list -1))
|
||||
(forth-check-stack ">= greater" "5 3 >=" (list -1))
|
||||
(forth-check-stack "0= true" "0 0=" (list -1))
|
||||
(forth-check-stack "0= false" "1 0=" (list 0))
|
||||
(forth-check-stack "0<> true" "1 0<>" (list -1))
|
||||
(forth-check-stack "0<> false" "0 0<>" (list 0))
|
||||
(forth-check-stack "0< true" "-5 0<" (list -1))
|
||||
(forth-check-stack "0< false" "5 0<" (list 0))
|
||||
(forth-check-stack "0> true" "5 0>" (list -1))
|
||||
(forth-check-stack "0> false" "-5 0>" (list 0))))
|
||||
|
||||
(define
|
||||
forth-bitwise-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "AND flags" "-1 0 AND" (list 0))
|
||||
(forth-check-stack "AND flags 2" "-1 -1 AND" (list -1))
|
||||
(forth-check-stack "AND 12 10" "12 10 AND" (list 8))
|
||||
(forth-check-stack "OR flags" "-1 0 OR" (list -1))
|
||||
(forth-check-stack "OR 12 10" "12 10 OR" (list 14))
|
||||
(forth-check-stack "XOR 12 10" "12 10 XOR" (list 6))
|
||||
(forth-check-stack "XOR same" "15 15 XOR" (list 0))
|
||||
(forth-check-stack "INVERT 0" "0 INVERT" (list -1))
|
||||
(forth-check-stack "INVERT 5" "5 INVERT" (list -6))
|
||||
(forth-check-stack "double INVERT" "7 INVERT INVERT" (list 7))))
|
||||
|
||||
(define
|
||||
forth-io-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-output "." "42 ." "42 ")
|
||||
(forth-check-output ". two values" "1 2 . ." "2 1 ")
|
||||
(forth-check-output ".S empty" ".S" "<0> ")
|
||||
(forth-check-output ".S three" "1 2 3 .S" "<3> 1 2 3 ")
|
||||
(forth-check-output "EMIT A" "65 EMIT" "A")
|
||||
(forth-check-output "CR" "CR" "\n")
|
||||
(forth-check-output "SPACE" "SPACE" " ")
|
||||
(forth-check-output "SPACES 3" "3 SPACES" " ")
|
||||
(forth-check-output "SPACES 0" "0 SPACES" "")
|
||||
(forth-check-stack "BL" "BL" (list 32))))
|
||||
|
||||
(define
|
||||
forth-case-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "case-insensitive DUP" "5 dup" (list 5 5))
|
||||
(forth-check-stack "case-insensitive SWAP" "1 2 Swap" (list 2 1))))
|
||||
|
||||
(define
|
||||
forth-mixed-tests
|
||||
(fn
|
||||
()
|
||||
(forth-check-stack "chained arith" "1 2 3 + +" (list 6))
|
||||
(forth-check-stack "(3+4)*2" "3 4 + 2 *" (list 14))
|
||||
(forth-check-stack "max of three" "5 3 MAX 7 MAX" (list 7))
|
||||
(forth-check-stack "abs chain" "-5 ABS 1+" (list 6))
|
||||
(forth-check-stack "swap then add" "5 7 SWAP -" (list 2))
|
||||
(forth-check-stack "hex literal" "$10 $20 +" (list 48))
|
||||
(forth-check-stack "binary literal" "%1010 %0011 +" (list 13))))
|
||||
|
||||
(define
|
||||
forth-run-all-phase1-tests
|
||||
(fn
|
||||
()
|
||||
(set! forth-tests-passed 0)
|
||||
(set! forth-tests-failed 0)
|
||||
(set! forth-tests-failures (list))
|
||||
(forth-reader-tests)
|
||||
(forth-stack-tests)
|
||||
(forth-arith-tests)
|
||||
(forth-cmp-tests)
|
||||
(forth-bitwise-tests)
|
||||
(forth-io-tests)
|
||||
(forth-case-tests)
|
||||
(forth-mixed-tests)
|
||||
(dict
|
||||
"passed"
|
||||
forth-tests-passed
|
||||
"failed"
|
||||
forth-tests-failed
|
||||
"failures"
|
||||
forth-tests-failures)))
|
||||
146
lib/forth/tests/test-phase2.sx
Normal file
146
lib/forth/tests/test-phase2.sx
Normal file
@@ -0,0 +1,146 @@
|
||||
;; Phase 2 — colon definitions + compile mode + variables/values/fetch/store.
|
||||
|
||||
(define forth-p2-passed 0)
|
||||
(define forth-p2-failed 0)
|
||||
(define forth-p2-failures (list))
|
||||
|
||||
(define
|
||||
forth-p2-assert
|
||||
(fn
|
||||
(label expected actual)
|
||||
(if
|
||||
(= expected actual)
|
||||
(set! forth-p2-passed (+ forth-p2-passed 1))
|
||||
(begin
|
||||
(set! forth-p2-failed (+ forth-p2-failed 1))
|
||||
(set!
|
||||
forth-p2-failures
|
||||
(concat
|
||||
forth-p2-failures
|
||||
(list
|
||||
(str label ": expected " (str expected) " got " (str actual)))))))))
|
||||
|
||||
(define
|
||||
forth-p2-check-stack
|
||||
(fn
|
||||
(label src expected)
|
||||
(let ((r (forth-run src))) (forth-p2-assert label expected (nth r 2)))))
|
||||
|
||||
(define
|
||||
forth-p2-check-output
|
||||
(fn
|
||||
(label src expected)
|
||||
(let ((r (forth-run src))) (forth-p2-assert label expected (nth r 1)))))
|
||||
|
||||
(define
|
||||
forth-p2-colon-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-stack "simple colon" ": DOUBLE 2 * ; 7 DOUBLE" (list 14))
|
||||
(forth-p2-check-stack "three-op body" ": ADD3 + + ; 1 2 3 ADD3" (list 6))
|
||||
(forth-p2-check-stack
|
||||
"nested call"
|
||||
": SQR DUP * ; : SOS SQR SWAP SQR + ; 3 4 SOS"
|
||||
(list 25))
|
||||
(forth-p2-check-stack
|
||||
"deep chain"
|
||||
": D 2 ; : B D ; : A B D * ; A"
|
||||
(list 4))
|
||||
(forth-p2-check-stack
|
||||
"colon uses literal"
|
||||
": FOO 1 2 + ; FOO FOO +"
|
||||
(list 6))
|
||||
(forth-p2-check-stack "case-insensitive def" ": BAR 9 ; bar" (list 9))
|
||||
(forth-p2-check-stack
|
||||
"redefinition picks newest"
|
||||
": F 1 ; : F 2 ; F"
|
||||
(list 2))
|
||||
(forth-p2-check-stack
|
||||
"negative literal in def"
|
||||
": NEG5 -5 ; NEG5"
|
||||
(list -5))
|
||||
(forth-p2-check-stack "hex literal in def" ": X $10 ; X" (list 16))))
|
||||
|
||||
(define
|
||||
forth-p2-var-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-stack "VARIABLE + !, @" "VARIABLE X 42 X ! X @" (list 42))
|
||||
(forth-p2-check-stack "uninitialised @ is 0" "VARIABLE Y Y @" (list 0))
|
||||
(forth-p2-check-stack
|
||||
"two variables"
|
||||
"VARIABLE A VARIABLE B 1 A ! 2 B ! A @ B @ +"
|
||||
(list 3))
|
||||
(forth-p2-check-stack
|
||||
"+! increments"
|
||||
"VARIABLE X 10 X ! 5 X +! X @"
|
||||
(list 15))
|
||||
(forth-p2-check-stack
|
||||
"+! multiple"
|
||||
"VARIABLE X 0 X ! 1 X +! 2 X +! 3 X +! X @"
|
||||
(list 6))))
|
||||
|
||||
(define
|
||||
forth-p2-const-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-stack "CONSTANT" "100 CONSTANT C C" (list 100))
|
||||
(forth-p2-check-stack
|
||||
"CONSTANT used twice"
|
||||
"5 CONSTANT FIVE FIVE FIVE *"
|
||||
(list 25))
|
||||
(forth-p2-check-stack
|
||||
"CONSTANT in colon"
|
||||
"3 CONSTANT T : TRIPLE T * ; 7 TRIPLE"
|
||||
(list 21))))
|
||||
|
||||
(define
|
||||
forth-p2-value-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-stack "VALUE initial" "50 VALUE V V" (list 50))
|
||||
(forth-p2-check-stack "TO overwrites" "50 VALUE V 99 TO V V" (list 99))
|
||||
(forth-p2-check-stack "TO twice" "1 VALUE V 2 TO V 3 TO V V" (list 3))
|
||||
(forth-p2-check-stack "VALUE in arithmetic" "7 VALUE V V 3 +" (list 10))))
|
||||
|
||||
(define
|
||||
forth-p2-io-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-output
|
||||
"colon prints"
|
||||
": HELLO 72 EMIT 73 EMIT ; HELLO"
|
||||
"HI")
|
||||
(forth-p2-check-output "colon CR" ": LINE 42 . CR ; LINE" "42 \n")))
|
||||
|
||||
(define
|
||||
forth-p2-mode-tests
|
||||
(fn
|
||||
()
|
||||
(forth-p2-check-stack "empty colon body" ": NOP ; 5 NOP" (list 5))
|
||||
(forth-p2-check-stack
|
||||
"colon using DUP"
|
||||
": TWICE DUP ; 9 TWICE"
|
||||
(list 9 9))
|
||||
(forth-p2-check-stack "IMMEDIATE NOP" ": X ; X" (list))))
|
||||
|
||||
(define
|
||||
forth-p2-run-all
|
||||
(fn
|
||||
()
|
||||
(set! forth-p2-passed 0)
|
||||
(set! forth-p2-failed 0)
|
||||
(set! forth-p2-failures (list))
|
||||
(forth-p2-colon-tests)
|
||||
(forth-p2-var-tests)
|
||||
(forth-p2-const-tests)
|
||||
(forth-p2-value-tests)
|
||||
(forth-p2-io-tests)
|
||||
(forth-p2-mode-tests)
|
||||
(dict
|
||||
"passed"
|
||||
forth-p2-passed
|
||||
"failed"
|
||||
forth-p2-failed
|
||||
"failures"
|
||||
forth-p2-failures)))
|
||||
Reference in New Issue
Block a user