X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=9c179fc00fa61696f744f94ea459a6ca39e85237;hb=7abb9e44907ef12b52ac26d6482fbe21c036ee9b;hp=a319f42f260cc487349387d7effd13dc6b0b40e0;hpb=937a46e64983862cb9e21761db95e58700341940;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index a319f42..9c179fc 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -663,5 +663,153 @@ (list x (call-next-method) (call-next-method x)))) (assert (equal (cnm-assignment 1) '(3 1 3))) +;;; 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)))) + ;;;; success (sb-ext:quit :unix-status 104)