X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=873e8cfb4ad792c5a94e502c88b1829728458fa7;hb=760349abe9068fe4e5e3c03013f3533b64602a93;hp=2f8d99ca32a4e14636a1e6754b317b6e6b39c930;hpb=9247f1e1e1daa42ed0c7d6df860ed7056fb8225e;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 2f8d99c..873e8cf 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -191,6 +191,7 @@ ((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 @@ -292,8 +293,8 @@ (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) @@ -450,8 +451,19 @@ (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)))) + ;;; Attempting to instantiate classes with forward references in their ;;; CPL should signal errors (FIXME: of what type?) @@ -676,5 +688,182 @@ (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)) + +;;; 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))) + ;;;; success (sb-ext:quit :unix-status 104)