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

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