(assert (= (slot-value *yao-super* 'obs) 3))
(assert (= (slot-value *yao-sub* 'obs) 3))
+;;; one more MIO test: variable slot names
+(defclass mio () ((x :initform 42)))
+(defvar *mio-slot* 'x)
+(defparameter *mio-counter* 0)
+(defmethod update-instance-for-redefined-class ((instance mio) new old plist &key)
+ (incf *mio-counter*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-value x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (setf (slot-value x *mio-slot*) 13))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-boundp x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-makunbound x *mio-slot*))
+
+(assert (= 4 *mio-counter*))
+
;;; shared -> local slot transfers of inherited slots, reported by
;;; Bruno Haible
(let (i)
(defclass class-with-odd-class-name-method ()
((a :accessor class-name)))
\f
-;;; another case where precomputing (this time on PRINT-OBJET) and
+;;; another case where precomputing (this time on PRINT-OBJECT) and
;;; lazily-finalized classes caused problems. (report from James Y
;;; Knight sbcl-devel 20-07-2006)
(assert (equal '(:foo 13)
(apply #'test-long-form-with-&rest :foo (make-list 13))))
+;;;; slot-missing for non-standard classes on SLOT-VALUE
+;;;;
+;;;; FIXME: This is arguably not right, actually: CLHS seems to say
+;;;; we should just signal an error at least for built-in classes, but
+;;;; for a while we were hitting NO-APPLICABLE-METHOD, which is definitely
+;;;; wrong -- so test this for now at least.
+
+(defvar *magic-symbol* (gensym "MAGIC"))
+
+(set *magic-symbol* 42)
+
+(defmethod slot-missing (class instance (slot-name (eql *magic-symbol*)) op
+ &optional new)
+ (if (eq 'setf op)
+ (setf (symbol-value *magic-symbol*) new)
+ (symbol-value *magic-symbol*)))
+
+(assert (eql 42 (slot-value (cons t t) *magic-symbol*)))
+(assert (eql 13 (setf (slot-value 123 *magic-symbol*) 13)))
+(assert (eql 13 (slot-value 'foobar *magic-symbol*)))
+
+;;;; Built-in structure and condition layouts should have NIL in
+;;;; LAYOUT-FOR-STD-CLASS-P, and classes should have T.
+
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'warning))))
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'hash-table))))
+(assert (eq t (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'standard-object))))
+
+;;;; bug 402: PCL used to warn about non-standard declarations
+(declaim (declaration bug-402-d))
+(defgeneric bug-402-gf (x))
+(with-test (:name :bug-402)
+ (handler-bind ((warning #'error))
+ (eval '(defmethod bug-402-gf (x)
+ (declare (bug-402-d x))
+ x))))
+
+;;;; non-keyword :default-initargs + :before method on shared initialize
+;;;; interacted badly with CTOR optimizations
+(defclass ctor-default-initarg-problem ()
+ ((slot :initarg slotto))
+ (:default-initargs slotto 123))
+(defmethod shared-initialize :before ((instance ctor-default-initarg-problem) slot-names &rest initargs)
+ (format t "~&Rock on: ~A~%" initargs))
+(defun provoke-ctor-default-initarg-problem ()
+ (make-instance 'ctor-default-initarg-problem))
+(handler-bind ((warning #'error))
+ (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot))))
+
+;;;; discriminating net on streams used to generate code deletion notes on
+;;;; first call
+(defgeneric stream-fd (stream direction))
+(defmethod stream-fd ((stream sb-sys:fd-stream) direction)
+ (declare (ignore direction))
+ (sb-sys:fd-stream-fd stream))
+(defmethod stream-fd ((stream synonym-stream) direction)
+ (stream-fd (symbol-value (synonym-stream-symbol stream)) direction))
+(defmethod stream-fd ((stream two-way-stream) direction)
+ (ecase direction
+ (:input
+ (stream-fd
+ (two-way-stream-input-stream stream) direction))
+ (:output
+ (stream-fd
+ (two-way-stream-output-stream stream) direction))))
+(with-test (:name (:discriminating-name :code-deletion-note))
+ (handler-bind ((compiler-note #'error))
+ (stream-fd sb-sys:*stdin* :output)
+ (stream-fd sb-sys:*stdin* :output)))
+
+(with-test (:name :bug-380)
+ (defclass bug-380 ()
+ ((slot :accessor bug380-slot)))
+ (fmakunbound 'foo-slot)
+ (defgeneric foo-slot (x y z))
+ (defclass foo ()
+ ((slot :accessor foo-slot-value))))
\f
;;;; success