April 2015 - cmucl-cvs - mailman3.common-lisp.net

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-2-gb728040
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 b7280406f5f91cdd6ffc8dcacc9e811317a9a99b (commit) from e2c9ecef46e95a79ad7655702088ec1c976267dd (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 b7280406f5f91cdd6ffc8dcacc9e811317a9a99b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 15 13:18:35 2013 -0800 Need -ffloat-store when compiling e_rem/k_rem. * Add CC_REM_PIO2 variable when compiling e_rem_pio2.c and k_rem_pio2.c. * On linux and freebsd, set CC_REM_PIO2 to -ffloat-store so that proper rounding happens. Not needed on Darwin because Darwin always uses sse2 and not x87. diff --git a/src/lisp/Config.x86_common b/src/lisp/Config.x86_common index 6f0ec95..f263d40 100644 --- a/src/lisp/Config.x86_common +++ b/src/lisp/Config.x86_common @@ -65,7 +65,13 @@ NM = nm -gp DEPEND_FLAGS = -MM # This no longer has aliasing problems, so no need to use -# -ffloat-store and -fno-strict-aliasing anymore. +# -fno-strict-aliasing anymore. However, if we're building with x87, +# we MUST use -ffloat-store to get proper double-float rounding. e_rem_pio2.o : e_rem_pio2.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $< + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +k_rem_pio2.o : k_rem_pio2.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + + diff --git a/src/lisp/Config.x86_freebsd b/src/lisp/Config.x86_freebsd index a050e50..911e2c2 100644 --- a/src/lisp/Config.x86_freebsd +++ b/src/lisp/Config.x86_freebsd @@ -1,6 +1,10 @@ # -*- Mode: makefile -*- include Config.x86_common +# Need -ffloat-store for e_rem_pio2 and k_rem_pio2 to get properly +# rounded double-floats while using x87 extended precision. +CC_REM_PIO2 = -ffloat-store + UNDEFSYMPATTERN = -Xlinker -u -Xlinker & OS_SRC += FreeBSD-os.c elf.c OS_LINK_FLAGS = -dynamic -export-dynamic diff --git a/src/lisp/Config.x86_linux b/src/lisp/Config.x86_linux index 569f4f5..13eb012 100644 --- a/src/lisp/Config.x86_linux +++ b/src/lisp/Config.x86_linux @@ -3,6 +3,10 @@ include Config.x86_common CPPFLAGS += -m32 -rdynamic -D__NO_CTYPE -D_GNU_SOURCE +# Need -ffloat-store for e_rem_pio2 and k_rem_pio2 to get properly +# rounded double-floats while using x87 extended precision. +CC_REM_PIO2 = -ffloat-store + UNDEFSYMPATTERN = -Xlinker -u -Xlinker & ASSEM_SRC += linux-stubs.S OS_SRC += Linux-os.c elf.c ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_common | 10 ++++++++-- src/lisp/Config.x86_freebsd | 4 ++++ src/lisp/Config.x86_linux | 4 ++++ 3 files changed, 16 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-03-11-g9706477
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-4-g8970ad1
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 8970ad11b03f863b40a9ee352d3aced52b783cce (commit) from 1554c686c73c29228bf5b77425837fe27f3aa201 (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 8970ad11b03f863b40a9ee352d3aced52b783cce Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Feb 9 09:53:11 2014 -0800 Fix ticket:92 Type derivation for log fixed to be consistent with the actual returned values. * src/compiler/float-tran.lisp: * Update {{{LOG-DERIVE-TYPE-AUX-1}}} to compute the correct type. * tests/trac.lisp: * Add test for trac ticket:92 diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 08ce90b..b856a6c 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -1494,11 +1494,15 @@ (two-arg-derive-type x y #'expt-derive-type-aux #'expt)) -;;; Note must assume that a type including 0.0 may also include -0.0 -;;; and thus the result may be complex -infinity + i*pi. -;;; (defun log-derive-type-aux-1 (x) - (elfun-derive-type-simple x #'log 0d0 nil nil nil)) + (elfun-derive-type-simple x + #'(lambda (z) + ;; log(0) and log(-0) is -infinity. + ;; Return NIL to indicate that. + (if (zerop z) + nil + (log z))) + -0d0 nil nil nil)) (defun log-derive-type-aux-2 (x y same-arg) (let ((log-x (log-derive-type-aux-1 x)) diff --git a/tests/trac.lisp b/tests/trac.lisp index 3e23d3e..dfbbf8b 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -273,3 +273,13 @@ ;; The following formats should not signal an error. (assert-true (ignore-errors (format nil "~ve" 21 5d-234))) (assert-true (ignore-errors (format nil "~ve" 100 5d-234)))) + +(define-test trac.92 + (:tag :trac) + (let ((f (compile nil + #'(lambda (x) + (declare (type (double-float 0d0) x)) + (log x))))) + (assert-equal + 'double-float + (third (kernel:%function-type f))))) ----------------------------------------------------------------------- Summary of changes: src/compiler/float-tran.lisp | 12 ++++++++---- tests/trac.lisp | 10 ++++++++++ 2 files changed, 18 insertions(+), 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-5-gea1b427
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 ea1b427815d5334da20d2821aea5abbcffbee0ad (commit) from 1b9697d7923b1e9f7d875b94a13e427ddc651453 (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 ea1b427815d5334da20d2821aea5abbcffbee0ad Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Jul 20 21:01:59 2014 -0700 Add declarations for the fdlibm trig functions. diff --git a/src/lisp/fdlibm.h b/src/lisp/fdlibm.h index 3a9fcdb..61794b3 100644 --- a/src/lisp/fdlibm.h +++ b/src/lisp/fdlibm.h @@ -41,3 +41,10 @@ extern double scalbn(double, int); /* fdlibm kernel function */ extern int __kernel_rem_pio2(double*,double*,int,int,int,const int*); + +extern double __kernel_sin(double x, double y, int iy); +extern double __kernel_cos(double x, double y); +extern double __kernel_tan(double x, double y, int iy); +extern double sin(double x); +extern double cos(double x); +extern double tan(double x); ----------------------------------------------------------------------- Summary of changes: src/lisp/fdlibm.h | 7 +++++++ 1 file changed, 7 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-92-g75d14d2
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 75d14d2ed7dc9085858d9119013b67fbdfe77390 (commit) from 47718592f9ef89fd8a52f07d41c8553aa8b525f2 (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 75d14d2ed7dc9085858d9119013b67fbdfe77390 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Aug 4 18:55:27 2014 -0700 Fix bug in DOUBLE-FLOAT-BITS vop. Add a lifetime spec to the arg so that we don't accidentally destroy the arg when writing the two results. Previously, HI-BITS was allocated to the same register as FLOAT (in a descriptor). Writing HI-BITS would destroy the contents of the FLOAT and when trying to write lo-bits, we would read from the wrong address because FLOAT now contains the high bits of the double float number. diff --git a/src/compiler/x86/float-sse2.lisp b/src/compiler/x86/float-sse2.lisp index bfa6df9..e7b1b86 100644 --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -1272,7 +1272,8 @@ (define-vop (double-float-bits) (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) + :load-if (not (sc-is float double-stack)) + :to (:result 1))) (:results (hi-bits :scs (signed-reg)) (lo-bits :scs (unsigned-reg))) (:arg-types double-float) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/float-sse2.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-7-ge934d7c
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 e934d7ccdc07f355d29014b670605d1bc0b92dc1 (commit) via e86092b1b330d640faf85f22407df598c8270122 (commit) from ea1b427815d5334da20d2821aea5abbcffbee0ad (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 e934d7ccdc07f355d29014b670605d1bc0b92dc1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jul 21 22:07:51 2014 -0700 Darwin doesn't need fdlibm because the system library is good. diff --git a/src/lisp/Config.x86_darwin b/src/lisp/Config.x86_darwin index 9d00a4d..39c09bd 100644 --- a/src/lisp/Config.x86_darwin +++ b/src/lisp/Config.x86_darwin @@ -17,19 +17,3 @@ OS_LINK_FLAGS = -m32 $(MIN_VER) OS_LIBS = EXEC_FINAL_OBJ = exec-final.o - -OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c - -k_sin.o : k_sin.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< -k_cos.o : k_cos.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< -k_tan.o : k_tan.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< - -s_sin.o : s_sin.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< -s_cos.o : s_cos.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< -s_tan.o : s_tan.c - $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< commit e86092b1b330d640faf85f22407df598c8270122 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Jul 20 21:03:17 2014 -0700 Compile fdlibm trig functions on linux and darwin. diff --git a/src/lisp/Config.x86_darwin b/src/lisp/Config.x86_darwin index 39c09bd..9d00a4d 100644 --- a/src/lisp/Config.x86_darwin +++ b/src/lisp/Config.x86_darwin @@ -17,3 +17,19 @@ OS_LINK_FLAGS = -m32 $(MIN_VER) OS_LIBS = EXEC_FINAL_OBJ = exec-final.o + +OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c + +k_sin.o : k_sin.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +k_cos.o : k_cos.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +k_tan.o : k_tan.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +s_sin.o : s_sin.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_cos.o : s_cos.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_tan.o : s_tan.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< diff --git a/src/lisp/Config.x86_linux b/src/lisp/Config.x86_linux index 13eb012..962c9e2 100644 --- a/src/lisp/Config.x86_linux +++ b/src/lisp/Config.x86_linux @@ -15,3 +15,19 @@ OS_LINK_FLAGS = -m32 -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker OS_LINK_FLAGS += -Wl,-z,noexecstack EXEC_FINAL_OBJ = exec-final.o + +OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c + +k_sin.o : k_sin.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +k_cos.o : k_cos.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +k_tan.o : k_tan.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +s_sin.o : s_sin.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_cos.o : s_cos.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_tan.o : s_tan.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_linux | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-15-g7916cfb
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 7916cfb0b1b01e42901d92d9669c3c6099a6cab6 (commit) from 9c4bcc617b25fdcbac0bd8372cdc545dfa1f0bd7 (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 7916cfb0b1b01e42901d92d9669c3c6099a6cab6 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 18 08:50:37 2013 -0800 Add more tests for exceptional values for cos and tan. Add a few comments. diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp index 41e444a..58d10b6 100644 --- a/src/tests/trig.lisp +++ b/src/tests/trig.lisp @@ -1,3 +1,5 @@ +;;; Tests for the basic trig functions, now implemented in Lisp. + (defpackage :trig-tests (:use :cl :lisp-unit)) @@ -52,8 +54,10 @@ "Test sin for exceptional values" (:tag :sin :exceptions) (kernel::with-float-traps-masked () - (assert-error 'floating-point-invalid-operation (sin ext:double-float-positive-infinity)) - (assert-error 'floating-point-invalid-operation (sin ext:double-float-negative-infinity)))) + (assert-error 'floating-point-invalid-operation + (sin ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (sin ext:double-float-negative-infinity)))) (define-test cos.signed-zeroes "Test cos for 0d0 and -0d0" @@ -104,6 +108,15 @@ (assert-eql -0.9258790228548379d0 (cos (scale-float 1d0 120)))) +(define-test cos.exceptions + "Test cos for exceptional values" + (:tag :sin :exceptions) + (kernel::with-float-traps-masked () + (assert-error 'floating-point-invalid-operation + (cos ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (cos ext:double-float-negative-infinity)))) + (define-test tan.signed-zeroes "Test tan for 0d0 and -0d0" (:tag :tan :signed-zeroes) @@ -150,6 +163,14 @@ (assert-eql -4.08066388841804238545143494525595117765084022768d-1 (tan (scale-float 1d0 120)))) +(define-test tan.exceptions + "Test tan for exceptional values" + (:tag :sin :exceptions) + (kernel::with-float-traps-masked () + (assert-error 'floating-point-invalid-operation + (tan ext:double-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (tan ext:double-float-negative-infinity)))) (define-test sincos.signed-zeroes "Test sincos at 0d0, -0d0" @@ -159,6 +180,9 @@ (assert-equal '(-0d0 1d0) (multiple-value-list (kernel::%sincos -0d0)))) +;; Test sincos at a bunch of random points and compare the result from +;; sin and cos. If they differ, save the result in a list to be +;; returned. (defun sincos-test (limit n) (let (results) (dotimes (k n) ----------------------------------------------------------------------- Summary of changes: src/tests/trig.lisp | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-98-gf05a440
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 f05a4402996b0b7bc7c00c48fa4a27a4b3cf532b (commit) from 6635ef21befd5126c23140d4be12db874577e24c (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 f05a4402996b0b7bc7c00c48fa4a27a4b3cf532b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Aug 5 21:22:10 2014 -0700 Addresses ticket #84 for Linux. * Add -m32 flag to build 32-bit object files and binaries. * Update -L to where the 32-bit X11 libraries are on my OpenSuSE 11.3 system. (This wasn't working before because apparently I didn't actually have the 32-bit X11 libraries installed.) diff --git a/src/motif/server/Config.x86 b/src/motif/server/Config.x86 index ded67cd..bbfb987 100644 --- a/src/motif/server/Config.x86 +++ b/src/motif/server/Config.x86 @@ -1,5 +1,7 @@ -CFLAGS += -O2 -I/usr/X11R6/include -I. -I$(VPATH) -LDFLAGS += -L/usr/X11R6/lib +CFLAGS += -m3 -O2 -I/usr/X11R6/include -I. -I$(VPATH) +# LDFLAGS += -L/usr/X11R6/lib +# On OpenSuSE 11.3,the 32-bit X libraries are in /usr/lib. +LDFLAGS += -L/usr/lib LIBS = -lXm -lXt -lXext -lX11 -lSM -lICE -lXp -ldl -lpthread # This def assumes you are building in the same or parallel # tree to the CVS souce layout. Sites may need to customize ----------------------------------------------------------------------- Summary of changes: src/motif/server/Config.x86 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-04-7-gb76e597
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 b76e59723e21a2c494948dcc4be940e5d7e802ec (commit) from 940ba8218564d4bba25a722774162d5030d6ae94 (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 b76e59723e21a2c494948dcc4be940e5d7e802ec Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Apr 27 09:08:11 2013 -0700 Clean up madvise implementation * Remove PAGE_MADVISE_MASK * Remove code using PAGE_MADVISE_MASK * Move some #defines from gencgc.c to gencgc.h * Add new or better comments diff --git a/src/lisp/gencgc.c b/src/lisp/gencgc.c index 2f7ecf1..fb4a741 100644 --- a/src/lisp/gencgc.c +++ b/src/lisp/gencgc.c @@ -288,34 +288,43 @@ boolean verify_dynamic_code_check = FALSE; boolean check_code_fixups = FALSE; -/* How have a page zero-filled. */ +/* + * How to have a page zero-filled. When a page is freed, we need to + * either zero it immediately or mark it as needing to be zero-filled + * when it is allocated later. + */ enum gencgc_unmap_mode { - /* Unmap and mmap the region to get it zeroed */ + /* + * Unmap and mmap the region to get it zeroed when the page + * is freed.. + */ MODE_MAP, - /* Memset the region to 0 */ + /* + * Memset the region to 0 when it is freed. + */ MODE_MEMSET, /* * Call madvise to allow the kernel to free the memory if needed. - * But when the region needs to be used, we will zero it if - * necessary + * But when the region needs to be allocated, we will zero it if + * necessary. */ MODE_MADVISE, /* * Like madvise, except we don't actually call madvize and lazily - * zero the region when needed. + * zero the region when it is allocated. */ MODE_LAZY, }; /* - * Control how freed regions should be zeroed. Default to MODE_MEMSET + * Control how freed regions should be zeroed. Default to MODE_LAZY * for all systems since tests indicate that it is much faster than * unmapping and re-mapping it to zero the region. See enum - * gencgc_unmap_made for other ossible options. + * gencgc_unmap_made for other possible options. * * XXX: Choose the appopriate mode for each OS/arch. * @@ -352,13 +361,13 @@ boolean gencgc_zero_check_during_free_heap = FALSE; #endif /* - * For now, enable the gencgc_zero_check if gencgc_unmap_zero is lazy. - * XXX: Remove this additional condition when we feel that - * gencgc_unmap_zero is good enough. + * For now, enable the gencgc_zero_check if gencgc_unmap_zero is lazy + * or madvise. XXX: Remove this additional condition when we feel + * that gencgc_unmap_zero is good enough. */ -#define DO_GENCGC_ZERO_CHECK (gencgc_zero_check || (gencgc_unmap_zero == MODE_LAZY)) -#define DO_GENCGC_ZERO_CHECK_DURING_FREE_HEAP (gencgc_zero_check_during_free_heap || (gencgc_unmap_zero == MODE_LAZY)) +#define DO_GENCGC_ZERO_CHECK (gencgc_zero_check || (gencgc_unmap_zero == MODE_LAZY) || (gencgc_unmap_zero == MODE_MADVISE)) +#define DO_GENCGC_ZERO_CHECK_DURING_FREE_HEAP (gencgc_zero_check_during_free_heap || (gencgc_unmap_zero == MODE_LAZY) || (gencgc_unmap_zero == MODE_MADVISE)) /* * The minimum size for a large object. @@ -954,7 +963,7 @@ handle_heap_overflow(const char *msg, int size) } /* - * Enable debug messages for MODE_MADVISE and MODE_LAZY + * Enables debug messages for MODE_MADVISE and MODE_LAZY */ boolean gencgc_debug_madvise = FALSE; @@ -968,11 +977,7 @@ handle_madvise_first_page(int first_page) first_page, flags, page_table[first_page].bytes_used); } -#if 0 - if ((flags & PAGE_MADVISE_MASK) && !PAGE_ALLOCATED(first_page)) { -#else if (!PAGE_ALLOCATED(first_page)) { -#endif int *page_start = (int *) page_address(first_page); if (gencgc_debug_madvise) { @@ -980,10 +985,6 @@ handle_madvise_first_page(int first_page) } if (*page_start != 0) { memset(page_start, 0, GC_PAGE_SIZE); -#if 0 - page_table[first_page].flags &= ~PAGE_MADVISE_MASK; -#else -#endif } } if (gencgc_debug_madvise) { @@ -997,11 +998,7 @@ handle_madvise_other_pages(int first_page, int last_page) int i; for (i = first_page + 1; i <= last_page; ++i) { -#if 0 - if (page_table[i].flags & PAGE_MADVISE_MASK) { -#else - if (!PAGE_ALLOCATED(i)) { -#endif + if (!PAGE_ALLOCATED(i)) { int *page_start = (int *) page_address(i); if (gencgc_debug_madvise) { @@ -1010,9 +1007,6 @@ handle_madvise_other_pages(int first_page, int last_page) } if (*page_start != 0) { memset(page_start, 0, GC_PAGE_SIZE); -#if 0 - page_table[i].flags &= ~PAGE_MADVISE_MASK; -#endif } } } @@ -6995,19 +6989,12 @@ free_oldspace(void) fprintf(stderr, "ADVISING pages %d-%d\n", first_page, last_page - 1); } -#if defined(__linux__) -#define GENCGC_MADVISE MADV_DONTNEED -#else -#define GENCGC_MADVISE MADV_FREE -#endif - page_start = (int *) page_address(first_page); madvise(page_start, GC_PAGE_SIZE * (last_page - first_page), GENCGC_MADVISE); for (page = first_page; page < last_page; ++page) { - page_table[page].flags |= PAGE_MADVISE_MASK; page_start = (int *) page_address(page); - *page_start = 0xdead0000; + *page_start = PAGE_NEEDS_ZEROING_MARKER; } break; @@ -7028,7 +7015,7 @@ free_oldspace(void) } page_start = (int *) page_address(page); - *page_start = 0xdead0000; + *page_start = PAGE_NEEDS_ZEROING_MARKER; } break; diff --git a/src/lisp/gencgc.h b/src/lisp/gencgc.h index ce1bf07..a7ce03a 100644 --- a/src/lisp/gencgc.h +++ b/src/lisp/gencgc.h @@ -19,6 +19,23 @@ int gc_write_barrier(void *); /* + * How to madvise pages, if enabled + */ +#if defined(__linux__) +#define GENCGC_MADVISE MADV_DONTNEED +#else +#define GENCGC_MADVISE MADV_FREE +#endif + +/* + * That start of each unallocate page is set to this value to indicate + * that the page needs to be zeroed before being allocated. This is + * used when gencgc_unmap_zero is MODE_MADVISE or MODE_LAZY. Any + * non-zero value will work. + */ +#define PAGE_NEEDS_ZEROING_MARKER 0xdead0000 + +/* * Set when the page is write protected. If it is writen into it is * made writable and this flag is cleared. This should always reflect * the actual write_protect status of a page. @@ -77,8 +94,6 @@ int gc_write_barrier(void *); #define PAGE_LARGE_OBJECT_VAL(page) \ (PAGE_LARGE_OBJECT(page) >> PAGE_LARGE_OBJECT_SHIFT) -#define PAGE_MADVISE_MASK 0x00000400 - /* * The generation that this page belongs to. This should be valid for * all pages that may have objects allocated, even current allocation ----------------------------------------------------------------------- Summary of changes: src/lisp/gencgc.c | 65 +++++++++++++++++++++-------------------------------- src/lisp/gencgc.h | 19 ++++++++++++++-- 2 files changed, 43 insertions(+), 41 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-60-g28ca349
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 28ca34951c313162068768fb80742254dd7af1b6 (commit) via 70bf595c72a9bb4a400dc6fdab9a269ccde060dd (commit) via 08fd3e4ea1565c8674c837cd9e08b1e24f438d33 (commit) via 8dd3a6aae9b37307eef4d48b740cba9cb265444d (commit) from c2e152be334f9e1272db737e2eb5056e67def8d0 (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 28ca34951c313162068768fb80742254dd7af1b6 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:42:38 2014 -0700 Add some braces to silence the warning from clang about dangling else statements. diff --git a/src/lisp/e_log.c b/src/lisp/e_log.c index 4404ce1..032f794 100644 --- a/src/lisp/e_log.c +++ b/src/lisp/e_log.c @@ -117,8 +117,15 @@ static double zero = 0.0; k += (i>>20); f = x-1.0; if((0x000fffff&(2+hx))<3) { /* |f| < 2**-20 */ - if(f==zero) if(k==0) return zero; else {dk=(double)k; - return dk*ln2_hi+dk*ln2_lo;} + if(f==zero) { + if(k==0) + return zero; + else { + dk=(double)k; + return dk*ln2_hi+dk*ln2_lo; + } + } + R = f*f*(0.5-0.33333333333333333*f); if(k==0) return f-R; else {dk=(double)k; return dk*ln2_hi-((R-dk*ln2_lo)-f);} diff --git a/src/lisp/s_expm1.c b/src/lisp/s_expm1.c index d6a1827..6e35fd8 100644 --- a/src/lisp/s_expm1.c +++ b/src/lisp/s_expm1.c @@ -194,9 +194,10 @@ Q5 = -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */ e = (x*(e-c)-c); e -= hxs; if(k== -1) return 0.5*(x-e)-0.5; - if(k==1) + if(k==1) { if(x < -0.25) return -2.0*(e-(x+0.5)); else return one+2.0*(x-e); + } if (k <= -2 || k>56) { /* suffice to return exp(x)-1 */ y = one-(e-x); utmp.d = y; commit 70bf595c72a9bb4a400dc6fdab9a269ccde060dd Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:39:39 2014 -0700 Remove the sccsid variable. diff --git a/src/lisp/e_pow.c b/src/lisp/e_pow.c index 9dafc26..914d7d9 100644 --- a/src/lisp/e_pow.c +++ b/src/lisp/e_pow.c @@ -1,8 +1,3 @@ - -#ifndef lint -static char sccsid[] = "@(#)e_pow.c 1.5 04/04/22 SMI"; -#endif - /* * ==================================================== * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. commit 08fd3e4ea1565c8674c837cd9e08b1e24f438d33 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:38:58 2014 -0700 Initialize k to get rid of a compiler warning from clang. The compiler thinks k might not be initialized because the if on line 143 might not be true, leaving t uninitialized. We know that the condition is always true because |x| < -2^-28 in the previous line. diff --git a/src/lisp/e_exp.c b/src/lisp/e_exp.c index 4d94a1e..3d84224 100644 --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -106,7 +106,8 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ #endif { double y,hi,lo,c,t; - int k,xsb; + int k = 0; + int xsb; unsigned hx; union { int i[2]; double d; } ux; commit 8dd3a6aae9b37307eef4d48b740cba9cb265444d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:35:17 2014 -0700 Initialize t to get rid of a compiler warning from clang. The compiler thinks t might not be initialized because the if on line 90 might not be true, leaving t uninitialized. We know that the condition is always true because |x| < -2^-27 in the previous line. diff --git a/src/lisp/e_asin.c b/src/lisp/e_asin.c index 9b476a4..4aa6c63 100644 --- a/src/lisp/e_asin.c +++ b/src/lisp/e_asin.c @@ -73,7 +73,8 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ double x; #endif { - double t,w,p,q,c,r,s; + double t = 0; + double w,p,q,c,r,s; int hx,ix; union { int i[2]; double d; } ux; ----------------------------------------------------------------------- Summary of changes: src/lisp/e_asin.c | 3 ++- src/lisp/e_exp.c | 3 ++- src/lisp/e_log.c | 11 +++++++++-- src/lisp/e_pow.c | 5 ----- src/lisp/s_expm1.c | 3 ++- 5 files changed, 15 insertions(+), 10 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0