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