rose-ash/lib/scheme/eval.sx

;; 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.

;; Scheme-side adapter for lib/guest/reflective/quoting.sx. Scheme
;; uses the bare unquote / unquote-splicing keywords and scheme-eval
;; as the host evaluator. Walker algorithm shared with Kernel via
;; the kit.
(define scm-quasi-cfg
  {:unquote-name "unquote"
   :unquote-splicing-name "unquote-splicing"
   :eval (fn (form env) (scheme-eval form env))})

(define scm-quasi-walk
  (fn (form env)
    (refl-quasi-walk-with scm-quasi-cfg form env)))

(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)
                                   (refl-quasi-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))))))