giles
7e795f95fc
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
eval.sx adds module support:
(define-library NAME EXPR...)
Where EXPR is one of:
(export NAME ...)
(import LIB-NAME ...)
(begin BODY ...)
(import LIB-NAME ...)
Looks up each library by key, copies its exported names
into the current env.
Library values: {:scm-tag :library :name :exports :env}
Stored in scheme-library-registry keyed by joined library-name
(`(my math)` → `"my/math"`).
Library body runs in a FRESH standard env (each library is its
own namespace). Only :exports are visible after import; private
internal definitions stay in the library's env. Internal calls
between library functions use the library's env, so public-facing
exports can rely on private helpers.
Multiple imports work — each library is independent.
NOT yet supported: cond-expand, include, include-library-
declarations, renaming (`(only ...)`, `(except ...)`, `(prefix ...)`,
`(rename ...)`). Standard R7RS modules use these but the core
two-operation flow (define-library / import) covers most everyday
module use.
7 tests: single export, multi-export, private-not-visible,
internal-calls-private, two-libs-both-imported, unknown-lib-error,
single-symbol library name.
296 total Scheme tests (62+23+49+78+25+20+13+10+9+7).
Phases done: 1, 2, 3, 3.5, 4, 5abc, 6ab, 7, 8, 9, 10.
Deferred: 6c (hygiene/scope-set — research-grade), 11 (conformance).
1038 lines
37 KiB
Plaintext
1038 lines
37 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)))
|
|
|
|
;; ── quasiquote (R7RS backquote runtime) ─────────────────────────
|
|
;; Walks the template form. At depth 0 (the most common case):
|
|
;; (unquote X) → (scheme-eval X env)
|
|
;; (unquote-splicing X) → spliced into surrounding list
|
|
;; (quasiquote X) → bumps depth (nested) — kept literal in
|
|
;; simple R7RS; full depth tracking only
|
|
;; when nested quasiquotes appear in practice.
|
|
;;
|
|
;; Algorithm is identical to kernel's knl-quasi-walk; the shared
|
|
;; structure is the second-consumer candidate for
|
|
;; lib/guest/reflective/quoting.sx.
|
|
|
|
(define scm-quasi-walk
|
|
(fn (form env)
|
|
(cond
|
|
((not (list? form)) form)
|
|
((= (length form) 0) form)
|
|
((and (string? (first form)) (= (first form) "unquote"))
|
|
(cond
|
|
((not (= (length form) 2))
|
|
(error "unquote: expects exactly 1 argument"))
|
|
(:else (scheme-eval (nth form 1) env))))
|
|
(:else (scm-quasi-walk-list form env)))))
|
|
|
|
(define scm-quasi-walk-list
|
|
(fn (forms env)
|
|
(cond
|
|
((or (nil? forms) (= (length forms) 0)) (list))
|
|
(:else
|
|
(let ((head (first forms)))
|
|
(cond
|
|
((and (list? head)
|
|
(= (length head) 2)
|
|
(string? (first head))
|
|
(= (first head) "unquote-splicing"))
|
|
(let ((spliced (scheme-eval (nth head 1) env)))
|
|
(cond
|
|
((not (list? spliced))
|
|
(error "unquote-splicing: value must be a list"))
|
|
(:else
|
|
(scm-list-concat
|
|
spliced
|
|
(scm-quasi-walk-list (rest forms) env))))))
|
|
(:else
|
|
(cons (scm-quasi-walk head env)
|
|
(scm-quasi-walk-list (rest forms) env)))))))))
|
|
|
|
(define scm-list-concat
|
|
(fn (xs ys)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) ys)
|
|
(:else (cons (first xs) (scm-list-concat (rest xs) ys))))))
|
|
|
|
(scheme-define-op! "quasiquote"
|
|
(fn (args env)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error "quasiquote: expects exactly 1 argument"))
|
|
(:else (scm-quasi-walk (first args) env)))))
|
|
|
|
;; unquote / unquote-splicing at top level (outside quasiquote)
|
|
;; are errors per R7RS. We still bind them as ops so a more useful
|
|
;; message fires than "unbound symbol".
|
|
(scheme-define-op! "unquote"
|
|
(fn (args env)
|
|
(error "unquote: only valid inside quasiquote")))
|
|
(scheme-define-op! "unquote-splicing"
|
|
(fn (args env)
|
|
(error "unquote-splicing: only valid inside quasiquote")))
|
|
|
|
;; ── 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 — delegate to scm-match-list, which itself
|
|
;; handles ellipsis tail patterns where the lengths differ.
|
|
((list? pat)
|
|
(cond
|
|
((not (list? 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))
|
|
(cond
|
|
((or (nil? forms) (= (length forms) 0)) bindings)
|
|
(:else :scm-no-match)))
|
|
;; Ellipsis: (<pat> ... <rest>) — currently Phase 6b only
|
|
;; supports a single ellipsis at the END of the pattern list.
|
|
;; <pat> binds to the rest of the forms as a LIST.
|
|
((and (>= (length pats) 2)
|
|
(string? (nth pats 1))
|
|
(= (nth pats 1) "..."))
|
|
(cond
|
|
((not (= (length pats) 2))
|
|
;; Tail-ellipsis only for now; nested or middle deferred.
|
|
:scm-no-match)
|
|
((not (string? (first pats)))
|
|
;; (<list-pat> ...) needs richer support — defer.
|
|
:scm-no-match)
|
|
(:else
|
|
;; Bind first-pat to the remaining forms as a list.
|
|
(let ((name (first pats)))
|
|
(cond
|
|
((dict-has? bindings name) :scm-no-match)
|
|
(:else (assoc bindings name forms)))))))
|
|
((or (nil? forms) (= (length forms) 0)) :scm-no-match)
|
|
(: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.
|
|
;; Inside a list, a `<var> ...` pair splices the list-valued binding
|
|
;; of <var> in place — matches the tail-ellipsis pattern shape.
|
|
(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 (scm-instantiate-list tmpl bindings))))
|
|
(:else tmpl))))
|
|
|
|
(define scm-instantiate-list
|
|
(fn (tmpl bindings)
|
|
(cond
|
|
((or (nil? tmpl) (= (length tmpl) 0)) (list))
|
|
;; <var> ... → splice the list-valued binding of <var>.
|
|
((and (>= (length tmpl) 2)
|
|
(string? (nth tmpl 1))
|
|
(= (nth tmpl 1) "...")
|
|
(string? (first tmpl))
|
|
(dict-has? bindings (first tmpl)))
|
|
(scm-list-append-all
|
|
(get bindings (first tmpl))
|
|
(scm-instantiate-list (rest (rest tmpl)) bindings)))
|
|
(:else
|
|
(cons (scm-instantiate (first tmpl) bindings)
|
|
(scm-instantiate-list (rest tmpl) bindings))))))
|
|
|
|
(define scm-list-append-all
|
|
(fn (xs ys)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) ys)
|
|
(:else (cons (first xs) (scm-list-append-all (rest xs) ys))))))
|
|
|
|
;; 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-library + import (R7RS Phase 8) ─────────────────────
|
|
;;
|
|
;; A library is a tagged value with exports + an env where the body
|
|
;; was evaluated. The global registry maps a string key (joined from
|
|
;; the library-name list) to the library value.
|
|
;;
|
|
;; (define-library NAME EXPR...) where EXPR can be:
|
|
;; (export NAME ...)
|
|
;; (import LIB-NAME ...)
|
|
;; (begin BODY ...)
|
|
;; cond-expand, include, include-library-declarations: deferred.
|
|
;;
|
|
;; (import LIB-NAME ...) at the top level: for each named library,
|
|
;; look up its exports and bind them in the current env.
|
|
|
|
(define scheme-library-registry {})
|
|
|
|
(define scm-lib-key
|
|
(fn (name)
|
|
(cond
|
|
((string? name) name)
|
|
((list? name) (scm-join-strings name "/"))
|
|
(:else (error "library name must be symbol or list")))))
|
|
|
|
(define scm-join-strings
|
|
(fn (xs sep)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) "")
|
|
((= (length xs) 1) (first xs))
|
|
(:else
|
|
(str (first xs) sep (scm-join-strings (rest xs) sep))))))
|
|
|
|
(define scm-library?
|
|
(fn (v)
|
|
(and (dict? v) (= (get v :scm-tag) :library))))
|
|
|
|
(define scm-collect-exports
|
|
(fn (forms acc)
|
|
(cond
|
|
((or (nil? forms) (= (length forms) 0)) acc)
|
|
(:else
|
|
(let ((form (first forms)))
|
|
(cond
|
|
((and (list? form) (>= (length form) 1)
|
|
(string? (first form)) (= (first form) "export"))
|
|
(scm-collect-exports (rest forms)
|
|
(scm-list-concat acc (rest form))))
|
|
(:else (scm-collect-exports (rest forms) acc))))))))
|
|
|
|
(define scm-run-library-body
|
|
(fn (forms env)
|
|
(cond
|
|
((or (nil? forms) (= (length forms) 0)) nil)
|
|
(:else
|
|
(let ((form (first forms)))
|
|
(cond
|
|
;; export/import declarations: handled separately
|
|
((and (list? form) (>= (length form) 1)
|
|
(string? (first form))
|
|
(or (= (first form) "export")
|
|
(= (first form) "import")))
|
|
(cond
|
|
((= (first form) "import")
|
|
(begin
|
|
(scm-do-import (rest form) env)
|
|
(scm-run-library-body (rest forms) env)))
|
|
(:else (scm-run-library-body (rest forms) env))))
|
|
;; begin: evaluate body
|
|
((and (list? form) (>= (length form) 1)
|
|
(string? (first form)) (= (first form) "begin"))
|
|
(begin
|
|
(scheme-eval-body (rest form) env)
|
|
(scm-run-library-body (rest forms) env)))
|
|
(:else (scm-run-library-body (rest forms) env))))))))
|
|
|
|
(define scm-do-import
|
|
(fn (lib-names env)
|
|
(cond
|
|
((or (nil? lib-names) (= (length lib-names) 0)) nil)
|
|
(:else
|
|
(let ((key (scm-lib-key (first lib-names))))
|
|
(cond
|
|
((not (dict-has? scheme-library-registry key))
|
|
(error (str "import: unknown library: " key)))
|
|
(:else
|
|
(begin
|
|
(let ((lib (get scheme-library-registry key)))
|
|
(scm-copy-exports! env
|
|
(get lib :exports)
|
|
(get lib :env)))
|
|
(scm-do-import (rest lib-names) env)))))))))
|
|
|
|
(define scm-copy-exports!
|
|
(fn (target-env exports source-env)
|
|
(cond
|
|
((or (nil? exports) (= (length exports) 0)) nil)
|
|
(:else
|
|
(let ((name (first exports)))
|
|
(cond
|
|
((refl-env-has? source-env name)
|
|
(begin
|
|
(scheme-env-bind! target-env name
|
|
(refl-env-lookup source-env name))
|
|
(scm-copy-exports! target-env (rest exports) source-env)))
|
|
(:else
|
|
(error (str "import: export not defined: " name)))))))))
|
|
|
|
(scheme-define-op! "define-library"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 1)
|
|
(error "define-library: expects (define-library NAME body...)"))
|
|
(:else
|
|
(let ((lib-name (first args))
|
|
(body (rest args)))
|
|
(let ((lib-env (scheme-standard-env))
|
|
(exports (scm-collect-exports body (list)))
|
|
(key (scm-lib-key lib-name)))
|
|
(begin
|
|
(scm-run-library-body body lib-env)
|
|
(dict-set! scheme-library-registry key
|
|
{:scm-tag :library
|
|
:name lib-name
|
|
:exports exports
|
|
:env lib-env})
|
|
key)))))))
|
|
|
|
(scheme-define-op! "import"
|
|
(fn (args env)
|
|
(begin
|
|
(scm-do-import args env)
|
|
nil)))
|
|
|
|
;; ── define-record-type (R7RS Phase 9) ──────────────────────────
|
|
;;
|
|
;; (define-record-type NAME
|
|
;; (CONSTRUCTOR ARG...)
|
|
;; PREDICATE
|
|
;; (FIELD ACCESSOR [MUTATOR])...)
|
|
;;
|
|
;; Defines a new record type. Records are tagged dicts:
|
|
;; {:scm-record TYPE-NAME :fields {FIELD-NAME VALUE ...}}
|
|
;;
|
|
;; CONSTRUCTOR is a procedure (ARG ...) → record. Each ARG must
|
|
;; correspond to a FIELD name in the field list; remaining fields
|
|
;; are initialised to nil.
|
|
;; PREDICATE returns true iff its arg is a record of this type.
|
|
;; ACCESSOR returns the field value. MUTATOR (if present) sets it.
|
|
|
|
(define scm-find-field-index
|
|
(fn (name fields i)
|
|
(cond
|
|
((or (nil? fields) (= (length fields) 0)) nil)
|
|
((= (first (first fields)) name) i)
|
|
(:else (scm-find-field-index name (rest fields) (+ i 1))))))
|
|
|
|
(define scm-make-record-ctor
|
|
(fn (type-name field-specs ctor-args)
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) (length ctor-args)))
|
|
(error (str type-name ": wrong number of constructor arguments")))
|
|
(:else
|
|
(let ((record {:scm-record type-name :fields {}}))
|
|
(begin
|
|
(scm-record-init-fields! record field-specs)
|
|
(scm-record-set-ctor-args! record ctor-args args)
|
|
record)))))))
|
|
|
|
(define scm-record-init-fields!
|
|
(fn (record field-specs)
|
|
(cond
|
|
((or (nil? field-specs) (= (length field-specs) 0)) nil)
|
|
(:else
|
|
(begin
|
|
(dict-set! (get record :fields) (first (first field-specs)) nil)
|
|
(scm-record-init-fields! record (rest field-specs)))))))
|
|
|
|
(define scm-record-set-ctor-args!
|
|
(fn (record names values)
|
|
(cond
|
|
((or (nil? names) (= (length names) 0)) nil)
|
|
(:else
|
|
(begin
|
|
(dict-set! (get record :fields) (first names) (first values))
|
|
(scm-record-set-ctor-args! record (rest names) (rest values)))))))
|
|
|
|
(define scm-install-record-type!
|
|
(fn (env type-name ctor-spec pred-name field-specs)
|
|
(let ((ctor-name (first ctor-spec))
|
|
(ctor-args (rest ctor-spec)))
|
|
(begin
|
|
;; Constructor
|
|
(scheme-env-bind! env ctor-name
|
|
(scm-make-record-ctor type-name field-specs ctor-args))
|
|
;; Predicate
|
|
(scheme-env-bind! env pred-name
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error (str pred-name ": expects 1 argument")))
|
|
(:else
|
|
(let ((v (first args)))
|
|
(and (dict? v)
|
|
(= (get v :scm-record) type-name)))))))
|
|
;; Accessors + optional mutators
|
|
(scm-install-field-procs! env type-name field-specs)))))
|
|
|
|
(define scm-install-field-procs!
|
|
(fn (env type-name field-specs)
|
|
(cond
|
|
((or (nil? field-specs) (= (length field-specs) 0)) nil)
|
|
(:else
|
|
(let ((spec (first field-specs)))
|
|
(cond
|
|
((< (length spec) 2)
|
|
(error "define-record-type: each field needs (name accessor [mutator])"))
|
|
(:else
|
|
(let ((field-name (first spec))
|
|
(accessor-name (nth spec 1)))
|
|
(begin
|
|
;; Accessor
|
|
(scheme-env-bind! env accessor-name
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error (str accessor-name ": expects 1 argument")))
|
|
((not (and (dict? (first args))
|
|
(= (get (first args) :scm-record) type-name)))
|
|
(error (str accessor-name ": not a " type-name)))
|
|
(:else
|
|
(get (get (first args) :fields) field-name)))))
|
|
;; Mutator (if present)
|
|
(cond
|
|
((>= (length spec) 3)
|
|
(let ((mutator-name (nth spec 2)))
|
|
(scheme-env-bind! env mutator-name
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error (str mutator-name ": expects 2 arguments")))
|
|
((not (and (dict? (first args))
|
|
(= (get (first args) :scm-record) type-name)))
|
|
(error (str mutator-name ": not a " type-name)))
|
|
(:else
|
|
(dict-set! (get (first args) :fields)
|
|
field-name
|
|
(nth args 1))))))))
|
|
(:else nil))
|
|
(scm-install-field-procs! env type-name (rest field-specs)))))))))))
|
|
|
|
(scheme-define-op! "define-record-type"
|
|
(fn (args env)
|
|
(cond
|
|
((< (length args) 3)
|
|
(error "define-record-type: expects (name (ctor args) pred [fields])"))
|
|
(:else
|
|
(let ((type-name (first args))
|
|
(ctor-spec (nth args 1))
|
|
(pred-name (nth args 2))
|
|
(field-specs
|
|
(cond
|
|
((>= (length args) 4) (rest (rest (rest args))))
|
|
(:else (list)))))
|
|
(cond
|
|
((not (string? type-name))
|
|
(error "define-record-type: type name must be a symbol"))
|
|
((not (list? ctor-spec))
|
|
(error "define-record-type: constructor spec must be a list"))
|
|
((not (string? pred-name))
|
|
(error "define-record-type: predicate name must be a symbol"))
|
|
(:else
|
|
(begin
|
|
(scm-install-record-type! env type-name ctor-spec
|
|
pred-name field-specs)
|
|
type-name))))))))
|
|
|
|
;; (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))))))
|