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)))

;; ── 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))
                (: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))))))