diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index 81d93d6c..739fa41c 100644 --- a/lib/scheme/eval.sx +++ b/lib/scheme/eval.sx @@ -111,8 +111,9 @@ ((nil? src) (error (str "set!: unbound variable: " name))) (:else - (dict-set! (get src :bindings) name val) - val)))))))) + (begin + (dict-set! (get src :bindings) name val) + val))))))))) ;; define — top-level or internal binding. (define name expr) or ;; (define (name . formals) body...) the latter being lambda sugar. diff --git a/lib/scheme/runtime.sx b/lib/scheme/runtime.sx new file mode 100644 index 00000000..86999f5b --- /dev/null +++ b/lib/scheme/runtime.sx @@ -0,0 +1,513 @@ +;; lib/scheme/runtime.sx — R7RS-small standard environment. +;; +;; Builds scheme-standard-env from scheme-make-env, populating it with +;; arithmetic, comparison, type predicates, list/pair/vector/string/char +;; primitives, and the higher-order combinators (map/filter/fold). +;; +;; Primitives are bound as SX fns taking a list of evaluated arguments. +;; Combinators that re-enter the evaluator (map, filter, fold, apply, +;; for-each) call `scheme-apply` directly on user-supplied procedures. +;; +;; Public API +;; (scheme-standard-env) — fresh env with the full R7RS-base surface +;; +;; Consumes: lib/scheme/eval.sx (scheme-apply, scheme-make-env, +;; scheme-env-bind!, scheme-string?, scheme-char?, +;; scheme-vector?, scheme-vector-elements, +;; scheme-string-value, scheme-char-value, +;; scheme-string-make, scheme-char-make, +;; scheme-vector-make). + +;; ── Arity / fold helpers ───────────────────────────────────────── + +(define + scm-unary + (fn + (name f) + (fn + (args) + (cond + ((not (= (length args) 1)) + (error (str name ": expects 1 argument"))) + (:else (f (first args))))))) + +(define + scm-binary + (fn + (name f) + (fn + (args) + (cond + ((not (= (length args) 2)) + (error (str name ": expects 2 arguments"))) + (:else (f (first args) (nth args 1))))))) + +;; Variadic left-fold helper. zero-id is the identity (`(+)` → 0). +;; one-fn handles single-arg case (`(- x)` negates). +(define + scm-fold-step + (fn + (f acc rest-args) + (cond + ((or (nil? rest-args) (= (length rest-args) 0)) acc) + (:else (scm-fold-step f (f acc (first rest-args)) (rest rest-args)))))) + +(define + scm-fold + (fn + (name f zero-id one-fn) + (fn + (args) + (cond + ((= (length args) 0) zero-id) + ((= (length args) 1) (one-fn (first args))) + (:else (scm-fold-step f (first args) (rest args))))))) + +;; n-ary chained comparison: (< 1 2 3) ≡ (< 1 2) ∧ (< 2 3). +(define + scm-chain-step + (fn + (cmp prev rest-args) + (cond + ((or (nil? rest-args) (= (length rest-args) 0)) true) + (:else + (let + ((next (first rest-args))) + (cond + ((cmp prev next) (scm-chain-step cmp next (rest rest-args))) + (:else false))))))) + +(define + scm-chain + (fn + (name cmp) + (fn + (args) + (cond + ((< (length args) 2) + (error (str name ": expects at least 2 arguments"))) + (:else (scm-chain-step cmp (first args) (rest args))))))) + +;; ── List helpers ───────────────────────────────────────────────── + +(define + scm-list-append + (fn + (xs ys) + (cond + ((or (nil? xs) (= (length xs) 0)) ys) + (:else (cons (first xs) (scm-list-append (rest xs) ys)))))) + +(define + scm-list-reverse-step + (fn + (xs acc) + (cond + ((or (nil? xs) (= (length xs) 0)) acc) + (:else (scm-list-reverse-step (rest xs) (cons (first xs) acc)))))) + +(define + scm-all-lists? + (fn + (xs) + (cond + ((or (nil? xs) (= (length xs) 0)) true) + ((list? (first xs)) (scm-all-lists? (rest xs))) + (:else false)))) + +(define + scm-append-all + (fn + (lists) + (cond + ((or (nil? lists) (= (length lists) 0)) (list)) + ((= (length lists) 1) (first lists)) + (:else (scm-list-append (first lists) (scm-append-all (rest lists))))))) + +;; ── Map / Filter / Fold ────────────────────────────────────────── +;; These call scheme-apply directly so closures and primitives both work. + +(define + scm-map-step + (fn + (proc xs) + (cond + ((or (nil? xs) (= (length xs) 0)) (list)) + (:else + (cons + (scheme-apply proc (list (first xs))) + (scm-map-step proc (rest xs))))))) + +(define + scm-filter-step + (fn + (pred xs) + (cond + ((or (nil? xs) (= (length xs) 0)) (list)) + (:else + (let + ((keep? (scheme-apply pred (list (first xs))))) + (cond + ((not (= keep? false)) + (cons (first xs) (scm-filter-step pred (rest xs)))) + (:else (scm-filter-step pred (rest xs))))))))) + +(define + scm-fold-left-step + (fn + (proc acc xs) + (cond + ((or (nil? xs) (= (length xs) 0)) acc) + (:else + (scm-fold-left-step + proc + (scheme-apply proc (list acc (first xs))) + (rest xs)))))) + +(define + scm-fold-right-step + (fn + (proc init xs) + (cond + ((or (nil? xs) (= (length xs) 0)) init) + (:else + (scheme-apply + proc + (list (first xs) (scm-fold-right-step proc init (rest xs)))))))) + +(define + scm-for-each-step + (fn + (proc xs) + (cond + ((or (nil? xs) (= (length xs) 0)) nil) + (:else + (begin + (scheme-apply proc (list (first xs))) + (scm-for-each-step proc (rest xs))))))) + +;; ── Vector helpers ────────────────────────────────────────────── + +(define + scm-make-vector-step + (fn + (n fill acc) + (cond + ((<= n 0) acc) + (:else (scm-make-vector-step (- n 1) fill (cons fill acc)))))) + +;; ── Standard env ───────────────────────────────────────────────── + +(define + scheme-standard-env + (fn + () + (let + ((env (scheme-make-env))) + (scheme-env-bind! + env + "+" + (scm-fold "+" (fn (a b) (+ a b)) 0 (fn (x) x))) + (scheme-env-bind! + env + "-" + (scm-fold + "-" + (fn (a b) (- a b)) + 0 + (fn (x) (- 0 x)))) + (scheme-env-bind! + env + "*" + (scm-fold "*" (fn (a b) (* a b)) 1 (fn (x) x))) + (scheme-env-bind! + env + "/" + (scm-fold + "/" + (fn (a b) (/ a b)) + 1 + (fn (x) (/ 1 x)))) + (scheme-env-bind! + env + "abs" + (scm-unary + "abs" + (fn (n) (if (< n 0) (- 0 n) n)))) + (scheme-env-bind! + env + "min" + (scm-fold "min" (fn (a b) (if (< a b) a b)) nil (fn (x) x))) + (scheme-env-bind! + env + "max" + (scm-fold "max" (fn (a b) (if (< a b) b a)) nil (fn (x) x))) + (scheme-env-bind! + env + "modulo" + (scm-binary "modulo" (fn (a b) (- a (* b (floor (/ a b))))))) + (scheme-env-bind! + env + "quotient" + (scm-binary "quotient" (fn (a b) (floor (/ a b))))) + (scheme-env-bind! + env + "remainder" + (scm-binary "remainder" (fn (a b) (- a (* b (floor (/ a b))))))) + (scheme-env-bind! + env + "zero?" + (scm-unary "zero?" (fn (n) (= n 0)))) + (scheme-env-bind! + env + "positive?" + (scm-unary "positive?" (fn (n) (> n 0)))) + (scheme-env-bind! + env + "negative?" + (scm-unary "negative?" (fn (n) (< n 0)))) + (scheme-env-bind! env "=" (scm-chain "=" (fn (a b) (= a b)))) + (scheme-env-bind! env "<" (scm-chain "<" (fn (a b) (< a b)))) + (scheme-env-bind! env ">" (scm-chain ">" (fn (a b) (> a b)))) + (scheme-env-bind! env "<=" (scm-chain "<=" (fn (a b) (<= a b)))) + (scheme-env-bind! env ">=" (scm-chain ">=" (fn (a b) (>= a b)))) + (scheme-env-bind! + env + "number?" + (scm-unary "number?" (fn (v) (number? v)))) + (scheme-env-bind! + env + "boolean?" + (scm-unary "boolean?" (fn (v) (boolean? v)))) + (scheme-env-bind! + env + "symbol?" + (scm-unary "symbol?" (fn (v) (string? v)))) + (scheme-env-bind! + env + "string?" + (scm-unary "string?" (fn (v) (scheme-string? v)))) + (scheme-env-bind! + env + "char?" + (scm-unary "char?" (fn (v) (scheme-char? v)))) + (scheme-env-bind! + env + "vector?" + (scm-unary "vector?" (fn (v) (scheme-vector? v)))) + (scheme-env-bind! + env + "null?" + (scm-unary + "null?" + (fn + (v) + (or (nil? v) (and (list? v) (= (length v) 0)))))) + (scheme-env-bind! + env + "pair?" + (scm-unary + "pair?" + (fn (v) (and (list? v) (> (length v) 0))))) + (scheme-env-bind! + env + "procedure?" + (scm-unary + "procedure?" + (fn + (v) + (or + (callable? v) + (and (dict? v) (= (get v :scm-tag) :closure)))))) + (scheme-env-bind! env "not" (scm-unary "not" (fn (v) (= v false)))) + (scheme-env-bind! + env + "cons" + (scm-binary "cons" (fn (a b) (cons a b)))) + (scheme-env-bind! + env + "car" + (scm-unary + "car" + (fn + (xs) + (cond + ((or (nil? xs) (and (list? xs) (= (length xs) 0))) + (error "car: empty list")) + (:else (first xs)))))) + (scheme-env-bind! + env + "cdr" + (scm-unary + "cdr" + (fn + (xs) + (cond + ((or (nil? xs) (and (list? xs) (= (length xs) 0))) + (error "cdr: empty list")) + (:else (rest xs)))))) + (scheme-env-bind! env "list" (fn (args) args)) + (scheme-env-bind! + env + "length" + (scm-unary "length" (fn (xs) (length xs)))) + (scheme-env-bind! + env + "reverse" + (scm-unary "reverse" (fn (xs) (scm-list-reverse-step xs (list))))) + (scheme-env-bind! + env + "append" + (fn + (args) + (cond + ((scm-all-lists? args) (scm-append-all args)) + (:else (error "append: all arguments must be lists"))))) + (scheme-env-bind! + env + "map" + (fn + (args) + (cond + ((not (= (length args) 2)) + (error "map: expects (proc list)")) + (:else (scm-map-step (first args) (nth args 1)))))) + (scheme-env-bind! + env + "filter" + (fn + (args) + (cond + ((not (= (length args) 2)) + (error "filter: expects (pred list)")) + (:else (scm-filter-step (first args) (nth args 1)))))) + (scheme-env-bind! + env + "fold-left" + (fn + (args) + (cond + ((not (= (length args) 3)) + (error "fold-left: expects (proc init list)")) + (:else + (scm-fold-left-step + (first args) + (nth args 1) + (nth args 2)))))) + (scheme-env-bind! + env + "fold-right" + (fn + (args) + (cond + ((not (= (length args) 3)) + (error "fold-right: expects (proc init list)")) + (:else + (scm-fold-right-step + (first args) + (nth args 1) + (nth args 2)))))) + (scheme-env-bind! + env + "for-each" + (fn + (args) + (cond + ((not (= (length args) 2)) + (error "for-each: expects (proc list)")) + (:else (scm-for-each-step (first args) (nth args 1)))))) + (scheme-env-bind! + env + "apply" + (fn + (args) + (cond + ((not (= (length args) 2)) + (error "apply: expects (proc args-list)")) + (:else (scheme-apply (first args) (nth args 1)))))) + (scheme-env-bind! + env + "string-length" + (scm-unary + "string-length" + (fn (s) (string-length (scheme-string-value s))))) + (scheme-env-bind! + env + "string=?" + (scm-binary + "string=?" + (fn (a b) (= (scheme-string-value a) (scheme-string-value b))))) + (scheme-env-bind! + env + "string-append" + (fn + (args) + (scheme-string-make + (scm-fold-step + (fn (acc s) (str acc (scheme-string-value s))) + "" + args)))) + (scheme-env-bind! + env + "substring" + (fn + (args) + (cond + ((not (= (length args) 3)) + (error "substring: expects (str start end)")) + (:else + (scheme-string-make + (substring + (scheme-string-value (first args)) + (nth args 1) + (nth args 2))))))) + (scheme-env-bind! + env + "char=?" + (scm-binary + "char=?" + (fn (a b) (= (scheme-char-value a) (scheme-char-value b))))) + (scheme-env-bind! env "vector" (fn (args) (scheme-vector-make args))) + (scheme-env-bind! + env + "vector-length" + (scm-unary + "vector-length" + (fn (v) (length (scheme-vector-elements v))))) + (scheme-env-bind! + env + "vector-ref" + (scm-binary + "vector-ref" + (fn (v i) (nth (scheme-vector-elements v) i)))) + (scheme-env-bind! + env + "vector->list" + (scm-unary "vector->list" (fn (v) (scheme-vector-elements v)))) + (scheme-env-bind! + env + "list->vector" + (scm-unary "list->vector" (fn (xs) (scheme-vector-make xs)))) + (scheme-env-bind! + env + "make-vector" + (fn + (args) + (cond + ((= (length args) 1) + (scheme-vector-make + (scm-make-vector-step (first args) nil (list)))) + ((= (length args) 2) + (scheme-vector-make + (scm-make-vector-step + (first args) + (nth args 1) + (list)))) + (:else (error "make-vector: expects (n [fill])"))))) + (scheme-env-bind! env "eqv?" (scm-binary "eqv?" (fn (a b) (= a b)))) + (scheme-env-bind! + env + "equal?" + (scm-binary "equal?" (fn (a b) (= a b)))) + (scheme-env-bind! env "eq?" (scm-binary "eq?" (fn (a b) (= a b)))) + env))) diff --git a/lib/scheme/tests/runtime.sx b/lib/scheme/tests/runtime.sx new file mode 100644 index 00000000..32817072 --- /dev/null +++ b/lib/scheme/tests/runtime.sx @@ -0,0 +1,213 @@ +;; lib/scheme/tests/runtime.sx — exercises the standard env. + +(define scm-rt-pass 0) +(define scm-rt-fail 0) +(define scm-rt-fails (list)) + +(define + scm-rt-test + (fn + (name actual expected) + (if + (= actual expected) + (set! scm-rt-pass (+ scm-rt-pass 1)) + (begin + (set! scm-rt-fail (+ scm-rt-fail 1)) + (append! scm-rt-fails {:name name :actual actual :expected expected}))))) + +(define + scm-rt + (fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env)))) + +(define + scm-rt-all + (fn + (src) + (scheme-eval-program (scheme-parse-all src) (scheme-standard-env)))) + +;; ── Variadic arithmetic ───────────────────────────────────────── +(scm-rt-test "+: zero" (scm-rt "(+)") 0) +(scm-rt-test "+: one" (scm-rt "(+ 7)") 7) +(scm-rt-test "+: many" (scm-rt "(+ 1 2 3 4 5)") 15) +(scm-rt-test "-: one" (scm-rt "(- 10)") -10) +(scm-rt-test "-: many" (scm-rt "(- 100 1 2 3)") 94) +(scm-rt-test "*: zero" (scm-rt "(*)") 1) +(scm-rt-test "*: many" (scm-rt "(* 1 2 3 4)") 24) +(scm-rt-test "/: two" (scm-rt "(/ 20 5)") 4) + +;; ── Chained comparison ────────────────────────────────────────── +(scm-rt-test "<: chained" (scm-rt "(< 1 2 3 4 5)") true) +(scm-rt-test "<: not strict" (scm-rt "(< 1 2 2 3)") false) +(scm-rt-test ">: chained" (scm-rt "(> 5 4 3 2 1)") true) +(scm-rt-test "<=: with equality" (scm-rt "(<= 1 1 2 3 3)") true) +(scm-rt-test "=: chained" (scm-rt "(= 7 7 7)") true) + +;; ── Numerical ─────────────────────────────────────────────────── +(scm-rt-test "abs neg" (scm-rt "(abs -5)") 5) +(scm-rt-test "abs pos" (scm-rt "(abs 5)") 5) +(scm-rt-test "min" (scm-rt "(min 3 1 4 1 5)") 1) +(scm-rt-test "max" (scm-rt "(max 3 1 4 1 5)") 5) +(scm-rt-test "modulo" (scm-rt "(modulo 10 3)") 1) +(scm-rt-test "zero? 0" (scm-rt "(zero? 0)") true) +(scm-rt-test "zero? 1" (scm-rt "(zero? 1)") false) +(scm-rt-test "positive?" (scm-rt "(positive? 5)") true) +(scm-rt-test "negative?" (scm-rt "(negative? -5)") true) + +;; ── Type predicates ───────────────────────────────────────────── +(scm-rt-test "number? int" (scm-rt "(number? 42)") true) +(scm-rt-test "number? str" (scm-rt "(number? \"hi\")") false) +(scm-rt-test "boolean? #t" (scm-rt "(boolean? #t)") true) +(scm-rt-test "boolean? 0" (scm-rt "(boolean? 0)") false) +(scm-rt-test "string? str" (scm-rt "(string? \"hi\")") true) +(scm-rt-test "string? sym" (scm-rt "(string? 'foo)") false) +(scm-rt-test "symbol? sym" (scm-rt "(symbol? 'foo)") true) +(scm-rt-test "null? ()" (scm-rt "(null? '())") true) +(scm-rt-test "null? (1)" (scm-rt "(null? '(1))") false) +(scm-rt-test "pair? (1)" (scm-rt "(pair? '(1))") true) +(scm-rt-test "pair? ()" (scm-rt "(pair? '())") false) +(scm-rt-test "procedure? lambda" (scm-rt "(procedure? (lambda (x) x))") true) +(scm-rt-test "procedure? +" (scm-rt "(procedure? +)") true) +(scm-rt-test "procedure? 42" (scm-rt "(procedure? 42)") false) +(scm-rt-test "not #t" (scm-rt "(not #t)") false) +(scm-rt-test "not #f" (scm-rt "(not #f)") true) +(scm-rt-test "not 0" (scm-rt "(not 0)") false) + +;; ── List operations ───────────────────────────────────────────── +(scm-rt-test + "cons" + (scm-rt "(cons 1 '(2 3))") + (list 1 2 3)) +(scm-rt-test "car" (scm-rt "(car '(1 2 3))") 1) +(scm-rt-test "cdr" (scm-rt "(cdr '(1 2 3))") (list 2 3)) +(scm-rt-test + "list builds" + (scm-rt "(list 1 2 3)") + (list 1 2 3)) +(scm-rt-test "list empty" (scm-rt "(list)") (list)) +(scm-rt-test "length 3" (scm-rt "(length '(a b c))") 3) +(scm-rt-test "length 0" (scm-rt "(length '())") 0) +(scm-rt-test + "reverse" + (scm-rt "(reverse '(1 2 3))") + (list 3 2 1)) +(scm-rt-test "reverse empty" (scm-rt "(reverse '())") (list)) +(scm-rt-test + "append two" + (scm-rt "(append '(1 2) '(3 4))") + (list 1 2 3 4)) +(scm-rt-test + "append three" + (scm-rt "(append '(1) '(2) '(3))") + (list 1 2 3)) +(scm-rt-test "append empty" (scm-rt "(append)") (list)) + +;; ── Higher-order combinators ──────────────────────────────────── +(scm-rt-test + "map square" + (scm-rt "(map (lambda (x) (* x x)) '(1 2 3 4))") + (list 1 4 9 16)) +(scm-rt-test + "map with primitive" + (scm-rt-all "(define inc (lambda (x) (+ x 1))) (map inc '(10 20 30))") + (list 11 21 31)) +(scm-rt-test + "filter positives" + (scm-rt "(filter positive? '(-2 -1 0 1 2))") + (list 1 2)) +(scm-rt-test + "filter empty result" + (scm-rt "(filter (lambda (x) #f) '(1 2 3))") + (list)) +(scm-rt-test + "fold-left sum" + (scm-rt "(fold-left + 0 '(1 2 3 4 5))") + 15) +(scm-rt-test + "fold-left build list" + (scm-rt "(fold-left (lambda (acc x) (cons x acc)) '() '(1 2 3))") + (list 3 2 1)) +(scm-rt-test + "fold-right preserves order" + (scm-rt "(fold-right cons '() '(1 2 3))") + (list 1 2 3)) +(scm-rt-test + "for-each side effect" + (let + ((env (scheme-standard-env))) + (scheme-eval-program + (scheme-parse-all + "(define sum 0) (for-each (lambda (n) (set! sum (+ sum n))) '(1 2 3 4 5)) sum") + env)) + 15) + +;; ── apply ─────────────────────────────────────────────────────── +(scm-rt-test "apply +" (scm-rt "(apply + '(1 2 3 4 5))") 15) +(scm-rt-test + "apply lambda" + (scm-rt "(apply (lambda (a b c) (+ a (* b c))) '(1 2 3))") + 7) +(scm-rt-test + "apply via map" + (scm-rt "(apply + (map (lambda (x) (* x x)) '(1 2 3)))") + 14) + +;; ── String / char / vector ────────────────────────────────────── +(scm-rt-test "string-length" (scm-rt "(string-length \"hello\")") 5) +(scm-rt-test "string=? same" (scm-rt "(string=? \"abc\" \"abc\")") true) +(scm-rt-test "string=? diff" (scm-rt "(string=? \"abc\" \"abd\")") false) +(scm-rt-test + "string-append" + (scheme-string-value (scm-rt "(string-append \"hello\" \" \" \"world\")")) + "hello world") +(scm-rt-test "vector?" (scm-rt "(vector? #(1 2 3))") true) +(scm-rt-test "vector-length" (scm-rt "(vector-length #(1 2 3))") 3) +(scm-rt-test "vector-ref" (scm-rt "(vector-ref #(10 20 30) 1)") 20) +(scm-rt-test + "vector->list" + (scm-rt "(vector->list #(1 2 3))") + (list 1 2 3)) + +;; ── Classic Scheme programs ───────────────────────────────────── +(scm-rt-test + "factorial 5" + (scm-rt-all + "(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)") + 120) +(scm-rt-test + "factorial 10" + (scm-rt-all + "(define (fact n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 10)") + 3628800) +(scm-rt-test + "fib 10" + (scm-rt-all + "(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 10)") + 55) +(scm-rt-test + "sum via reduce" + (scm-rt "(fold-left + 0 (map (lambda (x) (* x x)) '(1 2 3 4 5)))") + 55) +(scm-rt-test + "length via reduce" + (scm-rt-all + "(define (len xs) (fold-left (lambda (acc _) (+ acc 1)) 0 xs)) (len '(a b c d))") + 4) +(scm-rt-test + "Y-ish reverse" + (scm-rt-all + "(define (rev xs) (if (null? xs) '() (append (rev (cdr xs)) (list (car xs))))) (rev '(1 2 3 4))") + (list 4 3 2 1)) + +;; ── env-as-value (kit consumer demo) ──────────────────────────── +(scm-rt-test + "env: standard-env is refl-env" + (refl-env? (scheme-standard-env)) + true) +(scm-rt-test + "env: kit lookup finds primitive" + (let + ((env (scheme-standard-env))) + (callable? (refl-env-lookup env "+"))) + true) + +(define scm-rt-tests-run! (fn () {:total (+ scm-rt-pass scm-rt-fail) :passed scm-rt-pass :failed scm-rt-fail :fails scm-rt-fails}))