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:
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)
|
||||
Reference in New Issue
Block a user