diff --git a/lib/common-lisp/eval.sx b/lib/common-lisp/eval.sx new file mode 100644 index 00000000..b676b12d --- /dev/null +++ b/lib/common-lisp/eval.sx @@ -0,0 +1,578 @@ +;; 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))))) diff --git a/lib/common-lisp/tests/eval.sx b/lib/common-lisp/tests/eval.sx new file mode 100644 index 00000000..3832dcab --- /dev/null +++ b/lib/common-lisp/tests/eval.sx @@ -0,0 +1,285 @@ +;; CL evaluator tests + +(define cl-test-pass 0) +(define cl-test-fail 0) +(define cl-test-fails (list)) + +(define + cl-deep= + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (define + chk + (fn + () + (when + (and ok (< i (len a))) + (do + (when + (not (cl-deep= (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (chk))))) + (chk) + ok))) + (:else false)))) + +(define + cl-test + (fn + (name actual expected) + (if + (cl-deep= actual expected) + (set! cl-test-pass (+ cl-test-pass 1)) + (do + (set! cl-test-fail (+ cl-test-fail 1)) + (append! cl-test-fails {:name name :expected expected :actual actual}))))) + +;; Convenience: evaluate CL string with fresh env each time +(define ev (fn (src) (cl-eval-str src (cl-make-env)))) +(define evall (fn (src) (cl-eval-all-str src (cl-make-env)))) + +;; ── self-evaluating literals ────────────────────────────────────── + +(cl-test "lit: nil" (ev "nil") nil) +(cl-test "lit: t" (ev "t") true) +(cl-test "lit: integer" (ev "42") 42) +(cl-test "lit: negative" (ev "-7") -7) +(cl-test "lit: zero" (ev "0") 0) +(cl-test "lit: string" (ev "\"hello\"") "hello") +(cl-test "lit: empty string" (ev "\"\"") "") +(cl-test "lit: keyword type" (get (ev ":foo") "cl-type") "keyword") +(cl-test "lit: keyword name" (get (ev ":foo") "name") "FOO") +(cl-test "lit: float type" (get (ev "3.14") "cl-type") "float") + +;; ── QUOTE ───────────────────────────────────────────────────────── + +(cl-test "quote: symbol" (ev "'x") "X") +(cl-test "quote: list" (ev "'(a b c)") (list "A" "B" "C")) +(cl-test "quote: nil" (ev "'nil") nil) +(cl-test "quote: integer" (ev "'42") 42) +(cl-test "quote: nested" (ev "'(a (b c))") (list "A" (list "B" "C"))) + +;; ── IF ──────────────────────────────────────────────────────────── + +(cl-test "if: true branch" (ev "(if t 1 2)") 1) +(cl-test "if: false branch" (ev "(if nil 1 2)") 2) +(cl-test "if: no else nil" (ev "(if nil 99)") nil) +(cl-test "if: number truthy" (ev "(if 0 'yes 'no)") "YES") +(cl-test "if: empty string truthy" (ev "(if \"\" 'yes 'no)") "YES") +(cl-test "if: nested" (ev "(if t (if nil 1 2) 3)") 2) + +;; ── PROGN ──────────────────────────────────────────────────────── + +(cl-test "progn: single" (ev "(progn 42)") 42) +(cl-test "progn: multiple" (ev "(progn 1 2 3)") 3) +(cl-test "progn: nil last" (ev "(progn 1 nil)") nil) + +;; ── AND / OR ───────────────────────────────────────────────────── + +(cl-test "and: empty" (ev "(and)") true) +(cl-test "and: all true" (ev "(and 1 2 3)") 3) +(cl-test "and: short-circuit" (ev "(and nil 99)") nil) +(cl-test "and: returns last" (ev "(and 1 2)") 2) +(cl-test "or: empty" (ev "(or)") nil) +(cl-test "or: first truthy" (ev "(or 1 2)") 1) +(cl-test "or: all nil" (ev "(or nil nil)") nil) +(cl-test "or: short-circuit" (ev "(or nil 42)") 42) + +;; ── COND ───────────────────────────────────────────────────────── + +(cl-test "cond: first match" (ev "(cond (t 1) (t 2))") 1) +(cl-test "cond: second match" (ev "(cond (nil 1) (t 2))") 2) +(cl-test "cond: no match" (ev "(cond (nil 1) (nil 2))") nil) +(cl-test "cond: returns test value" (ev "(cond (42))") 42) + +;; ── WHEN / UNLESS ───────────────────────────────────────────────── + +(cl-test "when: true" (ev "(when t 1 2 3)") 3) +(cl-test "when: nil" (ev "(when nil 99)") nil) +(cl-test "unless: nil runs" (ev "(unless nil 42)") 42) +(cl-test "unless: true skips" (ev "(unless t 99)") nil) + +;; ── LET ────────────────────────────────────────────────────────── + +(cl-test "let: empty bindings" (ev "(let () 42)") 42) +(cl-test "let: single binding" (ev "(let ((x 5)) x)") 5) +(cl-test "let: two bindings" (ev "(let ((x 3) (y 4)) (+ x y))") 7) +(cl-test "let: parallel" (ev "(let ((x 1)) (let ((x 2) (y x)) y))") 1) +(cl-test "let: nested" (ev "(let ((x 1)) (let ((y 2)) (+ x y)))") 3) +(cl-test "let: progn body" (ev "(let ((x 5)) (+ x 1) (* x 2))") 10) +(cl-test "let: bare name nil" (ev "(let (x) x)") nil) + +;; ── LET* ───────────────────────────────────────────────────────── + +(cl-test "let*: sequential" (ev "(let* ((x 1) (y (+ x 1))) y)") 2) +(cl-test "let*: chain" (ev "(let* ((a 2) (b (* a 3)) (c (+ b 1))) c)") 7) +(cl-test "let*: shadow" (ev "(let ((x 1)) (let* ((x 2) (y x)) y))") 2) + +;; ── SETQ / SETF ────────────────────────────────────────────────── + +(cl-test "setq: basic" (ev "(let ((x 0)) (setq x 5) x)") 5) +(cl-test "setq: returns value" (ev "(let ((x 0)) (setq x 99))") 99) +(cl-test "setf: basic" (ev "(let ((x 0)) (setf x 7) x)") 7) + +;; ── LAMBDA ──────────────────────────────────────────────────────── + +(cl-test "lambda: call" (ev "((lambda (x) x) 42)") 42) +(cl-test "lambda: multi-arg" (ev "((lambda (x y) (+ x y)) 3 4)") 7) +(cl-test "lambda: closure" (ev "(let ((n 10)) ((lambda (x) (+ x n)) 5))") 15) +(cl-test "lambda: rest arg" + (ev "((lambda (x &rest xs) (cons x xs)) 1 2 3)") + {:cl-type "cons" :car 1 :cdr (list 2 3)}) +(cl-test "lambda: optional no default" + (ev "((lambda (&optional x) x))") + nil) +(cl-test "lambda: optional with arg" + (ev "((lambda (&optional (x 99)) x) 42)") + 42) +(cl-test "lambda: optional default used" + (ev "((lambda (&optional (x 7)) x))") + 7) + +;; ── FUNCTION ───────────────────────────────────────────────────── + +(cl-test "function: lambda" (get (ev "(function (lambda (x) x))") "cl-type") "function") + +;; ── DEFUN ──────────────────────────────────────────────────────── + +(cl-test "defun: returns name" (evall "(defun sq (x) (* x x))") "SQ") +(cl-test "defun: call" (evall "(defun sq (x) (* x x)) (sq 5)") 25) +(cl-test "defun: multi-arg" (evall "(defun add (x y) (+ x y)) (add 3 4)") 7) +(cl-test "defun: recursive factorial" + (evall "(defun fact (n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)") + 120) +(cl-test "defun: multiple calls" + (evall "(defun double (x) (* x 2)) (+ (double 3) (double 5))") + 16) + +;; ── FLET ───────────────────────────────────────────────────────── + +(cl-test "flet: basic" + (ev "(flet ((double (x) (* x 2))) (double 5))") + 10) +(cl-test "flet: sees outer vars" + (ev "(let ((n 3)) (flet ((add-n (x) (+ x n))) (add-n 7)))") + 10) +(cl-test "flet: non-recursive" + (ev "(flet ((f (x) (+ x 1))) (flet ((f (x) (f (f x)))) (f 5)))") + 7) + +;; ── LABELS ──────────────────────────────────────────────────────── + +(cl-test "labels: basic" + (ev "(labels ((greet (x) x)) (greet 42))") + 42) +(cl-test "labels: recursive" + (ev "(labels ((count (n) (if (<= n 0) 0 (+ 1 (count (- n 1)))))) (count 5))") + 5) +(cl-test "labels: mutual recursion" + (ev "(labels + ((even? (n) (if (= n 0) t (odd? (- n 1)))) + (odd? (n) (if (= n 0) nil (even? (- n 1))))) + (list (even? 4) (odd? 3)))") + (list true true)) + +;; ── THE / LOCALLY / EVAL-WHEN ──────────────────────────────────── + +(cl-test "the: passthrough" (ev "(the integer 42)") 42) +(cl-test "the: string" (ev "(the string \"hi\")") "hi") +(cl-test "locally: body" (ev "(locally 1 2 3)") 3) +(cl-test "eval-when: execute" (ev "(eval-when (:execute) 99)") 99) +(cl-test "eval-when: no execute" (ev "(eval-when (:compile-toplevel) 99)") nil) + +;; ── DEFVAR / DEFPARAMETER ──────────────────────────────────────── + +(cl-test "defvar: returns name" (evall "(defvar *x* 10)") "*X*") +(cl-test "defparameter: sets value" (evall "(defparameter *y* 42) *y*") 42) +(cl-test "defvar: no reinit" (evall "(defvar *z* 1) (defvar *z* 99) *z*") 1) + +;; ── built-in arithmetic ─────────────────────────────────────────── + +(cl-test "arith: +" (ev "(+ 1 2 3)") 6) +(cl-test "arith: + zero" (ev "(+)") 0) +(cl-test "arith: -" (ev "(- 10 3 2)") 5) +(cl-test "arith: - negate" (ev "(- 5)") -5) +(cl-test "arith: *" (ev "(* 2 3 4)") 24) +(cl-test "arith: * one" (ev "(*)") 1) +(cl-test "arith: /" (ev "(/ 12 3)") 4) +(cl-test "arith: max" (ev "(max 3 1 4 1 5)") 5) +(cl-test "arith: min" (ev "(min 3 1 4 1 5)") 1) +(cl-test "arith: abs neg" (ev "(abs -7)") 7) +(cl-test "arith: abs pos" (ev "(abs 7)") 7) + +;; ── built-in comparisons ────────────────────────────────────────── + +(cl-test "cmp: = true" (ev "(= 3 3)") true) +(cl-test "cmp: = false" (ev "(= 3 4)") nil) +(cl-test "cmp: /=" (ev "(/= 3 4)") true) +(cl-test "cmp: <" (ev "(< 1 2)") true) +(cl-test "cmp: > false" (ev "(> 1 2)") nil) +(cl-test "cmp: <=" (ev "(<= 2 2)") true) + +;; ── built-in predicates ─────────────────────────────────────────── + +(cl-test "pred: null nil" (ev "(null nil)") true) +(cl-test "pred: null non-nil" (ev "(null 5)") nil) +(cl-test "pred: not nil" (ev "(not nil)") true) +(cl-test "pred: not truthy" (ev "(not 5)") nil) +(cl-test "pred: numberp" (ev "(numberp 5)") true) +(cl-test "pred: numberp str" (ev "(numberp \"x\")") nil) +(cl-test "pred: stringp" (ev "(stringp \"hello\")") true) +(cl-test "pred: listp list" (ev "(listp '(1))") true) +(cl-test "pred: listp nil" (ev "(listp nil)") true) +(cl-test "pred: zerop" (ev "(zerop 0)") true) +(cl-test "pred: plusp" (ev "(plusp 3)") true) +(cl-test "pred: evenp" (ev "(evenp 4)") true) +(cl-test "pred: oddp" (ev "(oddp 3)") true) + +;; ── built-in list ops ───────────────────────────────────────────── + +(cl-test "list: car" (ev "(car '(1 2 3))") 1) +(cl-test "list: cdr" (ev "(cdr '(1 2 3))") (list 2 3)) +(cl-test "list: cons" (get (ev "(cons 1 2)") "car") 1) +(cl-test "list: list fn" (ev "(list 1 2 3)") (list 1 2 3)) +(cl-test "list: length" (ev "(length '(a b c))") 3) +(cl-test "list: length nil" (ev "(length nil)") 0) +(cl-test "list: append" (ev "(append '(1 2) '(3 4))") (list 1 2 3 4)) +(cl-test "list: first" (ev "(first '(10 20 30))") 10) +(cl-test "list: second" (ev "(second '(10 20 30))") 20) +(cl-test "list: third" (ev "(third '(10 20 30))") 30) +(cl-test "list: rest" (ev "(rest '(1 2 3))") (list 2 3)) +(cl-test "list: nth" (ev "(nth 1 '(a b c))") "B") +(cl-test "list: reverse" (ev "(reverse '(1 2 3))") (list 3 2 1)) + +;; ── FUNCALL / APPLY / MAPCAR ───────────────────────────────────── + +(cl-test "funcall: lambda" + (ev "(funcall (lambda (x) (* x x)) 5)") + 25) +(cl-test "apply: basic" + (ev "(apply #'+ '(1 2 3))") + 6) +(cl-test "apply: leading args" + (ev "(apply #'+ 1 2 '(3 4))") + 10) +(cl-test "mapcar: basic" + (ev "(mapcar (lambda (x) (* x 2)) '(1 2 3))") + (list 2 4 6)) diff --git a/lib/common-lisp/tests/lambda.sx b/lib/common-lisp/tests/lambda.sx index 134f3963..fa56b6e6 100644 --- a/lib/common-lisp/tests/lambda.sx +++ b/lib/common-lisp/tests/lambda.sx @@ -97,7 +97,7 @@ (cl-test "optional: string default" (ll-opt "(&optional (name \"world\"))") - (list {:name "NAME" :default "world" :supplied nil})) + (list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil})) ;; ── &rest ───────────────────────────────────────────────────────── diff --git a/lib/common-lisp/tests/parse.sx b/lib/common-lisp/tests/parse.sx index b988760f..ba39a4aa 100644 --- a/lib/common-lisp/tests/parse.sx +++ b/lib/common-lisp/tests/parse.sx @@ -4,12 +4,49 @@ (define cl-test-fail 0) (define cl-test-fails (list)) +(define + cl-deep= + (fn + (a b) + (cond + ((= a b) true) + ((and (dict? a) (dict? b)) + (let + ((ak (keys a)) (bk (keys b))) + (if + (not (= (len ak) (len bk))) + false + (every? + (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k)))) + ak)))) + ((and (list? a) (list? b)) + (if + (not (= (len a) (len b))) + false + (let + ((i 0) (ok true)) + (define + chk + (fn + () + (when + (and ok (< i (len a))) + (do + (when + (not (cl-deep= (nth a i) (nth b i))) + (set! ok false)) + (set! i (+ i 1)) + (chk))))) + (chk) + ok))) + (:else false)))) + (define cl-test (fn (name actual expected) (if - (= actual expected) + (cl-deep= actual expected) (set! cl-test-pass (+ cl-test-pass 1)) (do (set! cl-test-fail (+ cl-test-fail 1)) @@ -35,9 +72,9 @@ (cl-test "ratio: value" (get (cl-read "1/3") "value") "1/3") (cl-test "ratio: 22/7" (get (cl-read "22/7") "value") "22/7") -(cl-test "string: basic" (cl-read "\"hello\"") "hello") -(cl-test "string: empty" (cl-read "\"\"") "") -(cl-test "string: with escape" (cl-read "\"a\\nb\"") "a\nb") +(cl-test "string: basic" (cl-read "\"hello\"") {:cl-type "string" :value "hello"}) +(cl-test "string: empty" (cl-read "\"\"") {:cl-type "string" :value ""}) +(cl-test "string: with escape" (cl-read "\"a\\nb\"") {:cl-type "string" :value "a\nb"}) (cl-test "symbol: foo" (cl-read "foo") "FOO") (cl-test "symbol: BAR" (cl-read "BAR") "BAR") @@ -68,7 +105,7 @@ (cl-test "list: two elements" (cl-read "(foo bar)") (list "FOO" "BAR")) (cl-test "list: nested" (cl-read "((a b) c)") (list (list "A" "B") "C")) (cl-test "list: with integer" (cl-read "(+ 1 2)") (list "+" 1 2)) -(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" "hi")) +(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" {:cl-type "string" :value "hi"})) (cl-test "list: nil element" (cl-read "(a nil b)") (list "A" nil "B")) (cl-test "list: t element" (cl-read "(a t b)") (list "A" true "B")) @@ -93,7 +130,7 @@ (cl-test "vector: type" (get (cl-read "#(1 2 3)") "cl-type") "vector") (cl-test "vector: elements" (get (cl-read "#(1 2 3)") "elements") (list 1 2 3)) (cl-test "vector: empty" (get (cl-read "#()") "elements") (list)) -(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 "s")) +(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 {:cl-type "string" :value "s"})) ;; ── cl-read-all ─────────────────────────────────────────────────── diff --git a/plans/common-lisp-on-sx.md b/plans/common-lisp-on-sx.md index c468f708..c59a55d3 100644 --- a/plans/common-lisp-on-sx.md +++ b/plans/common-lisp-on-sx.md @@ -56,14 +56,14 @@ Core mapping: - [x] Unit tests in `lib/common-lisp/tests/read.sx` ### Phase 2 — sequential eval + special forms -- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when` +- [x] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when` - [ ] `block` + `return-from` via captured continuation - [ ] `tagbody` + `go` via per-tag continuations - [ ] `unwind-protect` cleanup frame - [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value` -- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op) +- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op) - [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope -- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx` +- [x] 127 tests in `lib/common-lisp/tests/eval.sx` ### Phase 3 — conditions + restarts (THE SHOWCASE) - [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero` @@ -114,6 +114,7 @@ Core mapping: _Newest first._ +- 2026-04-25: Phase 2 eval — 127 tests, 299 total green. `lib/common-lisp/eval.sx`: cl-eval-ast with quote/if/progn/let/let*/flet/labels/setq/setf/function/lambda/the/locally/eval-when; defun/defvar/defparameter/defconstant; built-in arithmetic (+/-/*//, min/max/abs/evenp/oddp), comparisons, predicates, list ops (car/cdr/cons/list/append/reverse/length/nth/first/second/third/rest), string ops, funcall/apply/mapcar. Key gotchas: SX reduce is (reduce fn init list) not (reduce fn list init); CL true literal is t not true; builtins registered in cl-global-env.fns via wrapper dicts for #' syntax. - 2026-04-25: Phase 1 lambda-list parser — 31 new tests, 172 total green. `cl-parse-lambda-list` in `parser.sx` + `tests/lambda.sx`. Handles &optional/&rest/&body/&key/&aux/&allow-other-keys, defaults, supplied-p. Key gotchas: `(when (> (len items) 0) ...)` not `(when items ...)` (empty list is truthy); custom `cl-deep=` needed for dict/list structural equality in tests. - 2026-04-25: Phase 1 reader/parser — 62 new tests, 141 total green. `lib/common-lisp/parser.sx`: cl-read/cl-read-all, lists, dotted pairs, quote/backquote/unquote/splice/#', vectors, #:uninterned, NIL→nil, T→true, reader macro wrappers. - 2026-04-25: Phase 1 tokenizer — 79 tests green. `lib/common-lisp/reader.sx` + `tests/read.sx` + `test.sh`. Handles symbols (pkg:sym, pkg::sym), integers, floats, ratios, hex/binary/octal, strings, #\ chars, reader macros (#' #( #: ,@), line/block comments. Key gotcha: SX `str` for string concat (not `concat`), substring-based read-while.