X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fmop.impure.lisp;h=3b9aede2ad6a5742866b270c9a3fe23feae432ec;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=9f2e9e53062464fc1e2970d5b13a8b943f2ac058;hpb=53e87d8996712548798736a2b85f9fccf200e76a;p=sbcl.git diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 9f2e9e5..3b9aede 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -146,5 +146,288 @@ (defvar *automethod-object* (make-instance 'automethod-object)) (assert (typep *automethod-object* 'automethod-object)) +;;; COMPUTE-EFFECTIVE-SLOT-DEFINITION should take three arguments, one +;;; of which is the name of the slot. +(defvar *compute-effective-slot-definition-count* 0) +(defmethod compute-effective-slot-definition :before + (class (name (eql 'foo)) dsds) + (incf *compute-effective-slot-definition-count*)) +(defclass cesd-test-class () + ((foo :initarg :foo))) +(make-instance 'cesd-test-class :foo 3) +;;; FIXME: this assertion seems a little weak. I don't know why +;;; COMPUTE-EFFECTIVE-SLOT-DEFINITION gets called twice in this +;;; sequence, nor whether that's compliant with AMOP. -- CSR, +;;; 2003-04-17 +(assert (> *compute-effective-slot-definition-count* 0)) + +;;; this used to cause a nasty uncaught metacircularity in PCL. +(defclass substandard-method (standard-method) ()) +(defgeneric substandard-defgeneric (x y) + (:method-class substandard-method) + (:method ((x number) (y number)) (+ x y)) + (:method ((x string) (y string)) (concatenate 'string x y))) +(assert (= (substandard-defgeneric 1 2) 3)) +(assert (string= (substandard-defgeneric "1" "2") "12")) + +(let* ((x (find-class 'pathname)) + (xs (class-direct-subclasses x))) + (assert (>= (length xs) 1)) + (assert (member (find-class 'logical-pathname) xs))) + +;;; BUG 338: "MOP specializers as type specifiers" +;;; (reported by Bruno Haible sbcl-devel 2004-06-11) +(let* ((m (defmethod eql-specialized-method ((x (eql 4.0))) 3.0)) + (spec (first (sb-mop:method-specializers m)))) + (assert (not (typep 1 spec))) + (assert (typep 4.0 spec))) + +;;; BUG #334, relating to programmatic addition of slots to a class +;;; with COMPUTE-SLOTS. +;;; +;;; FIXME: the DUMMY classes here are to prevent class finalization +;;; before the compute-slots method is around. This should probably +;;; be done by defining the COMPUTE-SLOTS methods on a metaclass, +;;; which can be defined before. +;;; +;;; a. adding an :allocation :instance slot +(defclass class-to-add-instance-slot (dummy-ctais) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-instance-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :instance)))) +(defclass dummy-ctais () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-instance-slot))) + ;; FIXME: is the order really guaranteed? + '(:class :instance))) +(assert (typep (slot-definition-location + (cadr (class-slots (find-class 'class-to-add-instance-slot)))) + 'unsigned-byte)) +#| (assert (typep (slot-definition-location (car ...)) '???)) |# +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) t) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(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)))) + +;;; b. adding an :allocation :class slot +(defclass class-to-add-class-slot (dummy-ctacs) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-class-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :class)))) +(defclass dummy-ctacs () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-class-slot))) + '(:class :class))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) nil) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (slot-boundp x 'x)) + (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 +(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)) + +;;; class as :metaclass +(assert (typep + (sb-mop:ensure-class-using-class + nil 'class-as-metaclass-test + :metaclass (find-class 'standard-class) + :name 'class-as-metaclass-test + :direct-superclasses (list (find-class 'standard-object))) + 'class)) + +;;; COMPUTE-DEFAULT-INITARGS protocol mismatch reported by Bruno +;;; Haible +(defparameter *extra-initarg-value* 'extra) +(defclass custom-default-initargs-class (standard-class) + ()) +(defmethod compute-default-initargs ((class custom-default-initargs-class)) + (let ((original-default-initargs + (remove-duplicates + (reduce #'append + (mapcar #'class-direct-default-initargs + (class-precedence-list class))) + :key #'car + :from-end t))) + (cons (list ':extra '*extra-initarg-value* #'(lambda () *extra-initarg-value*)) + (remove ':extra original-default-initargs :key #'car)))) +(defmethod validate-superclass ((c1 custom-default-initargs-class) + (c2 standard-class)) + t) +(defclass extra-initarg () + ((slot :initarg :extra)) + (:metaclass custom-default-initargs-class)) +(assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra)) + ;;;; success (sb-ext:quit :unix-status 104)