diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx new file mode 100644 index 00000000..a0559692 --- /dev/null +++ b/lib/scheme/eval.sx @@ -0,0 +1,150 @@ +;; lib/scheme/eval.sx — R7RS-small evaluator (Phase 2 skeleton). +;; +;; The evaluator walks parsed AST applying R7RS semantics: +;; - numbers, booleans, characters, vectors, strings self-evaluate +;; - symbols look up in the lexical env +;; - lists with a syntactic-operator head dispatch to native handler +;; - lists with an applicative head: eval head + args, then call +;; +;; Phase 2 covers literals, symbol lookup, and `quote`. The full +;; suite of syntactic operators (if/lambda/define/let/...) lands in +;; Phase 3. +;; +;; Environment representation +;; -------------------------- +;; Scheme is the THIRD CONSUMER for `lib/guest/reflective/env.sx`. +;; It uses the canonical mutable wire shape `{:refl-tag :env +;; :bindings DICT :parent ENV-OR-NIL}` directly — no adapter cfg — +;; because Scheme's lexical-scope semantics match the kit's defaults +;; exactly. Compare with Tcl (functional updates, level field) and +;; Smalltalk (rich frame metadata) which DID need cfg adapters. +;; +;; Public API +;; (scheme-eval EXPR ENV) — primary entry +;; (scheme-make-env) — fresh top-level env +;; (scheme-extend-env P) — child env +;; (scheme-env-bind! E N V) +;; (scheme-env-lookup E N) +;; +;; Consumes: lib/guest/reflective/env.sx; lib/scheme/parser.sx +;; (scheme-string?, scheme-char?, scheme-vector?). + +;; Thin wrappers over the kit. Scheme uses the canonical shape with +;; no cfg, so these are direct aliases. +(define scheme-make-env refl-make-env) +(define scheme-extend-env refl-extend-env) +(define scheme-env? refl-env?) +(define scheme-env-bind! refl-env-bind!) +(define scheme-env-has? refl-env-has?) +(define scheme-env-lookup refl-env-lookup) + +;; ── self-evaluating values ─────────────────────────────────────── + +(define + scheme-self-eval? + (fn + (v) + (or + (number? v) + (boolean? v) + (nil? v) + (scheme-string? v) + (scheme-char? v) + (scheme-vector? v)))) + +;; ── syntactic-operator table ───────────────────────────────────── +;; Each operator is a fn (args env) that returns the result of the +;; special form. Phase 2 only handles `quote`; Phase 3 fills out the +;; rest. The table-driven dispatch keeps the eval body small and +;; makes new operators easy to add. + +(define scheme-syntactic-ops {}) + +(define + scheme-define-op! + (fn (name handler) (dict-set! scheme-syntactic-ops name handler))) + +(define + scheme-syntactic-op? + (fn (name) (dict-has? scheme-syntactic-ops name))) + +;; quote — return arg unevaluated. +(scheme-define-op! + "quote" + (fn + (args env) + (cond + ((not (= (length args) 1)) + (error "quote: expects exactly 1 argument")) + (:else (first args))))) + +;; ── eval-args helper ───────────────────────────────────────────── + +(define + scheme-eval-args + (fn + (args env) + (cond + ((or (nil? args) (= (length args) 0)) (list)) + (:else + (cons + (scheme-eval (first args) env) + (scheme-eval-args (rest args) env)))))) + +;; ── main eval ──────────────────────────────────────────────────── + +(define + scheme-eval + (fn + (expr env) + (cond + ((scheme-self-eval? expr) expr) + ((string? expr) (scheme-env-lookup env expr)) + ((list? expr) + (cond + ((= (length expr) 0) + (error "scheme-eval: empty application")) + (:else + (let + ((head (first expr)) (rest-args (rest expr))) + (cond + ((and (string? head) (scheme-syntactic-op? head)) + ((get scheme-syntactic-ops head) rest-args env)) + (:else + (let + ((proc (scheme-eval head env)) + (vals (scheme-eval-args rest-args env))) + (scheme-apply proc vals)))))))) + (:else (error (str "scheme-eval: unknown form: " expr)))))) + +;; ── apply ──────────────────────────────────────────────────────── +;; Phase 2 only knows about HOST procedures (SX fns) bound in the +;; env as primitives. Phase 3 adds Scheme `lambda` closures. + +(define + scheme-apply + (fn + (proc args) + (cond + ((callable? proc) (proc args)) + ((and (dict? proc) (= (get proc :scm-tag) :closure)) + (scheme-apply-closure proc args)) + (:else (error (str "scheme-eval: not a procedure: " proc)))))) + +;; Stub for Phase 3 — closures land then. +(define + scheme-apply-closure + (fn (proc args) (error "scheme-eval: closures land in Phase 3"))) + +;; Evaluate a program (sequence of forms), returning the last value. +(define + scheme-eval-program + (fn + (forms env) + (cond + ((or (nil? forms) (= (length forms) 0)) nil) + ((= (length forms) 1) (scheme-eval (first forms) env)) + (:else + (begin + (scheme-eval (first forms) env) + (scheme-eval-program (rest forms) env)))))) diff --git a/lib/scheme/tests/eval.sx b/lib/scheme/tests/eval.sx new file mode 100644 index 00000000..c2aee288 --- /dev/null +++ b/lib/scheme/tests/eval.sx @@ -0,0 +1,162 @@ +;; lib/scheme/tests/eval.sx — exercises lib/scheme/eval.sx (Phase 2). + +(define scm-eval-pass 0) +(define scm-eval-fail 0) +(define scm-eval-fails (list)) + +(define + scm-eval-test + (fn + (name actual expected) + (if + (= actual expected) + (set! scm-eval-pass (+ scm-eval-pass 1)) + (begin + (set! scm-eval-fail (+ scm-eval-fail 1)) + (append! scm-eval-fails {:name name :actual actual :expected expected}))))) + +(define scm-eval-src (fn (src env) (scheme-eval (scheme-parse src) env))) + +;; A toy env with arithmetic + list primitives. +(define + scm-test-env + (fn + () + (let + ((env (scheme-make-env))) + (scheme-env-bind! + env + "+" + (fn (args) (+ (first args) (nth args 1)))) + (scheme-env-bind! + env + "-" + (fn (args) (- (first args) (nth args 1)))) + (scheme-env-bind! + env + "*" + (fn (args) (* (first args) (nth args 1)))) + (scheme-env-bind! env "list" (fn (args) args)) + env))) + +;; ── self-evaluating ────────────────────────────────────────────── +(scm-eval-test + "lit: integer" + (scm-eval-src "42" (scheme-make-env)) + 42) +(scm-eval-test "lit: float" (scm-eval-src "3.14" (scheme-make-env)) 3.14) +(scm-eval-test "lit: #t" (scm-eval-src "#t" (scheme-make-env)) true) +(scm-eval-test "lit: #f" (scm-eval-src "#f" (scheme-make-env)) false) +(scm-eval-test + "lit: empty list" + (scm-eval-src "()" (scheme-make-env)) + (list)) +(scm-eval-test + "lit: string" + (scheme-string? (scm-eval-src "\"hello\"" (scheme-make-env))) + true) +(scm-eval-test + "lit: char" + (scheme-char? (scm-eval-src "#\\a" (scheme-make-env))) + true) +(scm-eval-test + "lit: vector" + (scheme-vector? (scm-eval-src "#(1 2 3)" (scheme-make-env))) + true) + +;; ── symbol lookup ──────────────────────────────────────────────── +(scm-eval-test + "sym: bound" + (let + ((env (scheme-make-env))) + (scheme-env-bind! env "x" 100) + (scm-eval-src "x" env)) + 100) +(scm-eval-test + "sym: parent chain" + (let + ((p (scheme-make-env))) + (scheme-env-bind! p "outer" 1) + (let + ((c (scheme-extend-env p))) + (scheme-env-bind! c "inner" 2) + (+ (scm-eval-src "outer" c) (scm-eval-src "inner" c)))) + 3) +(scm-eval-test + "sym: shadowing" + (let + ((p (scheme-make-env))) + (scheme-env-bind! p "x" 1) + (let + ((c (scheme-extend-env p))) + (scheme-env-bind! c "x" 2) + (scm-eval-src "x" c))) + 2) + +;; ── quote ──────────────────────────────────────────────────────── +(scm-eval-test + "quote: symbol" + (scm-eval-src "(quote foo)" (scheme-make-env)) + "foo") +(scm-eval-test + "quote: list" + (scm-eval-src "(quote (+ 1 2))" (scheme-make-env)) + (list "+" 1 2)) +(scm-eval-test "quote: sugar 'x" (scm-eval-src "'x" (scheme-make-env)) "x") +(scm-eval-test + "quote: sugar list" + (scm-eval-src "'(a b c)" (scheme-make-env)) + (list "a" "b" "c")) +(scm-eval-test + "quote: nested" + (scm-eval-src "''x" (scheme-make-env)) + (list "quote" "x")) + +;; ── primitive application ──────────────────────────────────────── +(scm-eval-test "prim: +" (scm-eval-src "(+ 2 3)" (scm-test-env)) 5) +(scm-eval-test + "prim: nested +" + (scm-eval-src "(+ (+ 1 2) (+ 3 4))" (scm-test-env)) + 10) +(scm-eval-test + "prim: mixed ops" + (scm-eval-src "(- (* 4 5) (+ 3 2))" (scm-test-env)) + 15) +(scm-eval-test + "prim: list builds SX list" + (scm-eval-src "(list 1 2 3)" (scm-test-env)) + (list 1 2 3)) +(scm-eval-test + "prim: args eval in order" + (let + ((env (scm-test-env))) + (scheme-env-bind! env "a" 10) + (scheme-env-bind! env "b" 20) + (scm-eval-src "(+ a b)" env)) + 30) + +;; ── env-as-value (the third-consumer demonstration) ───────────── +;; Scheme's env IS lib/guest/reflective/env.sx's canonical wire shape +;; with no adapter cfg. Verify the kit primitives work directly. +(scm-eval-test + "env: refl-env? on Scheme env" + (refl-env? (scheme-make-env)) + true) +(scm-eval-test + "env: lookup via kit" + (let + ((env (scheme-make-env))) + (refl-env-bind! env "name" "scheme") + (refl-env-lookup env "name")) + "scheme") +(scm-eval-test + "env: find-frame walks parent" + (let + ((p (scheme-make-env))) + (refl-env-bind! p "root-binding" 99) + (let + ((c (scheme-extend-env p))) + (= (refl-env-find-frame c "root-binding") p))) + true) + +(define scm-eval-tests-run! (fn () {:total (+ scm-eval-pass scm-eval-fail) :passed scm-eval-pass :failed scm-eval-fail :fails scm-eval-fails}))