giles
eb14a7576b
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
eval.sx adds macro infrastructure:
- {:scm-tag :macro :literals (LIT...) :rules ((PAT TMPL)...) :env E}
- scheme-macro? predicate
- scm-match / scm-match-list — pattern matching against literals,
pattern variables, and structural list shapes
- scm-instantiate — template substitution with bindings
- scm-expand-rules — try each rule in order
- (syntax-rules (LITS) (PAT TMPL)...) → macro value
- (define-syntax NAME FORM) → bind macro in env
- scheme-eval: when head looks up to a macro, expand and re-eval
Pattern matching supports:
- _ → match anything, no bind
- literal symbols from the LITERALS list → must equal-match
- other symbols → pattern variables, bind to matched form
- list patterns → must be same length, each element matches
NO ellipsis (`...`) support yet — that's Phase 6b. NO hygiene
yet (introduced symbols can shadow caller bindings) — that's
Phase 6c, which will be the second consumer for
lib/guest/reflective/hygiene.sx.
12 tests cover: simple substitution, multi-rule selection,
nested macro use, swap-idiom (state mutation via set!), control-
flow wrappers, literal-keyword pattern matching, macros inside
lambdas.
249 total Scheme tests now (62 + 23 + 49 + 78 + 25 + 12).
643 lines
22 KiB
Plaintext
643 lines
22 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)))
|
|
|
|
;; ── syntax-rules / define-syntax (Phase 6a — no ellipsis yet) ────
|
|
;;
|
|
;; Macros are tagged values:
|
|
;; {:scm-tag :macro :literals (LIT...) :rules ((PAT TMPL)...) :env E}
|
|
;;
|
|
;; The pattern matcher binds pattern variables to matched sub-forms;
|
|
;; the template instantiator substitutes those bindings back. No
|
|
;; hygiene yet — introduced symbols can shadow caller bindings.
|
|
;; Hygiene lands in a follow-up (Phase 6c — second consumer for
|
|
;; lib/guest/reflective/hygiene.sx).
|
|
|
|
(define scheme-macro?
|
|
(fn (v) (and (dict? v) (= (get v :scm-tag) :macro))))
|
|
|
|
;; Pattern matching: returns a bindings dict or :scm-no-match.
|
|
;; The first PATTERN element is the macro keyword and is skipped.
|
|
(define scm-match
|
|
(fn (pat form literals)
|
|
(scm-match-step pat form literals {})))
|
|
|
|
(define scm-match-step
|
|
(fn (pat form literals bindings)
|
|
(cond
|
|
;; pat is `_` (any) — match anything, no binding
|
|
((and (string? pat) (= pat "_"))
|
|
bindings)
|
|
;; pat is a literal symbol from the literals list
|
|
((and (string? pat) (scm-is-literal? pat literals))
|
|
(cond
|
|
((and (string? form) (= form pat)) bindings)
|
|
(:else :scm-no-match)))
|
|
;; pat is a pattern variable — bind
|
|
((string? pat)
|
|
(cond
|
|
((dict-has? bindings pat) :scm-no-match) ;; non-linear
|
|
(:else (assoc bindings pat form))))
|
|
;; pat is a list — match list-of-same-length
|
|
((list? pat)
|
|
(cond
|
|
((not (list? form)) :scm-no-match)
|
|
((not (= (length pat) (length form))) :scm-no-match)
|
|
(:else (scm-match-list pat form literals bindings))))
|
|
;; literal value: must equal
|
|
(:else
|
|
(cond ((= pat form) bindings) (:else :scm-no-match))))))
|
|
|
|
(define scm-match-list
|
|
(fn (pats forms literals bindings)
|
|
(cond
|
|
((or (nil? pats) (= (length pats) 0)) bindings)
|
|
(:else
|
|
(let ((sub (scm-match-step (first pats) (first forms)
|
|
literals bindings)))
|
|
(cond
|
|
((= sub :scm-no-match) :scm-no-match)
|
|
(:else
|
|
(scm-match-list (rest pats) (rest forms)
|
|
literals sub))))))))
|
|
|
|
(define scm-is-literal?
|
|
(fn (name literals)
|
|
(cond
|
|
((or (nil? literals) (= (length literals) 0)) false)
|
|
((= (first literals) name) true)
|
|
(:else (scm-is-literal? name (rest literals))))))
|
|
|
|
;; Template instantiation: walk the template, substituting pattern
|
|
;; variables with their bindings; leave non-pattern-vars alone.
|
|
(define scm-instantiate
|
|
(fn (tmpl bindings)
|
|
(cond
|
|
((and (string? tmpl) (dict-has? bindings tmpl))
|
|
(get bindings tmpl))
|
|
((list? tmpl)
|
|
(cond
|
|
((= (length tmpl) 0) tmpl)
|
|
(:else (map (fn (t) (scm-instantiate t bindings)) tmpl))))
|
|
(:else tmpl))))
|
|
|
|
;; Try each rule against the form; return the instantiated template
|
|
;; or :scm-no-match if no rule matches.
|
|
(define scm-expand
|
|
(fn (macro-val form)
|
|
(scm-expand-rules
|
|
(get macro-val :rules)
|
|
form
|
|
(get macro-val :literals))))
|
|
|
|
(define scm-expand-rules
|
|
(fn (rules form literals)
|
|
(cond
|
|
((or (nil? rules) (= (length rules) 0))
|
|
(error (str "macro: no matching rule for: " form)))
|
|
(:else
|
|
(let ((rule (first rules)))
|
|
(let ((bindings (scm-match (first rule) form literals)))
|
|
(cond
|
|
((= bindings :scm-no-match)
|
|
(scm-expand-rules (rest rules) form literals))
|
|
(:else
|
|
(scm-instantiate (nth rule 1) bindings)))))))))
|
|
|
|
;; (syntax-rules (LITERALS...) (PAT TMPL) ...) → macro value
|
|
(scheme-define-op! "syntax-rules"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 1)
|
|
(error "syntax-rules: expects (literals) (pat tmpl)..."))
|
|
((not (list? (first args)))
|
|
(error "syntax-rules: first arg must be the literals list"))
|
|
(:else
|
|
{:scm-tag :macro
|
|
:literals (first args)
|
|
:rules (rest args)
|
|
:env env}))))
|
|
|
|
;; (define-syntax NAME SYNTAX-RULES-FORM)
|
|
(scheme-define-op! "define-syntax"
|
|
(fn (args env)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "define-syntax: expects (name syntax-rules-form)"))
|
|
((not (string? (first args)))
|
|
(error "define-syntax: name must be a symbol"))
|
|
(:else
|
|
(let ((macro-val (scheme-eval (nth args 1) env)))
|
|
(cond
|
|
((not (scheme-macro? macro-val))
|
|
(error "define-syntax: value must be a macro"))
|
|
(:else
|
|
(begin
|
|
(scheme-env-bind! env (first args) macro-val)
|
|
macro-val))))))))
|
|
|
|
;; ── guard (R7RS exception clause-dispatch syntactic form) ────────
|
|
;; (guard (var (test1 body1) (test2 body2) ... [else body]) body...)
|
|
;;
|
|
;; Evaluates body in an exception-protected scope. If an exception is
|
|
;; raised, var is bound to the raised value in a fresh child env, the
|
|
;; cond-like clauses are tried in order, and the first matching clause's
|
|
;; body is returned. If no clause matches (and no else), the exception
|
|
;; re-raises. The bare `else` symbol is the catch-all per R7RS.
|
|
|
|
;; Sentinel that means "no clause matched; re-raise outside the guard".
|
|
(define scm-guard-no-match-marker {:scm-guard-no-match true})
|
|
|
|
(define scm-guard-try-clauses
|
|
(fn (clauses env raised)
|
|
(cond
|
|
((or (nil? clauses) (= (length clauses) 0))
|
|
scm-guard-no-match-marker)
|
|
(:else
|
|
(let ((clause (first clauses)))
|
|
(cond
|
|
((not (list? clause)) scm-guard-no-match-marker)
|
|
((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-guard-try-clauses (rest clauses) env raised)))))))))))
|
|
|
|
(define scm-guard-handle
|
|
(fn (raised-val var-name clauses env)
|
|
(let ((local (scheme-extend-env env)))
|
|
(begin
|
|
(scheme-env-bind! local var-name raised-val)
|
|
(scm-guard-try-clauses clauses local raised-val)))))
|
|
|
|
(scheme-define-op! "guard"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 1)
|
|
(error "guard: expects ((var clauses...) body...)"))
|
|
((not (list? (first args)))
|
|
(error "guard: first form must be (var clauses...)"))
|
|
((= (length (first args)) 0)
|
|
(error "guard: clause list needs a var name"))
|
|
(:else
|
|
(let ((var-name (first (first args)))
|
|
(clauses (rest (first args)))
|
|
(body (rest args)))
|
|
;; Catch once; if no clause matches, the sentinel is returned
|
|
;; and we re-raise OUTSIDE the guard scope (so the re-raise
|
|
;; doesn't itself get caught).
|
|
(let ((outcome
|
|
(guard
|
|
(e (true {:scm-guard-raised true :value e}))
|
|
(scheme-eval-body body env))))
|
|
(cond
|
|
((and (dict? outcome) (get outcome :scm-guard-raised))
|
|
(let ((result (scm-guard-handle (get outcome :value)
|
|
var-name clauses env)))
|
|
(cond
|
|
((and (dict? result)
|
|
(get result :scm-guard-no-match))
|
|
(raise (get outcome :value)))
|
|
(:else result))))
|
|
(:else outcome))))))))
|
|
|
|
;; ── 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))
|
|
;; Macro dispatch: head looks up to a macro value.
|
|
((and (string? head)
|
|
(scheme-env-has? env head)
|
|
(scheme-macro? (scheme-env-lookup env head)))
|
|
(scheme-eval (scm-expand (scheme-env-lookup env head) expr)
|
|
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))))))
|