X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=28fccf3e17bcf4fe6c6abed8e8306cc5b50cc5f9;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=0382ddb5e2e5c0e010781a9378a01b3588a29da4;hpb=964e644f3f1ec2c169b1def87f11e2f5b09a748e;p=sbcl.git diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 0382ddb..28fccf3 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -239,11 +239,164 @@ (assert (eq nil (slot-value x 'x))) (assert (slot-boundp x 'y)) (assert (= 1 (slot-value x 'y)))) -;; extra paranoia: check that we haven't broken the instance-slot class +;;; extra paranoia: check that we haven't broken the instance-slot class (let ((x (make-instance 'class-to-add-instance-slot))) (assert (slot-boundp x 'x)) (assert (eq t (slot-value x 'x))) (assert (not (slot-boundp x 'y)))) +;;;; the CTOR optimization was insufficiently careful about its +;;;; assumptions: firstly, it failed with a failed AVER for +;;;; non-standard-allocation slots: +(defclass class-with-frob-slot () + ((frob-slot :initarg :frob-slot :allocation :frob))) +(handler-case + (funcall (compile nil '(lambda () + (make-instance 'class-with-frob-slot + :frob-slot 1)))) + (sb-int:bug (c) (error c)) + (error () "Probably OK: haven't implemented SLOT-BOUNDP-USING-CLASS")) +;;; secondly, it failed to take account of the fact that we might wish +;;; to customize (setf slot-value-using-class) +(defclass class-with-special-ssvuc () + ((some-slot :initarg :some-slot))) +(defvar *special-ssvuc-counter* 0) +(defmethod (setf slot-value-using-class) :before + (new-value class (instance class-with-special-ssvuc) slotd) + (incf *special-ssvuc-counter*)) +(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc + :some-slot 1))))) + (assert (= *special-ssvuc-counter* 0)) + (funcall fun) + (assert (= *special-ssvuc-counter* 1)) + (funcall fun) + (assert (= *special-ssvuc-counter* 2))) +;;; and now with the customization after running the function once +(defclass class-with-special-ssvuc-2 () + ((some-slot :initarg :some-slot))) +(defvar *special-ssvuc-counter-2* 0) +(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc-2 + :some-slot 1))))) + (assert (= *special-ssvuc-counter-2* 0)) + (funcall fun) + (assert (= *special-ssvuc-counter-2* 0)) + (defmethod (setf slot-value-using-class) :before + (new-value class (instance class-with-special-ssvuc-2) slotd) + (incf *special-ssvuc-counter-2*)) + (funcall fun) + (assert (= *special-ssvuc-counter-2* 1))) + +;;; vicious metacycle detection and resolution wasn't good enough: it +;;; didn't take account that the slots (and hence the slot readers) +;;; might be inherited from superclasses. This example, due to Bruno +;;; Haible, also tests programmatic addition of accessors. +(defclass auto-accessors-direct-slot-definition-class (standard-class) + ((containing-class-name :initarg :containing-class-name))) +(defmethod validate-superclass + ((c1 auto-accessors-direct-slot-definition-class) (c2 standard-class)) + t) +(defclass auto-accessors-class (standard-class) + ()) +(defmethod direct-slot-definition-class ((class auto-accessors-class) + &rest initargs) + (let ((dsd-class-name (gensym))) + (sb-pcl:ensure-class + dsd-class-name + :metaclass 'auto-accessors-direct-slot-definition-class + :direct-superclasses (list (find-class 'standard-direct-slot-definition)) + :containing-class-name (class-name class)) + (eval `(defmethod initialize-instance :after ((dsd ,dsd-class-name) + &rest args) + (when (and (null (slot-definition-readers dsd)) + (null (slot-definition-writers dsd))) + (let* ((containing-class-name + (slot-value (class-of dsd) 'containing-class-name)) + (accessor-name + (intern + (concatenate 'string + (symbol-name containing-class-name) + "-" + (symbol-name (slot-definition-name dsd))) + (symbol-package containing-class-name)))) + (setf (slot-definition-readers dsd) (list accessor-name)) + (setf (slot-definition-writers dsd) + (list (list 'setf accessor-name))))))) + (find-class dsd-class-name))) +(defmethod validate-superclass ((c1 auto-accessors-class) (c2 standard-class)) + t) +(defclass testclass15 () + ((x :initarg :x) (y)) + (:metaclass auto-accessors-class)) +(let ((inst (make-instance 'testclass15 :x 12))) + (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13)) + '(12 13)))) + +;;; bug reported by Bruno Haible on sbcl-devel 2004-11-17: incorrect +;;; handling of multiple values for non-standard slot-options +(progn + (defclass option-slot-definition (sb-mop:standard-direct-slot-definition) + ((option :accessor sl-option :initarg :my-option))) + (defclass option-slot-class (standard-class) + ()) + (defmethod sb-mop:direct-slot-definition-class + ((c option-slot-class) &rest args) + (declare (ignore args)) + (find-class 'option-slot-definition)) + (defmethod sb-mop:validate-superclass + ((c1 option-slot-class) (c2 standard-class)) + t) + (eval '(defclass test-multiple-slot-option-bug () + ((x :my-option bar :my-option baz)) + (:metaclass option-slot-class))) + (assert (null (set-difference + '(bar baz) + (sl-option (first (sb-mop:class-direct-slots + (find-class 'test-multiple-slot-option-bug)))))))) + +;;; bug reported by Bruno Haibel on sbcl-devel 2004-11-19: AMOP requires +;;; that CLASS-PROTOYPE signals an error if the class is not yet finalized +(defclass prototype-not-finalized-sub (prototype-not-finalized-super) ()) +(multiple-value-bind (val err) + (ignore-errors (sb-mop:class-prototype (find-class 'prototype-not-finalized-super))) + (assert (null val)) + (assert (typep err 'error))) + +;;; AMOP says so +(find-method (fdefinition 'sb-mop:allocate-instance) () '(built-in-class)) +(dolist (class-name '(fixnum bignum symbol)) + (let ((class (find-class class-name))) + (multiple-value-bind (value error) (ignore-errors (allocate-instance class)) + (assert (null value)) + (assert (typep error 'error))))) + +;;; bug reported by David Morse: direct-subclass update protocol was broken +(defclass vegetable () ()) +(defclass tomato (vegetable) ()) +(assert (equal (list (find-class 'tomato)) (sb-mop:class-direct-subclasses (find-class 'vegetable)))) +(defclass tomato () ()) +(assert (null (sb-mop:class-direct-subclasses (find-class 'vegetable)))) + +;;; bug 331: lazy creation of clos classes for defstructs +(defstruct bug-331-super) +(defstruct (bug-331-sub (:include bug-331-super))) +(let ((subs (sb-mop:class-direct-subclasses (find-class 'bug-331-super)))) + (assert (= 1 (length subs))) + (assert (eq (car subs) (find-class 'bug-331-sub)))) + +;;; detection of multiple class options in defclass, reported by Bruno Haible +(defclass option-class (standard-class) + ((option :accessor cl-option :initarg :my-option))) +(defmethod sb-pcl:validate-superclass ((c1 option-class) (c2 standard-class)) + t) +(multiple-value-bind (result error) + (ignore-errors (eval '(defclass option-class-instance () + () + (:my-option bar) + (:my-option baz) + (:metaclass option-class)))) + (assert (not result)) + (assert error)) + + ;;;; success (sb-ext:quit :unix-status 104)