mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
tests: Use WITH-TEST in mop-*.lisp
This commit is contained in:
Jan Moringen
parent
8e0dab21e1
commit
ceb4aff035
|
|
@ -19,23 +19,22 @@
|
|||
;;; fixups for running in the full MOP rather than closette: SLOTDs
|
||||
;;; instead of slot-names, and so on.
|
||||
|
||||
(defpackage "TEST" (:use "CL" "SB-MOP"))
|
||||
(in-package "TEST")
|
||||
|
||||
(defclass dynamic-slot-class (standard-class) ())
|
||||
|
||||
(defmethod validate-superclass
|
||||
(defmethod sb-mop:validate-superclass
|
||||
((class dynamic-slot-class) (super standard-class))
|
||||
t)
|
||||
|
||||
(defmethod compute-effective-slot-definition
|
||||
(defmethod sb-mop:compute-effective-slot-definition
|
||||
((class dynamic-slot-class) name direct-slots)
|
||||
(let ((slot (call-next-method)))
|
||||
(setf (slot-definition-allocation slot) :dynamic)
|
||||
(setf (sb-mop:slot-definition-allocation slot) :dynamic)
|
||||
slot))
|
||||
|
||||
(defun dynamic-slot-p (slot)
|
||||
(eq (slot-definition-allocation slot) :dynamic))
|
||||
(eq (sb-mop:slot-definition-allocation slot) :dynamic))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
|
||||
(let ((table (make-hash-table)))
|
||||
|
||||
|
|
@ -70,39 +69,39 @@
|
|||
(setf (gethash instance table) (delete entry alist))))
|
||||
instance)
|
||||
|
||||
)
|
||||
))
|
||||
|
||||
(defmethod allocate-instance ((class dynamic-slot-class) &key)
|
||||
(let ((instance (call-next-method)))
|
||||
(allocate-table-entry instance)
|
||||
instance))
|
||||
|
||||
(defmethod slot-value-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-value-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if slot
|
||||
(read-dynamic-slot-value instance (slot-definition-name slotd))
|
||||
(read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
|
||||
(defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if slot
|
||||
(write-dynamic-slot-value new-value instance (slot-definition-name slotd))
|
||||
(write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if slot
|
||||
(dynamic-slot-boundp instance (slot-definition-name slotd))
|
||||
(dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if slot
|
||||
(dynamic-slot-makunbound instance (slot-definition-name slotd))
|
||||
(dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defclass test-class-1 ()
|
||||
|
|
@ -118,8 +117,8 @@
|
|||
(defvar *one* (make-instance 'test-class-1))
|
||||
(defvar *two* (make-instance 'test-class-2 :slot3 1))
|
||||
|
||||
(with-test (:name :mop-1)
|
||||
(assert (not (slot-boundp *one* 'slot1)))
|
||||
(assert (null (slot-value *one* 'slot2)))
|
||||
(assert (eq t (slot-value *two* 'slot2)))
|
||||
(assert (= 1 (slot-value *two* 'slot3)))
|
||||
|
||||
(assert (= 1 (slot-value *two* 'slot3))))
|
||||
|
|
|
|||
|
|
@ -14,14 +14,9 @@
|
|||
;;; this file contains tests of REINITIALIZE-INSTANCE on generic
|
||||
;;; functions.
|
||||
|
||||
(defpackage "MOP-10"
|
||||
(:use "CL" "SB-MOP" "TEST-UTIL"))
|
||||
|
||||
(in-package "MOP-10")
|
||||
|
||||
(defclass my-generic-function (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defgeneric foo (x)
|
||||
(:method-combination list)
|
||||
|
|
@ -30,12 +25,16 @@
|
|||
(:method list ((x number)) (expt x 2))
|
||||
(:generic-function-class my-generic-function))
|
||||
|
||||
(assert (equal (foo 3) '(4 9)))
|
||||
(defmethod compute-discriminating-function ((gf my-generic-function))
|
||||
(with-test (:name (:mop-10 1))
|
||||
(assert (equal (foo 3) '(4 9))))
|
||||
|
||||
(defmethod sb-mop:compute-discriminating-function ((gf my-generic-function))
|
||||
(let ((orig (call-next-method)))
|
||||
(lambda (&rest args)
|
||||
(let ((orig-result (apply orig args)))
|
||||
(cons gf (reverse orig-result))))))
|
||||
|
||||
(with-test (:name (:mop-10 2))
|
||||
(assert (equal (foo 3) '(4 9)))
|
||||
(reinitialize-instance #'foo)
|
||||
(assert (equal (foo 3) (cons #'foo '(9 4))))
|
||||
(assert (equal (foo 3) (cons #'foo '(9 4)))))
|
||||
|
|
|
|||
|
|
@ -14,32 +14,32 @@
|
|||
;;; this file attempts to test possible metacircularity issues arising
|
||||
;;; from changing discriminating functions.
|
||||
|
||||
(defpackage "MOP-11"
|
||||
(:use "CL" "SB-MOP"))
|
||||
(in-package "MOP-11")
|
||||
|
||||
(defclass gf1-class (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defgeneric gf1 (x)
|
||||
(:method ((x t)) x)
|
||||
(:generic-function-class gf1-class))
|
||||
(assert (= (gf1 3) 3))
|
||||
(with-test (:name (:mop-11 1))
|
||||
(assert (= (gf1 3) 3)))
|
||||
|
||||
(defclass gf2-class (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defgeneric gf2 (y)
|
||||
(:method ((x number)) x)
|
||||
(:generic-function-class gf2-class))
|
||||
(assert (= (gf2 4) 4))
|
||||
(with-test (:name (:mop-11 2))
|
||||
(assert (= (gf2 4) 4)))
|
||||
|
||||
(defgeneric gf1a (x)
|
||||
(:method ((x symbol)) (symbol-name x))
|
||||
(:generic-function-class gf1-class))
|
||||
(assert (string= (gf1a t) "T"))
|
||||
(with-test (:name (:mop-11 3))
|
||||
(assert (string= (gf1a t) "T")))
|
||||
|
||||
(defclass gf3-class (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defgeneric gf3 (x y)
|
||||
(:method ((x number) (y number)) (+ x y))
|
||||
(:generic-function-class gf3-class))
|
||||
(assert (= (gf3 1 2) 3))
|
||||
(with-test (:name (:mop-11 4))
|
||||
(assert (= (gf3 1 2) 3)))
|
||||
|
|
|
|||
|
|
@ -14,17 +14,12 @@
|
|||
;;; this file attempts to test possible metacircularity issues arising
|
||||
;;; from adding slots to methods in odd places.
|
||||
|
||||
(defpackage "MOP-12"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-12")
|
||||
|
||||
(defclass super-method ()
|
||||
((abc :accessor abc :initarg :abc)))
|
||||
|
||||
;;; Test case reported by Jean Bresson sbcl-devel 2006-02-09
|
||||
(defclass sub-generic-function1 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass sub-method1 (standard-method super-method) ())
|
||||
|
||||
|
|
@ -37,23 +32,25 @@
|
|||
(defmethod myfun1 (a b)
|
||||
(incf *count1*))
|
||||
|
||||
(with-test (:name (:mop-12 1))
|
||||
(myfun1 2 3)
|
||||
(assert (= *count1* 1))
|
||||
(myfun1 t nil)
|
||||
(assert (= *count1* 2))
|
||||
(assert (= *count1* 2)))
|
||||
|
||||
(defmethod myfun1 ((a integer) (b integer))
|
||||
(incf *count1* 2))
|
||||
|
||||
(with-test (:name (:mop-12 2))
|
||||
(myfun1 2 3)
|
||||
(assert (= *count1* 4))
|
||||
(myfun1 t nil)
|
||||
(assert (= *count1* 5))
|
||||
(assert (= *count1* 5)))
|
||||
|
||||
;;; Friendlier superclass order test case from Pascal Costanza
|
||||
;;; sbcl-devel 2006-02-09
|
||||
(defclass sub-generic-function2 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass sub-method2 (super-method standard-method) ())
|
||||
|
||||
|
|
@ -66,15 +63,17 @@
|
|||
(defmethod myfun2 (a b)
|
||||
(incf *count2*))
|
||||
|
||||
(with-test (:name (:mop-12 3))
|
||||
(myfun2 2 3)
|
||||
(assert (= *count2* 1))
|
||||
(myfun2 t nil)
|
||||
(assert (= *count2* 2))
|
||||
(assert (= *count2* 2)))
|
||||
|
||||
(defmethod myfun2 ((a integer) (b integer))
|
||||
(incf *count2* 2))
|
||||
|
||||
(with-test (:name (:mop-12 4))
|
||||
(myfun2 2 3)
|
||||
(assert (= *count2* 4))
|
||||
(myfun2 t nil)
|
||||
(assert (= *count2* 5))
|
||||
(assert (= *count2* 5)))
|
||||
|
|
|
|||
|
|
@ -14,18 +14,13 @@
|
|||
;;; this file attempts to test possible metacircularity issues arising
|
||||
;;; from adding slots to generic functions in odd places.
|
||||
|
||||
(defpackage "MOP-13"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-13")
|
||||
|
||||
(defclass super-funcallable-mixin ()
|
||||
((abc :accessor abc :initarg :abc))
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass sub-generic-function1 (standard-generic-function
|
||||
super-funcallable-mixin) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass sub-method1 (standard-method) ())
|
||||
|
||||
|
|
@ -38,23 +33,25 @@
|
|||
(defmethod myfun1 (a b)
|
||||
(incf *count1*))
|
||||
|
||||
(with-test (:name (:mop-13 1))
|
||||
(myfun1 2 3)
|
||||
(assert (= *count1* 1))
|
||||
(myfun1 t nil)
|
||||
(assert (= *count1* 2))
|
||||
(assert (= *count1* 2)))
|
||||
|
||||
(defmethod myfun1 ((a integer) (b integer))
|
||||
(incf *count1* 2))
|
||||
|
||||
(with-test (:name (:mop-13 2))
|
||||
(myfun1 2 3)
|
||||
(assert (= *count1* 4))
|
||||
(myfun1 t nil)
|
||||
(assert (= *count1* 5))
|
||||
(assert (= *count1* 5)))
|
||||
|
||||
;;; Friendlier superclass order test case
|
||||
(defclass sub-generic-function2 (super-funcallable-mixin
|
||||
standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass sub-method2 (standard-method) ())
|
||||
|
||||
|
|
@ -67,15 +64,17 @@
|
|||
(defmethod myfun2 (a b)
|
||||
(incf *count2*))
|
||||
|
||||
(with-test (:name (:mop-13 3))
|
||||
(myfun2 2 3)
|
||||
(assert (= *count2* 1))
|
||||
(myfun2 t nil)
|
||||
(assert (= *count2* 2))
|
||||
(assert (= *count2* 2)))
|
||||
|
||||
(defmethod myfun2 ((a integer) (b integer))
|
||||
(incf *count2* 2))
|
||||
|
||||
(with-test (:name (:mop-13 4))
|
||||
(myfun2 2 3)
|
||||
(assert (= *count2* 4))
|
||||
(myfun2 t nil)
|
||||
(assert (= *count2* 5))
|
||||
(assert (= *count2* 5)))
|
||||
|
|
|
|||
|
|
@ -17,24 +17,17 @@
|
|||
;;; superclass. (This used to fail in cache-filling code: see reports
|
||||
;;; from Levente Mészáros sbcl-devel 2006-04-19)
|
||||
|
||||
(defpackage :dc
|
||||
(:use
|
||||
#:cl
|
||||
#:sb-mop))
|
||||
|
||||
(in-package :dc)
|
||||
|
||||
(defclass dwim-slot-definition
|
||||
(standard-slot-definition)
|
||||
(sb-mop:standard-slot-definition)
|
||||
())
|
||||
|
||||
(defclass dwim-direct-slot-definition
|
||||
(standard-direct-slot-definition dwim-slot-definition)
|
||||
(sb-mop:standard-direct-slot-definition dwim-slot-definition)
|
||||
())
|
||||
|
||||
(defclass dwim-effective-slot-definition
|
||||
(extra-effective-slot-definition
|
||||
standard-effective-slot-definition dwim-slot-definition)
|
||||
sb-mop:standard-effective-slot-definition dwim-slot-definition)
|
||||
())
|
||||
(defclass dwim-attribute-slot-definition
|
||||
(dwim-slot-definition)
|
||||
|
|
|
|||
|
|
@ -15,20 +15,15 @@
|
|||
;;; that when FINALIZE-INHERITANCE is called on a class, it returns
|
||||
;;; before subclasses are finalized.
|
||||
|
||||
(defpackage "MOP-15"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-15")
|
||||
|
||||
(defclass mop-15-class (standard-class) ())
|
||||
|
||||
(defmethod validate-superclass ((s mop-15-class) (super standard-class))
|
||||
(defmethod sb-mop:validate-superclass ((s mop-15-class) (super standard-class))
|
||||
t)
|
||||
|
||||
(defvar *count* 0)
|
||||
(defvar *max-count* 0)
|
||||
|
||||
(defmethod finalize-inheritance ((c mop-15-class))
|
||||
(defmethod sb-mop:finalize-inheritance ((c mop-15-class))
|
||||
(let ((*count* (1+ *count*)))
|
||||
(when (> *count* *max-count*)
|
||||
(setf *max-count* *count*))
|
||||
|
|
@ -42,7 +37,8 @@
|
|||
()
|
||||
(:metaclass mop-15-class))
|
||||
|
||||
(finalize-inheritance (find-class 'super))
|
||||
(finalize-inheritance (find-class 'sub))
|
||||
(with-test (:name :mop-15)
|
||||
(sb-mop:finalize-inheritance (find-class 'super))
|
||||
(sb-mop:finalize-inheritance (find-class 'sub))
|
||||
|
||||
(assert (= *max-count* 1))
|
||||
(assert (= *max-count* 1)))
|
||||
|
|
|
|||
|
|
@ -17,21 +17,14 @@
|
|||
;;; optimization, or if the optimization is deemed to be invalid, then
|
||||
;;; this test can go away.
|
||||
|
||||
(defpackage "MOP-16"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-16")
|
||||
|
||||
(defclass foo-class (standard-class) ())
|
||||
|
||||
(defclass foo-effective-slot-definition (standard-effective-slot-definition)
|
||||
())
|
||||
|
||||
(multiple-value-bind (value condition)
|
||||
(ignore-errors
|
||||
(defmethod (setf slot-value-using-class)
|
||||
(with-test (:name :mop-16)
|
||||
(assert-error
|
||||
(defmethod (setf sb-mop:slot-value-using-class)
|
||||
((new-value integer) (class foo-class)
|
||||
(object standard-object) (slotd foo-effective-slot-definition))
|
||||
"Haha"))
|
||||
(assert (null value))
|
||||
(assert (typep condition 'error)))
|
||||
"Haha")))
|
||||
|
|
|
|||
|
|
@ -14,11 +14,6 @@
|
|||
;;; this file tests the programmatic class example from pp.67-69 of
|
||||
;;; AMOP.
|
||||
|
||||
(defpackage "MOP-17"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-17")
|
||||
|
||||
(defun make-programmatic-instance (superclass-names &rest initargs)
|
||||
(apply #'make-instance
|
||||
(find-programmatic-class
|
||||
|
|
@ -29,8 +24,8 @@
|
|||
(let ((class (find-if
|
||||
(lambda (class)
|
||||
(equal superclasses
|
||||
(class-direct-superclasses class)))
|
||||
(class-direct-subclasses (car superclasses)))))
|
||||
(sb-mop:class-direct-superclasses class)))
|
||||
(sb-mop:class-direct-subclasses (car superclasses)))))
|
||||
(or class
|
||||
(make-programmatic-class superclasses))))
|
||||
|
||||
|
|
@ -49,12 +44,14 @@
|
|||
(defclass top-labeled (label-type) ())
|
||||
(defclass bottom-labeled (label-type) ())
|
||||
|
||||
(assert (null (class-direct-subclasses (find-class 'circle))))
|
||||
(with-test (:name (:mop-17 1))
|
||||
(assert (null (sb-mop:class-direct-subclasses (find-class 'circle)))))
|
||||
|
||||
(defvar *i1* (make-programmatic-instance '(circle orange top-labeled)))
|
||||
(defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled)))
|
||||
(defvar *i3* (make-programmatic-instance '(circle orange top-labeled)))
|
||||
|
||||
(with-test (:name (:mop-17 2))
|
||||
(assert (not (eq *i1* *i3*)))
|
||||
|
||||
(assert (= (length (class-direct-subclasses (find-class 'circle))) 2))
|
||||
(assert (= (length (sb-mop:class-direct-subclasses (find-class 'circle))) 2)))
|
||||
|
|
|
|||
|
|
@ -13,22 +13,17 @@
|
|||
|
||||
;;; this file tests the protocol for Reinitialization of Class Metaobjects
|
||||
|
||||
(defpackage "MOP-18"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-18")
|
||||
|
||||
(defvar *in-reinitialize-instance* nil)
|
||||
|
||||
(defvar *finalized-class* nil)
|
||||
|
||||
(defclass test-standard-class (standard-class) ())
|
||||
|
||||
(defmethod validate-superclass
|
||||
(defmethod sb-mop:validate-superclass
|
||||
((class test-standard-class) (superclass standard-class))
|
||||
t)
|
||||
|
||||
(defmethod finalize-inheritance :before ((class test-standard-class))
|
||||
(defmethod sb-mop:finalize-inheritance :before ((class test-standard-class))
|
||||
(when *in-reinitialize-instance*
|
||||
(setf *finalized-class* class)))
|
||||
|
||||
|
|
@ -40,23 +35,25 @@
|
|||
(defclass test-standard-object () ((slot))
|
||||
(:metaclass test-standard-class))
|
||||
|
||||
(unless (class-finalized-p (find-class 'test-standard-object))
|
||||
(finalize-inheritance (find-class 'test-standard-object)))
|
||||
(unless (sb-mop:class-finalized-p (find-class 'test-standard-object))
|
||||
(sb-mop:finalize-inheritance (find-class 'test-standard-object)))
|
||||
|
||||
(assert (class-slots (find-class 'test-standard-object)))
|
||||
(with-test (:name (:mop-18 1))
|
||||
(assert (sb-mop:class-slots (find-class 'test-standard-object)))
|
||||
(assert (null *finalized-class*))
|
||||
(reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
|
||||
(assert (eq *finalized-class* (find-class 'test-standard-object)))
|
||||
(assert (null (class-slots (find-class 'test-standard-object))))
|
||||
(assert (null (sb-mop:class-slots (find-class 'test-standard-object)))))
|
||||
|
||||
(defclass test-funcallable-standard-class (funcallable-standard-class) ())
|
||||
(defclass test-funcallable-standard-class (sb-mop:funcallable-standard-class)
|
||||
())
|
||||
|
||||
(defmethod validate-superclass
|
||||
(defmethod sb-mop:validate-superclass
|
||||
((class test-funcallable-standard-class)
|
||||
(superclass funcallable-standard-class))
|
||||
(superclass sb-mop:funcallable-standard-class))
|
||||
t)
|
||||
|
||||
(defmethod finalize-inheritance :before
|
||||
(defmethod sb-mop:finalize-inheritance :before
|
||||
((class test-funcallable-standard-class))
|
||||
(when *in-reinitialize-instance*
|
||||
(setf *finalized-class* class)))
|
||||
|
|
@ -69,12 +66,13 @@
|
|||
(defclass test-funcallable-standard-object () ((slot))
|
||||
(:metaclass test-funcallable-standard-class))
|
||||
|
||||
(unless (class-finalized-p (find-class 'test-funcallable-standard-object))
|
||||
(finalize-inheritance (find-class 'test-funcallable-standard-object)))
|
||||
(unless (sb-mop:class-finalized-p (find-class 'test-funcallable-standard-object))
|
||||
(sb-mop:finalize-inheritance (find-class 'test-funcallable-standard-object)))
|
||||
|
||||
(assert (class-slots (find-class 'test-funcallable-standard-object)))
|
||||
(with-test (:name (:mop-18 2))
|
||||
(assert (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))
|
||||
(assert (eq *finalized-class* (find-class 'test-standard-object)))
|
||||
(reinitialize-instance (find-class 'test-funcallable-standard-object)
|
||||
:direct-slots nil)
|
||||
(assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
|
||||
(assert (null (class-slots (find-class 'test-funcallable-standard-object))))
|
||||
(assert (null (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))))
|
||||
|
|
|
|||
|
|
@ -14,26 +14,21 @@
|
|||
;;; this file tests the accessor method class portion of the protocol
|
||||
;;; for Initialization of Class Metaobjects.
|
||||
|
||||
(defpackage "MOP-19"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-19")
|
||||
|
||||
(defclass my-class (standard-class) ())
|
||||
(defmethod validate-superclass ((a my-class) (b standard-class)) t)
|
||||
(defmethod sb-mop:validate-superclass ((a my-class) (b standard-class)) t)
|
||||
|
||||
(defclass my-reader (standard-reader-method) ())
|
||||
(defclass my-writer (standard-writer-method) ())
|
||||
(defclass my-reader (sb-mop:standard-reader-method) ())
|
||||
(defclass my-writer (sb-mop:standard-writer-method) ())
|
||||
|
||||
(defvar *calls* nil)
|
||||
|
||||
(defmethod reader-method-class ((c my-class) s &rest initargs)
|
||||
(defmethod sb-mop:reader-method-class ((c my-class) s &rest initargs)
|
||||
(declare (ignore initargs))
|
||||
(push (cons (slot-definition-name s) 'reader) *calls*)
|
||||
(push (cons (sb-mop:slot-definition-name s) 'reader) *calls*)
|
||||
(find-class 'my-reader))
|
||||
(defmethod writer-method-class ((c my-class) s &rest initargs)
|
||||
(defmethod sb-mop:writer-method-class ((c my-class) s &rest initargs)
|
||||
(declare (ignore initargs))
|
||||
(push (cons (slot-definition-name s) 'writer) *calls*)
|
||||
(push (cons (sb-mop:slot-definition-name s) 'writer) *calls*)
|
||||
(find-class 'my-writer))
|
||||
|
||||
(defclass foo ()
|
||||
|
|
@ -42,6 +37,7 @@
|
|||
(c :accessor c))
|
||||
(:metaclass my-class))
|
||||
|
||||
(with-test (:name (:mop-19 1))
|
||||
(assert (= (length *calls*) 4))
|
||||
(assert (= (count 'a *calls* :key #'car) 1))
|
||||
(assert (= (count 'b *calls* :key #'car) 1))
|
||||
|
|
@ -51,20 +47,20 @@
|
|||
(let ((method (find-method #'a nil (list (find-class 'foo)))))
|
||||
(assert (eq (class-of method) (find-class 'my-reader))))
|
||||
(let ((method (find-method #'b nil (list (find-class t) (find-class 'foo)))))
|
||||
(assert (eq (class-of method) (find-class 'my-writer))))
|
||||
(assert (eq (class-of method) (find-class 'my-writer)))))
|
||||
|
||||
(defclass my-other-class (my-class) ())
|
||||
(defmethod validate-superclass ((a my-other-class) (b standard-class)) t)
|
||||
(defmethod sb-mop:validate-superclass ((a my-other-class) (b standard-class)) t)
|
||||
|
||||
(defclass my-other-reader (standard-reader-method) ())
|
||||
(defclass my-other-reader (sb-mop:standard-reader-method) ())
|
||||
|
||||
(defclass my-direct-slot-definition (standard-direct-slot-definition) ())
|
||||
(defclass my-direct-slot-definition (sb-mop:standard-direct-slot-definition) ())
|
||||
|
||||
(defmethod direct-slot-definition-class ((c my-other-class) &rest args)
|
||||
(defmethod sb-mop:direct-slot-definition-class ((c my-other-class) &rest args)
|
||||
(declare (ignore args))
|
||||
(find-class 'my-direct-slot-definition))
|
||||
|
||||
(defmethod reader-method-class :around
|
||||
(defmethod sb-mop:reader-method-class :around
|
||||
(class (s my-direct-slot-definition) &rest initargs)
|
||||
(declare (ignore initargs))
|
||||
(find-class 'my-other-reader))
|
||||
|
|
@ -74,7 +70,8 @@
|
|||
(e :writer e))
|
||||
(:metaclass my-other-class))
|
||||
|
||||
(with-test (:name (:mop-19 2))
|
||||
(let ((method (find-method #'d nil (list (find-class 'bar)))))
|
||||
(assert (eq (class-of method) (find-class 'my-other-reader))))
|
||||
(let ((method (find-method #'e nil (list (find-class t) (find-class 'bar)))))
|
||||
(assert (eq (class-of method) (find-class 'my-writer))))
|
||||
(assert (eq (class-of method) (find-class 'my-writer)))))
|
||||
|
|
|
|||
|
|
@ -20,18 +20,16 @@
|
|||
;;; instead of slot-names, and so on -- and :allocation :dynamic for
|
||||
;;; dynamic slots.
|
||||
|
||||
(defpackage "TEST" (:use "CL" "SB-MOP"))
|
||||
(in-package "TEST")
|
||||
|
||||
(defclass dynamic-slot-class (standard-class) ())
|
||||
|
||||
(defmethod validate-superclass
|
||||
(defmethod sb-mop:validate-superclass
|
||||
((class dynamic-slot-class) (super standard-class))
|
||||
t)
|
||||
|
||||
(defun dynamic-slot-p (slot)
|
||||
(eq (slot-definition-allocation slot) :dynamic))
|
||||
(eq (sb-mop:slot-definition-allocation slot) :dynamic))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(let ((table (make-hash-table)))
|
||||
|
||||
(defun allocate-table-entry (instance)
|
||||
|
|
@ -67,39 +65,40 @@
|
|||
(unless (null entry)
|
||||
(setf (gethash instance table) (delete entry alist))))
|
||||
instance)
|
||||
)
|
||||
|
||||
))
|
||||
|
||||
(defmethod allocate-instance ((class dynamic-slot-class) &key)
|
||||
(let ((instance (call-next-method)))
|
||||
(allocate-table-entry instance)
|
||||
instance))
|
||||
|
||||
(defmethod slot-value-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-value-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(read-dynamic-slot-value instance (slot-definition-name slotd))
|
||||
(read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
|
||||
(defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(write-dynamic-slot-value new-value instance (slot-definition-name slotd))
|
||||
(write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(dynamic-slot-boundp instance (slot-definition-name slotd))
|
||||
(dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
|
||||
(defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(dynamic-slot-makunbound instance (slot-definition-name slotd))
|
||||
(dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defclass test-class-1 ()
|
||||
|
|
@ -115,10 +114,11 @@
|
|||
(defvar *one* (make-instance 'test-class-1))
|
||||
(defvar *two* (make-instance 'test-class-2 :slot3 1))
|
||||
|
||||
(with-test (:name (:mop-2 1))
|
||||
(assert (not (slot-boundp *one* 'slot1)))
|
||||
(assert (null (slot-value *one* 'slot2)))
|
||||
(assert (eq t (slot-value *two* 'slot2)))
|
||||
(assert (= 1 (slot-value *two* 'slot3)))
|
||||
(assert (= 1 (slot-value *two* 'slot3))))
|
||||
|
||||
;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
|
||||
;;; overconservatism in accessing a class's precedence list deep in
|
||||
|
|
@ -126,26 +126,26 @@
|
|||
;;; finalizing a class.
|
||||
(defclass dynamic-slot-subclass (dynamic-slot-class) ())
|
||||
|
||||
(defmethod slot-value-using-class ((class dynamic-slot-subclass)
|
||||
(defmethod sb-mop:slot-value-using-class ((class dynamic-slot-subclass)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(read-dynamic-slot-value instance (slot-definition-name slotd))
|
||||
(read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (new-value
|
||||
(defmethod (setf sb-mop:slot-value-using-class) (new-value
|
||||
(class dynamic-slot-subclass)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(write-dynamic-slot-value new-value instance (slot-definition-name slotd))
|
||||
(write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
|
||||
(defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-subclass)
|
||||
instance slotd)
|
||||
(let ((slot (find slotd (class-slots class))))
|
||||
(let ((slot (find slotd (sb-mop:class-slots class))))
|
||||
(if (and slot (dynamic-slot-p slot))
|
||||
(dynamic-slot-boundp instance (slot-definition-name slotd))
|
||||
(dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
|
||||
(call-next-method))))
|
||||
|
||||
(defclass test-class-3 (test-class-1)
|
||||
|
|
@ -154,9 +154,11 @@
|
|||
(:metaclass dynamic-slot-subclass))
|
||||
|
||||
(defvar *three* (make-instance 'test-class-3 :slot3 3))
|
||||
|
||||
(with-test (:name (:mop-2 2))
|
||||
(assert (not (slot-boundp *three* 'slot1)))
|
||||
(assert (eq (slot-value *three* 'slot2) t))
|
||||
(assert (= (slot-value *three* 'slot3) 3))
|
||||
(assert (= (slot-value *three* 'slot3) 3)))
|
||||
|
||||
(defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
|
||||
(declare (ignore v))
|
||||
|
|
@ -168,9 +170,11 @@
|
|||
(slot3 :initarg :slot3)
|
||||
(slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(assert (= 42 (slot-value *three* 'slot4)))
|
||||
|
||||
(test-util:with-test (:name :slot-exists-p-before-removal)
|
||||
(with-test (:name (:mop-2 3))
|
||||
(assert (= 42 (slot-value *three* 'slot4))))
|
||||
|
||||
(with-test (:name (:mop-2 :slot-exists-p-before-removal))
|
||||
(let ((i (make-instance 'test-class-3)))
|
||||
(dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s)))))
|
||||
|
||||
|
|
@ -179,9 +183,11 @@
|
|||
((slot2 :initarg :slot2 :initform t :allocation :dynamic)
|
||||
(slot3 :initarg :slot3))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
|
||||
|
||||
(test-util:with-test (:name :slot-exists-p-after-removal)
|
||||
(with-test (:name (:mop-2 4))
|
||||
(assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4))))
|
||||
|
||||
(with-test (:name (:mop-2 :slot-exists-p-after-removal))
|
||||
(let ((i (make-instance 'test-class-3)))
|
||||
(assert (not (slot-exists-p i 'slot4)))
|
||||
(dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s)))))
|
||||
|
|
@ -193,10 +199,12 @@
|
|||
((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
|
||||
(slot3 :initarg :slot3))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(let* ((slots (class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'slot-definition-name)))
|
||||
(assert (eq :instance (slot-definition-allocation slot)))
|
||||
(assert (eq 'ok (slot-value *three* 'slot2))))
|
||||
|
||||
(with-test (:name (:mop-2 5))
|
||||
(let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
|
||||
(assert (eq :instance (sb-mop:slot-definition-allocation slot)))
|
||||
(assert (eq 'ok (slot-value *three* 'slot2)))))
|
||||
|
||||
;;; Test redefinition making a local slot dynamic again
|
||||
;;;
|
||||
|
|
@ -207,10 +215,12 @@
|
|||
((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
|
||||
(slot3 :initarg :slot3))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(let* ((slots (class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'slot-definition-name)))
|
||||
(assert (eq :dynamic (slot-definition-allocation slot)))
|
||||
(assert (eq t (slot-value *three* 'slot2))))
|
||||
|
||||
(with-test (:name (:mop-2 6))
|
||||
(let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
|
||||
(assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
|
||||
(assert (eq t (slot-value *three* 'slot2)))))
|
||||
|
||||
;;; Test redefinition making a dynamic slot local, with
|
||||
;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
|
||||
|
|
@ -221,24 +231,30 @@
|
|||
&rest inits)
|
||||
(declare (ignore inits))
|
||||
(let* ((class (class-of obj))
|
||||
(slots (class-slots class)))
|
||||
(slots (sb-mop:class-slots class)))
|
||||
(dolist (name (dynamic-slot-names obj))
|
||||
(let ((slotd (find name slots :key #'slot-definition-name)))
|
||||
(unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
|
||||
(let ((slotd (find name slots :key #'sb-mop:slot-definition-name)))
|
||||
(unless (and slotd (eq :dynamic (sb-mop:slot-definition-allocation slotd)))
|
||||
(dynamic-slot-makunbound obj name))))))
|
||||
|
||||
(defclass test-class-3 (test-class-1)
|
||||
((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
|
||||
(slot3 :initarg :slot3))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(let* ((slots (class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'slot-definition-name)))
|
||||
(assert (eq :instance (slot-definition-allocation slot)))
|
||||
(assert (eq 'ok (slot-value *three* 'slot2))))
|
||||
|
||||
(with-test (:name (:mop-2 7))
|
||||
(let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
|
||||
(assert (eq :instance (sb-mop:slot-definition-allocation slot)))
|
||||
(assert (eq 'ok (slot-value *three* 'slot2)))))
|
||||
|
||||
(defclass test-class-3 (test-class-1)
|
||||
((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
|
||||
(slot3 :initarg :slot3))
|
||||
(:metaclass dynamic-slot-subclass))
|
||||
(let* ((slots (class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'slot-definition-name)))
|
||||
(assert (eq :dynamic (slot-definition-allocation slot)))
|
||||
(assert (eq 'ok! (slot-value *three* 'slot2))))
|
||||
|
||||
(with-test (:name (:mop-2 8))
|
||||
(let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
|
||||
(slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
|
||||
(assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
|
||||
(assert (eq 'ok! (slot-value *three* 'slot2)))))
|
||||
|
|
|
|||
|
|
@ -14,11 +14,6 @@
|
|||
;;; this file tests that user-defined methods can be used in
|
||||
;;; combination (ahem) with hairy bits of method-combination.
|
||||
|
||||
(defpackage "MOP-20"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-20")
|
||||
|
||||
;;; Simple test case from Pascal Costanza
|
||||
(defgeneric test (arg)
|
||||
(:method (arg) (format t "~D" arg) arg))
|
||||
|
|
@ -26,25 +21,26 @@
|
|||
(defun define-around-test ()
|
||||
(multiple-value-bind
|
||||
(method-lambda method-args)
|
||||
(make-method-lambda
|
||||
#'test (class-prototype (generic-function-method-class #'test))
|
||||
(sb-mop:make-method-lambda
|
||||
#'test (sb-mop:class-prototype (sb-mop:generic-function-method-class #'test))
|
||||
'(lambda (arg) (call-next-method)) ())
|
||||
(let ((method (apply #'make-instance
|
||||
(generic-function-method-class #'test)
|
||||
(sb-mop:generic-function-method-class #'test)
|
||||
:qualifiers '(:around)
|
||||
:lambda-list '(arg)
|
||||
:specializers (list (find-class 't))
|
||||
:function (compile nil method-lambda)
|
||||
method-args)))
|
||||
(add-method #'test method))))
|
||||
(sb-mop:add-method #'test method))))
|
||||
|
||||
(defun run-test ()
|
||||
(define-around-test)
|
||||
(test 42))
|
||||
|
||||
(with-test (:name (:mop-20 1))
|
||||
(assert (string= (with-output-to-string (*standard-output*)
|
||||
(assert (= (run-test) 42)))
|
||||
"42"))
|
||||
"42")))
|
||||
|
||||
;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel
|
||||
;;; 2004-06-11). First the setup.
|
||||
|
|
@ -71,20 +67,19 @@
|
|||
(append unspecialized-required-part
|
||||
(subseq required-part (length required-part)))))
|
||||
`(progn
|
||||
(add-method #',name
|
||||
(sb-mop:add-method #',name
|
||||
(make-instance 'user-method
|
||||
:qualifiers ',qualifiers
|
||||
:lambda-list ',unspecialized-lambdalist
|
||||
:specializers ',specializers
|
||||
:function
|
||||
|
||||
#'(lambda (arguments next-methods-list)
|
||||
(flet ((next-method-p () next-methods-list)
|
||||
(call-next-method (&rest new-arguments)
|
||||
(unless new-arguments (setq new-arguments arguments))
|
||||
(if (null next-methods-list)
|
||||
(error "no next method for arguments ~:s" arguments)
|
||||
(funcall (method-function (first next-methods-list))
|
||||
(funcall (sb-mop:method-function (first next-methods-list))
|
||||
new-arguments (rest next-methods-list)))))
|
||||
(apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
|
||||
',name)))
|
||||
|
|
@ -98,7 +93,9 @@
|
|||
(def-user-method test-um03 ((x rational))
|
||||
(list* 'rational x (not (null (next-method-p))) (call-next-method)))
|
||||
(defmethod test-um03 ((x real))
|
||||
(list 'real x (not (null (next-method-p)))))
|
||||
(list 'real x (not (null (next-method-p))))))
|
||||
|
||||
(with-test (:name (:mop-20 2))
|
||||
(assert (equal (test-um03 17) '(integer 17 t rational 17 t real 17 nil))))
|
||||
|
||||
;;; these two used to fail in slightly different ways
|
||||
|
|
@ -116,7 +113,9 @@
|
|||
(defmethod test-um10 :around ((x rational))
|
||||
(list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
|
||||
(defmethod test-um10 :around ((x real))
|
||||
(list* 'around-real x (not (null (next-method-p))) (call-next-method)))
|
||||
(list* 'around-real x (not (null (next-method-p))) (call-next-method))))
|
||||
|
||||
(with-test (:name (:mop-20 3))
|
||||
(assert (equal (test-um10 17)
|
||||
'(around-integer 17 t
|
||||
around-rational 17 t
|
||||
|
|
@ -139,7 +138,9 @@
|
|||
(defmethod test-um12 :around ((x rational))
|
||||
(list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
|
||||
(def-user-method test-um12 :around ((x real))
|
||||
(list* 'around-real x (not (null (next-method-p))) (call-next-method)))
|
||||
(list* 'around-real x (not (null (next-method-p))) (call-next-method))))
|
||||
|
||||
(with-test (:name (:mop-20 4))
|
||||
(assert (equal (test-um12 17)
|
||||
'(around-integer 17 t
|
||||
around-rational 17 t
|
||||
|
|
|
|||
|
|
@ -14,14 +14,9 @@
|
|||
;;; Pascal Costanza's implementation of beta methods, lightly
|
||||
;;; modified. Contains a specialization of MAKE-METHOD-LAMBDA.
|
||||
|
||||
(defpackage "MOP-21"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-21")
|
||||
|
||||
(defclass beta-generic-function (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defclass beta-method (standard-method)
|
||||
((betap :reader betap :initarg :betap :initform nil)))
|
||||
|
|
@ -73,7 +68,7 @@
|
|||
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
|
||||
form))))
|
||||
|
||||
(defmethod make-method-lambda
|
||||
(defmethod sb-mop:make-method-lambda
|
||||
((gf beta-generic-function) method-prototype lambda-expression environment)
|
||||
(declare (ignore method-prototype environment))
|
||||
(let ((method-args (gensym))
|
||||
|
|
@ -85,7 +80,7 @@
|
|||
(declare (dynamic-extent args))
|
||||
(if (null ,next-methods)
|
||||
(error "There is no next method for ~S." ,gf)
|
||||
(funcall (method-function (car ,next-methods))
|
||||
(funcall (sb-mop:method-function (car ,next-methods))
|
||||
(if args args ,method-args)
|
||||
(cdr ,next-methods)
|
||||
,inner-runs)))
|
||||
|
|
@ -94,7 +89,7 @@
|
|||
(declare (dynamic-extent args))
|
||||
(if (null ,inner-runs)
|
||||
(error "There is no inner method for ~S." ,gf)
|
||||
(funcall (method-function (caar ,inner-runs))
|
||||
(funcall (sb-mop:method-function (caar ,inner-runs))
|
||||
(if args args ,method-args)
|
||||
(cdar ,inner-runs)
|
||||
(cdr ,inner-runs))))
|
||||
|
|
@ -123,11 +118,17 @@
|
|||
;;; before DEFCLASS- and DEFGENERIC-load-time.
|
||||
(mapcar #'eval
|
||||
(list
|
||||
'(defmethod test ((object top)) 'top)
|
||||
'(defmethod test ((object top))
|
||||
(declare (ignore object))
|
||||
'top)
|
||||
'(defmethod test :beta ((object middle))
|
||||
(declare (ignore object))
|
||||
(list 'middle (call-inner-method) (call-next-method)))
|
||||
'(defmethod test :beta ((object bottom)) 'bottom)))
|
||||
'(defmethod test :beta ((object bottom))
|
||||
(declare (ignore object))
|
||||
'bottom)))
|
||||
|
||||
(with-test (:name (:mop-21))
|
||||
(assert (equal '(middle bottom top) (test (make-instance 'bottom))))
|
||||
(assert (equal 'top (test (make-instance 'top))))
|
||||
(assert (null (ignore-errors (test (make-instance 'middle)))))
|
||||
(assert (null (ignore-errors (test (make-instance 'middle))))))
|
||||
|
|
|
|||
|
|
@ -13,11 +13,6 @@
|
|||
|
||||
;;; Forward-referenced classes as specializers.
|
||||
|
||||
(defpackage "MOP-22"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-22")
|
||||
|
||||
;;; It's generally unclear to me whether this should be allowed. On
|
||||
;;; the one hand, FORWARD-REFERENCED-CLASS is a subclass of CLASS and
|
||||
;;; hence of SPECIALIZER, and AMOP specifies that as-yet-undefined
|
||||
|
|
@ -46,10 +41,11 @@
|
|||
|
||||
(defclass forward () ())
|
||||
|
||||
(with-test (:name :mop-22)
|
||||
(assert (eq (incomplete/1 (make-instance 'incomplete)) 'incomplete))
|
||||
(assert (eq (forward/1 (make-instance 'forward)) 'forward))
|
||||
(assert (eq (incomplete/7 (make-instance 'incomplete)
|
||||
(make-instance 'incomplete)
|
||||
t 1 (make-condition 'error)
|
||||
(find-class 'incomplete) 3)
|
||||
t))
|
||||
t)))
|
||||
|
|
|
|||
|
|
@ -14,14 +14,9 @@
|
|||
;;; Extending MAKE-METHOD-LAMBDA, and making sure that the resulting
|
||||
;;; method functions compile without warnings.
|
||||
|
||||
(defpackage "MOP-23"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-23")
|
||||
|
||||
(defclass verbose-generic-function (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(defmethod make-method-lambda
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defmethod sb-mop:make-method-lambda
|
||||
((gf verbose-generic-function) method lambda env)
|
||||
(multiple-value-bind (lambda initargs)
|
||||
(call-next-method)
|
||||
|
|
@ -37,9 +32,10 @@
|
|||
(handler-bind ((warning #'error))
|
||||
(eval '(defmethod foo ((x integer)) (1+ x))))
|
||||
|
||||
(with-test (:name (:mop-23 sb-mop:make-method-lambda 1))
|
||||
(assert (string= (with-output-to-string (*trace-output*)
|
||||
(assert (= (foo 3) 4)))
|
||||
"Called a method!"))
|
||||
"Called a method!")))
|
||||
|
||||
(defclass super () ((a :initarg :a)))
|
||||
(defclass sub (super) (b))
|
||||
|
|
@ -49,16 +45,18 @@
|
|||
(eval '(defmethod foo :around ((x super))
|
||||
(list (slot-value x 'a) (call-next-method)))))
|
||||
|
||||
(with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
|
||||
(assert (string= (with-output-to-string (*trace-output*)
|
||||
(assert (equal (foo (make-instance 'sub :a 4))
|
||||
'(4 nil))))
|
||||
"Called a method!Called a method!"))
|
||||
"Called a method!Called a method!")))
|
||||
|
||||
(defclass super ()
|
||||
((b :initform 3)
|
||||
(a :initarg :a)))
|
||||
|
||||
(with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
|
||||
(assert (string= (with-output-to-string (*trace-output*)
|
||||
(assert (equal (foo (make-instance 'sub :a 5))
|
||||
'(5 t))))
|
||||
"Called a method!Called a method!"))
|
||||
"Called a method!Called a method!")))
|
||||
|
|
|
|||
|
|
@ -13,11 +13,6 @@
|
|||
|
||||
;;; Some slot-valuish things in combination with user-defined methods
|
||||
|
||||
(defpackage "MOP-24"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-24")
|
||||
|
||||
(defclass user-method (standard-method) (myslot))
|
||||
|
||||
(defmacro def-user-method (name &rest rest)
|
||||
|
|
@ -54,7 +49,7 @@
|
|||
(unless new-arguments (setq new-arguments arguments))
|
||||
(if (null next-methods-list)
|
||||
(error "no next method for arguments ~:s" arguments)
|
||||
(funcall (method-function (first next-methods-list))
|
||||
(funcall (sb-mop:method-function (first next-methods-list))
|
||||
new-arguments (rest next-methods-list)))))
|
||||
(apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
|
||||
',name)))
|
||||
|
|
@ -77,7 +72,9 @@
|
|||
(list* 'sub (slot-value x 'a) (slot-value x 'b)
|
||||
(not (null (next-method-p))) (call-next-method)))
|
||||
(defmethod test-um03 ((x super))
|
||||
(list 'super (slot-value x 'a) (not (null (next-method-p)))))
|
||||
(list 'super (slot-value x 'a) (not (null (next-method-p))))))
|
||||
|
||||
(with-test (:name (:mop-24 1))
|
||||
(assert (equal (test-um03 (make-instance 'super)) '(super 3 nil)))
|
||||
(assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
|
||||
(assert (equal (test-um03 (make-instance 'subsub))
|
||||
|
|
@ -102,7 +99,9 @@
|
|||
(not (null (next-method-p))) (call-next-method)))
|
||||
(defmethod test-um10 :around ((x super))
|
||||
(list* 'around-super (slot-value x 'a)
|
||||
(not (null (next-method-p))) (call-next-method)))
|
||||
(not (null (next-method-p))) (call-next-method))))
|
||||
|
||||
(with-test (:name (:mop-24 2))
|
||||
(assert (equal (test-um10 (make-instance 'super))
|
||||
'(around-super 3 t super 3 nil)))
|
||||
(assert (equal (test-um10 (make-instance 'sub))
|
||||
|
|
@ -130,7 +129,9 @@
|
|||
(not (null (next-method-p))) (call-next-method)))
|
||||
(def-user-method test-um12 :around ((x super))
|
||||
(list* 'around-super (slot-value x 'a)
|
||||
(not (null (next-method-p))) (call-next-method)))
|
||||
(not (null (next-method-p))) (call-next-method))))
|
||||
|
||||
(with-test (:name (:mop-24 3))
|
||||
(assert (equal (test-um12 (make-instance 'super))
|
||||
'(around-super 3 t super 3 nil)))
|
||||
(assert (equal (test-um12 (make-instance 'sub))
|
||||
|
|
|
|||
|
|
@ -14,18 +14,13 @@
|
|||
;;; be sure that the :FUNCTION initarg to initialize methods overrides
|
||||
;;; any system-provided function.
|
||||
|
||||
(defpackage "MOP-25"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-25")
|
||||
|
||||
(defclass typechecking-reader-method (standard-reader-method)
|
||||
())
|
||||
|
||||
(defmethod initialize-instance
|
||||
((method typechecking-reader-method) &rest initargs &key slot-definition)
|
||||
(let ((name (slot-definition-name slot-definition))
|
||||
(type (slot-definition-type slot-definition)))
|
||||
(let ((name (sb-mop:slot-definition-name slot-definition))
|
||||
(type (sb-mop:slot-definition-type slot-definition)))
|
||||
(apply #'call-next-method method
|
||||
:function #'(lambda (args next-methods)
|
||||
(declare (ignore next-methods))
|
||||
|
|
@ -40,7 +35,7 @@
|
|||
(defclass typechecking-reader-class (standard-class)
|
||||
())
|
||||
|
||||
(defmethod validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
|
||||
(defmethod sb-mop:validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
|
||||
t)
|
||||
|
||||
(defmethod reader-method-class
|
||||
|
|
@ -52,13 +47,11 @@
|
|||
((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
|
||||
(:metaclass typechecking-reader-class))
|
||||
|
||||
(assert (equal '(t t t nil t)
|
||||
(macrolet ((succeeds (form)
|
||||
`(not (nth-value 1 (ignore-errors ,form)))))
|
||||
(with-test (:name (:mop-24))
|
||||
(let ((p (list 'abc 'def))
|
||||
(x (make-instance 'testclass25)))
|
||||
(list (succeeds (make-instance 'testclass25 :pair '(seventeen 17)))
|
||||
(succeeds (setf (testclass25-pair x) p))
|
||||
(succeeds (setf (second p) 456))
|
||||
(succeeds (testclass25-pair x))
|
||||
(succeeds (slot-value x 'pair)))))))
|
||||
(assert-no-signal (make-instance 'testclass25 :pair '(seventeen 17)))
|
||||
(assert-no-signal (setf (testclass25-pair x) p))
|
||||
(assert-no-signal (setf (second p) 456))
|
||||
(assert-no-signal (testclass25-pair x))
|
||||
(assert-no-signal (slot-value x 'pair))))
|
||||
|
|
|
|||
|
|
@ -21,8 +21,6 @@
|
|||
;;; function. So it's fine if this test starts failing, as long as
|
||||
;;; it's deliberate.
|
||||
|
||||
(in-package "CL-USER")
|
||||
|
||||
(defclass super () ())
|
||||
(defclass sub (super) ())
|
||||
|
||||
|
|
@ -32,11 +30,13 @@
|
|||
(let ((spec (sb-pcl::class-eq-specializer (find-class 'super))))
|
||||
(eval `(defmethod test ((x ,spec)) t)))
|
||||
|
||||
(with-test (:name (:mop-26 1))
|
||||
(assert (test (make-instance 'super)))
|
||||
(assert (null (test (make-instance 'sub))))
|
||||
(assert (null (test (make-instance 'sub)))))
|
||||
|
||||
(let ((spec (sb-pcl::class-eq-specializer (find-class 't))))
|
||||
(eval `(defmethod test ((x ,spec)) (class-of x))))
|
||||
|
||||
(with-test (:name (:mop-26 2))
|
||||
(assert (test (make-instance 'super)))
|
||||
(assert (null (test (make-instance 'sub))))
|
||||
(assert (null (test (make-instance 'sub)))))
|
||||
|
|
|
|||
|
|
@ -24,12 +24,7 @@
|
|||
;;; be an interesting exercise for the reader. (As would fixing some
|
||||
;;; other marked issues).
|
||||
|
||||
(defpackage "MOP-27"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-27")
|
||||
|
||||
(defclass pattern-specializer (specializer)
|
||||
(defclass pattern-specializer (sb-mop:specializer)
|
||||
((pattern :initarg pattern :reader pattern)
|
||||
(direct-methods :initform nil :reader specializer-direct-methods)))
|
||||
|
||||
|
|
@ -42,7 +37,7 @@
|
|||
|
||||
;;; only one arg for now
|
||||
(defclass pattern-gf/1 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defmethod sb-pcl:specializer-type-specifier
|
||||
((proto-generic-function pattern-gf/1)
|
||||
|
|
@ -66,22 +61,22 @@
|
|||
(defun method-interpreting-function (methods gf)
|
||||
(lambda (arg)
|
||||
(dolist (method methods (no-applicable-method gf (list arg)))
|
||||
(when (matchesp arg (pattern (car (method-specializers method))))
|
||||
(return (funcall (method-function method) (list arg) nil))))))
|
||||
(when (matchesp arg (pattern (first (sb-mop:method-specializers method))))
|
||||
(return (funcall (sb-mop:method-function method) (list arg) nil))))))
|
||||
|
||||
(defmethod compute-discriminating-function ((generic-function pattern-gf/1))
|
||||
(defmethod sb-mop:compute-discriminating-function ((generic-function pattern-gf/1))
|
||||
(lambda (arg)
|
||||
(let* ((methods (generic-function-methods generic-function))
|
||||
(let* ((methods (sb-mop:generic-function-methods generic-function))
|
||||
(function (method-interpreting-function methods generic-function)))
|
||||
(set-funcallable-instance-function generic-function function)
|
||||
(sb-mop:set-funcallable-instance-function generic-function function)
|
||||
(funcall function arg))))
|
||||
|
||||
;;; protocol functions. SPECIALIZER-DIRECT-METHODS is implemented by
|
||||
;;; a reader on the specializer. FIXME: implement
|
||||
;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS.
|
||||
(defmethod add-direct-method ((specializer pattern-specializer) method)
|
||||
(defmethod sb-mop:add-direct-method ((specializer pattern-specializer) method)
|
||||
(pushnew method (slot-value specializer 'direct-methods)))
|
||||
(defmethod remove-direct-method ((specializer pattern-specializer) method)
|
||||
(defmethod sb-mop:remove-direct-method ((specializer pattern-specializer) method)
|
||||
(setf (slot-value specializer 'direct-methods)
|
||||
(remove method (slot-value specializer 'direct-methods))))
|
||||
|
||||
|
|
@ -99,6 +94,8 @@
|
|||
(let ((specializer (ensure-pattern-specializer '(* 0 nil))))
|
||||
(eval `(defmethod simplify ((x ,specializer)) 0)))
|
||||
|
||||
|
||||
(with-test (:name (:mop-27))
|
||||
(assert (eql (simplify '(* 0 3)) 0))
|
||||
(assert (eql (simplify '(* (+ x y) 0)) 0))
|
||||
(assert (equal (simplify '(+ x y)) '(+ x y)))
|
||||
(assert (equal (simplify '(+ x y)) '(+ x y))))
|
||||
|
|
|
|||
|
|
@ -16,12 +16,7 @@
|
|||
;;; strategy implicit in the second return value of
|
||||
;;; compute-applicable-methods-using-classes.
|
||||
|
||||
(defpackage "OR-SPECIALIZER-TEST"
|
||||
(:use "CL" "SB-MOP" "ASSERTOID"))
|
||||
|
||||
(in-package "OR-SPECIALIZER-TEST")
|
||||
|
||||
(defclass or-specializer (specializer)
|
||||
(defclass or-specializer (sb-mop:specializer)
|
||||
((classes :initform nil :reader or-specializer-classes :initarg :classes)
|
||||
(direct-methods :initform nil :reader specializer-direct-methods)))
|
||||
|
||||
|
|
@ -36,7 +31,7 @@
|
|||
(make-instance 'or-specializer :classes sorted-classes)))))
|
||||
|
||||
(defclass gf-with-or (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defmethod sb-pcl:specializer-type-specifier
|
||||
((proto-generic-function gf-with-or)
|
||||
|
|
@ -44,21 +39,21 @@
|
|||
(specializer or-specializer))
|
||||
`(or ,@(or-specializer-classes specializer)))
|
||||
|
||||
(defmethod compute-applicable-methods-using-classes
|
||||
(defmethod sb-mop:compute-applicable-methods-using-classes
|
||||
((generic-function gf-with-or) classes)
|
||||
;; FIXME: assume one-argument for now
|
||||
(let (applicable-methods)
|
||||
(let ((methods (generic-function-methods generic-function)))
|
||||
(let ((methods (sb-mop:generic-function-methods generic-function)))
|
||||
(dolist (m methods)
|
||||
(let ((specializer (car (method-specializers m)))
|
||||
(class (car classes)))
|
||||
(let ((specializer (first (sb-mop:method-specializers m)))
|
||||
(class (first classes)))
|
||||
(typecase specializer
|
||||
(class (when (subtypep class specializer)
|
||||
(push m applicable-methods)))
|
||||
(eql-specializer
|
||||
(when (eql (class-of (eql-specializer-object specializer))
|
||||
(sb-mop:eql-specializer
|
||||
(when (eql (class-of (sb-mop:eql-specializer-object specializer))
|
||||
class)
|
||||
(return-from compute-applicable-methods-using-classes
|
||||
(return-from sb-mop:compute-applicable-methods-using-classes
|
||||
(values nil nil))))
|
||||
(or-specializer
|
||||
(dolist (c (or-specializer-classes specializer))
|
||||
|
|
@ -67,19 +62,19 @@
|
|||
;; FIXME: sort the methods
|
||||
(values applicable-methods t)))
|
||||
|
||||
(defmethod compute-applicable-methods
|
||||
(defmethod sb-mop:compute-applicable-methods
|
||||
((generic-function gf-with-or) arguments)
|
||||
;; FIXME: assume one-argument for now
|
||||
(let (applicable-methods)
|
||||
(let ((methods (generic-function-methods generic-function)))
|
||||
(let ((methods (sb-mop:generic-function-methods generic-function)))
|
||||
(dolist (m methods)
|
||||
(let ((specializer (car (method-specializers m)))
|
||||
(argument (car arguments)))
|
||||
(let ((specializer (first (sb-mop:method-specializers m)))
|
||||
(argument (first arguments)))
|
||||
(typecase specializer
|
||||
(class (when (typep argument specializer)
|
||||
(push m applicable-methods)))
|
||||
(eql-specializer
|
||||
(when (eql (eql-specializer-object specializer) argument)
|
||||
(sb-mop:eql-specializer
|
||||
(when (eql (sb-mop:eql-specializer-object specializer) argument)
|
||||
(push m applicable-methods)))
|
||||
(or-specializer
|
||||
(dolist (c (or-specializer-classes specializer))
|
||||
|
|
@ -88,10 +83,10 @@
|
|||
;; FIXME: sort the methods
|
||||
applicable-methods))
|
||||
|
||||
(defmethod add-direct-method ((specializer or-specializer) method)
|
||||
(defmethod sb-mop:add-direct-method ((specializer or-specializer) method)
|
||||
(pushnew method (slot-value specializer 'direct-methods)))
|
||||
|
||||
(defmethod remove-direct-method ((specializer or-specializer) method)
|
||||
(defmethod sb-mop:remove-direct-method ((specializer or-specializer) method)
|
||||
(setf (slot-value specializer 'direct-methods)
|
||||
(remove method (slot-value specializer 'direct-methods))))
|
||||
|
||||
|
|
@ -108,11 +103,13 @@
|
|||
(let ((specializer (ensure-or-specializer 'class1 'class2)))
|
||||
(eval `(defmethod foo ((x ,specializer)) t)))
|
||||
|
||||
(with-test (:name (:mop-28 1))
|
||||
(assert (foo (make-instance 'class1)))
|
||||
(assert (foo (make-instance 'class2)))
|
||||
(assert-error (foo (make-instance 'class3)))
|
||||
(assert (foo (make-instance 'class4)))
|
||||
(assert (foo (make-instance 'class4))))
|
||||
|
||||
;;; check that we are actually cacheing effective methods. If the
|
||||
;;; representation in PCL changes, this test needs to change too.
|
||||
(assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching))
|
||||
(with-test (:name (:mop-28 2))
|
||||
(assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching)))
|
||||
|
|
|
|||
|
|
@ -18,23 +18,22 @@
|
|||
;;; effective slot definitions to be available during class
|
||||
;;; finalization)
|
||||
|
||||
(defpackage "MOP-29"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-29")
|
||||
|
||||
(defclass my-class (standard-class)
|
||||
())
|
||||
(defmethod validate-superclass ((class my-class) (super-class standard-class))
|
||||
|
||||
(defmethod sb-mop:validate-superclass ((class my-class) (super-class standard-class))
|
||||
t)
|
||||
|
||||
(defvar *foo*)
|
||||
|
||||
;;; the specialization of OBJECT here triggers the PV optimization;
|
||||
;;; with an unspecialized argument, the SLOT-VALUE is not optimized.
|
||||
(defmethod slot-value-using-class
|
||||
(defmethod sb-mop:slot-value-using-class
|
||||
((class my-class) (object standard-object) eslotd)
|
||||
(if *foo*
|
||||
(setf (slot-value object 'id) 42)
|
||||
(call-next-method)))
|
||||
|
||||
(defclass my-object ()
|
||||
((id :type integer :reader id-of))
|
||||
(:metaclass my-class))
|
||||
|
|
@ -55,4 +54,6 @@
|
|||
(assert (= (id-of object) 42))
|
||||
(assert (= (slot-value object 'id) 42)))))
|
||||
(compile 'test-global-accessors)
|
||||
(test-global-accessors)
|
||||
|
||||
(with-test (:name (:mop-29))
|
||||
(test-global-accessors))
|
||||
|
|
|
|||
|
|
@ -16,28 +16,23 @@
|
|||
|
||||
;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
|
||||
|
||||
(defpackage "MOP-3"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-3")
|
||||
|
||||
(defclass msl-generic-function (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defun reverse-method-list (methods)
|
||||
(let ((result '()))
|
||||
(dolist (method methods)
|
||||
(if (and (consp result)
|
||||
(equal (method-qualifiers method)
|
||||
(method-qualifiers (caar result))))
|
||||
(equal (sb-mop:method-qualifiers method)
|
||||
(sb-mop:method-qualifiers (caar result))))
|
||||
(push method (car result))
|
||||
(push (list method) result)))
|
||||
(reduce #'append result)))
|
||||
|
||||
(defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
|
||||
(defmethod sb-mop:compute-applicable-methods ((gf msl-generic-function) arguments)
|
||||
(reverse-method-list (call-next-method)))
|
||||
(defmethod compute-applicable-methods-using-classes
|
||||
(defmethod sb-mop:compute-applicable-methods-using-classes
|
||||
((gf msl-generic-function) classes)
|
||||
(reverse-method-list (call-next-method)))
|
||||
|
||||
|
|
@ -52,23 +47,24 @@
|
|||
(:method :around ((x integer))
|
||||
(coerce (call-next-method) 'vector)))
|
||||
|
||||
(with-test (:name (:mop-3 1))
|
||||
(assert (equalp (list (testgf07 5.0) (testgf07 17))
|
||||
'((number real) #(number real integer))))
|
||||
'((number real) #(number real integer)))))
|
||||
|
||||
(defclass nonumber-generic-function (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defun nonumber-method-list (methods)
|
||||
(remove-if #'(lambda (method)
|
||||
(member (find-class 'number)
|
||||
(sb-pcl:method-specializers method)))
|
||||
(sb-mop:method-specializers method)))
|
||||
methods))
|
||||
|
||||
(defmethod compute-applicable-methods
|
||||
(defmethod sb-mop:compute-applicable-methods
|
||||
((gf nonumber-generic-function) arguments)
|
||||
(nonumber-method-list (call-next-method)))
|
||||
(defmethod compute-applicable-methods-using-classes
|
||||
(defmethod sb-mop:compute-applicable-methods-using-classes
|
||||
((gf nonumber-generic-function) classes)
|
||||
(nonumber-method-list (call-next-method)))
|
||||
|
||||
|
|
@ -83,5 +79,6 @@
|
|||
(:method :around ((x integer))
|
||||
(coerce (call-next-method) 'vector)))
|
||||
|
||||
(with-test (:name (:mop-3 2))
|
||||
(assert (equalp (list (testgf08 5.0) (testgf08 17))
|
||||
'((real) #(integer real))))
|
||||
'((real) #(integer real)))))
|
||||
|
|
|
|||
|
|
@ -11,11 +11,6 @@
|
|||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
(defpackage :mop-test-30
|
||||
(:use :sb-pcl :sb-ext :cl :test-util))
|
||||
|
||||
(in-package :mop-test-30)
|
||||
|
||||
(defclass foo ()
|
||||
((bar :initarg :bar)
|
||||
(quux :initarg :quux)))
|
||||
|
|
@ -24,33 +19,31 @@
|
|||
())
|
||||
|
||||
(defun find-slot (name class)
|
||||
(let ((class (find-class class)))
|
||||
(unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(find name (class-slots class) :key #'slot-definition-name)))
|
||||
(let ((class (sb-pcl:ensure-class-finalized (find-class class))))
|
||||
(find name (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name)))
|
||||
|
||||
(add-dependent (find-class 'foo) (find-class 'foomagic))
|
||||
(sb-mop:add-dependent (find-class 'foo) (find-class 'foomagic))
|
||||
|
||||
(defglobal **bar-loc** (slot-definition-location (find-slot 'bar 'foo)))
|
||||
(defglobal **quux-loc** (slot-definition-location (find-slot 'quux 'foo)))
|
||||
(defglobal **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo)))
|
||||
(defglobal **quux-loc** (sb-mop:slot-definition-location (find-slot 'quux 'foo)))
|
||||
|
||||
(defmethod update-dependent ((meta (eql (find-class 'foo)))
|
||||
(defmethod sb-mop:update-dependent ((meta (eql (find-class 'foo)))
|
||||
(dep (eql (find-class 'foomagic)))
|
||||
&key)
|
||||
(setf **bar-loc** (slot-definition-location (find-slot 'bar 'foo))
|
||||
**quux-loc** (slot-definition-location (find-slot 'quux 'foo))))
|
||||
(setf **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo))
|
||||
**quux-loc** (sb-mop:slot-definition-location (find-slot 'quux 'foo))))
|
||||
|
||||
(defun foo-bar/quux (foo)
|
||||
(declare (type foo foo))
|
||||
(values (standard-instance-access foo **bar-loc**)
|
||||
(standard-instance-access foo **quux-loc**)))
|
||||
(values (sb-mop:standard-instance-access foo **bar-loc**)
|
||||
(sb-mop:standard-instance-access foo **quux-loc**)))
|
||||
|
||||
(defun swap-bar/quux (foo)
|
||||
(declare (type foo foo))
|
||||
(rotatef (standard-instance-access foo **bar-loc**)
|
||||
(standard-instance-access foo **quux-loc**)))
|
||||
(rotatef (sb-mop:standard-instance-access foo **bar-loc**)
|
||||
(sb-mop:standard-instance-access foo **quux-loc**)))
|
||||
|
||||
(with-test (:name :standard-instance-access)
|
||||
(with-test (:name (:mop-30 sb-mop:standard-instance-access))
|
||||
(let ((bar (cons t t))
|
||||
(quux (cons nil nil)))
|
||||
(multiple-value-bind (bar? quux?)
|
||||
|
|
@ -58,7 +51,7 @@
|
|||
(assert (eq bar bar?))
|
||||
(assert (eq quux quux?)))))
|
||||
|
||||
(with-test (:name :standard-instance-access/setf)
|
||||
(with-test (:name (:mop-30 (setf sb-mop::standard-instance-access)))
|
||||
(let* ((bar (cons t t))
|
||||
(quux (cons nil nil))
|
||||
(foo
|
||||
|
|
@ -76,7 +69,7 @@
|
|||
((quux :initarg :quux)
|
||||
(bar :initarg :bar)))
|
||||
|
||||
(with-test (:name :standard-instance-access/updated)
|
||||
(with-test (:name (:mop-30 sb-mop:standard-instance-access :updated))
|
||||
(let ((bar (cons t t))
|
||||
(quux (cons nil nil)))
|
||||
(multiple-value-bind (bar? quux?)
|
||||
|
|
@ -84,9 +77,9 @@
|
|||
(assert (eq bar bar?))
|
||||
(assert (eq quux quux?)))))
|
||||
|
||||
(with-test (:name :standard-instance-access/slot-unbound)
|
||||
(with-test (:name (:mop-30 sb-mop:standard-instance-access slot-unbound))
|
||||
(let ((bar (cons t t)))
|
||||
(multiple-value-bind (bar? quux?)
|
||||
(foo-bar/quux (make-instance 'foo :bar bar))
|
||||
(assert (eq bar bar?))
|
||||
(assert (eq +slot-unbound+ quux?)))))
|
||||
(assert (eq sb-pcl:+slot-unbound+ quux?)))))
|
||||
|
|
|
|||
|
|
@ -14,16 +14,11 @@
|
|||
;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
|
||||
;;; subclasses of generic functions.
|
||||
|
||||
(defpackage "MOP-4"
|
||||
(:use "CL" "SB-MOP"))
|
||||
|
||||
(in-package "MOP-4")
|
||||
|
||||
;;; bug 343
|
||||
(defclass my-generic-function1 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defmethod compute-discriminating-function ((gf my-generic-function1))
|
||||
(defmethod sb-mop:compute-discriminating-function ((gf my-generic-function1))
|
||||
(let ((dfun (call-next-method)))
|
||||
(lambda (&rest args)
|
||||
(1+ (apply dfun args)))))
|
||||
|
|
@ -33,14 +28,15 @@
|
|||
|
||||
(defmethod foo (x) (+ x x))
|
||||
|
||||
(assert (= (foo 5) 11))
|
||||
(with-test (:name (:mop-4 1))
|
||||
(assert (= (foo 5) 11)))
|
||||
|
||||
;;; from PCL sources
|
||||
|
||||
(defclass my-generic-function-pcl1 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defmethod compute-discriminating-function ((gf my-generic-function-pcl1))
|
||||
(defmethod sb-mop:compute-discriminating-function ((gf my-generic-function-pcl1))
|
||||
(let ((std (call-next-method)))
|
||||
(lambda (arg)
|
||||
(print (list 'call-to-gf gf arg))
|
||||
|
|
@ -51,20 +47,21 @@
|
|||
|
||||
(defmethod pcl1 ((x integer)) (1+ x))
|
||||
|
||||
(with-test (:name (:mop-4 2))
|
||||
(let ((output (with-output-to-string (*standard-output*)
|
||||
(pcl1 3))))
|
||||
(assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 MOP-4::PCL1 (1)> 3)" output)))
|
||||
(assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 COMMON-LISP-USER::PCL1 (1)> 3)" output))))
|
||||
|
||||
#|
|
||||
(defclass my-generic-function-pcl2 (standard-generic-function) ()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(defmethod compute-discriminating-function ((gf my-generic-function-pcl2))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defmethod sb-mop:compute-discriminating-function ((gf my-generic-function-pcl2))
|
||||
(lambda (arg)
|
||||
(cond (<some condition>
|
||||
<store some info in the generic function>
|
||||
(set-funcallable-instance-function
|
||||
(sb-mop:set-funcallable-instance-function
|
||||
gf
|
||||
(compute-discriminating-function gf))
|
||||
(sb-mop:compute-discriminating-function gf))
|
||||
(funcall gf arg))
|
||||
(t
|
||||
<call-a-method-of-gf>))))
|
||||
|
|
@ -75,20 +72,22 @@
|
|||
(progn
|
||||
(defclass traced-generic-function (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defvar *last-traced-arguments* nil)
|
||||
(defvar *last-traced-values* nil)
|
||||
(defmethod compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method))
|
||||
(name (generic-function-name gf)))
|
||||
#'(lambda (&rest arguments)
|
||||
(format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
|
||||
(defmethod sb-mop:compute-discriminating-function ((gf traced-generic-function))
|
||||
(let ((orig-df (call-next-method)))
|
||||
(lambda (&rest arguments)
|
||||
(setq *last-traced-arguments* arguments)
|
||||
(let ((values (multiple-value-list (apply orig-df arguments))))
|
||||
(format *trace-output* "~%<= ~S values: ~:S" name values)
|
||||
(setq *last-traced-values* values)
|
||||
(values-list values)))))
|
||||
(defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
|
||||
(:method ((x number)) (values x (- x) (* x x) (/ x))))
|
||||
(defgeneric testgf15 (x)
|
||||
(:generic-function-class traced-generic-function)
|
||||
(:method ((x number))
|
||||
(values x (- x) (* x x) (/ x)))))
|
||||
|
||||
(with-test (:name (:mop-4 3))
|
||||
(testgf15 5)
|
||||
(assert (equal (list *last-traced-arguments* *last-traced-values*)
|
||||
'((5) (5 -5 25 1/5)))))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,6 @@
|
|||
;;; This file contains simple tests for
|
||||
;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs
|
||||
|
||||
|
||||
;;; from Justin Dubs on comp.lang.lisp
|
||||
(defclass fn ()
|
||||
()
|
||||
|
|
@ -30,9 +29,10 @@
|
|||
(setf *fn* fn)
|
||||
(1+ x))))
|
||||
|
||||
(with-test (:name (:mop-5 1))
|
||||
(let ((fun (make-instance 'fn)))
|
||||
(assert (= (funcall fun 42) 43))
|
||||
(assert (eq *fn* fun)))
|
||||
(assert (eq *fn* fun))))
|
||||
|
||||
;;; from Tony Martinez sbcl-devel
|
||||
(defclass counter ()
|
||||
|
|
@ -45,9 +45,10 @@
|
|||
instance
|
||||
;; When run, this function doesn't print the instance, but (what
|
||||
;; I think is) itself.
|
||||
(lambda () (print instance)))
|
||||
(lambda () (print instance (make-broadcast-stream))))
|
||||
instance))
|
||||
|
||||
(defparameter *counter* (make-counter :start 666))
|
||||
|
||||
(assert (eq (funcall *counter*) *counter*))
|
||||
(with-test (:name (:mop-5 2))
|
||||
(assert (eq (funcall *counter*) *counter*)))
|
||||
|
|
|
|||
|
|
@ -14,16 +14,12 @@
|
|||
;;; This file contains simple tests for COMPUTE-SLOTS :AROUND
|
||||
;;; respecting the order requested by the primary method.
|
||||
|
||||
(defpackage "MOP-6"
|
||||
(:use "CL" "SB-MOP" "TEST-UTIL"))
|
||||
(in-package "MOP-6")
|
||||
|
||||
;;; COMPUTE-SLOTS :AROUND respecting requested order
|
||||
(defclass slot-rearrangement-class (standard-class)
|
||||
())
|
||||
(defmethod compute-slots ((c slot-rearrangement-class))
|
||||
(defmethod sb-mop:compute-slots ((c slot-rearrangement-class))
|
||||
(reverse (call-next-method)))
|
||||
(defmethod validate-superclass ((c slot-rearrangement-class)
|
||||
(defmethod sb-mop:validate-superclass ((c slot-rearrangement-class)
|
||||
(s standard-class))
|
||||
t)
|
||||
(defclass rearranged-class ()
|
||||
|
|
@ -33,8 +29,9 @@
|
|||
|
||||
(with-test (:name (:compute-slots :standard-class :order))
|
||||
(let ((class (find-class 'rearranged-class)))
|
||||
(finalize-inheritance class)
|
||||
(assert (equal (mapcar #'slot-definition-name (class-slots class))
|
||||
(sb-mop:finalize-inheritance class)
|
||||
(assert (equal (mapcar #'sb-mop:slot-definition-name
|
||||
(sb-mop:class-slots class))
|
||||
'(b a)))))
|
||||
(with-test (:name (:compute-slots :standard-class :slots))
|
||||
(let ((r (make-instance 'rearranged-class))
|
||||
|
|
@ -44,12 +41,12 @@
|
|||
(assert (eql (slot-value r2 'a) 3))
|
||||
(assert (eql (slot-value r2 'b) 4))))
|
||||
|
||||
(defclass funcallable-slot-rearrangement-class (funcallable-standard-class)
|
||||
(defclass funcallable-slot-rearrangement-class (sb-mop:funcallable-standard-class)
|
||||
())
|
||||
(defmethod compute-slots ((c funcallable-slot-rearrangement-class))
|
||||
(defmethod sb-mop:compute-slots ((c funcallable-slot-rearrangement-class))
|
||||
(reverse (call-next-method)))
|
||||
(defmethod validate-superclass ((c funcallable-slot-rearrangement-class)
|
||||
(s funcallable-standard-class))
|
||||
(defmethod sb-mop:validate-superclass ((c funcallable-slot-rearrangement-class)
|
||||
(s sb-mop:funcallable-standard-class))
|
||||
t)
|
||||
(defclass funcallable-rearranged-class ()
|
||||
((a :initarg :a :initform 1)
|
||||
|
|
@ -58,9 +55,11 @@
|
|||
|
||||
(with-test (:name (:compute-slots :funcallable-standard-class :order))
|
||||
(let ((class (find-class 'funcallable-rearranged-class)))
|
||||
(finalize-inheritance class)
|
||||
(assert (equal (mapcar #'slot-definition-name (class-slots class))
|
||||
(sb-mop:finalize-inheritance class)
|
||||
(assert (equal (mapcar #'sb-mop:slot-definition-name
|
||||
(sb-mop:class-slots class))
|
||||
'(b a)))))
|
||||
|
||||
(with-test (:name (:compute-slots :funcallable-standard-class :slots))
|
||||
(let ((r (make-instance 'funcallable-rearranged-class))
|
||||
(r2 (make-instance 'funcallable-rearranged-class :a 3 :b 4)))
|
||||
|
|
@ -68,7 +67,8 @@
|
|||
(assert (eql (slot-value r 'b) 2))
|
||||
(assert (eql (slot-value r2 'a) 3))
|
||||
(assert (eql (slot-value r2 'b) 4))))
|
||||
|
||||
(with-test (:name (:compute-slots :funcallable-standard-clas :function))
|
||||
(let ((r (make-instance 'funcallable-rearranged-class)))
|
||||
(set-funcallable-instance-function r (lambda (x) (list "Hello, World!" x)))
|
||||
(sb-mop:set-funcallable-instance-function r (lambda (x) (list "Hello, World!" x)))
|
||||
(assert (equal (funcall r 3) '("Hello, World!" 3)))))
|
||||
|
|
|
|||
|
|
@ -14,22 +14,20 @@
|
|||
;;; This file contains the simplest test that the multiple subclasses
|
||||
;;; of generic function metacircle is gone.
|
||||
|
||||
(defpackage "MOP-7"
|
||||
(:use "CL" "SB-MOP" "TEST-UTIL"))
|
||||
|
||||
(in-package "MOP-7")
|
||||
|
||||
(defclass g1 (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defclass g2 (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
|
||||
(defgeneric f1 ()
|
||||
(:generic-function-class g1))
|
||||
(defgeneric f2 ()
|
||||
(:generic-function-class g2))
|
||||
|
||||
(print #'f1)
|
||||
(print #'f2)
|
||||
(with-test (:name :mop-7)
|
||||
(assert (plusp (length (with-output-to-string (stream)
|
||||
(print #'f1 stream)))))
|
||||
(assert (plusp (length (with-output-to-string (stream)
|
||||
(print #'f2 stream))))))
|
||||
|
|
|
|||
|
|
@ -13,19 +13,14 @@
|
|||
|
||||
;;; This file contains tests of UPDATE-DEPENDENT.
|
||||
|
||||
(defpackage "MOP-8"
|
||||
(:use "CL" "SB-MOP" "TEST-UTIL"))
|
||||
|
||||
(in-package "MOP-8")
|
||||
|
||||
(defclass dependent-history ()
|
||||
((history :initarg :history :accessor history)))
|
||||
|
||||
(defmethod update-dependent ((generic-function generic-function)
|
||||
(defmethod sb-mop:update-dependent ((generic-function generic-function)
|
||||
(history dependent-history)
|
||||
&rest args)
|
||||
(push args (history history)))
|
||||
(defmethod update-dependent ((class class)
|
||||
(defmethod sb-mop:update-dependent ((class class)
|
||||
(history dependent-history)
|
||||
&rest args)
|
||||
(push (cons class args) (history history)))
|
||||
|
|
@ -33,16 +28,20 @@
|
|||
(defvar *history* (make-instance 'dependent-history :history nil))
|
||||
|
||||
(defgeneric upd1 (x))
|
||||
(add-dependent #'upd1 *history*)
|
||||
(sb-mop:add-dependent #'upd1 *history*)
|
||||
(defmethod upd1 ((x integer)) x)
|
||||
|
||||
(with-test (:name (:mop-8 1))
|
||||
(let ((last (car (history *history*))))
|
||||
(assert (eq (car last) 'add-method))
|
||||
(assert (typep (cadr last) 'standard-method)))
|
||||
(assert (typep (cadr last) 'standard-method))))
|
||||
|
||||
(defclass foo ()
|
||||
())
|
||||
(add-dependent (find-class 'foo) *history*)
|
||||
(sb-mop:add-dependent (find-class 'foo) *history*)
|
||||
(defclass foo ()
|
||||
((a :initarg :a)))
|
||||
|
||||
(with-test (:name (:mop-8 2))
|
||||
(let ((last (car (history *history*))))
|
||||
(assert (eq (car last) (find-class 'foo))))
|
||||
(assert (eq (car last) (find-class 'foo)))))
|
||||
|
|
|
|||
|
|
@ -14,14 +14,9 @@
|
|||
;;; this file contains tests of (SETF CLASS-NAME) and (SETF
|
||||
;;; GENERIC-FUNCTION-NAME)
|
||||
|
||||
(defpackage "MOP-9"
|
||||
(:use "CL" "SB-MOP" "TEST-UTIL"))
|
||||
|
||||
(in-package "MOP-9")
|
||||
|
||||
(defclass metaclass/ri (standard-class)
|
||||
())
|
||||
(defmethod validate-superclass ((c metaclass/ri) (s standard-class))
|
||||
(defmethod sb-mop:validate-superclass ((c metaclass/ri) (s standard-class))
|
||||
t)
|
||||
(defclass class/ri ()
|
||||
()
|
||||
|
|
@ -29,6 +24,7 @@
|
|||
(defvar *class/ri-args* nil)
|
||||
(defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs)
|
||||
(setf *class/ri-args* initargs))
|
||||
|
||||
(with-test (:name ((setf class-name) reinitialize-instance))
|
||||
(let ((class (find-class 'class/ri)))
|
||||
(setf (class-name class) 'name)
|
||||
|
|
@ -41,43 +37,47 @@
|
|||
(defclass class/dependent ()
|
||||
())
|
||||
(defvar *dependent* (make-instance 'dependent))
|
||||
(defmethod update-dependent ((object standard-class) (dependent dependent)
|
||||
(defmethod sb-mop:update-dependent ((object standard-class)
|
||||
(dependent dependent)
|
||||
&rest args)
|
||||
(setf (dependent-slot dependent) args))
|
||||
(with-test (:name ((setf class-name) update-dependent))
|
||||
|
||||
(with-test (:name ((setf class-name) sb-mop:update-dependent))
|
||||
(let ((class (find-class 'class/dependent)))
|
||||
(add-dependent class *dependent*)
|
||||
(sb-mop:add-dependent class *dependent*)
|
||||
(setf (class-name class) 'name)
|
||||
(assert (equal (dependent-slot *dependent*) '(:name name)))
|
||||
(remove-dependent class *dependent*)
|
||||
(sb-mop:remove-dependent class *dependent*)
|
||||
(setf (class-name class) 'name)
|
||||
(assert (equal (dependent-slot *dependent*) '(:name name)))))
|
||||
|
||||
(defclass gfc/ri (standard-generic-function)
|
||||
()
|
||||
(:metaclass funcallable-standard-class))
|
||||
(:metaclass sb-mop:funcallable-standard-class))
|
||||
(defgeneric gf/ri ()
|
||||
(:generic-function-class gfc/ri))
|
||||
(defvar *gf/ri-args* nil)
|
||||
(defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs)
|
||||
(setf *gf/ri-args* initargs))
|
||||
(with-test (:name ((setf generic-function-name) reinitialize-instance))
|
||||
|
||||
(with-test (:name ((setf sb-mop:generic-function-name) reinitialize-instance))
|
||||
(let ((gf #'gf/ri))
|
||||
(setf (generic-function-name gf) 'name)
|
||||
(setf (sb-mop:generic-function-name gf) 'name)
|
||||
(assert (equal *gf/ri-args* '(:name name)))
|
||||
(setf (generic-function-name gf) 'gf/ri)
|
||||
(setf (sb-mop:generic-function-name gf) 'gf/ri)
|
||||
(assert (equal *gf/ri-args* '(:name gf/ri)))))
|
||||
|
||||
(defgeneric gf/dependent ())
|
||||
(defmethod update-dependent ((object standard-generic-function)
|
||||
(defmethod sb-mop:update-dependent ((object standard-generic-function)
|
||||
(dependent dependent)
|
||||
&rest args)
|
||||
(setf (dependent-slot dependent) args))
|
||||
(with-test (:name ((setf generic-function-name) update-dependent))
|
||||
|
||||
(with-test (:name ((setf sb-mop:generic-function-name) sb-mop:update-dependent))
|
||||
(let ((gf (find-class 'class/dependent)))
|
||||
(add-dependent gf *dependent*)
|
||||
(setf (generic-function-name gf) 'gf/name)
|
||||
(sb-mop:add-dependent gf *dependent*)
|
||||
(setf (sb-mop:generic-function-name gf) 'gf/name)
|
||||
(assert (equal (dependent-slot *dependent*) '(:name gf/name)))
|
||||
(remove-dependent gf *dependent*)
|
||||
(setf (generic-function-name gf) 'gf/dependent)
|
||||
(sb-mop:remove-dependent gf *dependent*)
|
||||
(setf (sb-mop:generic-function-name gf) 'gf/dependent)
|
||||
(assert (equal (dependent-slot *dependent*) '(:name gf/name)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue