common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

tests: Use WITH-TEST in mop-*.lisp

Browse source
This commit is contained in:
Jan Moringen 2018-12-07 18:23:04 +01:00
parent 8e0dab21e1
commit ceb4aff035
30 changed files with 547 additions and 589 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

89
tests/mop-1.impure-cload.lisp
View file

@ -19,90 +19,89 @@
;;; fixups for running in the full MOP rather than closette: SLOTDs ;;; fixups for running in the full MOP rather than closette: SLOTDs
;;; instead of slot-names, and so on. ;;; instead of slot-names, and so on.
(defpackage "TEST" (:use "CL" "SB-MOP"))
(in-package "TEST")
(defclass dynamic-slot-class (standard-class) ()) (defclass dynamic-slot-class (standard-class) ())
(defmethod validate-superclass (defmethod sb-mop:validate-superclass
((class dynamic-slot-class) (super standard-class)) ((class dynamic-slot-class) (super standard-class))
t) t)
(defmethod compute-effective-slot-definition (defmethod sb-mop:compute-effective-slot-definition
((class dynamic-slot-class) name direct-slots) ((class dynamic-slot-class) name direct-slots)
(let ((slot (call-next-method))) (let ((slot (call-next-method)))
(setf (slot-definition-allocation slot) :dynamic) (setf (sb-mop:slot-definition-allocation slot) :dynamic)
slot)) slot))
(defun dynamic-slot-p (slot) (defun dynamic-slot-p (slot)
(eq (slot-definition-allocation slot) :dynamic)) (eq (sb-mop:slot-definition-allocation slot) :dynamic))
(let ((table (make-hash-table))) (eval-when (:compile-toplevel :load-toplevel :execute)
(defun allocate-table-entry (instance) (let ((table (make-hash-table)))
(setf (gethash instance table) ()))
(defun read-dynamic-slot-value (instance slot-name) (defun allocate-table-entry (instance)
(let* ((alist (gethash instance table)) (setf (gethash instance table) ()))
(entry (assoc slot-name alist)))
(defun read-dynamic-slot-value (instance slot-name)
(let* ((alist (gethash instance table))
(entry (assoc slot-name alist)))
(if (null entry) (if (null entry)
(error "slot ~S unbound in ~S" slot-name instance) (error "slot ~S unbound in ~S" slot-name instance)
(cdr entry)))) (cdr entry))))
(defun write-dynamic-slot-value (new-value instance slot-name) (defun write-dynamic-slot-value (new-value instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(if (null entry) (if (null entry)
(push `(,slot-name . ,new-value) (push `(,slot-name . ,new-value)
(gethash instance table)) (gethash instance table))
(setf (cdr entry) new-value)) (setf (cdr entry) new-value))
new-value)) new-value))
(defun dynamic-slot-boundp (instance slot-name) (defun dynamic-slot-boundp (instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(not (null entry)))) (not (null entry))))
(defun dynamic-slot-makunbound (instance slot-name) (defun dynamic-slot-makunbound (instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(unless (null entry) (unless (null entry)
(setf (gethash instance table) (delete entry alist)))) (setf (gethash instance table) (delete entry alist))))
instance) instance)
) ))
(defmethod allocate-instance ((class dynamic-slot-class) &key) (defmethod allocate-instance ((class dynamic-slot-class) &key)
(let ((instance (call-next-method))) (let ((instance (call-next-method)))
(allocate-table-entry instance) (allocate-table-entry instance)
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))))
(if slot
(read-dynamic-slot-value instance (slot-definition-name slotd))
(call-next-method))))
(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
instance slotd) instance slotd)
(let ((slot (find slotd (class-slots class)))) (let ((slot (find slotd (sb-mop:class-slots class))))
(if slot (if slot
(write-dynamic-slot-value new-value instance (slot-definition-name slotd)) (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defmethod slot-boundp-using-class ((class dynamic-slot-class) (defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
instance slotd) instance slotd)
(let ((slot (find slotd (class-slots class)))) (let ((slot (find slotd (sb-mop:class-slots class))))
(if slot (if slot
(dynamic-slot-boundp instance (slot-definition-name slotd)) (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defmethod slot-makunbound-using-class ((class dynamic-slot-class) (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
instance slotd) instance slotd)
(let ((slot (find slotd (class-slots class)))) (let ((slot (find slotd (sb-mop:class-slots class))))
(if slot (if slot
(dynamic-slot-makunbound instance (slot-definition-name slotd)) (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
(call-next-method))))
(defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
instance slotd)
(let ((slot (find slotd (sb-mop:class-slots class))))
(if slot
(dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defclass test-class-1 () (defclass test-class-1 ()
@ -118,8 +117,8 @@
(defvar *one* (make-instance 'test-class-1)) (defvar *one* (make-instance 'test-class-1))
(defvar *two* (make-instance 'test-class-2 :slot3 1)) (defvar *two* (make-instance 'test-class-2 :slot3 1))
(assert (not (slot-boundp *one* 'slot1))) (with-test (:name :mop-1)
(assert (null (slot-value *one* 'slot2))) (assert (not (slot-boundp *one* 'slot1)))
(assert (eq t (slot-value *two* 'slot2))) (assert (null (slot-value *one* 'slot2)))
(assert (= 1 (slot-value *two* 'slot3))) (assert (eq t (slot-value *two* 'slot2)))
(assert (= 1 (slot-value *two* 'slot3))))

21
tests/mop-10.impure-cload.lisp
View file

@ -14,14 +14,9 @@
;;; this file contains tests of REINITIALIZE-INSTANCE on generic ;;; this file contains tests of REINITIALIZE-INSTANCE on generic
;;; functions. ;;; functions.
(defpackage "MOP-10"
(:use "CL" "SB-MOP" "TEST-UTIL"))
(in-package "MOP-10")
(defclass my-generic-function (standard-generic-function) (defclass my-generic-function (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric foo (x) (defgeneric foo (x)
(:method-combination list) (:method-combination list)
@ -30,12 +25,16 @@
(:method list ((x number)) (expt x 2)) (:method list ((x number)) (expt x 2))
(:generic-function-class my-generic-function)) (:generic-function-class my-generic-function))
(assert (equal (foo 3) '(4 9))) (with-test (:name (:mop-10 1))
(defmethod compute-discriminating-function ((gf my-generic-function)) (assert (equal (foo 3) '(4 9))))
(defmethod sb-mop:compute-discriminating-function ((gf my-generic-function))
(let ((orig (call-next-method))) (let ((orig (call-next-method)))
(lambda (&rest args) (lambda (&rest args)
(let ((orig-result (apply orig args))) (let ((orig-result (apply orig args)))
(cons gf (reverse orig-result)))))) (cons gf (reverse orig-result))))))
(assert (equal (foo 3) '(4 9)))
(reinitialize-instance #'foo) (with-test (:name (:mop-10 2))
(assert (equal (foo 3) (cons #'foo '(9 4)))) (assert (equal (foo 3) '(4 9)))
(reinitialize-instance #'foo)
(assert (equal (foo 3) (cons #'foo '(9 4)))))

22
tests/mop-11.impure-cload.lisp
View file

@ -14,32 +14,32 @@
;;; this file attempts to test possible metacircularity issues arising ;;; this file attempts to test possible metacircularity issues arising
;;; from changing discriminating functions. ;;; from changing discriminating functions.
(defpackage "MOP-11"
(:use "CL" "SB-MOP"))
(in-package "MOP-11")
(defclass gf1-class (standard-generic-function) () (defclass gf1-class (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric gf1 (x) (defgeneric gf1 (x)
(:method ((x t)) x) (:method ((x t)) x)
(:generic-function-class gf1-class)) (: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) () (defclass gf2-class (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric gf2 (y) (defgeneric gf2 (y)
(:method ((x number)) x) (:method ((x number)) x)
(:generic-function-class gf2-class)) (:generic-function-class gf2-class))
(assert (= (gf2 4) 4)) (with-test (:name (:mop-11 2))
(assert (= (gf2 4) 4)))
(defgeneric gf1a (x) (defgeneric gf1a (x)
(:method ((x symbol)) (symbol-name x)) (:method ((x symbol)) (symbol-name x))
(:generic-function-class gf1-class)) (: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) () (defclass gf3-class (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric gf3 (x y) (defgeneric gf3 (x y)
(:method ((x number) (y number)) (+ x y)) (:method ((x number) (y number)) (+ x y))
(:generic-function-class gf3-class)) (:generic-function-class gf3-class))
(assert (= (gf3 1 2) 3)) (with-test (:name (:mop-11 4))
(assert (= (gf3 1 2) 3)))

45
tests/mop-12.impure-cload.lisp
View file

@ -14,17 +14,12 @@
;;; this file attempts to test possible metacircularity issues arising ;;; this file attempts to test possible metacircularity issues arising
;;; from adding slots to methods in odd places. ;;; from adding slots to methods in odd places.
(defpackage "MOP-12"
(:use "CL" "SB-MOP"))
(in-package "MOP-12")
(defclass super-method () (defclass super-method ()
((abc :accessor abc :initarg :abc))) ((abc :accessor abc :initarg :abc)))
;;; Test case reported by Jean Bresson sbcl-devel 2006-02-09 ;;; Test case reported by Jean Bresson sbcl-devel 2006-02-09
(defclass sub-generic-function1 (standard-generic-function) () (defclass sub-generic-function1 (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass sub-method1 (standard-method super-method) ()) (defclass sub-method1 (standard-method super-method) ())
@ -37,23 +32,25 @@
(defmethod myfun1 (a b) (defmethod myfun1 (a b)
(incf *count1*)) (incf *count1*))
(myfun1 2 3) (with-test (:name (:mop-12 1))
(assert (= *count1* 1)) (myfun1 2 3)
(myfun1 t nil) (assert (= *count1* 1))
(assert (= *count1* 2)) (myfun1 t nil)
(assert (= *count1* 2)))
(defmethod myfun1 ((a integer) (b integer)) (defmethod myfun1 ((a integer) (b integer))
(incf *count1* 2)) (incf *count1* 2))
(myfun1 2 3) (with-test (:name (:mop-12 2))
(assert (= *count1* 4)) (myfun1 2 3)
(myfun1 t nil) (assert (= *count1* 4))
(assert (= *count1* 5)) (myfun1 t nil)
(assert (= *count1* 5)))
;;; Friendlier superclass order test case from Pascal Costanza ;;; Friendlier superclass order test case from Pascal Costanza
;;; sbcl-devel 2006-02-09 ;;; sbcl-devel 2006-02-09
(defclass sub-generic-function2 (standard-generic-function) () (defclass sub-generic-function2 (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass sub-method2 (super-method standard-method) ()) (defclass sub-method2 (super-method standard-method) ())
@ -66,15 +63,17 @@
(defmethod myfun2 (a b) (defmethod myfun2 (a b)
(incf *count2*)) (incf *count2*))
(myfun2 2 3) (with-test (:name (:mop-12 3))
(assert (= *count2* 1)) (myfun2 2 3)
(myfun2 t nil) (assert (= *count2* 1))
(assert (= *count2* 2)) (myfun2 t nil)
(assert (= *count2* 2)))
(defmethod myfun2 ((a integer) (b integer)) (defmethod myfun2 ((a integer) (b integer))
(incf *count2* 2)) (incf *count2* 2))
(myfun2 2 3) (with-test (:name (:mop-12 4))
(assert (= *count2* 4)) (myfun2 2 3)
(myfun2 t nil) (assert (= *count2* 4))
(assert (= *count2* 5)) (myfun2 t nil)
(assert (= *count2* 5)))

47
tests/mop-13.impure-cload.lisp
View file

@ -14,18 +14,13 @@
;;; this file attempts to test possible metacircularity issues arising ;;; this file attempts to test possible metacircularity issues arising
;;; from adding slots to generic functions in odd places. ;;; from adding slots to generic functions in odd places.
(defpackage "MOP-13"
(:use "CL" "SB-MOP"))
(in-package "MOP-13")
(defclass super-funcallable-mixin () (defclass super-funcallable-mixin ()
((abc :accessor abc :initarg :abc)) ((abc :accessor abc :initarg :abc))
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass sub-generic-function1 (standard-generic-function (defclass sub-generic-function1 (standard-generic-function
super-funcallable-mixin) () super-funcallable-mixin) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass sub-method1 (standard-method) ()) (defclass sub-method1 (standard-method) ())
@ -38,23 +33,25 @@
(defmethod myfun1 (a b) (defmethod myfun1 (a b)
(incf *count1*)) (incf *count1*))
(myfun1 2 3) (with-test (:name (:mop-13 1))
(assert (= *count1* 1)) (myfun1 2 3)
(myfun1 t nil) (assert (= *count1* 1))
(assert (= *count1* 2)) (myfun1 t nil)
(assert (= *count1* 2)))
(defmethod myfun1 ((a integer) (b integer)) (defmethod myfun1 ((a integer) (b integer))
(incf *count1* 2)) (incf *count1* 2))
(myfun1 2 3) (with-test (:name (:mop-13 2))
(assert (= *count1* 4)) (myfun1 2 3)
(myfun1 t nil) (assert (= *count1* 4))
(assert (= *count1* 5)) (myfun1 t nil)
(assert (= *count1* 5)))
;;; Friendlier superclass order test case ;;; Friendlier superclass order test case
(defclass sub-generic-function2 (super-funcallable-mixin (defclass sub-generic-function2 (super-funcallable-mixin
standard-generic-function) () standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass sub-method2 (standard-method) ()) (defclass sub-method2 (standard-method) ())
@ -67,15 +64,17 @@
(defmethod myfun2 (a b) (defmethod myfun2 (a b)
(incf *count2*)) (incf *count2*))
(myfun2 2 3) (with-test (:name (:mop-13 3))
(assert (= *count2* 1)) (myfun2 2 3)
(myfun2 t nil) (assert (= *count2* 1))
(assert (= *count2* 2)) (myfun2 t nil)
(assert (= *count2* 2)))
(defmethod myfun2 ((a integer) (b integer)) (defmethod myfun2 ((a integer) (b integer))
(incf *count2* 2)) (incf *count2* 2))
(myfun2 2 3) (with-test (:name (:mop-13 4))
(assert (= *count2* 4)) (myfun2 2 3)
(myfun2 t nil) (assert (= *count2* 4))
(assert (= *count2* 5)) (myfun2 t nil)
(assert (= *count2* 5)))

13
tests/mop-14.impure-cload.lisp
View file

@ -17,24 +17,17 @@
;;; superclass. (This used to fail in cache-filling code: see reports ;;; superclass. (This used to fail in cache-filling code: see reports
;;; from Levente Mészáros sbcl-devel 2006-04-19) ;;; from Levente Mészáros sbcl-devel 2006-04-19)
(defpackage :dc
(:use
#:cl
#:sb-mop))
(in-package :dc)
(defclass dwim-slot-definition (defclass dwim-slot-definition
(standard-slot-definition) (sb-mop:standard-slot-definition)
()) ())
(defclass dwim-direct-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 (defclass dwim-effective-slot-definition
(extra-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 (defclass dwim-attribute-slot-definition
(dwim-slot-definition) (dwim-slot-definition)

16
tests/mop-15.impure-cload.lisp
View file

@ -15,20 +15,15 @@
;;; that when FINALIZE-INHERITANCE is called on a class, it returns ;;; that when FINALIZE-INHERITANCE is called on a class, it returns
;;; before subclasses are finalized. ;;; before subclasses are finalized.
(defpackage "MOP-15"
(:use "CL" "SB-MOP"))
(in-package "MOP-15")
(defclass mop-15-class (standard-class) ()) (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) t)
(defvar *count* 0) (defvar *count* 0)
(defvar *max-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*))) (let ((*count* (1+ *count*)))
(when (> *count* *max-count*) (when (> *count* *max-count*)
(setf *max-count* *count*)) (setf *max-count* *count*))
@ -42,7 +37,8 @@
() ()
(:metaclass mop-15-class)) (:metaclass mop-15-class))
(finalize-inheritance (find-class 'super)) (with-test (:name :mop-15)
(finalize-inheritance (find-class 'sub)) (sb-mop:finalize-inheritance (find-class 'super))
(sb-mop:finalize-inheritance (find-class 'sub))
(assert (= *max-count* 1)) (assert (= *max-count* 1)))

19
tests/mop-16.impure-cload.lisp
View file

@ -17,21 +17,14 @@
;;; optimization, or if the optimization is deemed to be invalid, then ;;; optimization, or if the optimization is deemed to be invalid, then
;;; this test can go away. ;;; this test can go away.
(defpackage "MOP-16"
(:use "CL" "SB-MOP"))
(in-package "MOP-16")
(defclass foo-class (standard-class) ()) (defclass foo-class (standard-class) ())
(defclass foo-effective-slot-definition (standard-effective-slot-definition) (defclass foo-effective-slot-definition (standard-effective-slot-definition)
()) ())
(multiple-value-bind (value condition) (with-test (:name :mop-16)
(ignore-errors (assert-error
(defmethod (setf slot-value-using-class) (defmethod (setf sb-mop:slot-value-using-class)
((new-value integer) (class foo-class) ((new-value integer) (class foo-class)
(object standard-object) (slotd foo-effective-slot-definition)) (object standard-object) (slotd foo-effective-slot-definition))
"Haha")) "Haha")))
(assert (null value))
(assert (typep condition 'error)))

17
tests/mop-17.impure-cload.lisp
View file

@ -14,11 +14,6 @@
;;; this file tests the programmatic class example from pp.67-69 of ;;; this file tests the programmatic class example from pp.67-69 of
;;; AMOP. ;;; AMOP.
(defpackage "MOP-17"
(:use "CL" "SB-MOP"))
(in-package "MOP-17")
(defun make-programmatic-instance (superclass-names &rest initargs) (defun make-programmatic-instance (superclass-names &rest initargs)
(apply #'make-instance (apply #'make-instance
(find-programmatic-class (find-programmatic-class
@ -29,8 +24,8 @@
(let ((class (find-if (let ((class (find-if
(lambda (class) (lambda (class)
(equal superclasses (equal superclasses
(class-direct-superclasses class))) (sb-mop:class-direct-superclasses class)))
(class-direct-subclasses (car superclasses))))) (sb-mop:class-direct-subclasses (car superclasses)))))
(or class (or class
(make-programmatic-class superclasses)))) (make-programmatic-class superclasses))))
@ -49,12 +44,14 @@
(defclass top-labeled (label-type) ()) (defclass top-labeled (label-type) ())
(defclass bottom-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 *i1* (make-programmatic-instance '(circle orange top-labeled)))
(defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled))) (defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled)))
(defvar *i3* (make-programmatic-instance '(circle orange top-labeled))) (defvar *i3* (make-programmatic-instance '(circle orange top-labeled)))
(assert (not (eq *i1* *i3*))) (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)))

50
tests/mop-18.impure-cload.lisp
View file

@ -13,22 +13,17 @@
;;; this file tests the protocol for Reinitialization of Class Metaobjects ;;; 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 *in-reinitialize-instance* nil)
(defvar *finalized-class* nil) (defvar *finalized-class* nil)
(defclass test-standard-class (standard-class) ()) (defclass test-standard-class (standard-class) ())
(defmethod validate-superclass (defmethod sb-mop:validate-superclass
((class test-standard-class) (superclass standard-class)) ((class test-standard-class) (superclass standard-class))
t) t)
(defmethod finalize-inheritance :before ((class test-standard-class)) (defmethod sb-mop:finalize-inheritance :before ((class test-standard-class))
(when *in-reinitialize-instance* (when *in-reinitialize-instance*
(setf *finalized-class* class))) (setf *finalized-class* class)))
@ -40,23 +35,25 @@
(defclass test-standard-object () ((slot)) (defclass test-standard-object () ((slot))
(:metaclass test-standard-class)) (:metaclass test-standard-class))
(unless (class-finalized-p (find-class 'test-standard-object)) (unless (sb-mop:class-finalized-p (find-class 'test-standard-object))
(finalize-inheritance (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 (null *finalized-class*)) (assert (sb-mop:class-slots (find-class 'test-standard-object)))
(reinitialize-instance (find-class 'test-standard-object) :direct-slots nil) (assert (null *finalized-class*))
(assert (eq *finalized-class* (find-class 'test-standard-object))) (reinitialize-instance (find-class 'test-standard-object) :direct-slots nil)
(assert (null (class-slots (find-class 'test-standard-object)))) (assert (eq *finalized-class* (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) ((class test-funcallable-standard-class)
(superclass funcallable-standard-class)) (superclass sb-mop:funcallable-standard-class))
t) t)
(defmethod finalize-inheritance :before (defmethod sb-mop:finalize-inheritance :before
((class test-funcallable-standard-class)) ((class test-funcallable-standard-class))
(when *in-reinitialize-instance* (when *in-reinitialize-instance*
(setf *finalized-class* class))) (setf *finalized-class* class)))
@ -69,12 +66,13 @@
(defclass test-funcallable-standard-object () ((slot)) (defclass test-funcallable-standard-object () ((slot))
(:metaclass test-funcallable-standard-class)) (:metaclass test-funcallable-standard-class))
(unless (class-finalized-p (find-class 'test-funcallable-standard-object)) (unless (sb-mop:class-finalized-p (find-class 'test-funcallable-standard-object))
(finalize-inheritance (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 (eq *finalized-class* (find-class 'test-standard-object))) (assert (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))
(reinitialize-instance (find-class 'test-funcallable-standard-object) (assert (eq *finalized-class* (find-class 'test-standard-object)))
:direct-slots nil) (reinitialize-instance (find-class 'test-funcallable-standard-object)
(assert (eq *finalized-class* (find-class 'test-funcallable-standard-object))) :direct-slots nil)
(assert (null (class-slots (find-class 'test-funcallable-standard-object)))) (assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
(assert (null (sb-mop:class-slots (find-class 'test-funcallable-standard-object)))))

59
tests/mop-19.impure-cload.lisp
View file

@ -14,26 +14,21 @@
;;; this file tests the accessor method class portion of the protocol ;;; this file tests the accessor method class portion of the protocol
;;; for Initialization of Class Metaobjects. ;;; for Initialization of Class Metaobjects.
(defpackage "MOP-19"
(:use "CL" "SB-MOP"))
(in-package "MOP-19")
(defclass my-class (standard-class) ()) (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-reader (sb-mop:standard-reader-method) ())
(defclass my-writer (standard-writer-method) ()) (defclass my-writer (sb-mop:standard-writer-method) ())
(defvar *calls* nil) (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)) (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)) (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)) (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)) (find-class 'my-writer))
(defclass foo () (defclass foo ()
@ -42,29 +37,30 @@
(c :accessor c)) (c :accessor c))
(:metaclass my-class)) (:metaclass my-class))
(assert (= (length *calls*) 4)) (with-test (:name (:mop-19 1))
(assert (= (count 'a *calls* :key #'car) 1)) (assert (= (length *calls*) 4))
(assert (= (count 'b *calls* :key #'car) 1)) (assert (= (count 'a *calls* :key #'car) 1))
(assert (= (count 'c *calls* :key #'car) 2)) (assert (= (count 'b *calls* :key #'car) 1))
(assert (= (count 'reader *calls* :key #'cdr) 2)) (assert (= (count 'c *calls* :key #'car) 2))
(assert (= (count 'writer *calls* :key #'cdr) 2)) (assert (= (count 'reader *calls* :key #'cdr) 2))
(let ((method (find-method #'a nil (list (find-class 'foo))))) (assert (= (count 'writer *calls* :key #'cdr) 2))
(assert (eq (class-of method) (find-class 'my-reader)))) (let ((method (find-method #'a nil (list (find-class 'foo)))))
(let ((method (find-method #'b nil (list (find-class t) (find-class 'foo))))) (assert (eq (class-of method) (find-class 'my-reader))))
(assert (eq (class-of method) (find-class 'my-writer)))) (let ((method (find-method #'b nil (list (find-class t) (find-class 'foo)))))
(assert (eq (class-of method) (find-class 'my-writer)))))
(defclass my-other-class (my-class) ()) (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)) (declare (ignore args))
(find-class 'my-direct-slot-definition)) (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) (class (s my-direct-slot-definition) &rest initargs)
(declare (ignore initargs)) (declare (ignore initargs))
(find-class 'my-other-reader)) (find-class 'my-other-reader))
@ -74,7 +70,8 @@
(e :writer e)) (e :writer e))
(:metaclass my-other-class)) (:metaclass my-other-class))
(let ((method (find-method #'d nil (list (find-class 'bar))))) (with-test (:name (:mop-19 2))
(assert (eq (class-of method) (find-class 'my-other-reader)))) (let ((method (find-method #'d nil (list (find-class 'bar)))))
(let ((method (find-method #'e nil (list (find-class t) (find-class 'bar))))) (assert (eq (class-of method) (find-class 'my-other-reader))))
(assert (eq (class-of method) (find-class 'my-writer)))) (let ((method (find-method #'e nil (list (find-class t) (find-class 'bar)))))
(assert (eq (class-of method) (find-class 'my-writer)))))

186
tests/mop-2.impure-cload.lisp
View file

@ -20,86 +20,85 @@
;;; instead of slot-names, and so on -- and :allocation :dynamic for ;;; instead of slot-names, and so on -- and :allocation :dynamic for
;;; dynamic slots. ;;; dynamic slots.
(defpackage "TEST" (:use "CL" "SB-MOP"))
(in-package "TEST")
(defclass dynamic-slot-class (standard-class) ()) (defclass dynamic-slot-class (standard-class) ())
(defmethod validate-superclass (defmethod sb-mop:validate-superclass
((class dynamic-slot-class) (super standard-class)) ((class dynamic-slot-class) (super standard-class))
t) t)
(defun dynamic-slot-p (slot) (defun dynamic-slot-p (slot)
(eq (slot-definition-allocation slot) :dynamic)) (eq (sb-mop:slot-definition-allocation slot) :dynamic))
(let ((table (make-hash-table))) (eval-when (:compile-toplevel :load-toplevel :execute)
(let ((table (make-hash-table)))
(defun allocate-table-entry (instance) (defun allocate-table-entry (instance)
(setf (gethash instance table) ())) (setf (gethash instance table) ()))
(defun read-dynamic-slot-value (instance slot-name) (defun read-dynamic-slot-value (instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(if (null entry) (if (null entry)
(error "slot ~S unbound in ~S" slot-name instance) (error "slot ~S unbound in ~S" slot-name instance)
(cdr entry)))) (cdr entry))))
(defun write-dynamic-slot-value (new-value instance slot-name) (defun write-dynamic-slot-value (new-value instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(if (null entry) (if (null entry)
(push `(,slot-name . ,new-value) (push `(,slot-name . ,new-value)
(gethash instance table)) (gethash instance table))
(setf (cdr entry) new-value)) (setf (cdr entry) new-value))
new-value)) new-value))
(defun dynamic-slot-names (instance) (defun dynamic-slot-names (instance)
(mapcar #'car (gethash instance table))) (mapcar #'car (gethash instance table)))
(defun dynamic-slot-boundp (instance slot-name) (defun dynamic-slot-boundp (instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(not (null entry)))) (not (null entry))))
(defun dynamic-slot-makunbound (instance slot-name) (defun dynamic-slot-makunbound (instance slot-name)
(let* ((alist (gethash instance table)) (let* ((alist (gethash instance table))
(entry (assoc slot-name alist))) (entry (assoc slot-name alist)))
(unless (null entry) (unless (null entry)
(setf (gethash instance table) (delete entry alist)))) (setf (gethash instance table) (delete entry alist))))
instance) instance)
)
))
(defmethod allocate-instance ((class dynamic-slot-class) &key) (defmethod allocate-instance ((class dynamic-slot-class) &key)
(let ((instance (call-next-method))) (let ((instance (call-next-method)))
(allocate-table-entry instance) (allocate-table-entry instance)
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))))
(if (and slot (dynamic-slot-p slot))
(read-dynamic-slot-value instance (slot-definition-name slotd))
(call-next-method))))
(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
instance slotd) 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)) (if (and slot (dynamic-slot-p slot))
(write-dynamic-slot-value new-value instance (slot-definition-name slotd)) (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defmethod slot-boundp-using-class ((class dynamic-slot-class) (defmethod (setf sb-mop:slot-value-using-class) (new-value (class dynamic-slot-class)
instance slotd) 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)) (if (and slot (dynamic-slot-p slot))
(dynamic-slot-boundp instance (slot-definition-name slotd)) (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defmethod slot-makunbound-using-class ((class dynamic-slot-class) (defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-class)
instance slotd) 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)) (if (and slot (dynamic-slot-p slot))
(dynamic-slot-makunbound instance (slot-definition-name slotd)) (dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
(call-next-method))))
(defmethod sb-mop:slot-makunbound-using-class ((class dynamic-slot-class)
instance slotd)
(let ((slot (find slotd (sb-mop:class-slots class))))
(if (and slot (dynamic-slot-p slot))
(dynamic-slot-makunbound instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defclass test-class-1 () (defclass test-class-1 ()
@ -115,10 +114,11 @@
(defvar *one* (make-instance 'test-class-1)) (defvar *one* (make-instance 'test-class-1))
(defvar *two* (make-instance 'test-class-2 :slot3 1)) (defvar *two* (make-instance 'test-class-2 :slot3 1))
(assert (not (slot-boundp *one* 'slot1))) (with-test (:name (:mop-2 1))
(assert (null (slot-value *one* 'slot2))) (assert (not (slot-boundp *one* 'slot1)))
(assert (eq t (slot-value *two* 'slot2))) (assert (null (slot-value *one* 'slot2)))
(assert (= 1 (slot-value *two* 'slot3))) (assert (eq t (slot-value *two* 'slot2)))
(assert (= 1 (slot-value *two* 'slot3))))
;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
;;; overconservatism in accessing a class's precedence list deep in ;;; overconservatism in accessing a class's precedence list deep in
@ -126,26 +126,26 @@
;;; finalizing a class. ;;; finalizing a class.
(defclass dynamic-slot-subclass (dynamic-slot-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))))
(if (and slot (dynamic-slot-p slot))
(read-dynamic-slot-value instance (slot-definition-name slotd))
(call-next-method))))
(defmethod (setf slot-value-using-class) (new-value
(class dynamic-slot-subclass)
instance slotd) 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)) (if (and slot (dynamic-slot-p slot))
(write-dynamic-slot-value new-value instance (slot-definition-name slotd)) (read-dynamic-slot-value instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defmethod slot-boundp-using-class ((class dynamic-slot-subclass) (defmethod (setf sb-mop:slot-value-using-class) (new-value
instance slotd) (class dynamic-slot-subclass)
(let ((slot (find slotd (class-slots class)))) instance slotd)
(let ((slot (find slotd (sb-mop:class-slots class))))
(if (and slot (dynamic-slot-p slot)) (if (and slot (dynamic-slot-p slot))
(dynamic-slot-boundp instance (slot-definition-name slotd)) (write-dynamic-slot-value new-value instance (sb-mop:slot-definition-name slotd))
(call-next-method))))
(defmethod sb-mop:slot-boundp-using-class ((class dynamic-slot-subclass)
instance slotd)
(let ((slot (find slotd (sb-mop:class-slots class))))
(if (and slot (dynamic-slot-p slot))
(dynamic-slot-boundp instance (sb-mop:slot-definition-name slotd))
(call-next-method)))) (call-next-method))))
(defclass test-class-3 (test-class-1) (defclass test-class-3 (test-class-1)
@ -154,9 +154,11 @@
(:metaclass dynamic-slot-subclass)) (:metaclass dynamic-slot-subclass))
(defvar *three* (make-instance 'test-class-3 :slot3 3)) (defvar *three* (make-instance 'test-class-3 :slot3 3))
(assert (not (slot-boundp *three* 'slot1)))
(assert (eq (slot-value *three* 'slot2) t)) (with-test (:name (:mop-2 2))
(assert (= (slot-value *three* 'slot3) 3)) (assert (not (slot-boundp *three* 'slot1)))
(assert (eq (slot-value *three* 'slot2) t))
(assert (= (slot-value *three* 'slot3) 3)))
(defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v) (defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
(declare (ignore v)) (declare (ignore v))
@ -168,9 +170,11 @@
(slot3 :initarg :slot3) (slot3 :initarg :slot3)
(slot4 :initarg :slot4 :initform 42 :allocation :dynamic)) (slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
(:metaclass dynamic-slot-subclass)) (: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))) (let ((i (make-instance 'test-class-3)))
(dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s))))) (dolist (s '(slot1 slot2 slot3 slot4)) (assert (slot-exists-p i s)))))
@ -179,9 +183,11 @@
((slot2 :initarg :slot2 :initform t :allocation :dynamic) ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
(slot3 :initarg :slot3)) (slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass)) (: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))) (let ((i (make-instance 'test-class-3)))
(assert (not (slot-exists-p i 'slot4))) (assert (not (slot-exists-p i 'slot4)))
(dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s))))) (dolist (s '(slot1 slot2 slot3)) (assert (slot-exists-p i s)))))
@ -193,10 +199,12 @@
((slot2 :initarg :slot2 :initform 'ok :allocation :instance) ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
(slot3 :initarg :slot3)) (slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass)) (:metaclass dynamic-slot-subclass))
(let* ((slots (class-slots (find-class 'test-class-3)))
(slot (find 'slot2 slots :key #'slot-definition-name))) (with-test (:name (:mop-2 5))
(assert (eq :instance (slot-definition-allocation slot))) (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
(assert (eq 'ok (slot-value *three* 'slot2)))) (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 ;;; Test redefinition making a local slot dynamic again
;;; ;;;
@ -207,10 +215,12 @@
((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic) ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
(slot3 :initarg :slot3)) (slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass)) (:metaclass dynamic-slot-subclass))
(let* ((slots (class-slots (find-class 'test-class-3)))
(slot (find 'slot2 slots :key #'slot-definition-name))) (with-test (:name (:mop-2 6))
(assert (eq :dynamic (slot-definition-allocation slot))) (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
(assert (eq t (slot-value *three* 'slot2)))) (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 ;;; Test redefinition making a dynamic slot local, with
;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot. ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
@ -221,24 +231,30 @@
&rest inits) &rest inits)
(declare (ignore inits)) (declare (ignore inits))
(let* ((class (class-of obj)) (let* ((class (class-of obj))
(slots (class-slots class))) (slots (sb-mop:class-slots class)))
(dolist (name (dynamic-slot-names obj)) (dolist (name (dynamic-slot-names obj))
(let ((slotd (find name slots :key #'slot-definition-name))) (let ((slotd (find name slots :key #'sb-mop:slot-definition-name)))
(unless (and slotd (eq :dynamic (slot-definition-allocation slotd))) (unless (and slotd (eq :dynamic (sb-mop:slot-definition-allocation slotd)))
(dynamic-slot-makunbound obj name)))))) (dynamic-slot-makunbound obj name))))))
(defclass test-class-3 (test-class-1) (defclass test-class-3 (test-class-1)
((slot2 :initarg :slot2 :initform 'ok :allocation :instance) ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
(slot3 :initarg :slot3)) (slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass)) (:metaclass dynamic-slot-subclass))
(let* ((slots (class-slots (find-class 'test-class-3)))
(slot (find 'slot2 slots :key #'slot-definition-name))) (with-test (:name (:mop-2 7))
(assert (eq :instance (slot-definition-allocation slot))) (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
(assert (eq 'ok (slot-value *three* 'slot2)))) (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) (defclass test-class-3 (test-class-1)
((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic) ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
(slot3 :initarg :slot3)) (slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass)) (:metaclass dynamic-slot-subclass))
(let* ((slots (class-slots (find-class 'test-class-3)))
(slot (find 'slot2 slots :key #'slot-definition-name))) (with-test (:name (:mop-2 8))
(assert (eq :dynamic (slot-definition-allocation slot))) (let* ((slots (sb-mop:class-slots (find-class 'test-class-3)))
(assert (eq 'ok! (slot-value *three* 'slot2)))) (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)))))

37
tests/mop-20.impure-cload.lisp
View file

@ -14,11 +14,6 @@
;;; this file tests that user-defined methods can be used in ;;; this file tests that user-defined methods can be used in
;;; combination (ahem) with hairy bits of method-combination. ;;; 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 ;;; Simple test case from Pascal Costanza
(defgeneric test (arg) (defgeneric test (arg)
(:method (arg) (format t "~D" arg) arg)) (:method (arg) (format t "~D" arg) arg))
@ -26,25 +21,26 @@
(defun define-around-test () (defun define-around-test ()
(multiple-value-bind (multiple-value-bind
(method-lambda method-args) (method-lambda method-args)
(make-method-lambda (sb-mop:make-method-lambda
#'test (class-prototype (generic-function-method-class #'test)) #'test (sb-mop:class-prototype (sb-mop:generic-function-method-class #'test))
'(lambda (arg) (call-next-method)) ()) '(lambda (arg) (call-next-method)) ())
(let ((method (apply #'make-instance (let ((method (apply #'make-instance
(generic-function-method-class #'test) (sb-mop:generic-function-method-class #'test)
:qualifiers '(:around) :qualifiers '(:around)
:lambda-list '(arg) :lambda-list '(arg)
:specializers (list (find-class 't)) :specializers (list (find-class 't))
:function (compile nil method-lambda) :function (compile nil method-lambda)
method-args))) method-args)))
(add-method #'test method)))) (sb-mop:add-method #'test method))))
(defun run-test () (defun run-test ()
(define-around-test) (define-around-test)
(test 42)) (test 42))
(assert (string= (with-output-to-string (*standard-output*) (with-test (:name (:mop-20 1))
(assert (= (run-test) 42))) (assert (string= (with-output-to-string (*standard-output*)
"42")) (assert (= (run-test) 42)))
"42")))
;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel ;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel
;;; 2004-06-11). First the setup. ;;; 2004-06-11). First the setup.
@ -71,20 +67,19 @@
(append unspecialized-required-part (append unspecialized-required-part
(subseq required-part (length required-part))))) (subseq required-part (length required-part)))))
`(progn `(progn
(add-method #',name (sb-mop:add-method #',name
(make-instance 'user-method (make-instance 'user-method
:qualifiers ',qualifiers :qualifiers ',qualifiers
:lambda-list ',unspecialized-lambdalist :lambda-list ',unspecialized-lambdalist
:specializers ',specializers :specializers ',specializers
:function :function
#'(lambda (arguments next-methods-list) #'(lambda (arguments next-methods-list)
(flet ((next-method-p () next-methods-list) (flet ((next-method-p () next-methods-list)
(call-next-method (&rest new-arguments) (call-next-method (&rest new-arguments)
(unless new-arguments (setq new-arguments arguments)) (unless new-arguments (setq new-arguments arguments))
(if (null next-methods-list) (if (null next-methods-list)
(error "no next method for arguments ~:s" arguments) (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))))) new-arguments (rest next-methods-list)))))
(apply #'(lambda ,unspecialized-lambdalist ,@body) arguments))))) (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
',name))) ',name)))
@ -98,7 +93,9 @@
(def-user-method test-um03 ((x rational)) (def-user-method test-um03 ((x rational))
(list* 'rational x (not (null (next-method-p))) (call-next-method))) (list* 'rational x (not (null (next-method-p))) (call-next-method)))
(defmethod test-um03 ((x real)) (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)))) (assert (equal (test-um03 17) '(integer 17 t rational 17 t real 17 nil))))
;;; these two used to fail in slightly different ways ;;; these two used to fail in slightly different ways
@ -116,7 +113,9 @@
(defmethod test-um10 :around ((x rational)) (defmethod test-um10 :around ((x rational))
(list* 'around-rational x (not (null (next-method-p))) (call-next-method))) (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
(defmethod test-um10 :around ((x real)) (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) (assert (equal (test-um10 17)
'(around-integer 17 t '(around-integer 17 t
around-rational 17 t around-rational 17 t
@ -139,7 +138,9 @@
(defmethod test-um12 :around ((x rational)) (defmethod test-um12 :around ((x rational))
(list* 'around-rational x (not (null (next-method-p))) (call-next-method))) (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
(def-user-method test-um12 :around ((x real)) (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) (assert (equal (test-um12 17)
'(around-integer 17 t '(around-integer 17 t
around-rational 17 t around-rational 17 t

29
tests/mop-21.impure-cload.lisp
View file

@ -14,14 +14,9 @@
;;; Pascal Costanza's implementation of beta methods, lightly ;;; Pascal Costanza's implementation of beta methods, lightly
;;; modified. Contains a specialization of MAKE-METHOD-LAMBDA. ;;; 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) (defclass beta-generic-function (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass beta-method (standard-method) (defclass beta-method (standard-method)
((betap :reader betap :initarg :betap :initform nil))) ((betap :reader betap :initarg :betap :initform nil)))
@ -73,7 +68,7 @@
`(call-method ,(first around) (,@(rest around) (make-method ,form))) `(call-method ,(first around) (,@(rest around) (make-method ,form)))
form)))) form))))
(defmethod make-method-lambda (defmethod sb-mop:make-method-lambda
((gf beta-generic-function) method-prototype lambda-expression environment) ((gf beta-generic-function) method-prototype lambda-expression environment)
(declare (ignore method-prototype environment)) (declare (ignore method-prototype environment))
(let ((method-args (gensym)) (let ((method-args (gensym))
@ -85,7 +80,7 @@
(declare (dynamic-extent args)) (declare (dynamic-extent args))
(if (null ,next-methods) (if (null ,next-methods)
(error "There is no next method for ~S." ,gf) (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) (if args args ,method-args)
(cdr ,next-methods) (cdr ,next-methods)
,inner-runs))) ,inner-runs)))
@ -94,7 +89,7 @@
(declare (dynamic-extent args)) (declare (dynamic-extent args))
(if (null ,inner-runs) (if (null ,inner-runs)
(error "There is no inner method for ~S." ,gf) (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) (if args args ,method-args)
(cdar ,inner-runs) (cdar ,inner-runs)
(cdr ,inner-runs)))) (cdr ,inner-runs))))
@ -123,11 +118,17 @@
;;; before DEFCLASS- and DEFGENERIC-load-time. ;;; before DEFCLASS- and DEFGENERIC-load-time.
(mapcar #'eval (mapcar #'eval
(list (list
'(defmethod test ((object top)) 'top) '(defmethod test ((object top))
(declare (ignore object))
'top)
'(defmethod test :beta ((object middle)) '(defmethod test :beta ((object middle))
(declare (ignore object))
(list 'middle (call-inner-method) (call-next-method))) (list 'middle (call-inner-method) (call-next-method)))
'(defmethod test :beta ((object bottom)) 'bottom))) '(defmethod test :beta ((object bottom))
(declare (ignore object))
'bottom)))
(assert (equal '(middle bottom top) (test (make-instance 'bottom)))) (with-test (:name (:mop-21))
(assert (equal 'top (test (make-instance 'top)))) (assert (equal '(middle bottom top) (test (make-instance 'bottom))))
(assert (null (ignore-errors (test (make-instance 'middle))))) (assert (equal 'top (test (make-instance 'top))))
(assert (null (ignore-errors (test (make-instance 'middle))))))

20
tests/mop-22.impure-cload.lisp
View file

@ -13,11 +13,6 @@
;;; Forward-referenced classes as specializers. ;;; 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 ;;; It's generally unclear to me whether this should be allowed. On
;;; the one hand, FORWARD-REFERENCED-CLASS is a subclass of CLASS and ;;; the one hand, FORWARD-REFERENCED-CLASS is a subclass of CLASS and
;;; hence of SPECIALIZER, and AMOP specifies that as-yet-undefined ;;; hence of SPECIALIZER, and AMOP specifies that as-yet-undefined
@ -46,10 +41,11 @@
(defclass forward () ()) (defclass forward () ())
(assert (eq (incomplete/1 (make-instance 'incomplete)) 'incomplete)) (with-test (:name :mop-22)
(assert (eq (forward/1 (make-instance 'forward)) 'forward)) (assert (eq (incomplete/1 (make-instance 'incomplete)) 'incomplete))
(assert (eq (incomplete/7 (make-instance 'incomplete) (assert (eq (forward/1 (make-instance 'forward)) 'forward))
(make-instance 'incomplete) (assert (eq (incomplete/7 (make-instance 'incomplete)
t 1 (make-condition 'error) (make-instance 'incomplete)
(find-class 'incomplete) 3) t 1 (make-condition 'error)
t)) (find-class 'incomplete) 3)
t)))

34
tests/mop-23.impure.lisp
View file

@ -14,14 +14,9 @@
;;; Extending MAKE-METHOD-LAMBDA, and making sure that the resulting ;;; Extending MAKE-METHOD-LAMBDA, and making sure that the resulting
;;; method functions compile without warnings. ;;; method functions compile without warnings.
(defpackage "MOP-23"
(:use "CL" "SB-MOP"))
(in-package "MOP-23")
(defclass verbose-generic-function (standard-generic-function) () (defclass verbose-generic-function (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defmethod make-method-lambda (defmethod sb-mop:make-method-lambda
((gf verbose-generic-function) method lambda env) ((gf verbose-generic-function) method lambda env)
(multiple-value-bind (lambda initargs) (multiple-value-bind (lambda initargs)
(call-next-method) (call-next-method)
@ -37,9 +32,10 @@
(handler-bind ((warning #'error)) (handler-bind ((warning #'error))
(eval '(defmethod foo ((x integer)) (1+ x)))) (eval '(defmethod foo ((x integer)) (1+ x))))
(assert (string= (with-output-to-string (*trace-output*) (with-test (:name (:mop-23 sb-mop:make-method-lambda 1))
(assert (= (foo 3) 4))) (assert (string= (with-output-to-string (*trace-output*)
"Called a method!")) (assert (= (foo 3) 4)))
"Called a method!")))
(defclass super () ((a :initarg :a))) (defclass super () ((a :initarg :a)))
(defclass sub (super) (b)) (defclass sub (super) (b))
@ -49,16 +45,18 @@
(eval '(defmethod foo :around ((x super)) (eval '(defmethod foo :around ((x super))
(list (slot-value x 'a) (call-next-method))))) (list (slot-value x 'a) (call-next-method)))))
(assert (string= (with-output-to-string (*trace-output*) (with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
(assert (equal (foo (make-instance 'sub :a 4)) (assert (string= (with-output-to-string (*trace-output*)
'(4 nil)))) (assert (equal (foo (make-instance 'sub :a 4))
"Called a method!Called a method!")) '(4 nil))))
"Called a method!Called a method!")))
(defclass super () (defclass super ()
((b :initform 3) ((b :initform 3)
(a :initarg :a))) (a :initarg :a)))
(assert (string= (with-output-to-string (*trace-output*) (with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
(assert (equal (foo (make-instance 'sub :a 5)) (assert (string= (with-output-to-string (*trace-output*)
'(5 t)))) (assert (equal (foo (make-instance 'sub :a 5))
"Called a method!Called a method!")) '(5 t))))
"Called a method!Called a method!")))

19
tests/mop-24.impure.lisp
View file

@ -13,11 +13,6 @@
;;; Some slot-valuish things in combination with user-defined methods ;;; 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)) (defclass user-method (standard-method) (myslot))
(defmacro def-user-method (name &rest rest) (defmacro def-user-method (name &rest rest)
@ -54,7 +49,7 @@
(unless new-arguments (setq new-arguments arguments)) (unless new-arguments (setq new-arguments arguments))
(if (null next-methods-list) (if (null next-methods-list)
(error "no next method for arguments ~:s" arguments) (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))))) new-arguments (rest next-methods-list)))))
(apply #'(lambda ,unspecialized-lambdalist ,@body) arguments))))) (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
',name))) ',name)))
@ -77,7 +72,9 @@
(list* 'sub (slot-value x 'a) (slot-value x 'b) (list* 'sub (slot-value x 'a) (slot-value x 'b)
(not (null (next-method-p))) (call-next-method))) (not (null (next-method-p))) (call-next-method)))
(defmethod test-um03 ((x super)) (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 'super)) '(super 3 nil)))
(assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil))) (assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
(assert (equal (test-um03 (make-instance 'subsub)) (assert (equal (test-um03 (make-instance 'subsub))
@ -102,7 +99,9 @@
(not (null (next-method-p))) (call-next-method))) (not (null (next-method-p))) (call-next-method)))
(defmethod test-um10 :around ((x super)) (defmethod test-um10 :around ((x super))
(list* 'around-super (slot-value x 'a) (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)) (assert (equal (test-um10 (make-instance 'super))
'(around-super 3 t super 3 nil))) '(around-super 3 t super 3 nil)))
(assert (equal (test-um10 (make-instance 'sub)) (assert (equal (test-um10 (make-instance 'sub))
@ -130,7 +129,9 @@
(not (null (next-method-p))) (call-next-method))) (not (null (next-method-p))) (call-next-method)))
(def-user-method test-um12 :around ((x super)) (def-user-method test-um12 :around ((x super))
(list* 'around-super (slot-value x 'a) (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)) (assert (equal (test-um12 (make-instance 'super))
'(around-super 3 t super 3 nil))) '(around-super 3 t super 3 nil)))
(assert (equal (test-um12 (make-instance 'sub)) (assert (equal (test-um12 (make-instance 'sub))

29
tests/mop-25.impure.lisp
View file

@ -14,18 +14,13 @@
;;; be sure that the :FUNCTION initarg to initialize methods overrides ;;; be sure that the :FUNCTION initarg to initialize methods overrides
;;; any system-provided function. ;;; any system-provided function.
(defpackage "MOP-25"
(:use "CL" "SB-MOP"))
(in-package "MOP-25")
(defclass typechecking-reader-method (standard-reader-method) (defclass typechecking-reader-method (standard-reader-method)
()) ())
(defmethod initialize-instance (defmethod initialize-instance
((method typechecking-reader-method) &rest initargs &key slot-definition) ((method typechecking-reader-method) &rest initargs &key slot-definition)
(let ((name (slot-definition-name slot-definition)) (let ((name (sb-mop:slot-definition-name slot-definition))
(type (slot-definition-type slot-definition))) (type (sb-mop:slot-definition-type slot-definition)))
(apply #'call-next-method method (apply #'call-next-method method
:function #'(lambda (args next-methods) :function #'(lambda (args next-methods)
(declare (ignore next-methods)) (declare (ignore next-methods))
@ -40,7 +35,7 @@
(defclass typechecking-reader-class (standard-class) (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) t)
(defmethod reader-method-class (defmethod reader-method-class
@ -52,13 +47,11 @@
((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair)) ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
(:metaclass typechecking-reader-class)) (:metaclass typechecking-reader-class))
(assert (equal '(t t t nil t) (with-test (:name (:mop-24))
(macrolet ((succeeds (form) (let ((p (list 'abc 'def))
`(not (nth-value 1 (ignore-errors ,form))))) (x (make-instance 'testclass25)))
(let ((p (list 'abc 'def)) (assert-no-signal (make-instance 'testclass25 :pair '(seventeen 17)))
(x (make-instance 'testclass25))) (assert-no-signal (setf (testclass25-pair x) p))
(list (succeeds (make-instance 'testclass25 :pair '(seventeen 17))) (assert-no-signal (setf (second p) 456))
(succeeds (setf (testclass25-pair x) p)) (assert-no-signal (testclass25-pair x))
(succeeds (setf (second p) 456)) (assert-no-signal (slot-value x 'pair))))
(succeeds (testclass25-pair x))
(succeeds (slot-value x 'pair)))))))

12
tests/mop-26.impure.lisp
View file

@ -21,8 +21,6 @@
;;; function. So it's fine if this test starts failing, as long as ;;; function. So it's fine if this test starts failing, as long as
;;; it's deliberate. ;;; it's deliberate.
(in-package "CL-USER")
(defclass super () ()) (defclass super () ())
(defclass sub (super) ()) (defclass sub (super) ())
@ -32,11 +30,13 @@
(let ((spec (sb-pcl::class-eq-specializer (find-class 'super)))) (let ((spec (sb-pcl::class-eq-specializer (find-class 'super))))
(eval `(defmethod test ((x ,spec)) t))) (eval `(defmethod test ((x ,spec)) t)))
(assert (test (make-instance 'super))) (with-test (:name (:mop-26 1))
(assert (null (test (make-instance 'sub)))) (assert (test (make-instance 'super)))
(assert (null (test (make-instance 'sub)))))
(let ((spec (sb-pcl::class-eq-specializer (find-class 't)))) (let ((spec (sb-pcl::class-eq-specializer (find-class 't))))
(eval `(defmethod test ((x ,spec)) (class-of x)))) (eval `(defmethod test ((x ,spec)) (class-of x))))
(assert (test (make-instance 'super))) (with-test (:name (:mop-26 2))
(assert (null (test (make-instance 'sub)))) (assert (test (make-instance 'super)))
(assert (null (test (make-instance 'sub)))))

31
tests/mop-27.impure.lisp
View file

@ -24,12 +24,7 @@
;;; be an interesting exercise for the reader. (As would fixing some ;;; be an interesting exercise for the reader. (As would fixing some
;;; other marked issues). ;;; other marked issues).
(defpackage "MOP-27" (defclass pattern-specializer (sb-mop:specializer)
(:use "CL" "SB-MOP"))
(in-package "MOP-27")
(defclass pattern-specializer (specializer)
((pattern :initarg pattern :reader pattern) ((pattern :initarg pattern :reader pattern)
(direct-methods :initform nil :reader specializer-direct-methods))) (direct-methods :initform nil :reader specializer-direct-methods)))
@ -42,7 +37,7 @@
;;; only one arg for now ;;; only one arg for now
(defclass pattern-gf/1 (standard-generic-function) () (defclass pattern-gf/1 (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defmethod sb-pcl:specializer-type-specifier (defmethod sb-pcl:specializer-type-specifier
((proto-generic-function pattern-gf/1) ((proto-generic-function pattern-gf/1)
@ -66,22 +61,22 @@
(defun method-interpreting-function (methods gf) (defun method-interpreting-function (methods gf)
(lambda (arg) (lambda (arg)
(dolist (method methods (no-applicable-method gf (list arg))) (dolist (method methods (no-applicable-method gf (list arg)))
(when (matchesp arg (pattern (car (method-specializers method)))) (when (matchesp arg (pattern (first (sb-mop:method-specializers method))))
(return (funcall (method-function method) (list arg) nil)))))) (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) (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))) (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)))) (funcall function arg))))
;;; protocol functions. SPECIALIZER-DIRECT-METHODS is implemented by ;;; protocol functions. SPECIALIZER-DIRECT-METHODS is implemented by
;;; a reader on the specializer. FIXME: implement ;;; a reader on the specializer. FIXME: implement
;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS. ;;; 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))) (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) (setf (slot-value specializer 'direct-methods)
(remove method (slot-value specializer 'direct-methods)))) (remove method (slot-value specializer 'direct-methods))))
@ -99,6 +94,8 @@
(let ((specializer (ensure-pattern-specializer '(* 0 nil)))) (let ((specializer (ensure-pattern-specializer '(* 0 nil))))
(eval `(defmethod simplify ((x ,specializer)) 0))) (eval `(defmethod simplify ((x ,specializer)) 0)))
(assert (eql (simplify '(* 0 3)) 0))
(assert (eql (simplify '(* (+ x y) 0)) 0)) (with-test (:name (:mop-27))
(assert (equal (simplify '(+ x y)) '(+ x y))) (assert (eql (simplify '(* 0 3)) 0))
(assert (eql (simplify '(* (+ x y) 0)) 0))
(assert (equal (simplify '(+ x y)) '(+ x y))))

51
tests/mop-28.impure.lisp
View file

@ -16,12 +16,7 @@
;;; strategy implicit in the second return value of ;;; strategy implicit in the second return value of
;;; compute-applicable-methods-using-classes. ;;; compute-applicable-methods-using-classes.
(defpackage "OR-SPECIALIZER-TEST" (defclass or-specializer (sb-mop:specializer)
(:use "CL" "SB-MOP" "ASSERTOID"))
(in-package "OR-SPECIALIZER-TEST")
(defclass or-specializer (specializer)
((classes :initform nil :reader or-specializer-classes :initarg :classes) ((classes :initform nil :reader or-specializer-classes :initarg :classes)
(direct-methods :initform nil :reader specializer-direct-methods))) (direct-methods :initform nil :reader specializer-direct-methods)))
@ -36,7 +31,7 @@
(make-instance 'or-specializer :classes sorted-classes))))) (make-instance 'or-specializer :classes sorted-classes)))))
(defclass gf-with-or (standard-generic-function) () (defclass gf-with-or (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defmethod sb-pcl:specializer-type-specifier (defmethod sb-pcl:specializer-type-specifier
((proto-generic-function gf-with-or) ((proto-generic-function gf-with-or)
@ -44,21 +39,21 @@
(specializer or-specializer)) (specializer or-specializer))
`(or ,@(or-specializer-classes 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) ((generic-function gf-with-or) classes)
;; FIXME: assume one-argument for now ;; FIXME: assume one-argument for now
(let (applicable-methods) (let (applicable-methods)
(let ((methods (generic-function-methods generic-function))) (let ((methods (sb-mop:generic-function-methods generic-function)))
(dolist (m methods) (dolist (m methods)
(let ((specializer (car (method-specializers m))) (let ((specializer (first (sb-mop:method-specializers m)))
(class (car classes))) (class (first classes)))
(typecase specializer (typecase specializer
(class (when (subtypep class specializer) (class (when (subtypep class specializer)
(push m applicable-methods))) (push m applicable-methods)))
(eql-specializer (sb-mop:eql-specializer
(when (eql (class-of (eql-specializer-object specializer)) (when (eql (class-of (sb-mop:eql-specializer-object specializer))
class) class)
(return-from compute-applicable-methods-using-classes (return-from sb-mop:compute-applicable-methods-using-classes
(values nil nil)))) (values nil nil))))
(or-specializer (or-specializer
(dolist (c (or-specializer-classes specializer)) (dolist (c (or-specializer-classes specializer))
@ -67,19 +62,19 @@
;; FIXME: sort the methods ;; FIXME: sort the methods
(values applicable-methods t))) (values applicable-methods t)))
(defmethod compute-applicable-methods (defmethod sb-mop:compute-applicable-methods
((generic-function gf-with-or) arguments) ((generic-function gf-with-or) arguments)
;; FIXME: assume one-argument for now ;; FIXME: assume one-argument for now
(let (applicable-methods) (let (applicable-methods)
(let ((methods (generic-function-methods generic-function))) (let ((methods (sb-mop:generic-function-methods generic-function)))
(dolist (m methods) (dolist (m methods)
(let ((specializer (car (method-specializers m))) (let ((specializer (first (sb-mop:method-specializers m)))
(argument (car arguments))) (argument (first arguments)))
(typecase specializer (typecase specializer
(class (when (typep argument specializer) (class (when (typep argument specializer)
(push m applicable-methods))) (push m applicable-methods)))
(eql-specializer (sb-mop:eql-specializer
(when (eql (eql-specializer-object specializer) argument) (when (eql (sb-mop:eql-specializer-object specializer) argument)
(push m applicable-methods))) (push m applicable-methods)))
(or-specializer (or-specializer
(dolist (c (or-specializer-classes specializer)) (dolist (c (or-specializer-classes specializer))
@ -88,10 +83,10 @@
;; FIXME: sort the methods ;; FIXME: sort the methods
applicable-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))) (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) (setf (slot-value specializer 'direct-methods)
(remove method (slot-value specializer 'direct-methods)))) (remove method (slot-value specializer 'direct-methods))))
@ -108,11 +103,13 @@
(let ((specializer (ensure-or-specializer 'class1 'class2))) (let ((specializer (ensure-or-specializer 'class1 'class2)))
(eval `(defmethod foo ((x ,specializer)) t))) (eval `(defmethod foo ((x ,specializer)) t)))
(assert (foo (make-instance 'class1))) (with-test (:name (:mop-28 1))
(assert (foo (make-instance 'class2))) (assert (foo (make-instance 'class1)))
(assert-error (foo (make-instance 'class3))) (assert (foo (make-instance 'class2)))
(assert (foo (make-instance 'class4))) (assert-error (foo (make-instance 'class3)))
(assert (foo (make-instance 'class4))))
;;; check that we are actually cacheing effective methods. If the ;;; check that we are actually cacheing effective methods. If the
;;; representation in PCL changes, this test needs to change too. ;;; 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)))

17
tests/mop-29.impure.lisp
View file

@ -18,23 +18,22 @@
;;; effective slot definitions to be available during class ;;; effective slot definitions to be available during class
;;; finalization) ;;; finalization)
(defpackage "MOP-29"
(:use "CL" "SB-MOP"))
(in-package "MOP-29")
(defclass my-class (standard-class) (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) t)
(defvar *foo*) (defvar *foo*)
;;; the specialization of OBJECT here triggers the PV optimization; ;;; the specialization of OBJECT here triggers the PV optimization;
;;; with an unspecialized argument, the SLOT-VALUE is not optimized. ;;; 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) ((class my-class) (object standard-object) eslotd)
(if *foo* (if *foo*
(setf (slot-value object 'id) 42) (setf (slot-value object 'id) 42)
(call-next-method))) (call-next-method)))
(defclass my-object () (defclass my-object ()
((id :type integer :reader id-of)) ((id :type integer :reader id-of))
(:metaclass my-class)) (:metaclass my-class))
@ -55,4 +54,6 @@
(assert (= (id-of object) 42)) (assert (= (id-of object) 42))
(assert (= (slot-value object 'id) 42))))) (assert (= (slot-value object 'id) 42)))))
(compile 'test-global-accessors) (compile 'test-global-accessors)
(test-global-accessors)
(with-test (:name (:mop-29))
(test-global-accessors))

33
tests/mop-3.impure-cload.lisp
View file

@ -16,28 +16,23 @@
;;; tests from Bruno Haible (sbcl-devel 2004-08-02) ;;; 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) (defclass msl-generic-function (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defun reverse-method-list (methods) (defun reverse-method-list (methods)
(let ((result '())) (let ((result '()))
(dolist (method methods) (dolist (method methods)
(if (and (consp result) (if (and (consp result)
(equal (method-qualifiers method) (equal (sb-mop:method-qualifiers method)
(method-qualifiers (caar result)))) (sb-mop:method-qualifiers (caar result))))
(push method (car result)) (push method (car result))
(push (list method) result))) (push (list method) result)))
(reduce #'append 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))) (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) ((gf msl-generic-function) classes)
(reverse-method-list (call-next-method))) (reverse-method-list (call-next-method)))
@ -52,23 +47,24 @@
(:method :around ((x integer)) (:method :around ((x integer))
(coerce (call-next-method) 'vector))) (coerce (call-next-method) 'vector)))
(assert (equalp (list (testgf07 5.0) (testgf07 17)) (with-test (:name (:mop-3 1))
'((number real) #(number real integer)))) (assert (equalp (list (testgf07 5.0) (testgf07 17))
'((number real) #(number real integer)))))
(defclass nonumber-generic-function (standard-generic-function) (defclass nonumber-generic-function (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defun nonumber-method-list (methods) (defun nonumber-method-list (methods)
(remove-if #'(lambda (method) (remove-if #'(lambda (method)
(member (find-class 'number) (member (find-class 'number)
(sb-pcl:method-specializers method))) (sb-mop:method-specializers method)))
methods)) methods))
(defmethod compute-applicable-methods (defmethod sb-mop:compute-applicable-methods
((gf nonumber-generic-function) arguments) ((gf nonumber-generic-function) arguments)
(nonumber-method-list (call-next-method))) (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) ((gf nonumber-generic-function) classes)
(nonumber-method-list (call-next-method))) (nonumber-method-list (call-next-method)))
@ -83,5 +79,6 @@
(:method :around ((x integer)) (:method :around ((x integer))
(coerce (call-next-method) 'vector))) (coerce (call-next-method) 'vector)))
(assert (equalp (list (testgf08 5.0) (testgf08 17)) (with-test (:name (:mop-3 2))
'((real) #(integer real)))) (assert (equalp (list (testgf08 5.0) (testgf08 17))
'((real) #(integer real)))))

45
tests/mop-30.impure.lisp
View file

@ -11,11 +11,6 @@
;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information. ;;;; more information.
(defpackage :mop-test-30
(:use :sb-pcl :sb-ext :cl :test-util))
(in-package :mop-test-30)
(defclass foo () (defclass foo ()
((bar :initarg :bar) ((bar :initarg :bar)
(quux :initarg :quux))) (quux :initarg :quux)))
@ -24,33 +19,31 @@
()) ())
(defun find-slot (name class) (defun find-slot (name class)
(let ((class (find-class class))) (let ((class (sb-pcl:ensure-class-finalized (find-class class))))
(unless (class-finalized-p class) (find name (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name)))
(finalize-inheritance class))
(find name (class-slots class) :key #'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 **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo)))
(defglobal **quux-loc** (slot-definition-location (find-slot 'quux '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))) (dep (eql (find-class 'foomagic)))
&key) &key)
(setf **bar-loc** (slot-definition-location (find-slot 'bar 'foo)) (setf **bar-loc** (sb-mop:slot-definition-location (find-slot 'bar 'foo))
**quux-loc** (slot-definition-location (find-slot 'quux 'foo)))) **quux-loc** (sb-mop:slot-definition-location (find-slot 'quux 'foo))))
(defun foo-bar/quux (foo) (defun foo-bar/quux (foo)
(declare (type foo foo)) (declare (type foo foo))
(values (standard-instance-access foo **bar-loc**) (values (sb-mop:standard-instance-access foo **bar-loc**)
(standard-instance-access foo **quux-loc**))) (sb-mop:standard-instance-access foo **quux-loc**)))
(defun swap-bar/quux (foo) (defun swap-bar/quux (foo)
(declare (type foo foo)) (declare (type foo foo))
(rotatef (standard-instance-access foo **bar-loc**) (rotatef (sb-mop:standard-instance-access foo **bar-loc**)
(standard-instance-access foo **quux-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)) (let ((bar (cons t t))
(quux (cons nil nil))) (quux (cons nil nil)))
(multiple-value-bind (bar? quux?) (multiple-value-bind (bar? quux?)
@ -58,7 +51,7 @@
(assert (eq bar bar?)) (assert (eq bar bar?))
(assert (eq quux quux?))))) (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)) (let* ((bar (cons t t))
(quux (cons nil nil)) (quux (cons nil nil))
(foo (foo
@ -76,7 +69,7 @@
((quux :initarg :quux) ((quux :initarg :quux)
(bar :initarg :bar))) (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)) (let ((bar (cons t t))
(quux (cons nil nil))) (quux (cons nil nil)))
(multiple-value-bind (bar? quux?) (multiple-value-bind (bar? quux?)
@ -84,9 +77,9 @@
(assert (eq bar bar?)) (assert (eq bar bar?))
(assert (eq quux quux?))))) (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))) (let ((bar (cons t t)))
(multiple-value-bind (bar? quux?) (multiple-value-bind (bar? quux?)
(foo-bar/quux (make-instance 'foo :bar bar)) (foo-bar/quux (make-instance 'foo :bar bar))
(assert (eq bar bar?)) (assert (eq bar bar?))
(assert (eq +slot-unbound+ quux?))))) (assert (eq sb-pcl:+slot-unbound+ quux?)))))

57
tests/mop-4.impure-cload.lisp
View file

@ -14,16 +14,11 @@
;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on ;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
;;; subclasses of generic functions. ;;; subclasses of generic functions.
(defpackage "MOP-4"
(:use "CL" "SB-MOP"))
(in-package "MOP-4")
;;; bug 343 ;;; bug 343
(defclass my-generic-function1 (standard-generic-function) () (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))) (let ((dfun (call-next-method)))
(lambda (&rest args) (lambda (&rest args)
(1+ (apply dfun args))))) (1+ (apply dfun args)))))
@ -33,14 +28,15 @@
(defmethod foo (x) (+ x x)) (defmethod foo (x) (+ x x))
(assert (= (foo 5) 11)) (with-test (:name (:mop-4 1))
(assert (= (foo 5) 11)))
;;; from PCL sources ;;; from PCL sources
(defclass my-generic-function-pcl1 (standard-generic-function) () (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))) (let ((std (call-next-method)))
(lambda (arg) (lambda (arg)
(print (list 'call-to-gf gf arg)) (print (list 'call-to-gf gf arg))
@ -51,20 +47,21 @@
(defmethod pcl1 ((x integer)) (1+ x)) (defmethod pcl1 ((x integer)) (1+ x))
(let ((output (with-output-to-string (*standard-output*) (with-test (:name (:mop-4 2))
(pcl1 3)))) (let ((output (with-output-to-string (*standard-output*)
(assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 MOP-4::PCL1 (1)> 3)" output))) (pcl1 3))))
(assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 COMMON-LISP-USER::PCL1 (1)> 3)" output))))
#| #|
(defclass my-generic-function-pcl2 (standard-generic-function) () (defclass my-generic-function-pcl2 (standard-generic-function) ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defmethod compute-discriminating-function ((gf my-generic-function-pcl2)) (defmethod sb-mop:compute-discriminating-function ((gf my-generic-function-pcl2))
(lambda (arg) (lambda (arg)
(cond (<some condition> (cond (<some condition>
<store some info in the generic function> <store some info in the generic function>
(set-funcallable-instance-function (sb-mop:set-funcallable-instance-function
gf gf
(compute-discriminating-function gf)) (sb-mop:compute-discriminating-function gf))
(funcall gf arg)) (funcall gf arg))
(t (t
<call-a-method-of-gf>)))) <call-a-method-of-gf>))))
@ -75,20 +72,22 @@
(progn (progn
(defclass traced-generic-function (standard-generic-function) (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-arguments* nil)
(defvar *last-traced-values* nil) (defvar *last-traced-values* nil)
(defmethod compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method)) (defmethod sb-mop:compute-discriminating-function ((gf traced-generic-function))
(name (generic-function-name gf))) (let ((orig-df (call-next-method)))
#'(lambda (&rest arguments) (lambda (&rest arguments)
(format *trace-output* "~%=> ~S arguments: ~:S" name arguments) (setq *last-traced-arguments* arguments)
(setq *last-traced-arguments* arguments) (let ((values (multiple-value-list (apply orig-df arguments))))
(let ((values (multiple-value-list (apply orig-df arguments)))) (setq *last-traced-values* values)
(format *trace-output* "~%<= ~S values: ~:S" name values) (values-list values)))))
(setq *last-traced-values* values) (defgeneric testgf15 (x)
(values-list values))))) (:generic-function-class traced-generic-function)
(defgeneric testgf15 (x) (:generic-function-class traced-generic-function) (:method ((x number))
(:method ((x number)) (values x (- x) (* x x) (/ x)))) (values x (- x) (* x x) (/ x)))))
(with-test (:name (:mop-4 3))
(testgf15 5) (testgf15 5)
(assert (equal (list *last-traced-arguments* *last-traced-values*) (assert (equal (list *last-traced-arguments* *last-traced-values*)
'((5) (5 -5 25 1/5))))) '((5) (5 -5 25 1/5)))))

13
tests/mop-5.impure-cload.lisp
View file

@ -14,7 +14,6 @@
;;; This file contains simple tests for ;;; This file contains simple tests for
;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs
;;; from Justin Dubs on comp.lang.lisp ;;; from Justin Dubs on comp.lang.lisp
(defclass fn () (defclass fn ()
() ()
@ -30,9 +29,10 @@
(setf *fn* fn) (setf *fn* fn)
(1+ x)))) (1+ x))))
(let ((fun (make-instance 'fn))) (with-test (:name (:mop-5 1))
(assert (= (funcall fun 42) 43)) (let ((fun (make-instance 'fn)))
(assert (eq *fn* fun))) (assert (= (funcall fun 42) 43))
(assert (eq *fn* fun))))
;;; from Tony Martinez sbcl-devel ;;; from Tony Martinez sbcl-devel
(defclass counter () (defclass counter ()
@ -45,9 +45,10 @@
instance instance
;; When run, this function doesn't print the instance, but (what ;; When run, this function doesn't print the instance, but (what
;; I think is) itself. ;; I think is) itself.
(lambda () (print instance))) (lambda () (print instance (make-broadcast-stream))))
instance)) instance))
(defparameter *counter* (make-counter :start 666)) (defparameter *counter* (make-counter :start 666))
(assert (eq (funcall *counter*) *counter*)) (with-test (:name (:mop-5 2))
(assert (eq (funcall *counter*) *counter*)))

32
tests/mop-6.impure-cload.lisp
View file

@ -14,17 +14,13 @@
;;; This file contains simple tests for COMPUTE-SLOTS :AROUND ;;; This file contains simple tests for COMPUTE-SLOTS :AROUND
;;; respecting the order requested by the primary method. ;;; 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 ;;; COMPUTE-SLOTS :AROUND respecting requested order
(defclass slot-rearrangement-class (standard-class) (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))) (reverse (call-next-method)))
(defmethod validate-superclass ((c slot-rearrangement-class) (defmethod sb-mop:validate-superclass ((c slot-rearrangement-class)
(s standard-class)) (s standard-class))
t) t)
(defclass rearranged-class () (defclass rearranged-class ()
((a :initarg :a :initform 1) ((a :initarg :a :initform 1)
@ -33,8 +29,9 @@
(with-test (:name (:compute-slots :standard-class :order)) (with-test (:name (:compute-slots :standard-class :order))
(let ((class (find-class 'rearranged-class))) (let ((class (find-class 'rearranged-class)))
(finalize-inheritance class) (sb-mop:finalize-inheritance class)
(assert (equal (mapcar #'slot-definition-name (class-slots class)) (assert (equal (mapcar #'sb-mop:slot-definition-name
(sb-mop:class-slots class))
'(b a))))) '(b a)))))
(with-test (:name (:compute-slots :standard-class :slots)) (with-test (:name (:compute-slots :standard-class :slots))
(let ((r (make-instance 'rearranged-class)) (let ((r (make-instance 'rearranged-class))
@ -44,12 +41,12 @@
(assert (eql (slot-value r2 'a) 3)) (assert (eql (slot-value r2 'a) 3))
(assert (eql (slot-value r2 'b) 4)))) (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))) (reverse (call-next-method)))
(defmethod validate-superclass ((c funcallable-slot-rearrangement-class) (defmethod sb-mop:validate-superclass ((c funcallable-slot-rearrangement-class)
(s funcallable-standard-class)) (s sb-mop:funcallable-standard-class))
t) t)
(defclass funcallable-rearranged-class () (defclass funcallable-rearranged-class ()
((a :initarg :a :initform 1) ((a :initarg :a :initform 1)
@ -58,9 +55,11 @@
(with-test (:name (:compute-slots :funcallable-standard-class :order)) (with-test (:name (:compute-slots :funcallable-standard-class :order))
(let ((class (find-class 'funcallable-rearranged-class))) (let ((class (find-class 'funcallable-rearranged-class)))
(finalize-inheritance class) (sb-mop:finalize-inheritance class)
(assert (equal (mapcar #'slot-definition-name (class-slots class)) (assert (equal (mapcar #'sb-mop:slot-definition-name
(sb-mop:class-slots class))
'(b a))))) '(b a)))))
(with-test (:name (:compute-slots :funcallable-standard-class :slots)) (with-test (:name (:compute-slots :funcallable-standard-class :slots))
(let ((r (make-instance 'funcallable-rearranged-class)) (let ((r (make-instance 'funcallable-rearranged-class))
(r2 (make-instance 'funcallable-rearranged-class :a 3 :b 4))) (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 r 'b) 2))
(assert (eql (slot-value r2 'a) 3)) (assert (eql (slot-value r2 'a) 3))
(assert (eql (slot-value r2 'b) 4)))) (assert (eql (slot-value r2 'b) 4))))
(with-test (:name (:compute-slots :funcallable-standard-clas :function)) (with-test (:name (:compute-slots :funcallable-standard-clas :function))
(let ((r (make-instance 'funcallable-rearranged-class))) (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))))) (assert (equal (funcall r 3) '("Hello, World!" 3)))))

16
tests/mop-7.impure-cload.lisp
View file

@ -14,22 +14,20 @@
;;; This file contains the simplest test that the multiple subclasses ;;; This file contains the simplest test that the multiple subclasses
;;; of generic function metacircle is gone. ;;; of generic function metacircle is gone.
(defpackage "MOP-7"
(:use "CL" "SB-MOP" "TEST-UTIL"))
(in-package "MOP-7")
(defclass g1 (standard-generic-function) (defclass g1 (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defclass g2 (standard-generic-function) (defclass g2 (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric f1 () (defgeneric f1 ()
(:generic-function-class g1)) (:generic-function-class g1))
(defgeneric f2 () (defgeneric f2 ()
(:generic-function-class g2)) (:generic-function-class g2))
(print #'f1) (with-test (:name :mop-7)
(print #'f2) (assert (plusp (length (with-output-to-string (stream)
(print #'f1 stream)))))
(assert (plusp (length (with-output-to-string (stream)
(print #'f2 stream))))))

35
tests/mop-8.impure-cload.lisp
View file

@ -13,36 +13,35 @@
;;; This file contains tests of UPDATE-DEPENDENT. ;;; This file contains tests of UPDATE-DEPENDENT.
(defpackage "MOP-8"
(:use "CL" "SB-MOP" "TEST-UTIL"))
(in-package "MOP-8")
(defclass dependent-history () (defclass dependent-history ()
((history :initarg :history :accessor 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) (history dependent-history)
&rest args) &rest args)
(push args (history history))) (push args (history history)))
(defmethod update-dependent ((class class) (defmethod sb-mop:update-dependent ((class class)
(history dependent-history) (history dependent-history)
&rest args) &rest args)
(push (cons class args) (history history))) (push (cons class args) (history history)))
(defvar *history* (make-instance 'dependent-history :history nil)) (defvar *history* (make-instance 'dependent-history :history nil))
(defgeneric upd1 (x)) (defgeneric upd1 (x))
(add-dependent #'upd1 *history*) (sb-mop:add-dependent #'upd1 *history*)
(defmethod upd1 ((x integer)) x) (defmethod upd1 ((x integer)) x)
(let ((last (car (history *history*))))
(assert (eq (car last) 'add-method)) (with-test (:name (:mop-8 1))
(assert (typep (cadr last) 'standard-method))) (let ((last (car (history *history*))))
(assert (eq (car last) 'add-method))
(assert (typep (cadr last) 'standard-method))))
(defclass foo () (defclass foo ()
()) ())
(add-dependent (find-class 'foo) *history*) (sb-mop:add-dependent (find-class 'foo) *history*)
(defclass foo () (defclass foo ()
((a :initarg :a))) ((a :initarg :a)))
(let ((last (car (history *history*))))
(assert (eq (car last) (find-class 'foo)))) (with-test (:name (:mop-8 2))
(let ((last (car (history *history*))))
(assert (eq (car last) (find-class 'foo)))))

42
tests/mop-9.impure-cload.lisp
View file

@ -14,14 +14,9 @@
;;; this file contains tests of (SETF CLASS-NAME) and (SETF ;;; this file contains tests of (SETF CLASS-NAME) and (SETF
;;; GENERIC-FUNCTION-NAME) ;;; GENERIC-FUNCTION-NAME)
(defpackage "MOP-9"
(:use "CL" "SB-MOP" "TEST-UTIL"))
(in-package "MOP-9")
(defclass metaclass/ri (standard-class) (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) t)
(defclass class/ri () (defclass class/ri ()
() ()
@ -29,6 +24,7 @@
(defvar *class/ri-args* nil) (defvar *class/ri-args* nil)
(defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs) (defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs)
(setf *class/ri-args* initargs)) (setf *class/ri-args* initargs))
(with-test (:name ((setf class-name) reinitialize-instance)) (with-test (:name ((setf class-name) reinitialize-instance))
(let ((class (find-class 'class/ri))) (let ((class (find-class 'class/ri)))
(setf (class-name class) 'name) (setf (class-name class) 'name)
@ -41,43 +37,47 @@
(defclass class/dependent () (defclass class/dependent ()
()) ())
(defvar *dependent* (make-instance 'dependent)) (defvar *dependent* (make-instance 'dependent))
(defmethod update-dependent ((object standard-class) (dependent dependent) (defmethod sb-mop:update-dependent ((object standard-class)
&rest args) (dependent dependent)
&rest args)
(setf (dependent-slot dependent) 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))) (let ((class (find-class 'class/dependent)))
(add-dependent class *dependent*) (sb-mop:add-dependent class *dependent*)
(setf (class-name class) 'name) (setf (class-name class) 'name)
(assert (equal (dependent-slot *dependent*) '(:name name))) (assert (equal (dependent-slot *dependent*) '(:name name)))
(remove-dependent class *dependent*) (sb-mop:remove-dependent class *dependent*)
(setf (class-name class) 'name) (setf (class-name class) 'name)
(assert (equal (dependent-slot *dependent*) '(:name name))))) (assert (equal (dependent-slot *dependent*) '(:name name)))))
(defclass gfc/ri (standard-generic-function) (defclass gfc/ri (standard-generic-function)
() ()
(:metaclass funcallable-standard-class)) (:metaclass sb-mop:funcallable-standard-class))
(defgeneric gf/ri () (defgeneric gf/ri ()
(:generic-function-class gfc/ri)) (:generic-function-class gfc/ri))
(defvar *gf/ri-args* nil) (defvar *gf/ri-args* nil)
(defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs) (defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs)
(setf *gf/ri-args* 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)) (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))) (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))))) (assert (equal *gf/ri-args* '(:name gf/ri)))))
(defgeneric gf/dependent ()) (defgeneric gf/dependent ())
(defmethod update-dependent ((object standard-generic-function) (defmethod sb-mop:update-dependent ((object standard-generic-function)
(dependent dependent) (dependent dependent)
&rest args) &rest args)
(setf (dependent-slot dependent) 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))) (let ((gf (find-class 'class/dependent)))
(add-dependent gf *dependent*) (sb-mop:add-dependent gf *dependent*)
(setf (generic-function-name gf) 'gf/name) (setf (sb-mop:generic-function-name gf) 'gf/name)
(assert (equal (dependent-slot *dependent*) '(:name gf/name))) (assert (equal (dependent-slot *dependent*) '(:name gf/name)))
(remove-dependent gf *dependent*) (sb-mop:remove-dependent gf *dependent*)
(setf (generic-function-name gf) 'gf/dependent) (setf (sb-mop:generic-function-name gf) 'gf/dependent)
(assert (equal (dependent-slot *dependent*) '(:name gf/name))))) (assert (equal (dependent-slot *dependent*) '(:name gf/name)))))