rose-ash/lib/common-lisp/eval.sx

;; Common Lisp evaluator — evaluates CL AST forms.
;;
;; Depends on: lib/common-lisp/reader.sx, lib/common-lisp/parser.sx
;;
;; Environment:
;;   {:vars {"NAME" val ...} :fns {"NAME" cl-fn ...}}
;; CL function:
;;   {:cl-type "function" :params ll :body forms :env env}
;;
;; Public API:
;;   (cl-make-env)              — create empty environment
;;   (cl-eval form env)         — evaluate one CL AST form
;;   (cl-eval-str src env)      — read+eval a CL source string
;;   (cl-eval-all-str src env)  — read-all+eval-each, return last
;;   cl-global-env              — global mutable environment

;; ── environment ──────────────────────────────────────────────────

(define cl-make-env (fn () {:vars {} :fns {}}))

(define cl-global-env (cl-make-env))

(define cl-env-get-var  (fn (env name) (get (get env "vars") name)))
(define cl-env-has-var? (fn (env name) (has-key? (get env "vars") name)))
(define cl-env-get-fn   (fn (env name) (get (get env "fns") name)))
(define cl-env-has-fn?  (fn (env name) (has-key? (get env "fns") name)))

(define cl-env-bind-var
  (fn (env name value)
    {:vars (assoc (get env "vars") name value)
     :fns  (get env "fns")}))

(define cl-env-bind-fn
  (fn (env name fn-obj)
    {:vars (get env "vars")
     :fns  (assoc (get env "fns") name fn-obj)}))

;; ── body evaluation ───────────────────────────────────────────────

(define cl-eval-body
  (fn (forms env)
    (cond
      ((= (len forms) 0) nil)
      ((= (len forms) 1) (cl-eval (nth forms 0) env))
      (:else
        (do
          (cl-eval (nth forms 0) env)
          (cl-eval-body (rest forms) env))))))

;; ── lambda-list binding helpers ───────────────────────────────────

(define cl-bind-required
  (fn (names args env)
    (if (= (len names) 0)
      env
      (cl-bind-required
        (rest names)
        (if (> (len args) 0) (rest args) args)
        (cl-env-bind-var env
          (nth names 0)
          (if (> (len args) 0) (nth args 0) nil))))))

;; returns {:env e :rest remaining-args}
(define cl-bind-optional
  (fn (opts args env)
    (if (= (len opts) 0)
      {:env env :rest args}
      (let ((spec    (nth opts 0))
            (has-val (> (len args) 0)))
        (let ((val (if has-val (nth args 0) nil))
              (rem (if has-val (rest args) args)))
          (let ((e1 (cl-env-bind-var env (get spec "name")
                      (if has-val val
                        (if (get spec "default")
                          (cl-eval (get spec "default") env) nil)))))
            (let ((e2 (if (get spec "supplied")
                        (cl-env-bind-var e1 (get spec "supplied") has-val)
                        e1)))
              (cl-bind-optional (rest opts) rem e2))))))))

;; returns {:found bool :value v}
(define cl-find-kw-arg
  (fn (kw args i)
    (if (>= i (len args))
      {:found false :value nil}
      (let ((a (nth args i)))
        (if (and (dict? a)
                 (= (get a "cl-type") "keyword")
                 (= (get a "name") kw))
          {:found true
           :value (if (< (+ i 1) (len args)) (nth args (+ i 1)) nil)}
          (cl-find-kw-arg kw args (+ i 2)))))))

(define cl-bind-key
  (fn (key-specs all-args env)
    (if (= (len key-specs) 0)
      env
      (let ((spec (nth key-specs 0))
            (r    (cl-find-kw-arg (get (nth key-specs 0) "keyword") all-args 0)))
        (let ((found (get r "found"))
              (kval  (get r "value")))
          (let ((e1 (cl-env-bind-var env (get spec "name")
                      (if found kval
                        (if (get spec "default")
                          (cl-eval (get spec "default") env) nil)))))
            (let ((e2 (if (get spec "supplied")
                        (cl-env-bind-var e1 (get spec "supplied") found)
                        e1)))
              (cl-bind-key (rest key-specs) all-args e2))))))))

(define cl-bind-aux
  (fn (aux-specs env)
    (if (= (len aux-specs) 0)
      env
      (let ((spec (nth aux-specs 0)))
        (cl-bind-aux
          (rest aux-specs)
          (cl-env-bind-var env (get spec "name")
            (if (get spec "init") (cl-eval (get spec "init") env) nil)))))))

;; ── function creation ─────────────────────────────────────────────

;; ll-and-body: (list lambda-list-form body-form ...)
(define cl-make-lambda
  (fn (ll-and-body env)
    {:cl-type "function"
     :params  (cl-parse-lambda-list (nth ll-and-body 0))
     :body    (rest ll-and-body)
     :env     env}))

;; ── function application ──────────────────────────────────────────

(define cl-apply
  (fn (fn-obj args)
    (cond
      ((and (dict? fn-obj) (has-key? fn-obj "builtin-fn"))
        ((get fn-obj "builtin-fn") args))
      ((or (not (dict? fn-obj)) (not (= (get fn-obj "cl-type") "function")))
        {:cl-type "error" :message "Not a function"})
      (:else
        (let ((params (get fn-obj "params"))
            (body   (get fn-obj "body"))
            (cenv   (get fn-obj "env")))
        (let ((req       (get params "required"))
              (opt       (get params "optional"))
              (rest-name (get params "rest"))
              (key-specs (get params "key"))
              (aux-specs (get params "aux")))
          (let ((e1 (cl-bind-required req args cenv)))
            (let ((opt-r (cl-bind-optional
                           opt (slice args (len req) (len args)) e1)))
              (let ((e2  (get opt-r "env"))
                    (rem (get opt-r "rest")))
                (let ((e3 (if rest-name
                            (cl-env-bind-var e2 rest-name rem)
                            e2)))
                  (let ((e4 (cl-bind-key key-specs args e3)))
                    (let ((e5 (cl-bind-aux aux-specs e4)))
                      (cl-eval-body body e5)))))))))))))

;; ── built-in functions ────────────────────────────────────────────

(define cl-builtins
  (dict
    "+"   (fn (args) (reduce (fn (a b) (+ a b)) 0 args))
    "-"   (fn (args)
            (cond
              ((= (len args) 0) 0)
              ((= (len args) 1) (- 0 (nth args 0)))
              (:else (reduce (fn (a b) (- a b)) (nth args 0) (rest args)))))
    "*"   (fn (args) (reduce (fn (a b) (* a b)) 1 args))
    "/"   (fn (args)
            (cond
              ((= (len args) 0) 1)
              ((= (len args) 1) (/ 1 (nth args 0)))
              (:else (reduce (fn (a b) (/ a b)) (nth args 0) (rest args)))))
    "1+"  (fn (args) (+ (nth args 0) 1))
    "1-"  (fn (args) (- (nth args 0) 1))
    "="   (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
    "/="  (fn (args) (if (not (= (nth args 0) (nth args 1))) true nil))
    "<"   (fn (args) (if (< (nth args 0) (nth args 1)) true nil))
    ">"   (fn (args) (if (> (nth args 0) (nth args 1)) true nil))
    "<="  (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
    ">="  (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
    "NOT"   (fn (args) (if (nth args 0) nil true))
    "NULL"  (fn (args) (if (= (nth args 0) nil) true nil))
    "NUMBERP" (fn (args) (if (number? (nth args 0)) true nil))
    "STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
    "SYMBOLP" (fn (args) nil)
    "LISTP"   (fn (args)
                 (if (or (list? (nth args 0)) (= (nth args 0) nil)) true nil))
    "CONSP"   (fn (args)
                 (let ((x (nth args 0)))
                   (if (and (dict? x) (= (get x "cl-type") "cons")) true nil)))
    "ATOM"    (fn (args)
                 (let ((x (nth args 0)))
                   (if (and (dict? x) (= (get x "cl-type") "cons")) nil true)))
    "FUNCTIONP" (fn (args)
                   (let ((x (nth args 0)))
                     (if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
    "ZEROP"  (fn (args) (if (= (nth args 0) 0) true nil))
    "PLUSP"  (fn (args) (if (> (nth args 0) 0) true nil))
    "MINUSP" (fn (args) (if (< (nth args 0) 0) true nil))
    "EVENP"  (fn (args)
                (let ((n (nth args 0)))
                  (if (= (mod n 2) 0) true nil)))
    "ODDP"   (fn (args)
                (let ((n (nth args 0)))
                  (if (not (= (mod n 2) 0)) true nil)))
    "ABS"    (fn (args) (let ((n (nth args 0))) (if (< n 0) (- 0 n) n)))
    "MAX"    (fn (args) (reduce (fn (a b) (if (> a b) a b)) (nth args 0) (rest args)))
    "MIN"    (fn (args) (reduce (fn (a b) (if (< a b) a b)) (nth args 0) (rest args)))
    "CONS"   (fn (args) {:cl-type "cons" :car (nth args 0) :cdr (nth args 1)})
    "CAR"    (fn (args)
                (let ((x (nth args 0)))
                  (if (and (dict? x) (= (get x "cl-type") "cons"))
                    (get x "car")
                    (if (and (list? x) (> (len x) 0)) (nth x 0) nil))))
    "CDR"    (fn (args)
                (let ((x (nth args 0)))
                  (if (and (dict? x) (= (get x "cl-type") "cons"))
                    (get x "cdr")
                    (if (list? x) (rest x) nil))))
    "LIST"   (fn (args) args)
    "APPEND" (fn (args)
                (if (= (len args) 0) (list)
                  (reduce (fn (a b)
                    (if (= a nil) b (if (= b nil) a (concat a b))))
                  (list) args)))
    "LENGTH" (fn (args)
                (let ((x (nth args 0)))
                  (if (= x nil) 0 (len x))))
    "NTH"    (fn (args) (nth (nth args 1) (nth args 0)))
    "FIRST"  (fn (args)
                (let ((x (nth args 0)))
                  (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
    "SECOND" (fn (args)
                (let ((x (nth args 0)))
                  (if (and (list? x) (> (len x) 1)) (nth x 1) nil)))
    "THIRD"  (fn (args)
                (let ((x (nth args 0)))
                  (if (and (list? x) (> (len x) 2)) (nth x 2) nil)))
    "REST"   (fn (args) (rest (nth args 0)))
    "REVERSE" (fn (args)
                 (reduce (fn (acc x) (concat (list x) acc))
                         (list) (nth args 0)))
    "IDENTITY" (fn (args) (nth args 0))
    "VALUES"   (fn (args) (if (> (len args) 0) (nth args 0) nil))
    "PRINT"    (fn (args) (nth args 0))
    "PRIN1"    (fn (args) (nth args 0))
    "PRINC"    (fn (args) (nth args 0))
    "TERPRI"   (fn (args) nil)
    "WRITE"    (fn (args) (nth args 0))
    "STRING-UPCASE"   (fn (args) (upcase (nth args 0)))
    "STRING-DOWNCASE" (fn (args) (downcase (nth args 0)))
    "STRING="         (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
    "CONCATENATE"     (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
    "EQ"    (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
    "EQL"   (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
    "EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))))

;; Register builtins in cl-global-env so (function #'name) resolves them
(for-each
  (fn (name)
    (dict-set! (get cl-global-env "fns") name
      {:cl-type "function" :builtin-fn (get cl-builtins name)}))
  (keys cl-builtins))

;; ── special form evaluators ───────────────────────────────────────

(define cl-eval-if
  (fn (args env)
    (let ((cond-val  (cl-eval (nth args 0) env))
          (then-form (nth args 1))
          (else-form (if (> (len args) 2) (nth args 2) nil)))
      (if cond-val
        (cl-eval then-form env)
        (if else-form (cl-eval else-form env) nil)))))

(define cl-eval-and
  (fn (args env)
    (if (= (len args) 0)
      true
      (let ((val (cl-eval (nth args 0) env)))
        (if (not val)
          nil
          (if (= (len args) 1)
            val
            (cl-eval-and (rest args) env)))))))

(define cl-eval-or
  (fn (args env)
    (if (= (len args) 0)
      nil
      (let ((val (cl-eval (nth args 0) env)))
        (if val
          val
          (cl-eval-or (rest args) env))))))

(define cl-eval-cond
  (fn (clauses env)
    (if (= (len clauses) 0)
      nil
      (let ((clause (nth clauses 0)))
        (let ((test-val (cl-eval (nth clause 0) env)))
          (if test-val
            (if (= (len clause) 1)
              test-val
              (cl-eval-body (rest clause) env))
            (cl-eval-cond (rest clauses) env)))))))

;; Parallel LET and sequential LET*
(define cl-eval-let
  (fn (args env sequential)
    (let ((bindings (nth args 0))
          (body     (rest args)))
      (if sequential
        ;; LET*: each binding sees previous ones
        (let ((new-env env))
          (define bind-seq
            (fn (bs e)
              (if (= (len bs) 0)
                e
                (let ((b (nth bs 0)))
                  (let ((name (if (list? b) (nth b 0) b))
                        (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
                    (bind-seq (rest bs)
                      (cl-env-bind-var e name (cl-eval init e))))))))
          (cl-eval-body body (bind-seq bindings env)))
        ;; LET: evaluate all inits in current env, then bind
        (let ((pairs (map
                       (fn (b)
                         (let ((name (if (list? b) (nth b 0) b))
                               (init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
                           {:name name :value (cl-eval init env)}))
                       bindings)))
          (let ((new-env (reduce
                           (fn (e pair)
                             (cl-env-bind-var e (get pair "name") (get pair "value")))
                           env pairs)))
            (cl-eval-body body new-env)))))))

;; SETQ / SETF (simplified: mutate nearest scope or global)
(define cl-eval-setq
  (fn (args env)
    (if (< (len args) 2)
      nil
      (let ((name (nth args 0))
            (val  (cl-eval (nth args 1) env)))
        (if (has-key? (get env "vars") name)
          (dict-set! (get env "vars") name val)
          (dict-set! (get cl-global-env "vars") name val))
        (if (> (len args) 2)
          (cl-eval-setq (rest (rest args)) env)
          val)))))

;; FUNCTION: get function value or create lambda
(define cl-eval-function
  (fn (args env)
    (let ((spec (nth args 0)))
      (cond
        ((and (list? spec) (> (len spec) 0) (= (nth spec 0) "LAMBDA"))
          (cl-make-lambda (rest spec) env))
        ((string? spec)
          (cond
            ((cl-env-has-fn? env spec) (cl-env-get-fn env spec))
            ((cl-env-has-fn? cl-global-env spec)
              (cl-env-get-fn cl-global-env spec))
            (:else {:cl-type "error" :message (str "Undefined function: " spec)})))
        (:else {:cl-type "error" :message "FUNCTION: invalid spec"})))))

;; FLET: local functions (non-recursive, close over outer env)
(define cl-eval-flet
  (fn (args env)
    (let ((fn-defs (nth args 0))
          (body    (rest args)))
      (let ((new-env (reduce
                       (fn (e def)
                         (let ((name    (nth def 0))
                               (ll      (nth def 1))
                               (fn-body (rest (rest def))))
                           (cl-env-bind-fn e name
                             {:cl-type "function"
                              :params  (cl-parse-lambda-list ll)
                              :body    fn-body
                              :env     env})))
                       env fn-defs)))
        (cl-eval-body body new-env)))))

;; LABELS: mutually-recursive local functions
(define cl-eval-labels
  (fn (args env)
    (let ((fn-defs (nth args 0))
          (body    (rest args)))
      ;; Build env with placeholder nil entries for each name
      (let ((new-env (reduce
                       (fn (e def) (cl-env-bind-fn e (nth def 0) nil))
                       env fn-defs)))
        ;; Fill in real function objects that capture new-env
        (for-each
          (fn (def)
            (let ((name    (nth def 0))
                  (ll      (nth def 1))
                  (fn-body (rest (rest def))))
              (dict-set! (get new-env "fns") name
                {:cl-type "function"
                 :params  (cl-parse-lambda-list ll)
                 :body    fn-body
                 :env     new-env})))
          fn-defs)
        (cl-eval-body body new-env)))))

;; EVAL-WHEN: evaluate body only if :execute is in situations
(define cl-eval-eval-when
  (fn (args env)
    (let ((situations (nth args 0))
          (body       (rest args)))
      (define has-exec
        (some (fn (s)
                (or
                  (and (dict? s)
                       (= (get s "cl-type") "keyword")
                       (= (get s "name") "EXECUTE"))
                  (= s "EXECUTE")))
              situations))
      (if has-exec (cl-eval-body body env) nil))))

;; DEFUN: define function in global fns namespace
(define cl-eval-defun
  (fn (args env)
    (let ((name    (nth args 0))
          (ll      (nth args 1))
          (fn-body (rest (rest args))))
      (let ((fn-obj {:cl-type "function"
                     :params  (cl-parse-lambda-list ll)
                     :body    fn-body
                     :env     env}))
        (dict-set! (get cl-global-env "fns") name fn-obj)
        name))))

;; DEFVAR / DEFPARAMETER / DEFCONSTANT
(define cl-eval-defvar
  (fn (args env always-assign)
    (let ((name     (nth args 0))
          (has-init (> (len args) 1)))
      (let ((val (if has-init (cl-eval (nth args 1) env) nil)))
        (when (or always-assign
                  (not (cl-env-has-var? cl-global-env name)))
          (dict-set! (get cl-global-env "vars") name val))
        name))))

;; Function call: evaluate name → look up fns, builtins; evaluate args
(define cl-call-fn
  (fn (name args env)
    (let ((evaled (map (fn (a) (cl-eval a env)) args)))
      (cond
        ;; FUNCALL: (funcall fn arg...)
        ((= name "FUNCALL")
          (cl-apply (nth evaled 0) (rest evaled)))
        ;; APPLY: (apply fn arg... list)
        ((= name "APPLY")
          (let ((fn-obj   (nth evaled 0))
                (all-args (rest evaled)))
            (let ((leading  (slice all-args 0 (- (len all-args) 1)))
                  (last-arg (nth all-args (- (len all-args) 1))))
              (cl-apply fn-obj (concat leading (if (= last-arg nil) (list) last-arg))))))
        ;; MAPCAR: (mapcar fn list)
        ((= name "MAPCAR")
          (let ((fn-obj (nth evaled 0))
                (lst    (nth evaled 1)))
            (if (= lst nil) (list)
              (map (fn (x) (cl-apply fn-obj (list x))) lst))))
        ;; Look up in local fns namespace
        ((cl-env-has-fn? env name)
          (cl-apply (cl-env-get-fn env name) evaled))
        ;; Look up in global fns namespace
        ((cl-env-has-fn? cl-global-env name)
          (cl-apply (cl-env-get-fn cl-global-env name) evaled))
        ;; Look up in builtins
        ((has-key? cl-builtins name)
          ((get cl-builtins name) evaled))
        (:else
          {:cl-type "error" :message (str "Undefined function: " name)})))))

;; ── main evaluator ────────────────────────────────────────────────

(define cl-eval
  (fn (form env)
    (cond
      ;; Nil and booleans are self-evaluating
      ((= form nil) nil)
      ((= form true) true)
      ;; Numbers are self-evaluating
      ((number? form) form)
      ;; Dicts: typed CL values
      ((dict? form)
        (let ((ct (get form "cl-type")))
          (cond
            ((= ct "string") (get form "value"))  ;; CL string → SX string
            (:else form))))                         ;; keywords, floats, chars, etc.
      ;; Symbol reference (variable lookup)
      ((string? form)
        (cond
          ((cl-env-has-var? env form) (cl-env-get-var env form))
          ((cl-env-has-var? cl-global-env form)
            (cl-env-get-var cl-global-env form))
          (:else {:cl-type "error" :message (str "Undefined variable: " form)})))
      ;; List: special forms or function call
      ((list? form) (cl-eval-list form env))
      ;; Anything else self-evaluates
      (:else form))))

(define cl-eval-list
  (fn (form env)
    (if (= (len form) 0)
      nil
      (let ((head (nth form 0))
            (args (rest form)))
        (cond
          ((= head "QUOTE")        (nth args 0))
          ((= head "IF")           (cl-eval-if args env))
          ((= head "PROGN")        (cl-eval-body args env))
          ((= head "LET")          (cl-eval-let args env false))
          ((= head "LET*")         (cl-eval-let args env true))
          ((= head "AND")          (cl-eval-and args env))
          ((= head "OR")           (cl-eval-or args env))
          ((= head "COND")         (cl-eval-cond args env))
          ((= head "WHEN")
            (if (cl-eval (nth args 0) env)
              (cl-eval-body (rest args) env) nil))
          ((= head "UNLESS")
            (if (not (cl-eval (nth args 0) env))
              (cl-eval-body (rest args) env) nil))
          ((= head "SETQ")         (cl-eval-setq args env))
          ((= head "SETF")         (cl-eval-setq args env))
          ((= head "FUNCTION")     (cl-eval-function args env))
          ((= head "LAMBDA")       (cl-make-lambda args env))
          ((= head "FLET")         (cl-eval-flet args env))
          ((= head "LABELS")       (cl-eval-labels args env))
          ((= head "THE")          (cl-eval (nth args 1) env))
          ((= head "LOCALLY")      (cl-eval-body args env))
          ((= head "EVAL-WHEN")    (cl-eval-eval-when args env))
          ((= head "DEFUN")        (cl-eval-defun args env))
          ((= head "DEFVAR")       (cl-eval-defvar args env false))
          ((= head "DEFPARAMETER") (cl-eval-defvar args env true))
          ((= head "DEFCONSTANT")  (cl-eval-defvar args env true))
          ((= head "DECLAIM")      nil)
          ((= head "PROCLAIM")     nil)
          ;; Named function call
          ((string? head)
            (cl-call-fn head args env))
          ;; Anonymous call: ((lambda ...) args)
          (:else
            (let ((fn-obj (cl-eval head env)))
              (if (and (dict? fn-obj) (= (get fn-obj "cl-type") "function"))
                (cl-apply fn-obj (map (fn (a) (cl-eval a env)) args))
                {:cl-type "error" :message "Not callable"}))))))))

;; ── public API ────────────────────────────────────────────────────

(define cl-eval-str
  (fn (src env)
    (cl-eval (cl-read src) env)))

(define cl-eval-all-str
  (fn (src env)
    (let ((forms (cl-read-all src)))
      (if (= (len forms) 0)
        nil
        (let ((result nil) (i 0))
          (define loop (fn ()
            (when (< i (len forms))
              (do
                (set! result (cl-eval (nth forms i) env))
                (set! i (+ i 1))
                (loop)))))
          (loop)
          result)))))