[git] CMU Common Lisp branch master updated. snapshot-2014-03-11-g9706477
Raymond Toy
rtoy at common-lisp.net
Sat Mar 15 05:15:41 UTC 2014
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 9706477f9d5feebfbc8f7de353bab36b50b260bc (commit)
via 83231787bceca6ffcbb8d06cd25b508fddfc317a (commit)
via 3feda4afbf396e9360851eb8812f5e812c80bdd2 (commit)
via 7751a9115790d3418afef4d2fe00f7d0b14fe7f0 (commit)
via be4f68c14bf16e8f653ba374188593df1ed732dc (commit)
via e4fcbef0308ca88f877a3b36d22b9bd00e1f78a9 (commit)
from 337cf55d9e648a78354e82c74d79618f18f5840f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 9706477f9d5feebfbc8f7de353bab36b50b260bc
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Fri Mar 14 22:12:10 2014 -0700
Add comments. Note that this can't be run from a build; you have to
install it first.
diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index c77fec5..1502e89 100644
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -3,13 +3,20 @@
;;;; Main script to run all of the tests in the tests directory.
;;;; It is intended to be run using something like
;;;;
-;;;; lisp -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'
+;;;; lisp -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'
+;;;;
+;;;; Note that you cannot run these tests from a binary created during
+;;;; a build process. You must run
+;;;;
+;;;; bin/make-dist.sh -I inst-dir build-dir
+;;;;
+;;;; to install everything in some temporary directory. This is needed
+;;;; because the simple-streams test needs to load simple-streams, and
+;;;; the build directory isn't set up for that.
;;;;
;;;; The exit code indicates whether there were any test failures. A
;;;; non-zero code indicates a failure of some sort.
;;;;
-;;;; It is assumed that either asdf or quicklisp is set up
-;;;; appropriately so that lisp-unit can be automatically loaded
(defpackage :cmucl-test-runner
(:use :cl)
commit 83231787bceca6ffcbb8d06cd25b508fddfc317a
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Fri Mar 14 22:02:53 2014 -0700
Remove the tests and just use mk-defsystem to load the separate PCL
test files.
diff --git a/tests/pcl.lisp b/tests/pcl.lisp
index c49e279..dc59445 100644
--- a/tests/pcl.lisp
+++ b/tests/pcl.lisp
@@ -1,13 +1,11 @@
;;; Tests for PCL, taken from src/pcl/rt.
-;;;
-;;; It's clear that the tests used mk defsystem to load the tests, but
-;;; it's not clear if the tests were compiled or not before running.
(defpackage "PCL-TESTS"
(:use "COMMON-LISP" "PCL" "LISP-UNIT"))
(in-package "PCL-TESTS")
+;; Simple macro converting RT's DEFTEST to lisp-unit's DEFINE-TEST.
(defmacro deftest (name form &rest values)
(let ((results (gensym "RESULTS-")))
`(define-test ,name
@@ -21,2006 +19,68 @@
(defun ,name () ,form)
(deftest ,name (,name) , at 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 , at 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))))
- , at 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))
- , at 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))
- , at 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 (:load-toplevel :compile-toplevel :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 , at args)))
- ,form))
- (defun ,optimized-name ()
- (macrolet ((mi (&rest args)
- `(make-instance , at args)))
- ,form))
- (deftest ,name (,name) , at values)
- (deftest ,optimized-name (,optimized-name)
- , at 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)))
- , at values)
- (deftest ,method-test
- (multiple-value-bind (r c)
- (let ((,instance (make-instance ',class)))
- (ignore-errors (,method-name ,instance)))
- (values r (typep c 'condition)))
- , at values)
- (define-compiled-test ,compiled-test
- (multiple-value-bind (r c)
- (let ((,instance (make-instance ',class)))
- (ignore-errors ,access))
- (values r (typep c 'condition)))
- , at 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)
-
+(require :defsystem)
+
+(setf (logical-pathname-translations "pcl-test")
+ (list (list "*.*.*"
+ (merge-pathnames #p"pcl/*.*"
+ *load-truename*))))
+
+(mk:defsystem :pcl-test
+ :initially-do (progn )
+ :source-pathname "pcl-test:"
+ :binary-pathname "pcl-test:"
+ :components
+ ((:file "pkg"
+ :source-extension "lisp")
+ #+gerds-pcl
+ (:file "ctor"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "defclass"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "make-instance"
+ :source-extension "lisp"
+ :depends-on ("pkg" #+gerds-pcl "ctor"))
+ (:file "reinitialize-instance"
+ :source-extension "lisp"
+ :depends-on ("pkg" "make-instance"))
+ (:file "slot-value"
+ :source-extension "lisp"
+ :depends-on ("pkg" "make-instance"))
+ (:file "slot-boundp"
+ :source-extension "lisp"
+ :depends-on ("pkg" "make-instance"))
+ (:file "slot-missing"
+ :source-extension "lisp"
+ :depends-on ("pkg" "make-instance"))
+ (:file "slot-accessors"
+ :source-extension "lisp"
+ :depends-on ("pkg" "make-instance"))
+ (:file "slot-type"
+ :source-extension "lisp"
+ :depends-on ("pkg" "slot-value"))
+ (:file "inline-access"
+ :source-extension "lisp"
+ :depends-on ("pkg" "slot-type"))
+ (:file "method-combination"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "pv"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "defgeneric"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "defmethod"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "find-method"
+ :source-extension "lisp"
+ :depends-on ("pkg"))
+ (:file "methods"
+ :source-extension "lisp"
+ :depends-on ("pkg"))))
+
+(mk:oos :pcl-test :compile)
commit 3feda4afbf396e9360851eb8812f5e812c80bdd2
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Fri Mar 14 22:02:20 2014 -0700
Copy the PCL tests here, changing the package from PCL-TEST to
PCL-TESTS to match how our test-runner wants to name packages.
diff --git a/tests/pcl/ctor.lisp b/tests/pcl/ctor.lisp
new file mode 100644
index 0000000..58f14f7
--- /dev/null
+++ b/tests/pcl/ctor.lisp
@@ -0,0 +1,425 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/ctor.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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")
+
+
diff --git a/tests/pcl/defclass.lisp b/tests/pcl/defclass.lisp
new file mode 100644
index 0000000..2ba70ca
--- /dev/null
+++ b/tests/pcl/defclass.lisp
@@ -0,0 +1,281 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/defclass.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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 , at 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)
diff --git a/tests/pcl/defgeneric.lisp b/tests/pcl/defgeneric.lisp
new file mode 100644
index 0000000..05f01c7
--- /dev/null
+++ b/tests/pcl/defgeneric.lisp
@@ -0,0 +1,75 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/defgeneric.lisp $")
+
+(in-package "PCL-TESTS")
+
+(defmacro define-gf-lambda-list-test (name lambda-list)
+ `(deftest ,name
+ (multiple-value-bind (r c)
+ (ignore-errors
+ (defgeneric g ,lambda-list))
+ (values (null r) (typep c 'error)))
+ t t))
+
+(define-gf-lambda-list-test defgeneric-lambda-list.0 (a &optional (b 1)))
+(define-gf-lambda-list-test defgeneric-lambda-list.1 (a &key (b 1)))
+(define-gf-lambda-list-test defgeneric-lambda-list.2 ((a gf-class)))
+
+;;;
+;;; CMUCL died with an illegal instruction when creating an instance
+;;; of the following class, due to a slot layout that was incompatible
+;;; with that of funcallable instances.
+;;;
+(defclass gf-class (standard-generic-function)
+ ()
+ (:metaclass pcl::funcallable-standard-class))
+
+(deftest defgeneric-generic-function-class.0
+ (progn
+ (defgeneric g (a b c)
+ (:generic-function-class gf-class))
+ t)
+ t)
+
+;;;
+;;; This used to enter a vicious metacircle.
+;;;
+(deftest method-class.0
+ (multiple-value-bind (r c)
+ (ignore-errors
+ (defclass method-class.0 (mop:standard-method) ())
+ (defgeneric method-class.0.gf (x)
+ (:method-class method-class.0))
+ (defmethod method-class.0.gf ((x integer)) x)
+ (method-class.0.gf 1))
+ (values r (null c)))
+ 1 t)
diff --git a/tests/pcl/defmethod.lisp b/tests/pcl/defmethod.lisp
new file mode 100644
index 0000000..014ed8c
--- /dev/null
+++ b/tests/pcl/defmethod.lisp
@@ -0,0 +1,143 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/defmethod.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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))))
+ , at 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)
diff --git a/tests/pcl/find-method.lisp b/tests/pcl/find-method.lisp
new file mode 100644
index 0000000..773b1ef
--- /dev/null
+++ b/tests/pcl/find-method.lisp
@@ -0,0 +1,51 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/find-method.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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)
+
diff --git a/tests/pcl/inline-access.lisp b/tests/pcl/inline-access.lisp
new file mode 100644
index 0000000..e698e70
--- /dev/null
+++ b/tests/pcl/inline-access.lisp
@@ -0,0 +1,243 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/inline-access.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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))
+ , at 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))
+ , at 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)))))
+
diff --git a/tests/pcl/make-instance.lisp b/tests/pcl/make-instance.lisp
new file mode 100644
index 0000000..dc23dbf
--- /dev/null
+++ b/tests/pcl/make-instance.lisp
@@ -0,0 +1,401 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/make-instance.lisp $")
+
+(in-package "PCL-TESTS")
+
+
+;;; *********************
+;;; 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.
+
+(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 , at args)))
+ ,form))
+ (defun ,optimized-name ()
+ (macrolet ((mi (&rest args)
+ `(make-instance , at args)))
+ ,form))
+ (deftest ,name (,name) , at values)
+ (deftest ,optimized-name (,optimized-name)
+ , at 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
diff --git a/tests/pcl/method-combination.lisp b/tests/pcl/method-combination.lisp
new file mode 100644
index 0000000..3719605
--- /dev/null
+++ b/tests/pcl/method-combination.lisp
@@ -0,0 +1,217 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/method-combination.lisp $")
+
+(in-package "PCL-TESTS")
+
+;;; ********************************
+;;; 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)
diff --git a/tests/pcl/methods.lisp b/tests/pcl/methods.lisp
new file mode 100644
index 0000000..e8c2ee9
--- /dev/null
+++ b/tests/pcl/methods.lisp
@@ -0,0 +1,48 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+(ext:file-comment "$Header: src/pcl/rt/methods.lisp $")
+
+(in-package "PCL-TESTS")
+
+;;; 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)
diff --git a/tests/pcl/pkg.lisp b/tests/pcl/pkg.lisp
new file mode 100644
index 0000000..b2e1edb
--- /dev/null
+++ b/tests/pcl/pkg.lisp
@@ -0,0 +1,38 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/pkg.lisp $")
+
+(in-package "PCL-TESTS")
+
+(defmacro define-compiled-test (name form &rest values)
+ `(progn
+ (defun ,name () ,form)
+ (deftest ,name (,name) , at values)))
diff --git a/tests/pcl/pv.lisp b/tests/pcl/pv.lisp
new file mode 100644
index 0000000..9bc6d1f
--- /dev/null
+++ b/tests/pcl/pv.lisp
@@ -0,0 +1,136 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/pv.lisp $")
+
+(in-package "PCL-TESTS")
+
+;;;**************************
+;;; 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))
+
diff --git a/tests/pcl/reinitialize-instance.lisp b/tests/pcl/reinitialize-instance.lisp
new file mode 100644
index 0000000..be4a76b
--- /dev/null
+++ b/tests/pcl/reinitialize-instance.lisp
@@ -0,0 +1,89 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+(ext:file-comment "$Header: src/pcl/rt/reinitialize-instance.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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)
diff --git a/tests/pcl/slot-accessors.lisp b/tests/pcl/slot-accessors.lisp
new file mode 100644
index 0000000..775a7ca
--- /dev/null
+++ b/tests/pcl/slot-accessors.lisp
@@ -0,0 +1,131 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+;;; What if accessors with the same name are declared for different
+;;; direct slots? Should there be a warning? ACL gives none. LW
+;;; gives an error.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/slot-accessors.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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)
+
+
diff --git a/tests/pcl/slot-boundp.lisp b/tests/pcl/slot-boundp.lisp
new file mode 100644
index 0000000..c89fb7e
--- /dev/null
+++ b/tests/pcl/slot-boundp.lisp
@@ -0,0 +1,75 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/slot-boundp.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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)
diff --git a/tests/pcl/slot-missing.lisp b/tests/pcl/slot-missing.lisp
new file mode 100644
index 0000000..4e79290
--- /dev/null
+++ b/tests/pcl/slot-missing.lisp
@@ -0,0 +1,106 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/slot-missing.lisp $")
+
+(in-package "PCL-TESTS")
+
+;;; 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)))
+ , at values)
+ (deftest ,method-test
+ (multiple-value-bind (r c)
+ (let ((,instance (make-instance ',class)))
+ (ignore-errors (,method-name ,instance)))
+ (values r (typep c 'condition)))
+ , at values)
+ (define-compiled-test ,compiled-test
+ (multiple-value-bind (r c)
+ (let ((,instance (make-instance ',class)))
+ (ignore-errors ,access))
+ (values r (typep c 'condition)))
+ , at 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)
diff --git a/tests/pcl/slot-type.lisp b/tests/pcl/slot-type.lisp
new file mode 100644
index 0000000..2996847
--- /dev/null
+++ b/tests/pcl/slot-type.lisp
@@ -0,0 +1,82 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+(ext:file-comment "$Header: src/pcl/rt/slot-type.lisp $")
+
+(in-package "PCL-TESTS")
+
+#+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)
diff --git a/tests/pcl/slot-value.lisp b/tests/pcl/slot-value.lisp
new file mode 100644
index 0000000..15e6418
--- /dev/null
+++ b/tests/pcl/slot-value.lisp
@@ -0,0 +1,60 @@
+;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann at t-online.de>
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote
+;;; products derived from this software without specific prior written
+;;; permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+
+#+cmu
+(ext:file-comment "$Header: src/pcl/rt/slot-value.lisp $")
+
+(in-package "PCL-TESTS")
+
+(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)
+
commit 7751a9115790d3418afef4d2fe00f7d0b14fe7f0
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Fri Mar 14 21:20:00 2014 -0700
Add comments.
diff --git a/tests/pcl.lisp b/tests/pcl.lisp
index 218fead..c49e279 100644
--- a/tests/pcl.lisp
+++ b/tests/pcl.lisp
@@ -1,3 +1,7 @@
+;;; Tests for PCL, taken from src/pcl/rt.
+;;;
+;;; It's clear that the tests used mk defsystem to load the tests, but
+;;; it's not clear if the tests were compiled or not before running.
(defpackage "PCL-TESTS"
(:use "COMMON-LISP" "PCL" "LISP-UNIT"))
commit be4f68c14bf16e8f653ba374188593df1ed732dc
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Fri Mar 14 21:17:09 2014 -0700
Fix typos in eval-when cases.
diff --git a/tests/pcl.lisp b/tests/pcl.lisp
index fe4402b..218fead 100644
--- a/tests/pcl.lisp
+++ b/tests/pcl.lisp
@@ -1007,7 +1007,7 @@
;;; 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)
+(eval-when (:load-toplevel :compile-toplevel :execute)
(defmacro define-mi-test (name form &key values opt-values)
(let ((optimized-name
(let ((*print-case* :upcase)
commit e4fcbef0308ca88f877a3b36d22b9bd00e1f78a9
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Wed Mar 12 21:44:38 2014 -0700
First cut at adding PCL tests.
diff --git a/tests/pcl.lisp b/tests/pcl.lisp
new file mode 100644
index 0000000..fe4402b
--- /dev/null
+++ b/tests/pcl.lisp
@@ -0,0 +1,2022 @@
+
+(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) , at 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 , at 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))))
+ , at 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))
+ , at 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))
+ , at 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 , at args)))
+ ,form))
+ (defun ,optimized-name ()
+ (macrolet ((mi (&rest args)
+ `(make-instance , at args)))
+ ,form))
+ (deftest ,name (,name) , at values)
+ (deftest ,optimized-name (,optimized-name)
+ , at 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)))
+ , at values)
+ (deftest ,method-test
+ (multiple-value-bind (r c)
+ (let ((,instance (make-instance ',class)))
+ (ignore-errors (,method-name ,instance)))
+ (values r (typep c 'condition)))
+ , at values)
+ (define-compiled-test ,compiled-test
+ (multiple-value-bind (r c)
+ (let ((,instance (make-instance ',class)))
+ (ignore-errors ,access))
+ (values r (typep c 'condition)))
+ , at 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)
+
-----------------------------------------------------------------------
Summary of changes:
tests/pcl.lisp | 86 ++++++++++++++++++++
{src/pcl/rt => tests/pcl}/ctor.lisp | 2 +-
{src/pcl/rt => tests/pcl}/defclass.lisp | 2 +-
{src/pcl/rt => tests/pcl}/defgeneric.lisp | 2 +-
{src/pcl/rt => tests/pcl}/defmethod.lisp | 2 +-
{src/pcl/rt => tests/pcl}/find-method.lisp | 2 +-
{src/pcl/rt => tests/pcl}/inline-access.lisp | 2 +-
{src/pcl/rt => tests/pcl}/make-instance.lisp | 4 +-
{src/pcl/rt => tests/pcl}/method-combination.lisp | 2 +-
{src/pcl/rt => tests/pcl}/methods.lisp | 2 +-
{src/pcl/rt => tests/pcl}/pkg.lisp | 14 +---
{src/pcl/rt => tests/pcl}/pv.lisp | 2 +-
.../rt => tests/pcl}/reinitialize-instance.lisp | 2 +-
{src/pcl/rt => tests/pcl}/slot-accessors.lisp | 2 +-
{src/pcl/rt => tests/pcl}/slot-boundp.lisp | 2 +-
{src/pcl/rt => tests/pcl}/slot-missing.lisp | 2 +-
{src/pcl/rt => tests/pcl}/slot-type.lisp | 2 +-
{src/pcl/rt => tests/pcl}/slot-value.lisp | 2 +-
tests/run-tests.lisp | 13 ++-
19 files changed, 114 insertions(+), 33 deletions(-)
create mode 100644 tests/pcl.lisp
copy {src/pcl/rt => tests/pcl}/ctor.lisp (99%)
copy {src/pcl/rt => tests/pcl}/defclass.lisp (99%)
copy {src/pcl/rt => tests/pcl}/defgeneric.lisp (99%)
copy {src/pcl/rt => tests/pcl}/defmethod.lisp (99%)
copy {src/pcl/rt => tests/pcl}/find-method.lisp (98%)
copy {src/pcl/rt => tests/pcl}/inline-access.lisp (99%)
copy {src/pcl/rt => tests/pcl}/make-instance.lisp (99%)
copy {src/pcl/rt => tests/pcl}/method-combination.lisp (99%)
copy {src/pcl/rt => tests/pcl}/methods.lisp (98%)
copy {src/pcl/rt => tests/pcl}/pkg.lisp (86%)
copy {src/pcl/rt => tests/pcl}/pv.lisp (99%)
copy {src/pcl/rt => tests/pcl}/reinitialize-instance.lisp (99%)
copy {src/pcl/rt => tests/pcl}/slot-accessors.lisp (99%)
copy {src/pcl/rt => tests/pcl}/slot-boundp.lisp (99%)
copy {src/pcl/rt => tests/pcl}/slot-missing.lisp (99%)
copy {src/pcl/rt => tests/pcl}/slot-type.lisp (99%)
copy {src/pcl/rt => tests/pcl}/slot-value.lisp (98%)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list