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