;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(defpackage "FOO"
- (:use "CL"))
-(in-package "FOO")
+(load "assertoid.lisp")
+
+(defpackage "CLOS-IMPURE"
+ (:use "CL" "ASSERTOID"))
+(in-package "CLOS-IMPURE")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
;;; structure types defined earlier in the file.
(assert (expect-error (defgeneric foo2 (x a &rest))))
(defgeneric foo3 (x &rest y))
(defmethod foo3 ((x t) &rest y) nil)
-(defmethod foo4 ((x t) &key y &rest z) nil)
+(defmethod foo4 ((x t) &rest z &key y) nil)
(defgeneric foo4 (x &rest z &key y))
(assert (expect-error (defgeneric foo5 (x &rest))))
(assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
;;; that it doesn't happen again.
;;;
;;; First, the forward references:
-(defclass a (b) ())
-(defclass b () ())
+(defclass forward-ref-a (forward-ref-b) ())
+(defclass forward-ref-b () ())
+;;; (a couple more complicated examples found by Paul Dietz' test
+;;; suite):
+(defclass forward-ref-c1 (forward-ref-c2) ())
+(defclass forward-ref-c2 (forward-ref-c3) ())
+
+(defclass forward-ref-d1 (forward-ref-d2 forward-ref-d3) ())
+(defclass forward-ref-d2 (forward-ref-d4 forward-ref-d5) ())
+
;;; Then change-class
(defclass class-with-slots ()
((a-slot :initarg :a-slot :accessor a-slot)
(b-slot :initarg :b-slot :accessor b-slot)
(c-slot :initarg :c-slot :accessor c-slot)))
+
(let ((foo (make-instance 'class-with-slots
:a-slot 1
:b-slot 2
(macrolet ((assert-program-error (form)
`(multiple-value-bind (value error)
(ignore-errors ,form)
- (assert (null value))
- (assert (typep error 'program-error)))))
+ (unless (and (null value) (typep error 'program-error))
+ (error "~S failed: ~S, ~S" ',form value error)))))
(assert-program-error (defclass foo001 () (a b a)))
(assert-program-error (defclass foo002 ()
(a b)
(assert-program-error (defclass foo004 ()
((a :silly t))))
;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
- ;; Moellmann in 0.7.8.x:
+ ;; Moellmann in sbcl-0.7.8.x:
(assert-program-error (progn
(defmethod odd-key-args-checking (&key (key 42)) key)
(odd-key-args-checking 3)))
(assert (= (odd-key-args-checking) 42))
- (assert (eq (odd-key-args-checking :key t) t)))
+ (assert (eq (odd-key-args-checking :key t) t))
+ ;; yet some more, fixed in sbcl-0.7.9.xx
+ (assert-program-error (defclass foo005 ()
+ (:metaclass sb-pcl::funcallable-standard-class)
+ (:metaclass 1)))
+ (assert-program-error (defclass foo006 ()
+ ((a :reader (setf a)))))
+ (assert-program-error (defclass foo007 ()
+ ((a :initarg 1))))
+ (assert-program-error (defclass foo008 ()
+ (a :initarg :a)
+ (:default-initargs :a 1)
+ (:default-initargs :a 2)))
+ ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26
+ (assert-program-error (defgeneric if (x)))
+ ;; DEFCLASS should detect an error if slot names aren't suitable as
+ ;; variable names:
+ (assert-program-error (defclass foo009 ()
+ ((:a :initarg :a))))
+ (assert-program-error (defclass foo010 ()
+ (("a" :initarg :a))))
+ (assert-program-error (defclass foo011 ()
+ ((#1a() :initarg :a))))
+ (assert-program-error (defclass foo012 ()
+ ((t :initarg :t))))
+ (assert-program-error (defclass foo013 () ("a")))
+ ;; specialized lambda lists have certain restrictions on ordering,
+ ;; repeating keywords, and the like:
+ (assert-program-error (defmethod foo014 ((foo t) &rest) nil))
+ (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil))
+ (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil))
+ (assert-program-error (defmethod foo017 ((foo t)
+ &optional x &optional y) nil))
+ (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil))
+ (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil))
+ (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil))
+ (assert-program-error (defmethod foo021 ((foo t) &key x &rest y) nil)))
\f
;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
;;; preserved through the bootstrap process until sbcl-0.7.8.39.
form)))
'dmc-test-return))
\f
-;;; DEFMETHOD should signal a PROGRAM-ERROR if an incompatible lambda
-;;; list is given:
+;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
+;;; given:
(defmethod incompatible-ll-test-1 (x) x)
-(multiple-value-bind (result error)
- (ignore-errors (defmethod incompatible-ll-test-1 (x y) y))
- (assert (null result))
- (assert (typep error 'program-error)))
-(multiple-value-bind (result error)
- (ignore-errors (defmethod incompatible-ll-test-1 (x &rest y) y))
- (assert (null result))
- (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
;;; Sneakily using a bit of MOPness to check some consistency
(assert (= (length
(sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
(defmethod incompatible-ll-test-2 (x &key bar) bar)
-(multiple-value-bind (result error)
- (ignore-errors (defmethod incompatible-ll-test-2 (x) x))
- (assert (null result))
- (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
(defmethod incompatible-ll-test-2 (x &rest y) y)
(assert (= (length
(sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
(assert (= (length
(sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
-(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
+
+;;; Per Christophe, this is an illegal method call because of 7.6.5
+(assert (raises-error? (incompatible-ll-test-2 t 1 2)))
+
(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+
+(defmethod incompatible-ll-test-3 ((x integer)) x)
+(remove-method #'incompatible-ll-test-3
+ (find-method #'incompatible-ll-test-3
+ nil
+ (list (find-class 'integer))))
+(assert (raises-error? (defmethod incompatible-ll-test-3 (x y) (list x y))))
+
\f
;;; Attempting to instantiate classes with forward references in their
;;; CPL should signal errors (FIXME: of what type?)
(call-next-method)))
(assert (= (call-next-method-lexical-args 3) 3))
\f
-;;;; success
+;;; DEFINE-METHOD-COMBINATION with arguments was hopelessly broken
+;;; until 0.7.9.5x
+(defvar *d-m-c-args-test* nil)
+(define-method-combination progn-with-lock ()
+ ((methods ()))
+ (:arguments object)
+ `(unwind-protect
+ (progn (lock (object-lock ,object))
+ ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods))
+ (unlock (object-lock ,object))))
+(defun object-lock (obj)
+ (push "object-lock" *d-m-c-args-test*)
+ obj)
+(defun unlock (obj)
+ (push "unlock" *d-m-c-args-test*)
+ obj)
+(defun lock (obj)
+ (push "lock" *d-m-c-args-test*)
+ obj)
+(defgeneric d-m-c-args-test (x)
+ (:method-combination progn-with-lock))
+(defmethod d-m-c-args-test ((x symbol))
+ (push "primary" *d-m-c-args-test*))
+(defmethod d-m-c-args-test ((x number))
+ (error "foo"))
+(assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock")))
+(assert (equal *d-m-c-args-test*
+ '("unlock" "object-lock" "primary" "lock" "object-lock")))
+(setf *d-m-c-args-test* nil)
+(ignore-errors (d-m-c-args-test 1))
+(assert (equal *d-m-c-args-test*
+ '("unlock" "object-lock" "lock" "object-lock")))
+\f
+;;; The walker (on which DEFMETHOD depended) didn't know how to handle
+;;; SYMBOL-MACROLET properly. In fact, as of sbcl-0.7.10.20 it still
+;;; doesn't, but it does well enough to compile the following without
+;;; error (the problems remain in asking for a complete macroexpansion
+;;; of an arbitrary form).
+(symbol-macrolet ((x 1))
+ (defmethod bug222 (z)
+ (macrolet ((frob (form) `(progn ,form ,x)))
+ (frob (print x)))))
+(assert (= (bug222 t) 1))
+
+;;; also, a test case to guard against bogus environment hacking:
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq bug222-b 3))
+;;; this should at the least compile:
+(let ((bug222-b 1))
+ (defmethod bug222-b (z stream)
+ (macrolet ((frob (form) `(progn ,form ,bug222-b)))
+ (frob (format stream "~D~%" bug222-b)))))
+;;; and it would be nice (though not specified by ANSI) if the answer
+;;; were as follows:
+(let ((x (make-string-output-stream)))
+ ;; not specified by ANSI
+ (assert (= (bug222-b t x) 3))
+ ;; specified.
+ (assert (char= (char (get-output-stream-string x) 0) #\1)))
+\f
+;;; REINITIALIZE-INSTANCE, in the ctor optimization, wasn't checking
+;;; for invalid initargs where it should:
+(defclass class234 () ())
+(defclass subclass234 (class234) ())
+(defvar *bug234* 0)
+(defun bug-234 ()
+ (reinitialize-instance (make-instance 'class234) :dummy 0))
+(defun subbug-234 ()
+ (reinitialize-instance (make-instance 'subclass234) :dummy 0))
+(assert (raises-error? (bug-234) program-error))
+(defmethod shared-initialize :after ((i class234) slots &key dummy)
+ (incf *bug234*))
+(assert (typep (subbug-234) 'subclass234))
+(assert (= *bug234*
+ ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE
+ 2))
+
+;;; also, some combinations of MAKE-INSTANCE and subclassing missed
+;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29):
+(defclass class234-b1 () ())
+(defclass class234-b2 (class234-b1) ())
+(defvar *bug234-b* 0)
+(defun bug234-b ()
+ (make-instance 'class234-b2))
+(compile 'bug234-b)
+(bug234-b)
+(assert (= *bug234-b* 0))
+(defmethod initialize-instance :before ((x class234-b1) &rest args)
+ (declare (ignore args))
+ (incf *bug234-b*))
+(bug234-b)
+(assert (= *bug234-b* 1))
+\f
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+\f
+;;; SLOT-MISSING should be called when there are missing slots.
+(defclass class-with-all-slots-missing () ())
+(defmethod slot-missing (class (o class-with-all-slots-missing)
+ slot-name op
+ &optional new-value)
+ op)
+(assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (slot-value x 'bar))
+ (make-instance 'class-with-all-slots-missing))
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
+ (make-instance 'class-with-all-slots-missing))
+ ;; SLOT-MISSING's value is specified to be ignored; we
+ ;; return NEW-VALUE.
+ 'baz))
+\f
+;;; we should be able to specialize on anything that names a class.
+(defclass name-for-class () ())
+(defmethod something-that-specializes ((x name-for-class)) 1)
+(setf (find-class 'other-name-for-class) (find-class 'name-for-class))
+(defmethod something-that-specializes ((x other-name-for-class)) 2)
+(assert (= (something-that-specializes (make-instance 'name-for-class)) 2))
+(assert (= (something-that-specializes (make-instance 'other-name-for-class))
+ 2))
+\f
+;;; more forward referenced classes stuff
+(defclass frc-1 (frc-2) ())
+(assert (subtypep 'frc-1 (find-class 'frc-2)))
+(assert (subtypep (find-class 'frc-1) 'frc-2))
+(assert (not (subtypep (find-class 'frc-2) 'frc-1)))
+(defclass frc-2 (frc-3) ((a :initarg :a)))
+(assert (subtypep 'frc-1 (find-class 'frc-3)))
+(defclass frc-3 () ())
+(assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1)))
+(assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2)))
+\f
+;;; check that we can define classes with two slots of different names
+;;; (even if it STYLE-WARNs).
+(defclass odd-name-class ()
+ ((name :initarg :name)
+ (cl-user::name :initarg :name2)))
+(let ((x (make-instance 'odd-name-class :name 1 :name2 2)))
+ (assert (= (slot-value x 'name) 1))
+ (assert (= (slot-value x 'cl-user::name) 2)))
+\f
+;;; ALLOCATE-INSTANCE should work on structures, even if defined by
+;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
+(defstruct allocatable-structure a)
+(assert (typep (allocate-instance (find-class 'allocatable-structure))
+ 'allocatable-structure))
+\f
+;;; Bug found by Paul Dietz when devising CPL tests: somewhat
+;;; amazingly, calls to CPL would work a couple of times, and then
+;;; start returning NIL. A fix was found (relating to the
+;;; applicability of constant-dfun optimization) by Gerd Moellmann.
+(defgeneric cpl (x)
+ (:method-combination list)
+ (:method list ((x broadcast-stream)) 'broadcast-stream)
+ (:method list ((x integer)) 'integer)
+ (:method list ((x number)) 'number)
+ (:method list ((x stream)) 'stream)
+ (:method list ((x structure-object)) 'structure-object))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+\f
+;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal
+;;; parameters shouldn't affect the arguments to the next method for a
+;;; no-argument call to CALL-NEXT-METHOD
+(defgeneric cnm-assignment (x)
+ (:method (x) x)
+ (:method ((x integer)) (setq x 3)
+ (list x (call-next-method) (call-next-method x))))
+(assert (equal (cnm-assignment 1) '(3 1 3)))
+\f
+;;; Bug reported by Istvan Marko 2003-07-09
+(let ((class-name (gentemp)))
+ (loop for i from 1 to 9
+ for slot-name = (intern (format nil "X~D" i))
+ for initarg-name = (intern (format nil "X~D" i) :keyword)
+ collect `(,slot-name :initarg ,initarg-name) into slot-descs
+ append `(,initarg-name (list 0)) into default-initargs
+ finally (eval `(defclass ,class-name ()
+ (,@slot-descs)
+ (:default-initargs ,@default-initargs))))
+ (let ((f (compile nil `(lambda () (make-instance ',class-name)))))
+ (assert (typep (funcall f) class-name))))
+
+;;; bug 262: DEFMETHOD failed on a generic function without a lambda
+;;; list
+(ensure-generic-function 'bug262)
+(defmethod bug262 (x y)
+ (list x y))
+(assert (equal (bug262 1 2) '(1 2)))
+;;; salex on #lisp 2003-10-13 reported that type declarations inside
+;;; WITH-SLOTS are too hairy to be checked
+(defun ensure-no-notes (form)
+ (handler-case (compile nil `(lambda () ,form))
+ (sb-ext:compiler-note (c)
+ ;; FIXME: it would be better to check specifically for the "type
+ ;; is too hairy" note
+ (error c))))
+(defvar *x*)
+(ensure-no-notes '(with-slots (a) *x*
+ (declare (integer a))
+ a))
+(ensure-no-notes '(with-slots (a) *x*
+ (declare (integer a))
+ (declare (notinline slot-value))
+ a))
+
+;;; from CLHS 7.6.5.1
+(defclass character-class () ((char :initarg :char)))
+(defclass picture-class () ((glyph :initarg :glyph)))
+(defclass character-picture-class (character-class picture-class) ())
+
+(defmethod width ((c character-class) &key font) font)
+(defmethod width ((p picture-class) &key pixel-size) pixel-size)
+
+(assert (raises-error?
+ (width (make-instance 'character-class :char #\Q)
+ :font 'baskerville :pixel-size 10)
+ program-error))
+(assert (raises-error?
+ (width (make-instance 'picture-class :glyph #\Q)
+ :font 'baskerville :pixel-size 10)
+ program-error))
+(assert (eq (width (make-instance 'character-picture-class :char #\Q)
+ :font 'baskerville :pixel-size 10)
+ 'baskerville))
+
+;;; class redefinition shouldn't give any warnings, in the usual case
+(defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
+(handler-bind ((warning #'error))
+ (defclass about-to-be-redefined () ((some-slot :accessor some-slot))))
+
+;;; attempts to add accessorish methods to generic functions with more
+;;; complex lambda lists should fail
+(defgeneric accessoroid (object &key &allow-other-keys))
+(assert (raises-error?
+ (defclass accessoroid-class () ((slot :accessor accessoroid)))
+ program-error))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass shared-slot-and-redefinition ()
+ ((size :initarg :size :initform 1 :allocation :class)))
+(let ((i (make-instance 'shared-slot-and-redefinition)))
+ (defclass shared-slot-and-redefinition ()
+ ((size :initarg :size :initform 2 :allocation :class)))
+ (assert (= (slot-value i 'size) 1)))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass superclass-born-to-be-obsoleted () (a))
+(defclass subclass-born-to-be-obsoleted (superclass-born-to-be-obsoleted) ())
+(defparameter *born-to-be-obsoleted*
+ (make-instance 'subclass-born-to-be-obsoleted))
+(defparameter *born-to-be-obsoleted-obsoleted* nil)
+(defmethod update-instance-for-redefined-class
+ ((o subclass-born-to-be-obsoleted) a d pl &key)
+ (setf *born-to-be-obsoleted-obsoleted* t))
+(make-instances-obsolete 'superclass-born-to-be-obsoleted)
+(slot-boundp *born-to-be-obsoleted* 'a)
+(assert *born-to-be-obsoleted-obsoleted*)
+
+;;; additional test suggested by Bruno Haible sbcl-devel 2004-04-21
+(defclass super-super-obsoleted () (a))
+(defclass super-obsoleted-1 (super-super-obsoleted) ())
+(defclass super-obsoleted-2 (super-super-obsoleted) ())
+(defclass obsoleted (super-obsoleted-1 super-obsoleted-2) ())
+(defparameter *obsoleted* (make-instance 'obsoleted))
+(defparameter *obsoleted-counter* 0)
+(defmethod update-instance-for-redefined-class ((o obsoleted) a d pl &key)
+ (incf *obsoleted-counter*))
+(make-instances-obsolete 'super-super-obsoleted)
+(slot-boundp *obsoleted* 'a)
+(assert (= *obsoleted-counter* 1))
+
+;;; shared -> local slot transfers of inherited slots, reported by
+;;; Bruno Haible
+(let (i)
+ (defclass super-with-magic-slot ()
+ ((magic :initarg :size :initform 1 :allocation :class)))
+ (defclass sub-of-super-with-magic-slot (super-with-magic-slot) ())
+ (setq i (make-instance 'sub-of-super-with-magic-slot))
+ (defclass super-with-magic-slot ()
+ ((magic :initarg :size :initform 2)))
+ (assert (= 1 (slot-value i 'magic))))
+
+;;; MAKE-INSTANCES-OBSOLETE return values
+(defclass one-more-to-obsolete () ())
+(assert (eq 'one-more-to-obsolete
+ (make-instances-obsolete 'one-more-to-obsolete)))
+(assert (eq (find-class 'one-more-to-obsolete)
+ (make-instances-obsolete (find-class 'one-more-to-obsolete))))
+
+;;; Sensible error instead of a BUG. Reported by Thomas Burdick.
+(multiple-value-bind (value err)
+ (ignore-errors
+ (defclass slot-def-with-duplicate-accessors ()
+ ((slot :writer get-slot :reader get-slot))))
+ (assert (typep err 'error))
+ (assert (not (typep err 'sb-int:bug))))
+
+;;; BUG 321: errors in parsing DEFINE-METHOD-COMBINATION arguments
+;;; lambda lists.
+
+(define-method-combination w-args ()
+ ((method-list *))
+ (:arguments arg1 arg2 &aux (extra :extra))
+ `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list)))
+(defgeneric mc-test-w-args (p1 p2 s)
+ (:method-combination w-args)
+ (:method ((p1 number) (p2 t) s)
+ (vector-push-extend (list 'number p1 p2) s))
+ (:method ((p1 string) (p2 t) s)
+ (vector-push-extend (list 'string p1 p2) s))
+ (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s)))
+(let ((v (make-array 0 :adjustable t :fill-pointer t)))
+ (assert (= (mc-test-w-args 1 2 v) 1))
+ (assert (equal (aref v 0) '(number 1 2)))
+ (assert (equal (aref v 1) '(t 1 2))))
+
+;;; BUG 276: declarations and mutation.
+(defmethod fee ((x fixnum))
+ (setq x (/ x 2))
+ x)
+(assert (= (fee 1) 1/2))
+(defmethod fum ((x fixnum))
+ (setf x (/ x 2))
+ x)
+(assert (= (fum 3) 3/2))
+(defmethod fii ((x fixnum))
+ (declare (special x))
+ (setf x (/ x 2))
+ x)
+(assert (= (fii 1) 1/2))
+(defvar *faa*)
+(defmethod faa ((*faa* string-stream))
+ (setq *faa* (make-broadcast-stream *faa*))
+ (write-line "Break, you sucker!" *faa*)
+ 'ok)
+(assert (eq 'ok (faa (make-string-output-stream))))
+(defmethod fex ((x fixnum) (y fixnum))
+ (multiple-value-setq (x y) (values (/ x y) (/ y x)))
+ (list x y))
+(assert (equal (fex 5 3) '(5/3 3/5)))
+
+;;; Bug reported by Zach Beane; incorrect return of (function
+;;; ',fun-name) in defgeneric
+(assert
+ (typep (funcall (compile nil
+ '(lambda () (flet ((nonsense () nil))
+ (defgeneric nonsense ())))))
+ 'generic-function))
+
+(assert
+ (typep (funcall (compile nil
+ '(lambda () (flet ((nonsense-2 () nil))
+ (defgeneric nonsense-2 ()
+ (:method () t))))))
+ 'generic-function))
+
+;;; bug reported by Bruno Haible: (setf find-class) using a
+;;; forward-referenced class
+(defclass fr-sub (fr-super) ())
+(setf (find-class 'fr-alt) (find-class 'fr-super))
+(assert (eq (find-class 'fr-alt) (find-class 'fr-super)))
+
+
+;;; ANSI Figure 4-8: all defined classes. Check that we can define
+;;; methods on all of these.
+(progn
+ (defgeneric method-for-defined-classes (x))
+ (dolist (c '(arithmetic-error
+ generic-function simple-error array hash-table
+ simple-type-error
+ bit-vector integer simple-warning
+ broadcast-stream list standard-class
+ built-in-class logical-pathname standard-generic-function
+ cell-error method standard-method
+ character method-combination standard-object
+ class null storage-condition
+ complex number stream
+ concatenated-stream package stream-error
+ condition package-error string
+ cons parse-error string-stream
+ control-error pathname structure-class
+ division-by-zero print-not-readable structure-object
+ echo-stream program-error style-warning
+ end-of-file random-state symbol
+ error ratio synonym-stream
+ file-error rational t
+ file-stream reader-error two-way-stream
+ float readtable type-error
+ floating-point-inexact real unbound-slot
+ floating-point-invalid-operation restart unbound-variable
+ floating-point-overflow sequence undefined-function
+ floating-point-underflow serious-condition vector
+ function simple-condition warning))
+ (eval `(defmethod method-for-defined-classes ((x ,c)) (princ x))))
+ (assert (string= (with-output-to-string (*standard-output*)
+ (method-for-defined-classes #\3))
+ "3")))
+
+
+\f
+;;; When class definition does not complete due to a bad accessor
+;;; name, do not cause an error when a new accessor name is provided
+;;; during class redefinition
+
+(defun existing-name (object)
+ (list object))
+
+(assert (raises-error? (defclass redefinition-of-accessor-class ()
+ ((slot :accessor existing-name)))))
+
+(defclass redefinition-of-accessor-class ()
+ ((slot :accessor new-name)))
+
+\f
+
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
+(delete-package "PACKAGE-CTOR-BUG")
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
+
+(deftype defined-type () 'integer)
+(assert (raises-error?
+ (defmethod method-on-defined-type ((x defined-type)) x)))
+(deftype defined-type-and-class () 'integer)
+(setf (find-class 'defined-type-and-class) (find-class 'integer))
+(defmethod method-on-defined-type-and-class ((x defined-type-and-class))
+ (1+ x))
+(assert (= (method-on-defined-type-and-class 3) 4))
+
+;;;; success
(sb-ext:quit :unix-status 104)
projects / sbcl.git / blobdiff