coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cl: Phase 4 CLOS complete — generic functions, multi-dispatch, method qualifiers, 437/437 tests

Browse Source 
- lib/common-lisp/clos.sx (27 forms): class registry (8 built-in classes),
  defclass/make-instance/slot-value/slot-boundp/change-class, defgeneric/defmethod
  with :before/:after/:around, clos-call-generic (standard combination: sort by
  specificity, fire befores, call primary chain, fire afters reversed),
  call-next-method/next-method-p, with-slots, deferred accessor installation
- lib/common-lisp/tests/clos.sx: 41 tests (class-of, subclass-of?, defclass,
  make-instance, slot ops, inheritance, method specificity, qualifiers, accessors,
  with-slots, change-class)
- lib/common-lisp/tests/programs/geometry.sx: 12 tests — intersect generic
  dispatching on geo-point×geo-point, geo-point×geo-line, geo-line×geo-line,
  geo-line×geo-plane (multi-dispatch by class precedence)
- lib/common-lisp/tests/programs/mop-trace.sx: 13 tests — :before/:after
  tracing on area and describe-shape generics, call-next-method in circle/rect
- eval.sx: dynamic variables — cl-apply-dyn saves/restores global slot for
  specials; cl-mark-special!/cl-special?/cl-dyn-unbound; defvar now marks
  specials; let/let* rebind via cl-apply-dyn; 8 new tests (182 eval total)
- conformance.sh + test.sh: Phase 4 suites wired in
- plans/common-lisp-on-sx.md: Phase 4 + dynamic variable boxes ticked

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-05 11:38:37 +00:00
parent 71c4b5e33f
commit 0e426cfea8
11 changed files with 1529 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
lib/common-lisp/eval.sx
View File

@@ -425,6 +425,55 @@
(cl-eval-body (rest clause) env))
(cl-eval-cond (rest clauses) env)))))))
;; Dynamic variable infrastructure
(define cl-dyn-unbound {:cl-type "dyn-unbound"})
(define cl-specials {})
(define cl-mark-special!
(fn (name) (dict-set! cl-specials name true)))
(define cl-special?
(fn (name) (has-key? cl-specials name)))
;; Apply dynamic bindings: save old global values, set new, run thunk, restore
(define cl-apply-dyn
(fn (binds thunk)
(if (= (len binds) 0)
(thunk)
(let ((b (nth binds 0))
(rest-binds (rest binds)))
(let ((name (get b "name"))
(val (get b "value"))
(gvars (get cl-global-env "vars")))
(let ((old (if (has-key? gvars name)
(get gvars name)
cl-dyn-unbound)))
(dict-set! gvars name val)
(let ((result (cl-apply-dyn rest-binds thunk)))
(if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
(dict-set! gvars name nil)
(dict-set! gvars name old))
result)))))))
;; Sequential LET* with dynamic variable support
(define cl-letstar-bind
(fn (bs e thunk)
(if (= (len bs) 0)
(thunk e)
(let ((b (nth bs 0))
(rest-bs (rest bs)))
(let ((name (if (list? b) (nth b 0) b))
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
(let ((val (cl-eval init e)))
(if (cl-special? name)
(let ((gvars (get cl-global-env "vars")))
(let ((old (if (has-key? gvars name)
(get gvars name)
cl-dyn-unbound)))
(dict-set! gvars name val)
(let ((result (cl-letstar-bind rest-bs e thunk)))
(if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
(dict-set! gvars name nil)
(dict-set! gvars name old))
result)))
(cl-letstar-bind rest-bs (cl-env-bind-var e name val) thunk))))))))
;; Parallel LET and sequential LET*
(define cl-eval-let
(fn (args env sequential)
@@ -432,17 +481,7 @@
(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)))
(cl-letstar-bind bindings env (fn (new-env) (cl-eval-body body new-env)))
;; LET: evaluate all inits in current env, then bind
(let ((pairs (map
(fn (b)
@@ -450,11 +489,14 @@
(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)))))))
(let ((spec-pairs (filter (fn (p) (cl-special? (get p "name"))) pairs))
(lex-pairs (filter (fn (p) (not (cl-special? (get p "name")))) pairs)))
(let ((new-env (reduce
(fn (e pair)
(cl-env-bind-var e (get pair "name") (get pair "value")))
env lex-pairs)))
(cl-apply-dyn spec-pairs
(fn () (cl-eval-body body new-env))))))))))
;; SETQ / SETF (simplified: mutate nearest scope or global)
(define cl-eval-setq
@@ -563,6 +605,7 @@
(when (or always-assign
(not (cl-env-has-var? cl-global-env name)))
(dict-set! (get cl-global-env "vars") name val))
(cl-mark-special! name)
name))))
;; Function call: evaluate name → look up fns, builtins; evaluate args