rose-ash/lib/common-lisp/tests/clos.sx

;; 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"))))