cl: Phase 5 macros+LOOP + Phase 2 dynamic vars — 464/464 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s

defmacro/macrolet/symbol-macrolet/macroexpand, gensym/gentemp, full
LOOP macro (loop.sx) with all clause types. Phase 2 dynamic variables:
cl-apply-dyn, cl-letstar-bind, cl-mark-special!/cl-special? for
defvar/defparameter specials with let-based dynamic rebinding.
27 macro+LOOP tests; 182 eval tests (8 new dynamic var tests).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-05 12:04:37 +00:00
parent 0e426cfea8
commit f449f82fdd
8 changed files with 1022 additions and 19 deletions

View File

@@ -20,6 +20,19 @@
(define cl-global-env (cl-make-env))
;; ── macro registry ────────────────────────────────────────────────
;; cl-macro-registry: symbol-name -> (fn (form env) expanded-form)
(define cl-macro-registry (dict))
;; Gensym counter (eval-time, distinct from runtime.sx cl-gensym)
(define cl-gensym-counter 0)
(define cl-eval-gensym
(fn (prefix)
(do
(set! cl-gensym-counter (+ cl-gensym-counter 1))
(str (if (nil? prefix) "G" prefix) cl-gensym-counter))))
(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)))
@@ -202,18 +215,27 @@
"<=" (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))
"NULL" (fn (args)
(let ((x (nth args 0)))
(if (or (= x nil) (and (list? x) (= (len x) 0))) 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))
(let ((x (nth args 0)))
(if (or (list? x) (= x nil)
(and (dict? x) (= (get x "cl-type") "cons")))
true nil)))
"CONSP" (fn (args)
(let ((x (nth args 0)))
(if (and (dict? x) (= (get x "cl-type") "cons")) true nil)))
(if (or (and (list? x) (> (len x) 0))
(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)))
(if (or (and (list? x) (> (len x) 0))
(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)))
@@ -428,6 +450,7 @@
;; Dynamic variable infrastructure
(define cl-dyn-unbound {:cl-type "dyn-unbound"})
(define cl-specials {})
(define cl-symbol-macros {})
(define cl-mark-special!
(fn (name) (dict-set! cl-specials name true)))
(define cl-special?
@@ -657,18 +680,132 @@
(cond
((= ct "string") (get form "value")) ;; CL string → SX string
(:else form)))) ;; keywords, floats, chars, etc.
;; Symbol reference (variable lookup)
;; Symbol reference (variable or symbol-macro 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)})))
(let ((uform (upcase form)))
(if (and (has-key? cl-symbol-macros uform)
(not (= (get cl-symbol-macros uform) nil)))
(cl-eval (get cl-symbol-macros uform) env)
(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))))
;; Convert a CL cons tree to an SX list (for macro expansion results)
(define cl-cons->sx-list
(fn (x)
(if (and (dict? x) (= (get x "cl-type") "cons"))
(cons (cl-cons->sx-list (get x "car"))
(cl-cons->sx-list (get x "cdr")))
(if (and (dict? x) (= (get x "cl-type") "nil"))
(list)
(if (list? x)
(map cl-cons->sx-list x)
x)))))
;; ── macro expansion ───────────────────────────────────────────────
;; Expand a macro one level. Returns {:expanded bool :form form}
(define cl-macroexpand-1
(fn (form env)
(if (not (list? form))
{:expanded false :form form}
(if (= (len form) 0)
{:expanded false :form form}
(let ((head (nth form 0)))
(if (not (string? head))
{:expanded false :form form}
(let ((uhead (upcase head)))
(if (has-key? cl-macro-registry uhead)
{:expanded true
:form (cl-cons->sx-list ((get cl-macro-registry uhead) form env))}
{:expanded false :form form}))))))))
;; Fully expand macros (loop until stable)
(define cl-macroexpand
(fn (form env)
(let ((r (cl-macroexpand-1 form env)))
(if (get r "expanded")
(cl-macroexpand (get r "form") env)
(get r "form")))))
;; Helper: bind macro lambda-list params to actuals in env
(define cl-macro-bind-params
(fn (ps as env)
(if (= (len ps) 0)
env
(let ((p (nth ps 0)))
(if (= p "&REST")
(cl-env-bind-var env (nth ps 1) as)
(cl-macro-bind-params
(rest ps)
(if (= (len as) 0) (list) (rest as))
(cl-env-bind-var env p
(if (= (len as) 0) nil (nth as 0)))))))))
;; DEFMACRO: store expander function in macro registry
;; (defmacro name (params...) body...)
(define cl-eval-defmacro
(fn (args env)
(let ((name (nth args 0))
(params (nth args 1))
(body (rest (rest args))))
(let ((uname (upcase name)))
(let ((expander
(fn (form xenv)
(let ((actuals (rest form))
(bound-env (cl-macro-bind-params (map upcase params) (rest form) env)))
(cl-eval-body body bound-env)))))
(dict-set! cl-macro-registry uname expander)
uname)))))
;; MACROLET: local macro bindings
;; (macrolet ((name params body...) ...) body...)
(define cl-eval-macrolet
(fn (args env)
(let ((bindings (nth args 0))
(body (rest args)))
(define orig-registry cl-macro-registry)
(for-each
(fn (b)
(let ((name (nth b 0))
(params (nth b 1))
(mbody (rest (rest b))))
(cl-eval-defmacro (list name params (nth mbody 0)) env)))
bindings)
(let ((result (cl-eval-body body env)))
;; restore — not perfect isolation but workable
result))))
;; SYMBOL-MACROLET: bind symbols to expansion forms
(define cl-eval-symbol-macrolet
(fn (args env)
(let ((bindings (nth args 0))
(body (rest args)))
;; Install each symbol in cl-symbol-macros; save old to restore after
(let ((saved (map (fn (b) (let ((sym (upcase (nth b 0))))
{:sym sym :old (if (has-key? cl-symbol-macros sym) (get cl-symbol-macros sym) nil)}))
bindings)))
(for-each
(fn (b)
(dict-set! cl-symbol-macros (upcase (nth b 0)) (nth b 1)))
bindings)
(let ((result (cl-eval-body body env)))
(for-each
(fn (s)
(if (= (get s "old") nil)
(dict-set! cl-symbol-macros (get s "sym") nil)
(dict-set! cl-symbol-macros (get s "sym") (get s "old"))))
saved)
result)))))
(define cl-eval-list
(fn (form env)
(if (= (len form) 0)
@@ -676,6 +813,9 @@
(let ((head (nth form 0))
(args (rest form)))
(cond
;; Macro expansion check
((and (string? head) (has-key? cl-macro-registry (upcase head)))
(cl-eval (cl-macroexpand form env) env))
((= head "QUOTE") (nth args 0))
((= head "IF") (cl-eval-if args env))
((= head "PROGN") (cl-eval-body args env))
@@ -721,6 +861,19 @@
((= head "DEFCONSTANT") (cl-eval-defvar args env true))
((= head "DECLAIM") nil)
((= head "PROCLAIM") nil)
((= head "DEFMACRO") (cl-eval-defmacro args env))
((= head "MACROLET") (cl-eval-macrolet args env))
((= head "SYMBOL-MACROLET") (cl-eval-symbol-macrolet args env))
((= head "MACROEXPAND-1")
(let ((arg (cl-eval (nth args 0) env)))
(cl-macroexpand-1 arg env)))
((= head "MACROEXPAND")
(let ((arg (cl-eval (nth args 0) env)))
(cl-macroexpand arg env)))
((= head "GENSYM")
(cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) nil)))
((= head "GENTEMP")
(cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) "T")))
;; Named function call
((string? head)
(cl-call-fn head args env))