Forked from
cmucl / cmucl
2144 commits behind the upstream repository.
-
Raymond Toy authoredRaymond Toy authored
pcl.lisp 50.48 KiB
(defpackage "PCL-TESTS"
(:use "COMMON-LISP" "PCL" "LISP-UNIT"))
(in-package "PCL-TESTS")
(defmacro deftest (name form &rest values)
(let ((results (gensym "RESULTS-")))
`(define-test ,name
(:tag :pcl)
(let ((,results (multiple-value-list ,form)))
(assert-equalp ,results
',values)))))
(defmacro define-compiled-test (name form &rest values)
`(progn
(defun ,name () ,form)
(deftest ,name (,name) ,@values)))
;; ctor.lisp
(deftest plist-keys.0
(pcl::plist-keys '())
nil)
(deftest plist-keys.1
(pcl::plist-keys '(:a 1 :b 2))
(:a :b))
(deftest plist-keys.2
(multiple-value-bind (result condition)
(ignore-errors (pcl::plist-keys '(:a)))
(values result (typep condition 'condition)))
nil
t)
(deftest make-instance->constructor-call.0
(pcl::make-instance->constructor-call '(make-instance 'foo a x))
nil)
(deftest make-instance->constructor-call.1
(pcl::make-instance->constructor-call '(make-instance foo :a x))
nil)
(deftest make-instance->constructor-call.2
(pcl::make-instance->constructor-call '(make-instance 'foo x))
nil)
(deftest make-instance->constructor-call.4
(pcl::make-instance->constructor-call '(make-instance 1))
nil)
(deftest make-instance->constructor-call.5
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t ())
(deftest make-instance->constructor-call.6
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo :x 1 :y 2)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t ())
(deftest make-instance->constructor-call.7
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo :x x :y 2)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t (x))
(deftest make-instance->constructor-call.8
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo :x x :y y)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t (x y))
(deftest make-instance->constructor-call.9
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo :x x :y 1)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t (x))
(deftest make-instance->constructor-call.10
(let* ((form (pcl::make-instance->constructor-call
'(make-instance 'foo :x x :y 1 :z z)))
(call (car (last form))))
(values (eq (first call) 'funcall)
(cddr call)))
t (x z))
(deftest make-ctor.0
(let ((ctor (pcl::make-ctor '(pcl::ctor bar) 'bar '(:x 1 :y 2))))
(values (pcl::ctor-function-name ctor)
(pcl::ctor-class-name ctor)
(pcl::ctor-initargs ctor)))
(pcl::ctor bar)
bar
(:x 1 :y 2))
(defclass foo ()
((a :initarg :a :initform 1)
(b :initarg :b :initform 2)))
(defun call-generator (generator function-name class-name args)
(declare (ignore function-name))
(let* ((ctor
(pcl::make-ctor (list 'pcl::ctor class-name) class-name args))
(class (find-class class-name))
(proto (pcl::class-prototype class))
(ii (pcl::compute-applicable-methods
#'initialize-instance (list proto)))
(si (pcl::compute-applicable-methods
#'shared-initialize (list proto t))))
(setf (pcl::ctor-class ctor) class)
(if (eq generator #'pcl::fallback-generator)
(funcall generator ctor)
(funcall generator ctor ii si))))
(deftest fallback-generator.0
(let ((fn (call-generator #'pcl::fallback-generator
'make-foo 'foo '(:a 0 :b 1))))
(values (second fn)
(type-of (second (third fn)))
(nthcdr 2 (third fn))))
()
pcl::standard-class
(:a 0 :b 1))
(deftest fallback-generator.1
(let ((fn (call-generator #'pcl::fallback-generator
'make-foo 'foo '(:a 0))))
(values (second fn)
(first (third fn))
(type-of (second (third fn)))
(nthcdr 2 (third fn))))
()
make-instance
pcl::standard-class
(:a 0))
(deftest fallback-generator.2
(let ((fn (call-generator #'pcl::fallback-generator
'make-foo 'foo '())))
(values (second fn)
(type-of (second (third fn)))
(nthcdr 2 (third fn))))
()
pcl::standard-class
())
(deftest fallback-generator.3
(let ((fn (call-generator #'pcl::fallback-generator
'make-foo 'foo '(:a .p0.))))
(values (second fn)
(type-of (second (third fn)))
(nthcdr 2 (third fn))))
(.p0.)
pcl::standard-class
(:a .p0.))
(deftest fallback-generator.4
(let ((fn (call-generator #'pcl::fallback-generator
'make-foo 'foo '(:a a :b b))))
(values (second fn)
(type-of (second (third fn)))
(nthcdr 2 (third fn))))
(a b)
pcl::standard-class
(:a a :b b))
;;; These depend on the actual slot definition location computation,
;;; which may be different in my PCL than in the CVS PCL.
(deftest compute-initarg-locations.0
(let ((class (find-class 'foo)))
(pcl::compute-initarg-locations class '(:a :b)))
((:a (0 . t)) (:b (1 . t))))
(defclass foo2 (foo)
((c :initarg :a)))
(deftest compute-initarg-locations.1
(let ((class (find-class 'foo2)))
(pcl::compute-initarg-locations class '(:a :b)))
((:a (0 . t) (2 . t)) (:b (1 . t))))
(defclass foo3 (foo)
((c :initarg :a :allocation :class)))
;;;
;;; This test must be compiled for the case that PCL::+SLOT-UNBOUND+
;;; is a symbol macro calling PCL::MAKE-UNBOUND-MARKER, otherwise
;;; we'll get a complaint that C::%%PRIMITIVE is not defined.
;;;
(define-compiled-test compute-initarg-locations.2
(let ((class (find-class 'foo3)))
(subst 'unbound pcl::+slot-unbound+
(pcl::compute-initarg-locations class '(:a :b))))
((:a (0 . t) ((c . unbound) . t)) (:b (1 . t))))
(defclass foo4 ()
((a :initarg :a :initarg :both)
(b :initarg :b :initarg :both)))
(deftest compute-initarg-locations.3
(let ((class (find-class 'foo4)))
(pcl::compute-initarg-locations class '(:both :a :b)))
((:both (0 . t) (1 . t)) (:a) (:b)))
(deftest compute-initarg-locations.4
(let ((class (find-class 'foo4)))
(pcl::compute-initarg-locations class '(:a :both)))
((:a (0 . t)) (:both (1 . t))))
(deftest slot-init-forms.0
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo '(:a a :b b))))
(setf (pcl::ctor-class ctor) (find-class 'foo))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t a))
(setf (svref pcl::.slots. 1) (the t b)))
nil)
(deftest slot-init-forms.1
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo '(:a a))))
(setf (pcl::ctor-class ctor) (find-class 'foo))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t a))
(setf (svref pcl::.slots. 1) (the t '2)))
nil)
(defclass foo5 ()
((a :initarg :a :initform 0)
(b :initarg :b)))
(deftest slot-init-forms.2
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo5 '(:a a))))
(setf (pcl::ctor-class ctor) (find-class 'foo5))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t a))
(setf (svref pcl::.slots. 1) pcl::+slot-unbound+))
nil)
(defclass foo5a ()
((a :initarg :a :initform 0)
(b :initarg :b :initform 0)))
(deftest slot-init-forms.2a
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo5a '())))
(setf (pcl::ctor-class ctor) (find-class 'foo5a))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t '0))
(setf (svref pcl::.slots. 1) (the t '0)))
nil)
(defclass foo6 ()
((a :initarg :a :initform 0 :allocation :class)
(b :initarg :b)))
(deftest slot-init-forms.3
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo6 '(:a a))))
(setf (pcl::ctor-class ctor) (find-class 'foo6))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) pcl::+slot-unbound+)
(setf (cdr '(a . 0)) (the t a)))
nil)
(defun foo ()
(error "should never be called"))
(defclass foo7 ()
((a :initarg :a :initform (foo))
(b :initarg :b)))
(deftest slot-init-forms.4
(let* ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo7 '())))
(setf (pcl::ctor-class ctor) (find-class 'foo7))
(let ((form (pcl::slot-init-forms ctor nil)))
(destructuring-bind (let vars declare setf1 setf2) form
(declare (ignore let vars declare))
(values setf2 (second setf1) (first (third (third setf1)))
(functionp (second (third (third setf1))))))))
(setf (svref pcl::.slots. 1) pcl::+slot-unbound+)
(svref pcl::.slots. 0)
funcall
t)
(deftest slot-init-forms.5
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo '(:a '(foo)))))
(setf (pcl::ctor-class ctor) (find-class 'foo))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t '(foo)))
(setf (svref pcl::.slots. 1) (the t '2)))
nil)
(deftest slot-init-forms.6
(let ((ctor (pcl::make-ctor
(list 'pcl::ctor 'make-foo)
'foo '(:a 'x))))
(setf (pcl::ctor-class ctor) (find-class 'foo))
(pcl::slot-init-forms ctor nil))
(let ()
(declare (ignorable) (optimize (safety 3)))
(setf (svref pcl::.slots. 0) (the t 'x))
(setf (svref pcl::.slots. 1) (the t '2)))
nil)
(defmethod bar1 ((x integer))
(* x 2))
(defmethod bar2 ((x integer)) x)
(defmethod bar2 :around ((x integer)) x)
(deftest around-or-nonstandard-primary-method-p.0
(pcl::around-or-nonstandard-primary-method-p
(pcl::compute-applicable-methods #'bar2 (list 1)))
t)
(defmethod bar3 ((x integer)) x)
(defmethod bar3 :after ((x integer)) x)
(deftest around-or-nonstandard-primary-method-p.1
(pcl::around-or-nonstandard-primary-method-p
(pcl::compute-applicable-methods #'bar3 (list 1)))
nil)
(deftest optimizing-generator.0
(let ((fn (call-generator #'pcl::optimizing-generator
'make-foo 'foo '(:a 0 :b 1))))
(second fn))
())
(defun construct (class-name initargs &rest args)
(let* ((form (call-generator #'pcl::optimizing-generator
'some-function-name
class-name
initargs))
(fn (pcl::compile-lambda form)))
(apply fn args)))
(deftest optimizing-generator.1
(with-slots (a b) (construct 'foo '(:a 0 :b 1))
(values a b))
0 1)
(deftest optimizing-generator.2
(with-slots (a b) (construct 'foo '())
(values a b))
1 2)
(defclass g1 ()
((a :initform 0)
(b)))
(deftest optimizing-generator.3
(let ((instance (construct 'g1 '())))
(values (slot-value instance 'a)
(slot-boundp instance 'b)))
0 nil)
;; Test for default-initargs bug.
(defclass g2 ()
((a :initarg :aa)))
(defmethod initialize-instance :after ((f g2) &key aa)
(princ aa))
(defclass g3 (g2)
((b :initarg :b))
(:default-initargs :aa 5))
(deftest defaulting-initargs.1
(with-output-to-string (*standard-output*)
(make-instance 'g3))
"5")
;; defclass.lisp
(deftest defclass-subtypep.0
(progn
(defclass st0 () ())
(defclass st1 () ())
(subtypep 'st1 'st0))
nil t)
(deftest defclass-subtypep.1
(progn
(defclass st1 (st0) ())
(subtypep 'st1 'st0))
t t)
(deftest defclass-subtypep.2
(progn
(defclass st1 () ())
(subtypep 'st1 'st0))
nil t)
(defvar *instance* nil)
(defvar *update-instance-result* nil)
(defclass st2 ()
((a :initform 0 :accessor a)))
(defclass st3 ()
((b :initform 0 :accessor b)))
(deftest update-instance-for-redefined-class.0
(progn
(setq *instance* (make-instance 'st3))
t)
t)
(defmethod update-instance-for-redefined-class :after
((instance st3) added-slots discarded-slots property-list &rest initargs)
(setq *update-instance-result*
(list instance added-slots discarded-slots property-list initargs)))
(deftest update-instance-for-redefined-class.1
(progn
(defclass st3 (st2)
((b :initform 0 :accessor b)))
(values (slot-value *instance* 'b)
(eq *instance* (first *update-instance-result*))
(rest *update-instance-result*)))
0 t ((a) nil nil nil))
(deftest update-instance-for-redefined-class.2
(progn
(defclass st3 ()
((b :initform 0 :accessor b)))
(values (slot-value *instance* 'b)
(eq *instance* (first *update-instance-result*))
(rest *update-instance-result*)))
0 t (nil (a) (a 0) nil))
(deftest defclass-sxhash.0
(let ((i1 (make-instance 'st2))
(i2 (make-instance 'st2)))
(/= (sxhash i1) (sxhash i2)))
t)
(deftest generic-function-sxhash.0
(/= (sxhash #'allocate-instance)
(sxhash #'make-instance))
t)
(deftest defclass-redefinition.0
(multiple-value-bind (r c)
(ignore-errors
(defclass rd0 () ())
(defclass rd1 (rd0) ())
(defclass rd2 () ())
(defclass rd0 (rd2) ())
(make-instance 'rd1))
(values (not (null r)) (null c)))
t t)
;;; This failed to compile in an old version, that's why it's here.
(deftest defclass-inherited-class-slots.0
(multiple-value-bind (r c)
(ignore-errors
(defclass ics0 ()
((a :allocation :class :accessor ics0-a)))
(defclass ics1 (ics0)
())
(make-instance 'ics1))
(values (not (null r)) (null c)))
t t)
(defmacro define-defclass-syntax-test (name class-body &rest options)
`(deftest ,name
(multiple-value-bind (r c)
(ignore-errors
(defclass dc0 ()
,class-body ,@options))
(declare (ignore r))
(typep c 'error))
t))
;; CLHS: allocation should be :class or :instance
(define-defclass-syntax-test defclass.0 ((a :allocation :foo)))
;; Reader names should be symbols.
(define-defclass-syntax-test defclass.1 ((a :reader (setf a))))
;;; initarg names must be symbols.
(define-defclass-syntax-test defclass.2 ((a :initarg 1)))
;; Duplicate :default-initargs is an error.
(define-defclass-syntax-test defclass.3 ()
(:default-initargs :a 1)
(:default-initargs :b 2))
;; Duplicate :metaclass.
(define-defclass-syntax-test defclass.4 ()
(:metaclass pcl::funcallable-standard-class)
(:metaclass 1))
;; class option that is not implemented locally -> error
(define-defclass-syntax-test defclass.5 ()
(:foo t))
(deftest defclass-structure-class.0
(multiple-value-bind (r c)
(ignore-errors
(defclass dscl.0 ()
(a b)
(:metaclass pcl::structure-class))
t)
(values r (null c)))
t t)
(deftest defclass-structure-class.1
(multiple-value-bind (r c)
(ignore-errors
(make-instance 'dscl.0)
t)
(values r (null c)))
t t)
;;;
;;; The change of DFR1 from forward-referenced to standard class
;;; caused problems at some point, which were fixed by passing
;;; initargs to CHANGE-CLASS in ENSURE-CLASS-USING-CLASS.
;;;
(deftest defclass-forward-referenced-class.0
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr0 (dfr1 dfr2) ())
(defclass dfr1 (dfr3 dfr4) ())
t)
(values r (null c)))
t t)
(deftest defclass-forward-referenced-class.1
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr.c1 (dfr.c2) ())
(defclass dfr.c2 (dfr.c3) ())
(defclass dfr.c3 () ())
(make-instance 'dfr.c1)
t)
(values r (null c)))
t t)
;;;
;;; TYPEP and SUBTYPEP used to fail with forward-referenced/unfinalized
;;; classes.
;;;
(deftest defclass-types.0
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr5 (dfr6) ())
(typep t (find-class 'dfr6)))
(values r (null c)))
nil t)
(deftest defclass-types.2
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr7 (dfr8) ())
(multiple-value-list
(subtypep (find-class 'dfr7) (find-class 'dfr8))))
(values r (null c)))
(t t) t)
(deftest defclass-types.3
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr7 (dfr8) ())
(multiple-value-list
(subtypep (find-class 'dfr8) (find-class 'dfr7))))
(values r (null c)))
(nil t) t)
(deftest defclass-types.4
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr9 (dfr10) ())
(defclass dfr11 (dfr9 dfr12) ())
(append
(multiple-value-list
(subtypep (find-class 'dfr9) (find-class 'dfr10)))
(multiple-value-list
(subtypep (find-class 'dfr11) (find-class 'dfr10)))
(multiple-value-list
(subtypep (find-class 'dfr11) (find-class 'dfr9)))
(multiple-value-list
(subtypep (find-class 'dfr11) (find-class 'dfr12)))))
(values r (null c)))
(t t t t t t t t) t)
(deftest defclass-types.5
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr13 () ())
(defclass dfr14 (dfr15 dfr13) ())
(defclass dfr16 (dfr14 dfr17) ())
(append
(multiple-value-list
(subtypep (find-class 'dfr16) (find-class 'dfr14)))
(multiple-value-list
(subtypep (find-class 'dfr16) (find-class 'dfr17)))
(multiple-value-list
(subtypep (find-class 'dfr16) (find-class 'dfr15)))
(multiple-value-list
(subtypep (find-class 'dfr16) (find-class 'dfr13)))))
(values r (null c)))
(t t t t t t t t) t)
(deftest defclass-types.6
(multiple-value-bind (r c)
(ignore-errors
(defclass dfr20 (dfr21) ())
(defclass dfr21 (dfr22) ())
(append
(multiple-value-list
(subtypep (find-class 'dfr20) (find-class 'dfr21)))
(multiple-value-list
(subtypep (find-class 'dfr21) (find-class 'dfr22)))
(multiple-value-list
(subtypep (find-class 'dfr20) (find-class 'dfr22)))))
(values r (null c)))
(t t t t t t) t)
;; defmethod.lisp
(defmethod dm0 (x)
x)
(defmethod dm1 (x &rest y)
(list x y))
(defmethod dm2 (x &optional y)
(list x y))
(defmacro define-defmethod-test (name method qual lambda-list
&rest values)
`(deftest ,name
(multiple-value-bind (r c)
(ignore-errors
(defmethod ,method ,@(when qual `(,qual)) ,lambda-list
#+cmu (declare (optimize (ext:inhibit-warnings 3)))
nil))
(values (typep r 'method)
(typep c 'error)
(length (pcl:generic-function-methods #',method))))
,@values))
(defmacro define-defmethod-test-1 (name method qual lambda-list)
`(define-defmethod-test ,name ,method ,qual ,lambda-list nil t 1))
(define-defmethod-test-1 defmethod.0 dm0 nil (x y))
(define-defmethod-test-1 defmethod.1 dm0 nil (x &rest y))
(define-defmethod-test-1 defmethod.2 dm0 nil (x &key y))
(define-defmethod-test-1 defmethod.4 dm0 :before (x y))
(define-defmethod-test-1 defmethod.5 dm0 :before (x &rest y))
(define-defmethod-test-1 defmethod.6 dm0 :before (x &key y))
(define-defmethod-test defmethod.7 dm0 nil (x) t nil 1)
(define-defmethod-test-1 defmethod.10 dm1 nil (x y))
(define-defmethod-test-1 defmethod.11 dm1 nil (x))
(define-defmethod-test defmethod.12 dm1 nil (x &key y) t nil 1)
(define-defmethod-test defmethod.13 dm1 nil (x &key y z) t nil 1)
(define-defmethod-test defmethod.14 dm1 nil (x &rest y) t nil 1)
(define-defmethod-test-1 defmethod.20 dm2 nil (x))
(define-defmethod-test-1 defmethod.21 dm2 nil (x &optional y z))
(define-defmethod-test-1 defmethod.22 dm2 nil (x &key y))
;;;
;;; A forward-referenced class used as specializer signaled an
;;; error at some point.
;;;
(deftest defmethod-forwared-referenced.0
(multiple-value-bind (r c)
(ignore-errors
(defclass dm.3 () ())
(defclass dm.4 (dm.forward) ())
(defmethod dm.5 ((x dm.3)) x)
(defmethod dm.5 ((x dm.4)) x)
t)
(values r (null c)))
t t)
(deftest defmethod-forwared-referenced.1
(multiple-value-bind (r c)
(ignore-errors
(defclass dm.3 () ())
(defclass dm.4 (dm.forward) ())
(defmethod dm.5 ((x dm.3)) x)
(defmethod dm.5 ((x dm.4)) x)
(dm.5 (make-instance 'dm.3))
t)
(values r (null c)))
t t)
(deftest defmethod-metacircle.0
(multiple-value-bind (r c)
(ignore-errors
(defclass dmm.0 () ())
(defclass dmm.1 () ())
(defclass dmm.0+1 (dmm.0 dmm.1) ())
(defmethod dmm.0 ((x dmm.0) (y dmm.1)) 1)
(defmethod dmm.0 ((x dmm.1) (y dmm.0)) 2)
(dmm.0 (make-instance 'dmm.0+1) (make-instance 'dmm.0+1))
(defmethod dmm.0 ((x dmm.0+1) (y dmm.0+1)) 3)
(dmm.0 (make-instance 'dmm.0+1) (make-instance 'dmm.0+1)))
(values r (null c)))
3 t)
(deftest defmethod-setf-fdefinition.0
(multiple-value-bind (r c)
(ignore-errors
(defgeneric dsf.0 (x))
(defmethod dsf.0 ((x integer)) x)
(setf (fdefinition 'dsf.1) #'dsf.0)
(defmethod dsf.1 ((x string)) x)
(list (length (mop:generic-function-methods #'dsf.0))
(equal (mop:generic-function-methods #'dsf.1)
(mop:generic-function-methods #'dsf.0))))
(values r (null c)))
(2 t) t)
(deftest defmethod-setf-fdefinition.1
(multiple-value-bind (r c)
(ignore-errors
(defgeneric dsf.2 (x))
(defmethod dsf.2 ((x integer)) x)
(setf (fdefinition 'dsf.3) #'dsf.2)
(defmethod dsf.3 ((x integer)) x)
(list (length (mop:generic-function-methods #'dsf.2))
(equal (mop:generic-function-methods #'dsf.3)
(mop:generic-function-methods #'dsf.2))))
(values r (null c)))
(1 t) t)
;; find-method.lisp
(defmethod fm0 (x y)
(list x y))
(deftest find-method.0
(multiple-value-bind (r c)
(ignore-errors
(find-method #'fm0 nil (list t)))
(values r (typep c 'error)))
nil t)
(deftest find-method.1
(multiple-value-bind (r c)
(ignore-errors
(find-method #'fm0 nil (list t t)))
(values (typep r 'method) (typep c 'error)))
t nil)
;; inline-access.lisp
(defun test-walk (form test-function &optional env)
(let ((result nil))
(flet ((walk-function (form context env)
(declare (ignore context))
(when (and (consp form) (eq (car form) 'test))
(push (funcall test-function env) result))
form))
(walker:walk-form form env #'walk-function)
(nreverse result))))
(defmacro define-declaration-test (name declaration test &key values)
`(deftest ,name
(test-walk '(defun dummy () ,declaration (test))
(lambda (env) ,test))
,@values))
(define-declaration-test slot-declaration.0
(declare (ext:slots (slot-boundp xx)))
(pcl::slot-declaration env 'slot-boundp 'xx)
:values ((t)))
(define-declaration-test slot-declaration.1
(declare (ext:slots (inline xx)))
(pcl::slot-declaration env 'inline 'xx)
:values ((t)))
(define-declaration-test slot-declaration.2
(declare (ext:slots (inline (xx))))
(pcl::slot-declaration env 'inline 'xx)
:values ((t)))
(define-declaration-test slot-declaration.3
(declare (ext:slots (inline (xx a))))
(pcl::slot-declaration env 'inline 'xx 'a)
:values ((t)))
(define-declaration-test slot-declaration.4
(declare (ext:slots (inline (xx a))))
(pcl::slot-declaration env 'inline 'xx 'b)
:values ((nil)))
(define-declaration-test slot-declaration.5
(declare (ext:slots (inline (xx a) yy)))
(pcl::slot-declaration env 'inline 'yy)
:values ((t)))
(define-declaration-test slot-declaration.6
(declare (ext:slots (inline (xx a) (yy a))))
(pcl::slot-declaration env 'inline 'yy 'a)
:values ((t)))
(define-declaration-test slot-declaration.7
(declare (ext:slots (inline (xx a) (yy a))))
(pcl::slot-declaration env 'inline 'yy 'b)
:values ((nil)))
(deftest global-slot-declaration.0
(progn
(proclaim '(ext:slots (slot-boundp gsd)))
(not (null (pcl::slot-declaration nil 'slot-boundp 'gsd))))
t)
(deftest global-slot-declaration.1
(progn
(proclaim '(ext:slots (inline (gsd gsd-a))))
(not (null (pcl::slot-declaration nil 'inline 'gsd 'gsd-a))))
t)
(deftest auto-compile-declaration.0
(progn
(proclaim '(ext:auto-compile acd))
(pcl::auto-compile-p 'acd nil nil))
t)
(deftest auto-compile-declaration.1
(progn
(proclaim '(ext:auto-compile acd))
(pcl::auto-compile-p 'acd '(:around) '(t t)))
t)
(deftest auto-compile-declaration.2
(progn
(proclaim '(ext:not-auto-compile acd))
(proclaim '(ext:auto-compile (acd :around (t t))))
(values (pcl::auto-compile-p 'acd nil nil)
(pcl::auto-compile-p 'acd nil '(t t))
(pcl::auto-compile-p 'acd '(:around) '(t t))))
nil nil t)
(deftest auto-compile-declaration.3
(progn
(proclaim '(ext:auto-compile acd))
(proclaim '(ext:not-auto-compile (acd :around (t t))))
(values (pcl::auto-compile-p 'acd nil nil)
(pcl::auto-compile-p 'acd nil '(t t))
(pcl::auto-compile-p 'acd '(:around) '(t t))))
t t nil)
(deftest auto-compile-declaration.4
(progn
(proclaim '(ext:auto-compile))
(proclaim '(ext:not-auto-compile acd))
(values (pcl::auto-compile-p 'foo nil nil)
(pcl::auto-compile-p 'acd nil '(t t))
(pcl::auto-compile-p 'acd '(:around) '(t t))))
t nil nil)
(deftest auto-compile-declaration.5
(progn
(proclaim '(ext:auto-compile (setf acd)))
(pcl::auto-compile-p '(setf acd) '(:around) '(t t)))
t)
(declaim (ext:slots (inline sacc.0)))
(defclass sacc.0 ()
((a :initform 0 :initarg :a :accessor sacc.0-a)))
(defclass sacc.1 (sacc.0)
((b :initform 0 :initarg :b :accessor sacc.1-b)
(a :initform 0 :initarg :a :accessor sacc.0-a)))
(defmethod sacc.0.0 ((x sacc.0))
(slot-value x 'a))
(defmethod sacc.0.1 ((x sacc.0))
(sacc.0-a x))
(defmethod sacc.0.2 ((x sacc.0) nv)
(setf (slot-value x 'a) nv))
(defmethod sacc.0.3 ((x sacc.0) nv)
(setf (sacc.0-a x) nv))
(defun method-using-inline-access-p (class-name method-name qualifiers
specializers)
(let ((method (find-method (fdefinition method-name) qualifiers
specializers)))
(car (member class-name (pcl::plist-value method 'pcl::inline-access)
:test #'eq))))
(deftest inline-access-p.0
(and (method-using-inline-access-p 'sacc.0 'sacc.0.0 nil '(sacc.0))
(method-using-inline-access-p 'sacc.0 'sacc.0.1 nil '(sacc.0))
(method-using-inline-access-p 'sacc.0 'sacc.0.2 nil '(sacc.0 t))
(method-using-inline-access-p 'sacc.0 'sacc.0.3 nil '(sacc.0 t)))
sacc.0)
(deftest inline-access-p.1
(let ((methods (pcl::methods-using-inline-slot-access
(pcl::find-class 'sacc.0))))
(length methods))
4)
(deftest inline-access.0
(sacc.0.0 (make-instance 'sacc.0))
0)
(deftest inline-access.1
(let ((instance (make-instance 'sacc.0 :a 11)))
(values (sacc.0.0 instance)
(sacc.0.1 instance)))
11 11)
(deftest inline-access.2
(let ((instance (make-instance 'sacc.0 :a 11)))
(sacc.0.2 instance 10)
(slot-value instance 'a))
10)
(deftest inline-access.3
(let ((instance (make-instance 'sacc.0 :a 11)))
(sacc.0.3 instance 10)
(slot-value instance 'a))
10)
(defmacro define-warning-test (name (value) &body body)
`(deftest ,name
(let (warning)
(flet ((note-warning (c)
(declare (ignore c))
(setq warning t)
(muffle-warning)))
(handler-bind ((warning #'note-warning))
,@body)
warning))
,value))
(define-warning-test warn.0 (t) (warn "Test the test"))
(define-warning-test warn.1 (nil) nil)
(define-warning-test inline-warn.0 (nil)
(defclass sacc.0 ()
((a :initform 0 :initarg :a :accessor sacc.0-a))))
(define-warning-test inline-warn.1 (t)
(defclass sacc.0 ()
((a :initform 0 :initarg :a :accessor sacc.0-a)
(b :initform 0))))
(define-warning-test inline-warn.2 (t)
(progn
(defmethod inline-warn.2.method ((x sacc.1))
(declare (pcl::slots (inline sacc.1)))
(slot-value x 'b))
(defclass sacc.0 ()
((a :initform 0 :initarg :a :accessor sacc.0-a)))))
;; make-instance.lisp
;;; *********************
;;; MAKE-INSTANCE ******
;;; *********************
;;; Test forms in DEFTEST are not compiled, that is, a compiler
;;; macro won't be used in them. Also, we want tests using
;;; both the optimized constructor functions, and the default.
(eval-when (:top-level :compile :execute)
(defmacro define-mi-test (name form &key values opt-values)
(let ((optimized-name
(let ((*print-case* :upcase)
(*print-pretty* nil)
(*print-gensym* t))
(intern (format nil "~S.OPT" name))))
(optimized-values (or opt-values values)))
`(progn
(defun ,name ()
(macrolet ((mi (&rest args)
`(funcall #'make-instance ,@args)))
,form))
(defun ,optimized-name ()
(macrolet ((mi (&rest args)
`(make-instance ,@args)))
,form))
(deftest ,name (,name) ,@values)
(deftest ,optimized-name (,optimized-name)
,@optimized-values))))
)
(defclass m1 ()
((a :initarg :a :initarg :both :initform 1)
(b :initarg :b :initarg :both :initform 2)))
(define-mi-test make-instance.0
(with-slots (a b) (mi 'm1)
(values a b))
:values (1 2))
(define-mi-test make-instance.1
(with-slots (a b) (mi 'm1 :a 3)
(values a b))
:values (3 2))
(define-mi-test make-instance.2
(with-slots (a b) (mi 'm1 :b 3)
(values a b))
:values (1 3))
(define-mi-test make-instance.3
(with-slots (a b) (mi 'm1 :b 3 :a 4)
(values a b))
:values (4 3))
(define-mi-test make-instance.4
(with-slots (a b) (mi 'm1 :both (list nil))
(eq a b))
:values (t))
(defclass m2 (m1)
((a :initarg :a :initform 3)))
;;; Overriding slot in subclass -> new initform should be used.
(define-mi-test make-instance.5
(with-slots (a b) (mi 'm2)
(values a b))
:values (3 2))
;;; :BOTH should be inherited by slot A.
(define-mi-test make-instance.6
(with-slots (a b) (mi 'm2 :both 11)
(values a b))
:values (11 11))
(defclass m3 (m2)
((a :allocation :class :initform nil)))
;;; Class slot should not be overwritten when there's no initarg for it.
;;; Note that slot A overrides an instance slot A in M2 which itself
;;; overrides an instance slot in M1.
(define-mi-test make-instance.7
(progn
(setf (slot-value (pcl:class-prototype (pcl:find-class 'm3)) 'a) 1)
(with-slots (a b) (mi 'm3)
(values a b)))
:values (1 2))
;;; Class slot should be written when there is an initarg for it.
(define-mi-test make-instance.8
(with-slots (a) (mi 'm3 :a 11)
a)
:values (11))
;;; Class slot should be written when there is an initarg for it.
(define-mi-test make-instance.9
(with-slots (a b) (mi 'm3 :both 12)
(values a b))
:values (12 12))
(define-mi-test make-instance.10
(with-slots (a b) (mi 'm3 :both 13)
(values a b))
:values (13 13))
;;; Invalid initialization arguments
(define-mi-test make-instance.11
(multiple-value-bind (r c)
(ignore-errors (mi 'm3 :hansi t))
(values r (typep c 'condition)))
:values (nil t))
(define-mi-test make-instance.12
(multiple-value-bind (r c)
(ignore-errors (mi 'm3 :hansi t :allow-other-keys t))
(values (slot-value r 'b) (typep c 'condition)))
:values (2 nil))
;;; Default initargs
(defclass m5 (m1)
()
(:default-initargs :a 'a :b 'b))
(define-mi-test make-instance.13
(with-slots (a b) (mi 'm5)
(values a b))
:values (a b))
(defclass m6 (m5)
()
(:default-initargs :a 'c))
(define-mi-test make-instance.14
(with-slots (a b) (mi 'm6)
(values a b))
:values (c b))
(defclass m7 (m6)
((a :allocation :class :initform nil)))
(define-mi-test make-instance.15
(with-slots (a b) (mi 'm7)
(values a b))
:values (c b))
;;; Lexical environment.
(let ((x 0))
(defclass m8 ()
((a :initform (incf x))))
(defun reset-counter ()
(setq x 0)))
(define-mi-test make-instance.16
(progn
(reset-counter)
(loop for i below 5
collect (slot-value (mi 'm8) 'a)))
:values ((1 2 3 4 5)))
(defclass m9 ()
((a :initarg :a)
(b :initarg :b)
(c :initarg :c)
(d :initarg :d)))
(define-mi-test make-instance.17
(let* ((x 'x)
(instance (mi 'm9 :a () :b x :c '(baz bar foo)
:d (lambda () ()))))
(with-slots (a b c) instance
(values a b c)))
:values (nil x (baz bar foo)))
;; After and before methods.
(defclass m10 ()
((a :initform 0 :initarg :a)
(b :initarg :b)
(c :initform 2 :initarg :c))
(:default-initargs :c 1))
(defvar *result* ())
(defmethod initialize-instance :before ((x m10) &rest args)
(declare (ignore args))
(push (list 'm10 :before (slot-boundp x 'a)
(slot-boundp x 'b) (slot-boundp x 'c))
*result*))
(define-mi-test make-instance.18
(progn
(setq *result* ())
(with-slots (a b c) (mi 'm10 :b 42)
(values *result* a b c)))
:values (((m10 :before nil nil nil)) 0 42 1))
(defclass m11 (m10)
()
(:default-initargs :c 11))
(defmethod initialize-instance :before ((x m11) &rest args)
(declare (ignore args))
(push (list 'm11 :before (slot-boundp x 'a)
(slot-boundp x 'b)
(slot-boundp x 'c))
*result*))
(defmethod initialize-instance :after ((x m11) &rest args)
(declare (ignore args))
(push (list 'm11 :after (slot-boundp x 'a)
(slot-boundp x 'b)
(slot-boundp x 'c))
*result*))
(define-mi-test make-instance.19
(progn
(setq *result* ())
(with-slots (a b c) (mi 'm11 :b 42)
(values *result* a b c)))
:values (((m11 :after t t t)
(m10 :before nil nil nil)
(m11 :before nil nil nil))
0 42 11))
(defclass m12 (m10)
()
(:default-initargs :c 13))
(defmethod initialize-instance :before ((x m12) &rest args)
(declare (ignore args))
(setf (slot-value x 'a) 77))
(define-mi-test make-instance.20
(progn
(setq *result* ())
(with-slots (a b c) (mi 'm12 :b 42)
(values *result* a b c)))
:values (((m10 :before t nil nil))
77 42 13))
(define-mi-test make-instance.21
(progn
(setq *result* ())
(with-slots (a b c) (mi 'm12 :b 41 :c 67)
(values *result* a b c)))
:values (((m10 :before t nil nil))
77 41 67))
;;; :ALLOW-OTHER-KEYS
(define-mi-test make-instance.22
(let ((obj (ignore-errors (mi 'm12 :b 41 :allow-other-keys t))))
(when obj
(with-slots (a b c) obj
(values a b c))))
:values (77 41 13))
(define-mi-test make-instance.23
(let ((obj (ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys t))))
(when obj
(with-slots (a b c) obj
(values a b c))))
:values (77 41 13))
(define-mi-test make-instance.24
(multiple-value-bind (r c)
(ignore-errors (mi 'm12 :b 41 :x 11))
(values r (typep c 'condition)))
:values (nil t))
(define-mi-test make-instance.25
(multiple-value-bind (r c)
(ignore-errors (mi 'm12 :b 41 :x 11 :allow-other-keys nil))
(values r (typep c 'condition)))
:values (nil t))
;; Create a constructor, than rename the package of the class it was
;; defined for.
(defpackage "%CTOR"
(:use "COMMON-LISP"))
(in-package "%CTOR")
(defclass p1 ()
((a :initform 0)))
(defun f1 ()
(make-instance 'p1))
(in-package "PCL-TESTS")
(define-mi-test make-instance.26
(progn
(rename-package "%CTOR" "%CTOR2")
(let* ((f (find-symbol "F1" "%CTOR2"))
(a (find-symbol "A" "%CTOR2"))
(i (funcall f)))
(prog1
(slot-value i a)
(rename-package "%CTOR2" "%CTOR"))))
:values (0))
(defclass stru.0 ()
((a :initarg :a :accessor a-accessor)
(b :initform 2 :reader b-reader))
(:metaclass structure-class))
(defclass stru.1 (stru.0)
((c :initarg :c :writer c-writer :accessor c-accessor))
(:metaclass structure-class))
(define-mi-test make-instance.27
(with-slots (a b) (mi 'stru.0)
(values a b))
:values (nil 2))
(define-mi-test make-instance.28
(with-slots (a b) (mi 'stru.0 :a 1)
(values a b))
:values (1 2))
(define-mi-test make-instance.29
(with-slots (a b c) (mi 'stru.1)
(values a b c))
:values (nil 2 nil))
(define-mi-test make-instance.30
(with-slots (a b c) (mi 'stru.1 :a 1 :c 3)
(values a b c))
:values (1 2 3))
(deftest make-instance.31
(let ((*m30* nil))
(declare (special *m30*))
(defclass m30 () ())
(defclass m31 (m30) ())
(defun f () (make-instance 'm31))
(compile 'f)
(f)
(defmethod initialize-instance :before ((x m30) &rest args)
(declare (ignore args))
(declare (special *m30*))
(setq *m30* t))
(f)
*m30*)
t)
(defclass mi13 ()
((s1 :initarg :s1a :initarg :s1b :reader s1)
(s2 :initarg :s2 :reader s2)))
(define-mi-test make-instance.32
(with-slots (s1 s2)
(make-instance 'mi13 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z)
(values s1 s2))
:values (b a))
;; (setf find-class), class redefinitions
;; method-combination.lisp
;;; ********************************
;;; Method Group Specifiers ********
;;; ********************************
(define-method-combination mgs0 (x)
((primary () :required t))
(progn
x
`(call-method ,(first primary))))
;;; This should simply not signal an error as it did in 18d.
(deftest method-group-specifiers.0
(multiple-value-bind (r c)
(ignore-errors
(defgeneric mgs0 (obj)
(:method-combination mgs0 1))
(defmethod mgs0 (obj)
obj)
(mgs0 1))
(values r c))
1 nil)
;;; **************************
;;; :generic-function *******
;;; **************************
;;; *******************
;;; :arguments *******
;;; *******************
(defvar *result* nil)
(defvar *mca0-value*
(define-method-combination mca0 ()
((methods *))
(:arguments x y &optional opt)
(:generic-function gf)
`(progn
(setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,opt))
(call-method ,(first methods)))))
(defgeneric mca0 (a)
(:method-combination mca0)
(:method (a) a))
(defgeneric mca1 (a b)
(:method-combination mca0)
(:method (a b) (list a b)))
(defgeneric mca2 (a &optional b)
(:method-combination mca0)
(:method (a &optional b) (list a b)))
(defgeneric mca3 (&optional b)
(:method-combination mca0)
(:method (&optional b) b))
(deftest method-combination.0
*mca0-value*
mca0)
(deftest method-combination-arguments.0
(multiple-value-bind (r c)
(ignore-errors (mca0 1) *result*)
(values r (null c)))
(mca0 1 nil nil) t)
(deftest method-combination-arguments.1
(multiple-value-bind (r c)
(ignore-errors (mca1 1 2) *result*)
(values r (null c)))
(mca1 1 2 nil) t)
(deftest method-combination-arguments.2
(multiple-value-bind (r c)
(ignore-errors (mca2 1) *result*)
(values r (null c)))
(mca2 1 nil nil) t)
(deftest method-combination-arguments.3
(multiple-value-bind (r c)
(ignore-errors (mca2 1 2) *result*)
(values r (null c)))
(mca2 1 nil 2) t)
(deftest method-combination-arguments.4
(multiple-value-bind (r c)
(ignore-errors (mca3) *result*)
(values r (null c)))
(mca3 nil nil nil) t)
(deftest method-combination-arguments.5
(multiple-value-bind (r c)
(ignore-errors (mca3 1) *result*)
(values r (null c)))
(mca3 nil nil 1) t)
(define-method-combination mca1 ()
((methods *))
(:arguments x y &rest r)
(:generic-function gf)
`(progn
(setq *result* (list (pcl:generic-function-name ,gf) ,x ,y ,r))
(call-method ,(first methods))))
(defgeneric mca1.0 (&rest b)
(:method-combination mca1)
(:method (&rest b) b))
(deftest method-combination-arguments.6
(multiple-value-bind (r c)
(ignore-errors (mca1.0) *result*)
(values r (null c)))
(mca1.0 nil nil nil) t)
(deftest method-combination-arguments.7
(multiple-value-bind (r c)
(ignore-errors (mca1.0 1) *result*)
(values r (null c)))
(mca1.0 nil nil (1)) t)
(define-method-combination mca2 ()
((methods *))
(:arguments &key a b)
(:generic-function gf)
`(progn
(setq *result* (list (pcl:generic-function-name ,gf) ,a ,b))
(call-method ,(first methods))))
(defgeneric mca2.0 (&key a b)
(:method-combination mca2)
(:method (&key (a 0) (b 1)) (list a b)))
(deftest method-combination-arguments.8
(multiple-value-bind (r c)
(ignore-errors (mca2.0) *result*)
(values r (null c)))
(mca2.0 nil nil) t)
(deftest method-combination-arguments.9
(multiple-value-bind (r c)
(ignore-errors (mca2.0 :a 1) *result*)
(values r (null c)))
(mca2.0 1 nil) t)
(deftest method-combination-arguments.10
(multiple-value-bind (r c)
(ignore-errors (mca2.0 :b 1) *result*)
(values r (null c)))
(mca2.0 nil 1) t)
(deftest method-combination-arguments.11
(multiple-value-bind (r c)
(ignore-errors (mca2.0 :b 1 :a 0) *result*)
(values r (null c)))
(mca2.0 0 1) t)
(define-method-combination mca3 ()
((methods *))
(:arguments &whole w x &key k)
(:generic-function gf)
`(progn
(setq *result* (list (pcl:generic-function-name ,gf) ,w ,x ,k))
(call-method ,(first methods))))
(defgeneric mca3.0 (x &key k)
(:method-combination mca3)
(:method (x &key k) (list x k)))
(deftest method-combination-arguments.12
(multiple-value-bind (r c)
(ignore-errors (mca3.0 1) *result*)
(values r (null c)))
(mca3.0 (1) 1 nil) t)
(deftest method-combination-arguments.13
(multiple-value-bind (r c)
(ignore-errors (mca3.0 1 :k 2) *result*)
(values r (null c)))
(mca3.0 (1 :k 2) 1 2) t)
;; methods.lisp
;;; Old PCL has a bug wrt rebinding a parameter around
;;; CALL-NEXT-METHOD.
(deftest methods.0
(progn
(defclass mt0 ()
())
(defmethod mt0 ((m mt0) x)
x)
(defmethod mt0 :around ((m mt0) x)
(let ((x (1+ x)))
#+cmu (declare (optimize (ext:inhibit-warnings 3)))
(call-next-method)))
(mt0 (make-instance 'mt0) 42))
42)
;; pv.lisp
;;;**************************
;;; With Optimization ******
;;; *************************
#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq pcl::*optimize-gf-calls-p* t))
(defclass pv0 ()
((a :accessor pv0-a :initform 0)))
(defmethod pv0.0 ((x pv0))
1)
(defmethod pv0.1 ((x pv0) &rest r)
(car r))
(defmethod pv0.2 ((x pv0) &key k)
k)
(defmethod pv0.3 ((x pv0) &optional o)
o)
(defmethod pv0.4 ((x pv0) (y pv0))
1)
(defmethod call-pv0 ((x pv0))
(list (pv0.0 x)
(pv0.1 x 2)
(pv0.2 x :k 3) (pv0.2 x)
(pv0.3 x 1) (pv0.3 x)
(pv0.4 x x)))
(deftest pv-gf-call-optimized.0
(ignore-errors (call-pv0 (make-instance 'pv0)))
(1 2 3 nil 1 nil 1))
(defclass pv0.1 (pv0) ())
(defmethod pv0.0 ((x pv0.1))
(call-next-method))
(defmethod pv0.1 ((x pv0.1) &rest r)
(declare (ignorable r))
(call-next-method))
(defmethod pv0.2 ((x pv0.1) &key k)
(declare (ignorable k))
(call-next-method))
(defmethod pv0.3 ((x pv0.1) &optional o)
(declare (ignorable o))
(call-next-method))
(defmethod pv0.4 ((x pv0.1) (y pv0.1))
(call-next-method))
(defmethod call-pv0 ((x pv0.1))
(call-next-method))
(deftest pv-gf-call-optimized.1
(ignore-errors (call-pv0 (make-instance 'pv0.1)))
(1 2 3 nil 1 nil 1))
(deftest pv-gf-call-optimized.2
(ignore-errors (call-pv0 (make-instance 'pv0)))
(1 2 3 nil 1 nil 1))
;;;*****************************
;;; Without Optimization ******
;;; ****************************
#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq pcl::*optimize-gf-calls-p* nil))
(defclass pv1 ()
((a :accessor pv1-a :initform 0)))
(defmethod pv1.0 ((x pv1))
1)
(defmethod pv1.1 ((x pv1) &rest r)
(car r))
(defmethod pv1.2 ((x pv1) &key k)
k)
(defmethod pv1.3 ((x pv1) &optional o)
o)
(defmethod call-pv1 ((x pv1))
(list (pv1.0 x)
(pv1.1 x 2)
(pv1.2 x :k 3) (pv1.2 x)
(pv1.3 x 1) (pv1.3 x)))
(deftest pv-gf-call.1
(call-pv1 (make-instance 'pv1))
(1 2 3 nil 1 nil))
;; reinitialize-instance.lisp
(deftest reinitialize-instance.0
(multiple-value-bind (r c)
(ignore-errors
(defclass ri0 () ((a :initarg :a)))
(reinitialize-instance (make-instance 'ri0) :a 1))
(values (null r) (typep c 'error)))
nil nil)
(deftest reinitialize-instance.1
(multiple-value-bind (r c)
(ignore-errors
(defclass ri1 () ())
(reinitialize-instance (make-instance 'ri1) :a 1))
(values (null r) (typep c 'error)))
t t)
(deftest reinitialize-instance.2
(multiple-value-bind (r c)
(ignore-errors
(defclass ri2 () ())
(defmethod shared-initialize ((x ri2) slots &rest initargs &key a)
(declare (ignore slots initargs a)))
(reinitialize-instance (make-instance 'ri2) :a 1))
(values (null r) (typep c 'error)))
nil nil)
(deftest reinitialize-instance.3
(multiple-value-bind (r c)
(ignore-errors
(defclass ri3 () ())
(defmethod reinitialize-instance :after ((x ri3) &rest initargs
&key a)
(declare (ignore initargs a)))
(reinitialize-instance (make-instance 'ri3) :a 1))
(values (null r) (typep c 'error)))
nil nil)
(deftest reinitialize-instance.4
(multiple-value-bind (r c)
(ignore-errors
(defclass ri4 () ())
(defmethod reinitialize-instance :after ((x ri4) &rest initargs
&key a &allow-other-keys)
(declare (ignore initargs a)))
(reinitialize-instance (make-instance 'ri4) :a 1 :b 2))
(values (null r) (typep c 'error)))
nil nil)
(deftest reinitialize-instance.5
(multiple-value-bind (r c)
(ignore-errors
(defclass ri5 () ())
(reinitialize-instance (make-instance 'ri4)
:a 1 :b 2 :allow-other-keys t))
(values (null r) (typep c 'error)))
nil nil)
;; slot-accessors.lisp
(defclass sa0 ()
((a :accessor a-of :initarg :a)))
(deftest slot-accessor.0
(let ((instance (make-instance 'sa0 :a 0)))
(a-of instance))
0)
(deftest slot-accessor.1
(let ((instance (make-instance 'sa0)))
(setf (a-of instance) 1)
(a-of instance))
1)
(defmethod sa0.0 ((x sa0))
(a-of x))
(deftest slot-accessor.2
(let ((instance (make-instance 'sa0)))
(setf (a-of instance) 2)
(sa0.0 instance))
2)
;;; Redefining the class should update the PV table cache of
;;; method SA0.0 so that is reads the right slot.
(deftest slot-accessor.3
(progn
(defclass sa0 ()
((c :accessor c-of)
(a :accessor a-of :initarg :a)
(b :accessor b-of)))
(sa0.0 (make-instance 'sa0 :a 42)))
42)
(defclass sa1 (sa0)
((b :accessor a-of :initarg :b)))
(deftest slot-accessor.4
(let ((instance (make-instance 'sa1 :b 0)))
(sa0.0 instance))
0)
(defclass sa2 (sa0)
())
(defmethod (setf a-of) (new-value (obj sa2))
(setf (slot-value obj 'a) (* 2 new-value)))
(defmethod sa2.0 ((obj sa2))
(setf (a-of obj) 42))
(deftest slot-accessor.5
(let ((instance (make-instance 'sa2)))
(sa2.0 instance))
84)
(defclass sa3 ()
())
(defmethod (setf foo-of) (n (obj sa3))
n)
(defmethod sa3.0 ((obj sa3))
(setf (foo-of obj) 11))
(deftest slot-accessor.6
(let ((instance (make-instance 'sa3)))
(sa3.0 instance))
11)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass sa4 ()
((a :initform 0 :accessor sa4-a))))
(defmethod sa4.0 ((x sa4))
(sa4-a x))
(deftest slot-accessor.7
(sa4.0 (make-instance 'sa4))
0)
(deftest slot-accessor.8
(progn
(defun sa4-a (x)
(declare (ignore x))
11)
(prog1
(sa4.0 (make-instance 'sa4))
(fmakunbound 'sa4-a)))
11)
;; slot-boundp.lisp
(defclass sbp0 ()
((a :initarg :a :initform 0)
(b :initarg :b)
(c :allocation :class)))
(defmethod sbp0.0 ((x sbp0) slot)
(null (slot-boundp x slot)))
(deftest slot-boundp.0
(null (slot-boundp (make-instance 'sbp0) 'a))
nil)
(define-compiled-test slot-boundp.1
(null (slot-boundp (make-instance 'sbp0) 'a))
nil)
(deftest slot-boundp.2
(null (slot-boundp (make-instance 'sbp0) 'b))
t)
(define-compiled-test slot-boundp.3
(multiple-value-bind (r c)
(ignore-errors (slot-boundp (make-instance 'sbp0) 'b))
(values (null r) c))
t nil)
(deftest slot-boundp.4
(null (slot-boundp (make-instance 'sbp0) 'c))
t)
(define-compiled-test slot-boundp.5
(null (slot-boundp (make-instance 'sbp0) 'c))
t)
(deftest slot-boundp.6
(sbp0.0 (make-instance 'sbp0) 'b)
t)
(deftest slot-boundp.7
(sbp0.0 (make-instance 'sbp0 :a 2) 'a)
nil)
;; slot-missing.lisp
;;; in method (pv table optimization)
;;; in compiled defun
;;; uncompiled.
(defmacro define-sm-test (name (instance class) access &rest values)
(let* ((*print-case* :upcase)
(*print-pretty* nil)
(*print-gensym* t)
(method-name (intern (format nil "~S.METHOD" name)))
(method-test (intern (format nil "~S.METHOD-TEST" name)))
(compiled-test (intern (format nil "~S.COMPILED" name))))
`(progn
(defmethod ,method-name ((,instance ,class))
,access)
(deftest ,name
(multiple-value-bind (r c)
(let ((,instance (make-instance ',class)))
(ignore-errors ,access))
(values r (typep c 'condition)))
,@values)
(deftest ,method-test
(multiple-value-bind (r c)
(let ((,instance (make-instance ',class)))
(ignore-errors (,method-name ,instance)))
(values r (typep c 'condition)))
,@values)
(define-compiled-test ,compiled-test
(multiple-value-bind (r c)
(let ((,instance (make-instance ',class)))
(ignore-errors ,access))
(values r (typep c 'condition)))
,@values))))
(defclass sm0 () ())
(define-sm-test slot-missing.0 (instance sm0)
(slot-value instance 'a)
nil t)
(define-sm-test slot-missing.1 (instance sm0)
(setf (slot-value instance 'a) 1)
nil t)
(define-sm-test slot-missing.2 (instance sm0)
(slot-boundp instance 'a)
nil t)
(defclass sm1 () ())
(defvar *sm-result* nil)
(defmethod slot-missing (class (obj sm1) slot-name operation
&optional new-value)
(setq *sm-result* (list slot-name operation new-value)))
(define-sm-test slot-missing.3 (instance sm1)
(progn
(slot-value instance 'a)
*sm-result*)
(a slot-value nil) nil)
(define-sm-test slot-missing.4 (instance sm1)
(progn
(setf (slot-value instance 'a) 1)
*sm-result*)
(a setf 1) nil)
(define-sm-test slot-missing.5 (instance sm1)
(progn
(slot-boundp instance 'a)
*sm-result*)
(a slot-boundp nil) nil)
;; slot-type.lisp
#+gerds-pcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq pcl::*use-slot-types-p* t))
;;; Check that we check slot types, at least sometimes.
(defclass stype ()
((a :type fixnum :initform 0 :initarg :a)))
(defmethod stype.0 ((obj stype))
(slot-value obj 'a))
(defmethod stype.1 ((obj stype) value)
(setf (slot-value obj 'a) value))
(deftest slot-type.0
(multiple-value-bind (r c)
(ignore-errors
(stype.0 (make-instance 'stype :a 1)))
(values r (null c)))
1 t)
(deftest slot-type.1
(multiple-value-bind (r c)
(ignore-errors
(stype.0 (make-instance 'stype :a 1.0)))
(values r (typep c 'error)))
nil t)
(deftest slot-type.2
(multiple-value-bind (r c)
(ignore-errors
(stype.1 (make-instance 'stype) 1))
(values r (typep c 'error)))
1 nil)
(deftest slot-type.3
(multiple-value-bind (r c)
(ignore-errors
(stype.1 (make-instance 'stype) 1.0))
(values r (typep c 'error)))
nil t)
(deftest slot-type.4
(multiple-value-bind (r c)
(ignore-errors
(setf (slot-value (make-instance 'stype) 'a) "string"))
(values r (typep c 'error)))
nil t)
;; slot-value.lisp
(defclass sv0 ()
((a :allocation :class :initarg :a :initform 0)))
(defun sv0.0 ()
(let* ((x (random 10))
(obj (make-instance 'sv0 :a x)))
(eql x (slot-value obj (identity 'a)))))
;;; In previous versions of PCL (18d for example), the above
;;; slot-value fails when the class is redefined.
(deftest slot-value.0
(sv0.0)
t)
(deftest slot-value.1
(progn
(defclass sv0 ()
((a :allocation :class :initarg :a :initform 0)))
t)
t)
(deftest slot-value.2
(sv0.0)
t)