(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)
(assert-program-error (defclass foo008 ()
(a :initarg :a)
(:default-initargs :a 1)
- (:default-initargs :a 2))))
+ (: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?)
'slot-value))
(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
(make-instance 'class-with-all-slots-missing))
- 'setf))
+ ;; 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))))
+
+;;; 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))
+
+
+
;;;; success
(sb-ext:quit :unix-status 104)