giles
cf933f0ece
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
lib/scheme/runtime.sx — full R7RS-base surface: - Arithmetic: variadic +/-/*//, abs, min, max, modulo, quotient, remainder. Predicates zero?/positive?/negative?. - Comparison: chained =/</>/<=/>=. - Type predicates: number?/boolean?/symbol?/string?/char?/vector?/ null?/pair?/procedure?/not. - List: cons/car/cdr/list/length/reverse/append. - Higher-order: map/filter/fold-left/fold-right/for-each/apply. These re-enter scheme-apply to invoke user-supplied procs. - String: string-length/string=?/string-append/substring. - Char: char=?. - Vector: vector/vector-length/vector-ref/vector->list/list->vector/ make-vector. - Equality: eqv?/equal?/eq? (all = under the hood for now). Built via small adapters: scm-unary, scm-binary, scm-fold (variadic left-fold with identity + one-arity special), scm-chain (n-ary chained comparison). **Bugfix in eval.sx set! handler.** The :else branch had two expressions `(dict-set! ...) val` — SX cond branches don't run multiple expressions, they return nil silently (or evaluate only the first, depending on shape). Wrapped in (begin ...) to force sequential execution. This fix also unblocks 4 set!-dependent tests in lib/scheme/tests/syntax.sx that were silently raising during load (and thus not counted) — syntax test count jumps from 45 → 49. Classic programs verified: - factorial 10 → 3628800 - fib 10 → 55 - recursive list reverse → working - sum of squares via fold-left + map → 55 212 total Scheme tests: parse 62 + eval 23 + syntax 49 + runtime 78. All green. The env-as-value section in runtime tests demonstrates scheme-standard-env IS a refl-env? — kit primitives operate on it directly, confirming the third-consumer adoption with zero adapter.
432 lines
15 KiB
Plaintext
432 lines
15 KiB
Plaintext
;; 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)))))
|
|
|
|
;; if — (if TEST CONSEQUENT) or (if TEST CONSEQUENT ALTERNATE).
|
|
;; Scheme truthiness: only #f is false; everything else (incl. nil/empty
|
|
;; list) is truthy. Match SX's `if` semantics where possible.
|
|
(scheme-define-op! "if"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error "if: expects (test then [else])"))
|
|
(:else
|
|
(let ((test-val (scheme-eval (first args) env)))
|
|
(cond
|
|
((not (= test-val false))
|
|
(scheme-eval (nth args 1) env))
|
|
((>= (length args) 3)
|
|
(scheme-eval (nth args 2) env))
|
|
(:else nil)))))))
|
|
|
|
;; set! — mutate an existing binding by walking the env chain.
|
|
(scheme-define-op! "set!"
|
|
(fn (args env)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "set!: expects (set! name expr)"))
|
|
((not (string? (first args)))
|
|
(error "set!: name must be a symbol"))
|
|
(:else
|
|
(let ((name (first args))
|
|
(val (scheme-eval (nth args 1) env)))
|
|
(let ((src (refl-env-find-frame env name)))
|
|
(cond
|
|
((nil? src)
|
|
(error (str "set!: unbound variable: " name)))
|
|
(:else
|
|
(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.
|
|
(scheme-define-op! "define"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error "define: expects (define name expr) or (define (name . formals) body)"))
|
|
((string? (first args))
|
|
;; (define name expr)
|
|
(let ((val (scheme-eval (nth args 1) env)))
|
|
(scheme-env-bind! env (first args) val)
|
|
val))
|
|
((list? (first args))
|
|
;; (define (name . formals) body...) — sugar
|
|
(let ((header (first args))
|
|
(body (rest args)))
|
|
(cond
|
|
((= (length header) 0)
|
|
(error "define: malformed function header"))
|
|
(:else
|
|
(let ((name (first header))
|
|
(formals (rest header)))
|
|
(let ((closure (scheme-make-closure formals nil body env)))
|
|
(scheme-env-bind! env name closure)
|
|
closure))))))
|
|
(:else (error "define: malformed form")))))
|
|
|
|
;; begin — evaluate each expression in sequence, return the last.
|
|
(scheme-define-op! "begin"
|
|
(fn (args env)
|
|
(cond
|
|
((or (nil? args) (= (length args) 0)) nil)
|
|
(:else (scheme-eval-body args env)))))
|
|
|
|
(define scheme-eval-body
|
|
(fn (forms env)
|
|
(cond
|
|
((= (length forms) 1) (scheme-eval (first forms) env))
|
|
(:else
|
|
(begin
|
|
(scheme-eval (first forms) env)
|
|
(scheme-eval-body (rest forms) env))))))
|
|
|
|
;; lambda — (lambda formals body...) where formals is one of:
|
|
;; () — no args
|
|
;; (a b c) — fixed-arity
|
|
;; name — bare symbol; binds all args as a list
|
|
;; Dotted-pair tail (a b . rest) deferred until parser support lands.
|
|
(scheme-define-op! "lambda"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error "lambda: expects (lambda formals body...)"))
|
|
(:else
|
|
(let ((formals (first args))
|
|
(body (rest args)))
|
|
(cond
|
|
;; bare symbol: collect-all-args
|
|
((string? formals)
|
|
(scheme-make-closure (list) formals body env))
|
|
;; flat list: each must be a symbol
|
|
((list? formals)
|
|
(cond
|
|
((not (scm-formals-ok? formals))
|
|
(error "lambda: formals must be symbols"))
|
|
(:else
|
|
(scheme-make-closure formals nil body env))))
|
|
(:else (error "lambda: invalid formals"))))))))
|
|
|
|
(define scm-formals-ok?
|
|
(fn (formals)
|
|
(cond
|
|
((or (nil? formals) (= (length formals) 0)) true)
|
|
((string? (first formals)) (scm-formals-ok? (rest formals)))
|
|
(:else false))))
|
|
|
|
(define scheme-make-closure
|
|
(fn (params rest-name body env)
|
|
{:scm-tag :closure
|
|
:params params
|
|
:rest rest-name
|
|
:body body
|
|
:env env}))
|
|
|
|
;; ── let / let* — bindings in a fresh child env ───────────────────
|
|
|
|
(define scm-bind-let-vals!
|
|
(fn (local bindings dyn-env)
|
|
(cond
|
|
((or (nil? bindings) (= (length bindings) 0)) nil)
|
|
(:else
|
|
(let ((b (first bindings)))
|
|
(cond
|
|
((not (and (list? b) (= (length b) 2)))
|
|
(error "let: each binding must be (name expr)"))
|
|
((not (string? (first b)))
|
|
(error "let: binding name must be a symbol"))
|
|
(:else
|
|
(begin
|
|
(scheme-env-bind! local (first b)
|
|
(scheme-eval (nth b 1) dyn-env))
|
|
(scm-bind-let-vals! local (rest bindings) dyn-env)))))))))
|
|
|
|
(scheme-define-op! "let"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error "let: expects (bindings body...)"))
|
|
((not (list? (first args)))
|
|
(error "let: bindings must be a list"))
|
|
(:else
|
|
(let ((local (scheme-extend-env env)))
|
|
(scm-bind-let-vals! local (first args) env)
|
|
(scheme-eval-body (rest args) local))))))
|
|
|
|
;; let* — sequential let; each binding sees earlier ones.
|
|
(define scm-let*-step
|
|
(fn (bindings env body)
|
|
(cond
|
|
((or (nil? bindings) (= (length bindings) 0))
|
|
(scheme-eval-body body env))
|
|
(:else
|
|
(let ((b (first bindings)))
|
|
(cond
|
|
((not (and (list? b) (= (length b) 2)))
|
|
(error "let*: each binding must be (name expr)"))
|
|
(:else
|
|
(let ((child (scheme-extend-env env)))
|
|
(scheme-env-bind! child (first b)
|
|
(scheme-eval (nth b 1) env))
|
|
(scm-let*-step (rest bindings) child body)))))))))
|
|
|
|
(scheme-define-op! "let*"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error "let*: expects (bindings body...)"))
|
|
((not (list? (first args)))
|
|
(error "let*: bindings must be a list"))
|
|
(:else (scm-let*-step (first args) env (rest args))))))
|
|
|
|
;; ── cond / when / unless ─────────────────────────────────────────
|
|
|
|
(define scm-cond-clauses
|
|
(fn (clauses env)
|
|
(cond
|
|
((or (nil? clauses) (= (length clauses) 0)) nil)
|
|
(:else
|
|
(let ((clause (first clauses)))
|
|
(cond
|
|
((not (list? clause))
|
|
(error "cond: each clause must be a list"))
|
|
((= (length clause) 0)
|
|
(error "cond: empty clause"))
|
|
((and (string? (first clause)) (= (first clause) "else"))
|
|
(scheme-eval-body (rest clause) env))
|
|
(:else
|
|
(let ((test-val (scheme-eval (first clause) env)))
|
|
(cond
|
|
((not (= test-val false))
|
|
(cond
|
|
((= (length clause) 1) test-val)
|
|
(:else (scheme-eval-body (rest clause) env))))
|
|
(:else (scm-cond-clauses (rest clauses) env)))))))))))
|
|
|
|
(scheme-define-op! "cond"
|
|
(fn (args env) (scm-cond-clauses args env)))
|
|
|
|
(scheme-define-op! "when"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 1) (error "when: expects (when test body...)"))
|
|
(:else
|
|
(let ((v (scheme-eval (first args) env)))
|
|
(cond
|
|
((= v false) nil)
|
|
(:else (scheme-eval-body (rest args) env))))))))
|
|
|
|
(scheme-define-op! "unless"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 1)
|
|
(error "unless: expects (unless test body...)"))
|
|
(:else
|
|
(let ((v (scheme-eval (first args) env)))
|
|
(cond
|
|
((= v false) (scheme-eval-body (rest args) env))
|
|
(:else nil)))))))
|
|
|
|
;; ── and / or — short-circuit boolean operators ──────────────────
|
|
|
|
(define scm-and-step
|
|
(fn (args env)
|
|
(cond
|
|
((or (nil? args) (= (length args) 0)) true)
|
|
((= (length args) 1) (scheme-eval (first args) env))
|
|
(:else
|
|
(let ((v (scheme-eval (first args) env)))
|
|
(cond
|
|
((= v false) false)
|
|
(:else (scm-and-step (rest args) env))))))))
|
|
|
|
(scheme-define-op! "and"
|
|
(fn (args env) (scm-and-step args env)))
|
|
|
|
(define scm-or-step
|
|
(fn (args env)
|
|
(cond
|
|
((or (nil? args) (= (length args) 0)) false)
|
|
((= (length args) 1) (scheme-eval (first args) env))
|
|
(:else
|
|
(let ((v (scheme-eval (first args) env)))
|
|
(cond
|
|
((not (= v false)) v)
|
|
(:else (scm-or-step (rest args) env))))))))
|
|
|
|
(scheme-define-op! "or"
|
|
(fn (args env) (scm-or-step args env)))
|
|
|
|
;; ── 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))))))
|
|
|
|
;; Apply a Scheme closure: bind formals + rest, eval body in
|
|
;; (extend static-env), return value of last form.
|
|
(define scheme-apply-closure
|
|
(fn (proc args)
|
|
(let ((local (scheme-extend-env (get proc :env)))
|
|
(params (get proc :params))
|
|
(rest-name (get proc :rest))
|
|
(body (get proc :body)))
|
|
(begin
|
|
(scm-bind-params! local params args rest-name)
|
|
(scheme-eval-body body local)))))
|
|
|
|
(define scm-bind-params!
|
|
(fn (env params args rest-name)
|
|
(cond
|
|
;; No more formals: maybe bind the rest, else check arity.
|
|
((or (nil? params) (= (length params) 0))
|
|
(cond
|
|
((not (nil? rest-name))
|
|
(scheme-env-bind! env rest-name args))
|
|
((or (nil? args) (= (length args) 0)) nil)
|
|
(:else (error "lambda: too many arguments"))))
|
|
;; Out of args but still have formals → arity error.
|
|
((or (nil? args) (= (length args) 0))
|
|
(error "lambda: too few arguments"))
|
|
(:else
|
|
(begin
|
|
(scheme-env-bind! env (first params) (first args))
|
|
(scm-bind-params! env (rest params) (rest args) rest-name))))))
|
|
|
|
;; 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))))))
|