X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=9c179fc00fa61696f744f94ea459a6ca39e85237;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=405a219ad43c8b8dbdd40a3e5b41d9a9d2c34c22;hpb=28b4b70473ad927acb2aee6d3a8cb3f107b02864;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 405a219..9c179fc 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -683,5 +683,133 @@ (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)