cl: Phase 4 CLOS complete — generic functions, multi-dispatch, method qualifiers, 437/437 tests
- 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:
500
lib/common-lisp/clos.sx
Normal file
500
lib/common-lisp/clos.sx
Normal file
@@ -0,0 +1,500 @@
|
||||
;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions
|
||||
;;
|
||||
;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]}
|
||||
;; Instance: {:clos-type "instance" :class "NAME" :slots {slot: val ...}}
|
||||
;; Method: {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)}
|
||||
;;
|
||||
;; SX primitive notes:
|
||||
;; dict->list: use (map (fn (k) (list k (get d k))) (keys d))
|
||||
;; dict-set (pure): use assoc
|
||||
;; fn?/callable?: use callable?
|
||||
|
||||
;; ── dict helpers ───────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-dict->list
|
||||
(fn (d) (map (fn (k) (list k (get d k))) (keys d))))
|
||||
|
||||
;; ── class registry ─────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-class-registry
|
||||
(dict
|
||||
"t"
|
||||
{:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"}
|
||||
"null"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"}
|
||||
"integer"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"}
|
||||
"float"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"}
|
||||
"string"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"}
|
||||
"symbol"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"}
|
||||
"cons"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"}
|
||||
"list"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"}))
|
||||
|
||||
;; ── clos-generic-registry ─────────────────────────────────────────────────
|
||||
|
||||
(define clos-generic-registry (dict))
|
||||
|
||||
;; ── class-of ──────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-class-of
|
||||
(fn
|
||||
(x)
|
||||
(cond
|
||||
((nil? x) "null")
|
||||
((integer? x) "integer")
|
||||
((float? x) "float")
|
||||
((string? x) "string")
|
||||
((symbol? x) "symbol")
|
||||
((and (list? x) (> (len x) 0)) "cons")
|
||||
((and (list? x) (= (len x) 0)) "null")
|
||||
((and (dict? x) (= (get x "clos-type") "instance")) (get x "class"))
|
||||
(:else "t"))))
|
||||
|
||||
;; ── subclass-of? ──────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Captures clos-class-registry at define time to avoid free-variable issues.
|
||||
|
||||
(define
|
||||
clos-subclass-of?
|
||||
(let
|
||||
((registry clos-class-registry))
|
||||
(fn
|
||||
(class-name super-name)
|
||||
(if
|
||||
(= class-name super-name)
|
||||
true
|
||||
(let
|
||||
((rec (get registry class-name)))
|
||||
(if
|
||||
(nil? rec)
|
||||
false
|
||||
(some
|
||||
(fn (p) (clos-subclass-of? p super-name))
|
||||
(get rec "parents"))))))))
|
||||
|
||||
;; ── instance-of? ──────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-instance-of?
|
||||
(fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name)))
|
||||
|
||||
;; ── defclass ──────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer
|
||||
;; Each missing key defaults to nil.
|
||||
|
||||
(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec)))
|
||||
|
||||
(define
|
||||
clos-defclass
|
||||
(fn
|
||||
(name parents slot-specs)
|
||||
(let
|
||||
((slots (dict)))
|
||||
(for-each
|
||||
(fn
|
||||
(pname)
|
||||
(let
|
||||
((prec (get clos-class-registry pname)))
|
||||
(when
|
||||
(not (nil? prec))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when
|
||||
(nil? (get slots k))
|
||||
(dict-set! slots k (get (get prec "slots") k))))
|
||||
(keys (get prec "slots"))))))
|
||||
parents)
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((spec (clos-slot-spec s)))
|
||||
(dict-set! slots (get spec "name") spec)))
|
||||
slot-specs)
|
||||
(let
|
||||
((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name}))
|
||||
(dict-set! clos-class-registry name class-rec)
|
||||
(clos-install-accessors-for name slots)
|
||||
name))))
|
||||
|
||||
;; ── accessor installation (forward-declared, defined after defmethod) ──────
|
||||
|
||||
(define
|
||||
clos-install-accessors-for
|
||||
(fn
|
||||
(class-name slots)
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(let
|
||||
((spec (get slots k)))
|
||||
(let
|
||||
((reader (get spec "reader")))
|
||||
(when
|
||||
(not (nil? reader))
|
||||
(clos-add-reader-method reader class-name k)))
|
||||
(let
|
||||
((accessor (get spec "accessor")))
|
||||
(when
|
||||
(not (nil? accessor))
|
||||
(clos-add-reader-method accessor class-name k)))))
|
||||
(keys slots))))
|
||||
|
||||
;; placeholder — real impl filled in after defmethod is defined
|
||||
(define clos-add-reader-method (fn (method-name class-name slot-name) nil))
|
||||
|
||||
;; ── make-instance ─────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-make-instance
|
||||
(fn
|
||||
(class-name &rest initargs)
|
||||
(let
|
||||
((class-rec (get clos-class-registry class-name)))
|
||||
(if
|
||||
(nil? class-rec)
|
||||
(error (str "No class named: " class-name))
|
||||
(let
|
||||
((slots (dict)))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(let
|
||||
((spec (get (get class-rec "slots") k)))
|
||||
(let
|
||||
((initform (get spec "initform")))
|
||||
(when
|
||||
(not (nil? initform))
|
||||
(dict-set!
|
||||
slots
|
||||
k
|
||||
(if (callable? initform) (initform) initform))))))
|
||||
(keys (get class-rec "slots")))
|
||||
(define
|
||||
apply-args
|
||||
(fn
|
||||
(args)
|
||||
(when
|
||||
(>= (len args) 2)
|
||||
(let
|
||||
((key (str (first args))) (val (first (rest args))))
|
||||
(let
|
||||
((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key)))
|
||||
(let
|
||||
((matched false))
|
||||
(for-each
|
||||
(fn
|
||||
(sk)
|
||||
(let
|
||||
((spec (get (get class-rec "slots") sk)))
|
||||
(let
|
||||
((ia (get spec "initarg")))
|
||||
(when
|
||||
(or
|
||||
(= ia key)
|
||||
(= ia (str ":" skey))
|
||||
(= sk skey))
|
||||
(dict-set! slots sk val)
|
||||
(set! matched true)))))
|
||||
(keys (get class-rec "slots")))))
|
||||
(apply-args (rest (rest args)))))))
|
||||
(apply-args initargs)
|
||||
{:clos-type "instance" :slots slots :class class-name})))))
|
||||
|
||||
;; ── slot-value ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-slot-value
|
||||
(fn
|
||||
(instance slot-name)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(get (get instance "slots") slot-name)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
(define
|
||||
clos-set-slot-value!
|
||||
(fn
|
||||
(instance slot-name value)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(dict-set! (get instance "slots") slot-name value)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
(define
|
||||
clos-slot-boundp
|
||||
(fn
|
||||
(instance slot-name)
|
||||
(and
|
||||
(dict? instance)
|
||||
(= (get instance "clos-type") "instance")
|
||||
(not (nil? (get (get instance "slots") slot-name))))))
|
||||
|
||||
;; ── find-class / change-class ─────────────────────────────────────────────
|
||||
|
||||
(define clos-find-class (fn (name) (get clos-class-registry name)))
|
||||
|
||||
(define
|
||||
clos-change-class!
|
||||
(fn
|
||||
(instance new-class-name)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(dict-set! instance "class" new-class-name)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
;; ── defgeneric ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-defgeneric
|
||||
(fn
|
||||
(name options)
|
||||
(let
|
||||
((combination (or (get options "method-combination") "standard")))
|
||||
(when
|
||||
(nil? (get clos-generic-registry name))
|
||||
(dict-set! clos-generic-registry name {:methods (list) :combination combination :name name}))
|
||||
name)))
|
||||
|
||||
;; ── defmethod ─────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; method-fn: (fn (args next-fn) body)
|
||||
;; args = list of all call arguments
|
||||
;; next-fn = (fn () next-method-result) or nil
|
||||
|
||||
(define
|
||||
clos-defmethod
|
||||
(fn
|
||||
(generic-name qualifiers specializers method-fn)
|
||||
(when
|
||||
(nil? (get clos-generic-registry generic-name))
|
||||
(clos-defgeneric generic-name {}))
|
||||
(let
|
||||
((grec (get clos-generic-registry generic-name))
|
||||
(new-method {:fn method-fn :qualifiers qualifiers :specializers specializers}))
|
||||
(let
|
||||
((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods"))))
|
||||
(dict-set!
|
||||
clos-generic-registry
|
||||
generic-name
|
||||
(assoc grec "methods" (append kept (list new-method))))
|
||||
generic-name))))
|
||||
|
||||
;; Now install the real accessor-method installer
|
||||
(set!
|
||||
clos-add-reader-method
|
||||
(fn
|
||||
(method-name class-name slot-name)
|
||||
(clos-defmethod
|
||||
method-name
|
||||
(list)
|
||||
(list class-name)
|
||||
(fn (args next-fn) (clos-slot-value (first args) slot-name)))))
|
||||
|
||||
;; ── method specificity ─────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-method-matches?
|
||||
(fn
|
||||
(method args)
|
||||
(let
|
||||
((specs (get method "specializers")))
|
||||
(if
|
||||
(> (len specs) (len args))
|
||||
false
|
||||
(define
|
||||
check-all
|
||||
(fn
|
||||
(i)
|
||||
(if
|
||||
(>= i (len specs))
|
||||
true
|
||||
(let
|
||||
((spec (nth specs i)) (arg (nth args i)))
|
||||
(if
|
||||
(= spec "t")
|
||||
(check-all (+ i 1))
|
||||
(if
|
||||
(clos-instance-of? arg spec)
|
||||
(check-all (+ i 1))
|
||||
false))))))
|
||||
(check-all 0)))))
|
||||
|
||||
;; Precedence distance: how far class-name is from spec-name up the hierarchy.
|
||||
(define
|
||||
clos-specificity
|
||||
(let
|
||||
((registry clos-class-registry))
|
||||
(fn
|
||||
(class-name spec-name)
|
||||
(define
|
||||
walk
|
||||
(fn
|
||||
(cn depth)
|
||||
(if
|
||||
(= cn spec-name)
|
||||
depth
|
||||
(let
|
||||
((rec (get registry cn)))
|
||||
(if
|
||||
(nil? rec)
|
||||
nil
|
||||
(let
|
||||
((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents"))))
|
||||
(let
|
||||
((non-nil (filter (fn (x) (not (nil? x))) results)))
|
||||
(if
|
||||
(empty? non-nil)
|
||||
nil
|
||||
(reduce
|
||||
(fn (a b) (if (< a b) a b))
|
||||
(first non-nil)
|
||||
(rest non-nil))))))))))
|
||||
(walk class-name 0))))
|
||||
|
||||
(define
|
||||
clos-method-more-specific?
|
||||
(fn
|
||||
(m1 m2 args)
|
||||
(let
|
||||
((s1 (get m1 "specializers")) (s2 (get m2 "specializers")))
|
||||
(define
|
||||
cmp
|
||||
(fn
|
||||
(i)
|
||||
(if
|
||||
(>= i (len s1))
|
||||
false
|
||||
(let
|
||||
((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i)))
|
||||
(c2
|
||||
(clos-specificity (clos-class-of (nth args i)) (nth s2 i))))
|
||||
(cond
|
||||
((and (nil? c1) (nil? c2)) (cmp (+ i 1)))
|
||||
((nil? c1) false)
|
||||
((nil? c2) true)
|
||||
((< c1 c2) true)
|
||||
((> c1 c2) false)
|
||||
(:else (cmp (+ i 1))))))))
|
||||
(cmp 0))))
|
||||
|
||||
(define
|
||||
clos-sort-methods
|
||||
(fn
|
||||
(methods args)
|
||||
(define
|
||||
insert
|
||||
(fn
|
||||
(m sorted)
|
||||
(if
|
||||
(empty? sorted)
|
||||
(list m)
|
||||
(if
|
||||
(clos-method-more-specific? m (first sorted) args)
|
||||
(cons m sorted)
|
||||
(cons (first sorted) (insert m (rest sorted)))))))
|
||||
(reduce (fn (acc m) (insert m acc)) (list) methods)))
|
||||
|
||||
;; ── call-generic (standard method combination) ─────────────────────────────
|
||||
|
||||
(define
|
||||
clos-call-generic
|
||||
(fn
|
||||
(generic-name args)
|
||||
(let
|
||||
((grec (get clos-generic-registry generic-name)))
|
||||
(if
|
||||
(nil? grec)
|
||||
(error (str "No generic function: " generic-name))
|
||||
(let
|
||||
((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods"))))
|
||||
(if
|
||||
(empty? applicable)
|
||||
(error
|
||||
(str
|
||||
"No applicable method for "
|
||||
generic-name
|
||||
" with classes "
|
||||
(inspect (map clos-class-of args))))
|
||||
(let
|
||||
((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable))
|
||||
(before
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "before")))
|
||||
applicable))
|
||||
(after
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "after")))
|
||||
applicable))
|
||||
(around
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "around")))
|
||||
applicable)))
|
||||
(let
|
||||
((sp (clos-sort-methods primary args))
|
||||
(sb (clos-sort-methods before args))
|
||||
(sa (clos-sort-methods after args))
|
||||
(sw (clos-sort-methods around args)))
|
||||
(define
|
||||
make-primary-chain
|
||||
(fn
|
||||
(methods)
|
||||
(if
|
||||
(empty? methods)
|
||||
(fn
|
||||
()
|
||||
(error (str "No next primary method: " generic-name)))
|
||||
(fn
|
||||
()
|
||||
((get (first methods) "fn")
|
||||
args
|
||||
(make-primary-chain (rest methods)))))))
|
||||
(define
|
||||
make-around-chain
|
||||
(fn
|
||||
(around-methods inner-thunk)
|
||||
(if
|
||||
(empty? around-methods)
|
||||
inner-thunk
|
||||
(fn
|
||||
()
|
||||
((get (first around-methods) "fn")
|
||||
args
|
||||
(make-around-chain
|
||||
(rest around-methods)
|
||||
inner-thunk))))))
|
||||
(for-each (fn (m) ((get m "fn") args (fn () nil))) sb)
|
||||
(let
|
||||
((primary-thunk (make-primary-chain sp)))
|
||||
(let
|
||||
((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk)))))
|
||||
(for-each
|
||||
(fn (m) ((get m "fn") args (fn () nil)))
|
||||
(reverse sa))
|
||||
result))))))))))
|
||||
|
||||
;; ── call-next-method / next-method-p ──────────────────────────────────────
|
||||
|
||||
(define clos-call-next-method (fn (next-fn) (next-fn)))
|
||||
|
||||
(define clos-next-method-p (fn (next-fn) (not (nil? next-fn))))
|
||||
|
||||
;; ── with-slots ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-with-slots
|
||||
(fn
|
||||
(instance slot-names body-fn)
|
||||
(let
|
||||
((vals (map (fn (s) (clos-slot-value instance s)) slot-names)))
|
||||
(apply body-fn vals))))
|
||||
@@ -91,6 +91,18 @@ run_suite "Phase 3: interactive-debugger" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||
|
||||
run_suite "Phase 4: CLOS" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
|
||||
"passed" "failed" "failures"
|
||||
|
||||
run_suite "Phase 4: geometry" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
|
||||
"geo-passed" "geo-failed" "geo-failures"
|
||||
|
||||
run_suite "Phase 4: mop-trace" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||
"mop-passed" "mop-failed" "mop-failures"
|
||||
|
||||
echo ""
|
||||
echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -1,14 +1,17 @@
|
||||
{
|
||||
"generated": "2026-05-05T11:24:34Z",
|
||||
"total_pass": 363,
|
||||
"generated": "2026-05-05T11:37:47Z",
|
||||
"total_pass": 437,
|
||||
"total_fail": 0,
|
||||
"suites": [
|
||||
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
|
||||
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
|
||||
{"name": "Phase 2: evaluator", "pass": 174, "fail": 0},
|
||||
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
|
||||
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
|
||||
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0}
|
||||
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
|
||||
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
|
||||
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,15 +1,18 @@
|
||||
# Common Lisp on SX — Scoreboard
|
||||
|
||||
_Generated: 2026-05-05 11:24 UTC_
|
||||
_Generated: 2026-05-05 11:37 UTC_
|
||||
|
||||
| Suite | Pass | Fail | Status |
|
||||
|-------|------|------|--------|
|
||||
| Phase 1: tokenizer/reader | 79 | 0 | pass |
|
||||
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
|
||||
| Phase 2: evaluator | 174 | 0 | pass |
|
||||
| Phase 2: evaluator | 182 | 0 | pass |
|
||||
| Phase 3: condition system | 59 | 0 | pass |
|
||||
| Phase 3: restart-demo | 7 | 0 | pass |
|
||||
| Phase 3: parse-recover | 6 | 0 | pass |
|
||||
| Phase 3: interactive-debugger | 7 | 0 | pass |
|
||||
| Phase 4: CLOS | 41 | 0 | pass |
|
||||
| Phase 4: geometry | 12 | 0 | pass |
|
||||
| Phase 4: mop-trace | 13 | 0 | pass |
|
||||
|
||||
**Total: 363 passed, 0 failed**
|
||||
**Total: 437 passed, 0 failed**
|
||||
|
||||
@@ -366,6 +366,56 @@ run_program_suite \
|
||||
"lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||
|
||||
# ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
|
||||
CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
|
||||
CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
|
||||
rm -f "$CLOS_FILE"
|
||||
CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
CLOS_FAILED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
|
||||
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=$(echo "$CLOS_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$CLOS_FAILED" ] && CLOS_FAILED=$(echo "$CLOS_OUT" | grep "^(ok 6 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=0; [ -z "$CLOS_FAILED" ] && CLOS_FAILED=0
|
||||
if [ "$CLOS_FAILED" = "0" ] && [ "$CLOS_PASSED" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + CLOS_PASSED))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok CLOS unit tests ($CLOS_PASSED)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [CLOS unit tests] (${CLOS_PASSED} passed, ${CLOS_FAILED} failed)
|
||||
"
|
||||
fi
|
||||
|
||||
# ── Phase 4: CLOS classic programs ───────────────────────────────────────────
|
||||
run_clos_suite() {
|
||||
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
|
||||
local PROG_FILE=$(mktemp)
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
|
||||
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
|
||||
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
|
||||
rm -f "$PROG_FILE"
|
||||
local P F
|
||||
P=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
F=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
|
||||
local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true)
|
||||
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||
if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + P))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS}
|
||||
"
|
||||
fi
|
||||
}
|
||||
|
||||
run_clos_suite \
|
||||
"lib/common-lisp/tests/programs/geometry.sx" \
|
||||
"geo-passed" "geo-failed" "geo-failures"
|
||||
|
||||
run_clos_suite \
|
||||
"lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||
"mop-passed" "mop-failed" "mop-failures"
|
||||
|
||||
TOTAL=$((PASS+FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "ok $PASS/$TOTAL lib/common-lisp tests passed"
|
||||
|
||||
334
lib/common-lisp/tests/clos.sx
Normal file
334
lib/common-lisp/tests/clos.sx
Normal file
@@ -0,0 +1,334 @@
|
||||
;; lib/common-lisp/tests/clos.sx — CLOS test suite
|
||||
;;
|
||||
;; Loaded after: spec/stdlib.sx, lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
assert-equal
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
(define
|
||||
assert-true
|
||||
(fn
|
||||
(label got)
|
||||
(if
|
||||
got
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str "FAIL [" label "]: expected true, got " (inspect got)))))))))
|
||||
|
||||
(define
|
||||
assert-nil
|
||||
(fn
|
||||
(label got)
|
||||
(if
|
||||
(nil? got)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))
|
||||
|
||||
;; ── 1. class-of for built-in types ────────────────────────────────────────
|
||||
|
||||
(assert-equal "class-of integer" (clos-class-of 42) "integer")
|
||||
(assert-equal "class-of float" (clos-class-of 3.14) "float")
|
||||
(assert-equal "class-of string" (clos-class-of "hi") "string")
|
||||
(assert-equal "class-of nil" (clos-class-of nil) "null")
|
||||
(assert-equal "class-of list" (clos-class-of (list 1)) "cons")
|
||||
(assert-equal "class-of empty" (clos-class-of (list)) "null")
|
||||
|
||||
;; ── 2. subclass-of? ───────────────────────────────────────────────────────
|
||||
|
||||
(assert-true "integer subclass-of t" (clos-subclass-of? "integer" "t"))
|
||||
(assert-true "float subclass-of t" (clos-subclass-of? "float" "t"))
|
||||
(assert-true "t subclass-of t" (clos-subclass-of? "t" "t"))
|
||||
(assert-equal
|
||||
"integer not subclass-of float"
|
||||
(clos-subclass-of? "integer" "float")
|
||||
false)
|
||||
|
||||
;; ── 3. defclass + make-instance ───────────────────────────────────────────
|
||||
|
||||
(clos-defclass "point" (list "t") (list {:initform 0 :initarg ":x" :reader nil :writer nil :accessor "point-x" :name "x"} {:initform 0 :initarg ":y" :reader nil :writer nil :accessor "point-y" :name "y"}))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(begin
|
||||
(assert-equal "make-instance slot x" (clos-slot-value p "x") 3)
|
||||
(assert-equal "make-instance slot y" (clos-slot-value p "y") 4)
|
||||
(assert-equal "class-of instance" (clos-class-of p) "point")
|
||||
(assert-true "instance-of? point" (clos-instance-of? p "point"))
|
||||
(assert-true "instance-of? t" (clos-instance-of? p "t"))
|
||||
(assert-equal "instance-of? string" (clos-instance-of? p "string") false)))
|
||||
|
||||
;; initform defaults
|
||||
(let
|
||||
((p0 (clos-make-instance "point")))
|
||||
(begin
|
||||
(assert-equal "initform default x=0" (clos-slot-value p0 "x") 0)
|
||||
(assert-equal "initform default y=0" (clos-slot-value p0 "y") 0)))
|
||||
|
||||
;; ── 4. slot-value / set-slot-value! ──────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 10 ":y" 20)))
|
||||
(begin
|
||||
(clos-set-slot-value! p "x" 99)
|
||||
(assert-equal "set-slot-value! x" (clos-slot-value p "x") 99)
|
||||
(assert-equal "slot-value y unchanged" (clos-slot-value p "y") 20)))
|
||||
|
||||
;; ── 5. slot-boundp ────────────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 5)))
|
||||
(begin
|
||||
(assert-true "slot-boundp x" (clos-slot-boundp p "x"))
|
||||
(assert-true "slot-boundp y (initform 0)" (clos-slot-boundp p "y"))))
|
||||
|
||||
;; ── 6. find-class ─────────────────────────────────────────────────────────
|
||||
|
||||
(assert-equal
|
||||
"find-class point"
|
||||
(get (clos-find-class "point") "name")
|
||||
"point")
|
||||
(assert-nil "find-class missing" (clos-find-class "no-such-class"))
|
||||
|
||||
;; ── 7. inheritance ────────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "colored-point" (list "point") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 1 ":y" 2 ":color" "red")))
|
||||
(begin
|
||||
(assert-equal "inherited slot x" (clos-slot-value cp "x") 1)
|
||||
(assert-equal "inherited slot y" (clos-slot-value cp "y") 2)
|
||||
(assert-equal "own slot color" (clos-slot-value cp "color") "red")
|
||||
(assert-true
|
||||
"instance-of? colored-point"
|
||||
(clos-instance-of? cp "colored-point"))
|
||||
(assert-true "instance-of? point (parent)" (clos-instance-of? cp "point"))
|
||||
(assert-true "instance-of? t (root)" (clos-instance-of? cp "t"))))
|
||||
|
||||
;; ── 8. defgeneric + primary method ───────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "describe-obj" {})
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p (first args)))
|
||||
(str "(" (clos-slot-value p "x") "," (clos-slot-value p "y") ")"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn (args next-fn) (str "object:" (inspect (first args)))))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(begin
|
||||
(assert-equal
|
||||
"primary method for point"
|
||||
(clos-call-generic "describe-obj" (list p))
|
||||
"(3,4)")
|
||||
(assert-equal
|
||||
"fallback t method"
|
||||
(clos-call-generic "describe-obj" (list 42))
|
||||
"object:42")))
|
||||
|
||||
;; ── 9. method inheritance + specificity ───────────────────────────────────
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "colored-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((cp (first args)))
|
||||
(str
|
||||
(clos-slot-value cp "color")
|
||||
"@("
|
||||
(clos-slot-value cp "x")
|
||||
","
|
||||
(clos-slot-value cp "y")
|
||||
")"))))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 5 ":y" 6 ":color" "blue")))
|
||||
(assert-equal
|
||||
"most specific method wins"
|
||||
(clos-call-generic "describe-obj" (list cp))
|
||||
"blue@(5,6)"))
|
||||
|
||||
;; ── 10. :before / :after / :around qualifiers ─────────────────────────────
|
||||
|
||||
(clos-defgeneric "logged-action" {})
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list "before")
|
||||
(list "t")
|
||||
(fn (args next-fn) (set! action-log (append action-log (list "before")))))
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! action-log (append action-log (list "primary")))
|
||||
"result"))
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list "after")
|
||||
(list "t")
|
||||
(fn (args next-fn) (set! action-log (append action-log (list "after")))))
|
||||
|
||||
(define action-log (list))
|
||||
(clos-call-generic "logged-action" (list 1))
|
||||
(assert-equal
|
||||
":before/:after order"
|
||||
action-log
|
||||
(list "before" "primary" "after"))
|
||||
|
||||
;; :around
|
||||
(define around-log (list))
|
||||
|
||||
(clos-defgeneric "wrapped-action" {})
|
||||
|
||||
(clos-defmethod
|
||||
"wrapped-action"
|
||||
(list "around")
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! around-log (append around-log (list "around-enter")))
|
||||
(let
|
||||
((r (next-fn)))
|
||||
(set! around-log (append around-log (list "around-exit")))
|
||||
r)))
|
||||
|
||||
(clos-defmethod
|
||||
"wrapped-action"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! around-log (append around-log (list "primary")))
|
||||
42))
|
||||
|
||||
(let
|
||||
((r (clos-call-generic "wrapped-action" (list nil))))
|
||||
(begin
|
||||
(assert-equal ":around result" r 42)
|
||||
(assert-equal
|
||||
":around log"
|
||||
around-log
|
||||
(list "around-enter" "primary" "around-exit"))))
|
||||
|
||||
;; ── 11. call-next-method ─────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "chain-test" {})
|
||||
|
||||
(clos-defmethod
|
||||
"chain-test"
|
||||
(list)
|
||||
(list "colored-point")
|
||||
(fn (args next-fn) (str "colored:" (clos-call-next-method next-fn))))
|
||||
|
||||
(clos-defmethod
|
||||
"chain-test"
|
||||
(list)
|
||||
(list "point")
|
||||
(fn (args next-fn) "point-base"))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 0 ":y" 0 ":color" "green")))
|
||||
(assert-equal
|
||||
"call-next-method chains"
|
||||
(clos-call-generic "chain-test" (list cp))
|
||||
"colored:point-base"))
|
||||
|
||||
;; ── 12. accessor methods ──────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 7 ":y" 8)))
|
||||
(begin
|
||||
(assert-equal
|
||||
"accessor point-x"
|
||||
(clos-call-generic "point-x" (list p))
|
||||
7)
|
||||
(assert-equal
|
||||
"accessor point-y"
|
||||
(clos-call-generic "point-y" (list p))
|
||||
8)))
|
||||
|
||||
;; ── 13. with-slots ────────────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(assert-equal
|
||||
"with-slots"
|
||||
(clos-with-slots p (list "x" "y") (fn (x y) (* x y)))
|
||||
12))
|
||||
|
||||
;; ── 14. change-class ─────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "special-point" (list "point") (list {:initform "" :initarg ":label" :reader nil :writer nil :accessor nil :name "label"}))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 1 ":y" 2)))
|
||||
(begin
|
||||
(clos-change-class! p "special-point")
|
||||
(assert-equal
|
||||
"change-class updates class"
|
||||
(clos-class-of p)
|
||||
"special-point")))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(if
|
||||
(= failed 0)
|
||||
(print (str "ok " passed "/" (+ passed failed) " CLOS tests passed"))
|
||||
(begin
|
||||
(for-each (fn (f) (print f)) failures)
|
||||
(print
|
||||
(str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed"))))
|
||||
@@ -436,3 +436,31 @@
|
||||
(cl-test "values: truthy primary in if"
|
||||
(ev "(if (values 42 nil) 'yes 'no)")
|
||||
"YES")
|
||||
|
||||
;; --- Dynamic variables ---
|
||||
(cl-test "defvar marks special"
|
||||
(do (ev "(defvar *dv* 10)")
|
||||
(cl-special? "*DV*"))
|
||||
true)
|
||||
(cl-test "defvar: let rebinds dynamically"
|
||||
(ev "(progn (defvar *x* 1) (defun get-x () *x*) (let ((*x* 99)) (get-x)))")
|
||||
99)
|
||||
(cl-test "defvar: binding restores after let"
|
||||
(ev "(progn (defvar *yrst* 5) (let ((*yrst* 42)) *yrst*) *yrst*)")
|
||||
5)
|
||||
(cl-test "defparameter marks special"
|
||||
(do (ev "(defparameter *dp* 0)")
|
||||
(cl-special? "*DP*"))
|
||||
true)
|
||||
(cl-test "defparameter: let rebinds dynamically"
|
||||
(ev "(progn (defparameter *z* 10) (defun get-z () *z*) (let ((*z* 77)) (get-z)))")
|
||||
77)
|
||||
(cl-test "defparameter: always assigns"
|
||||
(ev "(progn (defparameter *p* 1) (defparameter *p* 2) *p*)")
|
||||
2)
|
||||
(cl-test "dynamic binding: nested lets"
|
||||
(ev "(progn (defvar *n* 0) (let ((*n* 1)) (let ((*n* 2)) *n*)))")
|
||||
2)
|
||||
(cl-test "dynamic binding: restores across nesting"
|
||||
(ev "(progn (defvar *m* 10) (let ((*m* 20)) (let ((*m* 30)) nil)) *m*)")
|
||||
10)
|
||||
|
||||
291
lib/common-lisp/tests/programs/geometry.sx
Normal file
291
lib/common-lisp/tests/programs/geometry.sx
Normal file
@@ -0,0 +1,291 @@
|
||||
;; geometry.sx — Multiple dispatch with CLOS
|
||||
;;
|
||||
;; Demonstrates generic functions dispatching on combinations of
|
||||
;; geometric types: point, line, plane.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
;; ── geometric classes ──────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "geo-point" (list "t") (list {:initform 0 :initarg ":px" :reader nil :writer nil :accessor nil :name "px"} {:initform 0 :initarg ":py" :reader nil :writer nil :accessor nil :name "py"}))
|
||||
|
||||
(clos-defclass "geo-line" (list "t") (list {:initform nil :initarg ":p1" :reader nil :writer nil :accessor nil :name "p1"} {:initform nil :initarg ":p2" :reader nil :writer nil :accessor nil :name "p2"}))
|
||||
|
||||
(clos-defclass "geo-plane" (list "t") (list {:initform nil :initarg ":normal" :reader nil :writer nil :accessor nil :name "normal"} {:initform 0 :initarg ":d" :reader nil :writer nil :accessor nil :name "d"}))
|
||||
|
||||
;; ── helpers ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define geo-point-x (fn (p) (clos-slot-value p "px")))
|
||||
(define geo-point-y (fn (p) (clos-slot-value p "py")))
|
||||
|
||||
(define
|
||||
geo-make-point
|
||||
(fn (x y) (clos-make-instance "geo-point" ":px" x ":py" y)))
|
||||
|
||||
(define
|
||||
geo-make-line
|
||||
(fn (p1 p2) (clos-make-instance "geo-line" ":p1" p1 ":p2" p2)))
|
||||
|
||||
(define
|
||||
geo-make-plane
|
||||
(fn
|
||||
(nx ny d)
|
||||
(clos-make-instance "geo-plane" ":normal" (list nx ny) ":d" d)))
|
||||
|
||||
;; ── describe generic ───────────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "geo-describe" {})
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p (first args)))
|
||||
(str "P(" (geo-point-x p) "," (geo-point-y p) ")"))))
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((l (first args)))
|
||||
(str
|
||||
"L["
|
||||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p1")))
|
||||
"-"
|
||||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p2")))
|
||||
"]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-plane")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((pl (first args)))
|
||||
(str "Plane(d=" (clos-slot-value pl "d") ")"))))
|
||||
|
||||
;; ── intersect: multi-dispatch generic ─────────────────────────────────────
|
||||
;;
|
||||
;; Returns a string description of the intersection result.
|
||||
|
||||
(clos-defgeneric "intersect" {})
|
||||
|
||||
;; point ∩ point: same if coordinates match
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-point" "geo-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p1 (first args)) (p2 (first (rest args))))
|
||||
(if
|
||||
(and
|
||||
(= (geo-point-x p1) (geo-point-x p2))
|
||||
(= (geo-point-y p1) (geo-point-y p2)))
|
||||
"point"
|
||||
"empty"))))
|
||||
|
||||
;; point ∩ line: check if point lies on line (cross product = 0)
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-point" "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((pt (first args)) (ln (first (rest args))))
|
||||
(let
|
||||
((lp1 (clos-slot-value ln "p1")) (lp2 (clos-slot-value ln "p2")))
|
||||
(let
|
||||
((dx (- (geo-point-x lp2) (geo-point-x lp1)))
|
||||
(dy (- (geo-point-y lp2) (geo-point-y lp1)))
|
||||
(ex (- (geo-point-x pt) (geo-point-x lp1)))
|
||||
(ey (- (geo-point-y pt) (geo-point-y lp1))))
|
||||
(if (= (- (* dx ey) (* dy ex)) 0) "point" "empty"))))))
|
||||
|
||||
;; line ∩ line: parallel (same slope = empty) or point
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-line" "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((l1 (first args)) (l2 (first (rest args))))
|
||||
(let
|
||||
((p1 (clos-slot-value l1 "p1"))
|
||||
(p2 (clos-slot-value l1 "p2"))
|
||||
(p3 (clos-slot-value l2 "p1"))
|
||||
(p4 (clos-slot-value l2 "p2")))
|
||||
(let
|
||||
((dx1 (- (geo-point-x p2) (geo-point-x p1)))
|
||||
(dy1 (- (geo-point-y p2) (geo-point-y p1)))
|
||||
(dx2 (- (geo-point-x p4) (geo-point-x p3)))
|
||||
(dy2 (- (geo-point-y p4) (geo-point-y p3))))
|
||||
(let
|
||||
((cross (- (* dx1 dy2) (* dy1 dx2))))
|
||||
(if (= cross 0) "parallel" "point")))))))
|
||||
|
||||
;; line ∩ plane: general case = point (or parallel if line ⊥ normal)
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-line" "geo-plane")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((ln (first args)) (pl (first (rest args))))
|
||||
(let
|
||||
((p1 (clos-slot-value ln "p1"))
|
||||
(p2 (clos-slot-value ln "p2"))
|
||||
(n (clos-slot-value pl "normal")))
|
||||
(let
|
||||
((dx (- (geo-point-x p2) (geo-point-x p1)))
|
||||
(dy (- (geo-point-y p2) (geo-point-y p1)))
|
||||
(nx (first n))
|
||||
(ny (first (rest n))))
|
||||
(let
|
||||
((dot (+ (* dx nx) (* dy ny))))
|
||||
(if (= dot 0) "parallel" "point")))))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; describe
|
||||
(check
|
||||
"describe point"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list (geo-make-point 3 4)))
|
||||
"P(3,4)")
|
||||
(check
|
||||
"describe line"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list
|
||||
(geo-make-line
|
||||
(geo-make-point 0 0)
|
||||
(geo-make-point 1 1))))
|
||||
"L[P(0,0)-P(1,1)]")
|
||||
(check
|
||||
"describe plane"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list (geo-make-plane 0 1 5)))
|
||||
"Plane(d=5)")
|
||||
|
||||
;; intersect point×point
|
||||
(check
|
||||
"P∩P same"
|
||||
(clos-call-generic
|
||||
"intersect"
|
||||
(list
|
||||
(geo-make-point 2 3)
|
||||
(geo-make-point 2 3)))
|
||||
"point")
|
||||
(check
|
||||
"P∩P diff"
|
||||
(clos-call-generic
|
||||
"intersect"
|
||||
(list
|
||||
(geo-make-point 1 2)
|
||||
(geo-make-point 3 4)))
|
||||
"empty")
|
||||
|
||||
;; intersect point×line
|
||||
(let
|
||||
((origin (geo-make-point 0 0))
|
||||
(p10 (geo-make-point 10 0))
|
||||
(p55 (geo-make-point 5 5))
|
||||
(l-x
|
||||
(geo-make-line
|
||||
(geo-make-point 0 0)
|
||||
(geo-make-point 10 0))))
|
||||
(begin
|
||||
(check
|
||||
"P∩L on line"
|
||||
(clos-call-generic "intersect" (list p10 l-x))
|
||||
"point")
|
||||
(check
|
||||
"P∩L on x-axis"
|
||||
(clos-call-generic "intersect" (list origin l-x))
|
||||
"point")
|
||||
(check
|
||||
"P∩L off line"
|
||||
(clos-call-generic "intersect" (list p55 l-x))
|
||||
"empty")))
|
||||
|
||||
;; intersect line×line
|
||||
(let
|
||||
((horiz (geo-make-line (geo-make-point 0 0) (geo-make-point 10 0)))
|
||||
(vert
|
||||
(geo-make-line
|
||||
(geo-make-point 5 -5)
|
||||
(geo-make-point 5 5)))
|
||||
(horiz2
|
||||
(geo-make-line
|
||||
(geo-make-point 0 3)
|
||||
(geo-make-point 10 3))))
|
||||
(begin
|
||||
(check
|
||||
"L∩L crossing"
|
||||
(clos-call-generic "intersect" (list horiz vert))
|
||||
"point")
|
||||
(check
|
||||
"L∩L parallel"
|
||||
(clos-call-generic "intersect" (list horiz horiz2))
|
||||
"parallel")))
|
||||
|
||||
;; intersect line×plane
|
||||
(let
|
||||
((diag (geo-make-line (geo-make-point 0 0) (geo-make-point 1 1)))
|
||||
(vert-plane (geo-make-plane 1 0 5))
|
||||
(diag-plane (geo-make-plane -1 1 0)))
|
||||
(begin
|
||||
(check
|
||||
"L∩Plane cross"
|
||||
(clos-call-generic "intersect" (list diag vert-plane))
|
||||
"point")
|
||||
(check
|
||||
"L∩Plane parallel"
|
||||
(clos-call-generic "intersect" (list diag diag-plane))
|
||||
"parallel")))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define geo-passed passed)
|
||||
(define geo-failed failed)
|
||||
(define geo-failures failures)
|
||||
228
lib/common-lisp/tests/programs/mop-trace.sx
Normal file
228
lib/common-lisp/tests/programs/mop-trace.sx
Normal file
@@ -0,0 +1,228 @@
|
||||
;; mop-trace.sx — :before/:after method tracing with CLOS
|
||||
;;
|
||||
;; Classic CLOS pattern: instrument generic functions with :before and :after
|
||||
;; qualifiers to print call/return traces without modifying the primary method.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
;; ── trace log (mutable accumulator) ───────────────────────────────────────
|
||||
|
||||
(define trace-log (list))
|
||||
|
||||
(define
|
||||
trace-push
|
||||
(fn (msg) (set! trace-log (append trace-log (list msg)))))
|
||||
|
||||
(define trace-clear (fn () (set! trace-log (list))))
|
||||
|
||||
;; ── domain classes ─────────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "shape" (list "t") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
|
||||
|
||||
(clos-defclass "circle" (list "shape") (list {:initform 1 :initarg ":radius" :reader nil :writer nil :accessor nil :name "radius"}))
|
||||
|
||||
(clos-defclass "rect" (list "shape") (list {:initform 1 :initarg ":width" :reader nil :writer nil :accessor nil :name "width"} {:initform 1 :initarg ":height" :reader nil :writer nil :accessor nil :name "height"}))
|
||||
|
||||
;; ── generic function: area ─────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "area" {})
|
||||
|
||||
;; primary methods
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list)
|
||||
(list "circle")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((c (first args)))
|
||||
(let ((r (clos-slot-value c "radius"))) (* r r)))))
|
||||
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list)
|
||||
(list "rect")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((r (first args)))
|
||||
(* (clos-slot-value r "width") (clos-slot-value r "height")))))
|
||||
|
||||
;; :before tracing
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list "before")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push (str "BEFORE area(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; :after tracing
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list "after")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push (str "AFTER area(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; ── generic function: describe-shape ──────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "describe-shape" {})
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((s (first args)))
|
||||
(str "shape[" (clos-slot-value s "color") "]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "circle")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((c (first args)))
|
||||
(str
|
||||
"circle[r="
|
||||
(clos-slot-value c "radius")
|
||||
" "
|
||||
(clos-call-next-method next-fn)
|
||||
"]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "rect")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((r (first args)))
|
||||
(str
|
||||
"rect["
|
||||
(clos-slot-value r "width")
|
||||
"x"
|
||||
(clos-slot-value r "height")
|
||||
" "
|
||||
(clos-call-next-method next-fn)
|
||||
"]"))))
|
||||
|
||||
;; :before on base shape (fires for all subclasses too)
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list "before")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push
|
||||
(str "BEFORE describe-shape(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; ── area tests ────────────────────────────────────────────────────────────
|
||||
|
||||
;; circle area = r*r (no pi — integer arithmetic for predictability)
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 5 ":color" "red")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check "circle area" (clos-call-generic "area" (list c)) 25)
|
||||
(check
|
||||
":before fired for circle"
|
||||
(= (first trace-log) "BEFORE area(circle)")
|
||||
true)
|
||||
(check
|
||||
":after fired for circle"
|
||||
(= (first (rest trace-log)) "AFTER area(circle)")
|
||||
true)
|
||||
(check "trace length 2" (len trace-log) 2)))
|
||||
|
||||
;; rect area = w*h
|
||||
(let
|
||||
((r (clos-make-instance "rect" ":width" 4 ":height" 6 ":color" "blue")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check "rect area" (clos-call-generic "area" (list r)) 24)
|
||||
(check
|
||||
":before fired for rect"
|
||||
(= (first trace-log) "BEFORE area(rect)")
|
||||
true)
|
||||
(check
|
||||
":after fired for rect"
|
||||
(= (first (rest trace-log)) "AFTER area(rect)")
|
||||
true)
|
||||
(check "trace length 2 (rect)" (len trace-log) 2)))
|
||||
|
||||
;; ── describe-shape tests ───────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 3 ":color" "green")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check
|
||||
"circle describe"
|
||||
(clos-call-generic "describe-shape" (list c))
|
||||
"circle[r=3 shape[green]]")
|
||||
(check
|
||||
":before fired for describe circle"
|
||||
(= (first trace-log) "BEFORE describe-shape(circle)")
|
||||
true)))
|
||||
|
||||
(let
|
||||
((r (clos-make-instance "rect" ":width" 2 ":height" 7 ":color" "black")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check
|
||||
"rect describe"
|
||||
(clos-call-generic "describe-shape" (list r))
|
||||
"rect[2x7 shape[black]]")
|
||||
(check
|
||||
":before fired for describe rect"
|
||||
(= (first trace-log) "BEFORE describe-shape(rect)")
|
||||
true)))
|
||||
|
||||
;; ── call-next-method: circle -> shape ─────────────────────────────────────
|
||||
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 1 ":color" "purple")))
|
||||
(check
|
||||
"call-next-method result in describe"
|
||||
(clos-call-generic "describe-shape" (list c))
|
||||
"circle[r=1 shape[purple]]"))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define mop-passed passed)
|
||||
(define mop-failed failed)
|
||||
(define mop-failures failures)
|
||||
@@ -62,8 +62,8 @@ Core mapping:
|
||||
- [x] `unwind-protect` cleanup frame
|
||||
- [x] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [x] 127 tests in `lib/common-lisp/tests/eval.sx`
|
||||
- [x] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [x] 182 tests in `lib/common-lisp/tests/eval.sx`
|
||||
|
||||
### Phase 3 — conditions + restarts (THE SHOWCASE)
|
||||
- [x] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
|
||||
@@ -81,17 +81,17 @@ Core mapping:
|
||||
- [x] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` (363 total tests)
|
||||
|
||||
### Phase 4 — CLOS
|
||||
- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||
- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||
- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||
- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||
- [ ] `call-next-method` (continuation), `next-method-p`
|
||||
- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||
- [ ] Multiple dispatch — method specificity by argument-class precedence list
|
||||
- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||
- [ ] Classic programs:
|
||||
- [ ] `geometry.lisp` — `intersect` generic dispatching on (point line), (line line), (line plane)…
|
||||
- [ ] `mop-trace.lisp` — `:before` + `:after` printing call trace
|
||||
- [x] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||
- [x] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||
- [x] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||
- [x] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||
- [x] `call-next-method` (continuation), `next-method-p`
|
||||
- [x] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||
- [x] Multiple dispatch — method specificity by argument-class precedence list
|
||||
- [x] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||
- [x] Classic programs:
|
||||
- [x] `geometry.sx` — `intersect` generic dispatching on (point line), (line line), (line plane) — 12 tests
|
||||
- [x] `mop-trace.sx` — `:before` + `:after` printing call trace — 13 tests
|
||||
|
||||
### Phase 5 — macros + LOOP + reader macros
|
||||
- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
||||
@@ -124,6 +124,7 @@ data; format for string templating.
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-05: Phase 4 CLOS fully complete — `lib/common-lisp/clos.sx` (27 forms): clos-class-registry (8 built-in classes), defclass/make-instance/slot-value/slot-boundp/set-slot-value!/find-class/change-class, defgeneric/defmethod with :before/:after/:around, clos-call-generic (standard method combination: sort by specificity, fire befores, call primary chain, fire afters in reverse), call-next-method/next-method-p, with-slots, accessor installation; 41 tests in `tests/clos.sx`; classic programs `geometry.sx` (12 tests, multi-dispatch intersect on P/L/Plane) and `mop-trace.sx` (13 tests, :before/:after tracing). Dynamic variables in eval.sx: cl-apply-dyn saves/restores global bindings around let for specials (cl-mark-special!/cl-special?/cl-dyn-unbound). Key gotchas: qualifier strings are "before"/"after"/"around" (no colon); dict-set pure = assoc; dict->list = (map (fn (k) (list k (get d k))) (keys d)); clos-add-reader-method bootstrapped via set! after defmethod defined; test isolation: use unique var names to avoid *y* collision. 437 total tests, 0 failed.
|
||||
- 2026-05-05: Phase 3 fully complete — conformance.sh runner + scoreboard.json/scoreboard.md; 363 total tests across all suites (79 reader, 31 parser, 174 eval, 59 conditions, 7+6+7 classic programs).
|
||||
- 2026-05-05: Phase 3 complete — cl-debugger-hook/cl-invoke-debugger in runtime.sx (cl-error routes through hook), cl-break-on-signals (fires hook before handlers on type match), cl-invoke-restart-interactively (calls fn with no args); 4 new tests (147 total). Phase 3 all boxes ticked.
|
||||
- 2026-05-05: Phase 3 interactive-debugger.sx — cl-debugger-hook global, cl-invoke-debugger, cl-error-with-debugger, make-policy-debugger; 7 tests (143 total). Tests wired into test.sh program suite runner. Phase 3 condition core complete.
|
||||
|
||||
Reference in New Issue
Block a user