X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=d5116f999bca40a8a6d59e87d26a0acebbce8449;hb=8c81c0972f9e70f124b57394b5be29d9e661a0c7;hp=22cbcb17693a202431344a055884e7a1ad442179;hpb=84ad2fa18ae17072b78199977d1edef5168c176c;p=sbcl.git

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index 22cbcb1..d5116f9 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -89,7 +89,7 @@
 ;;; that it is at least possible to define classes with that as a
 ;;; metaclass.
 (defclass gf-class (standard-generic-function) ()
-  (:metaclass sb-pcl::funcallable-standard-class))
+  (:metaclass funcallable-standard-class))
 (defgeneric g (a b c)
   (:generic-function-class gf-class))
 
@@ -109,20 +109,66 @@
 ;;; of all built-in-classes is of the relevant type)
 (assert (null (class-prototype (find-class 'null))))
 
-;;; simple consistency checks for the SB-PCL (perhaps AKA SB-MOP)
-;;; package: all of the functionality specified in AMOP is in
-;;; functions:
-(assert (null (loop for x being each external-symbol in "SB-PCL"
-		    unless (fboundp x) collect x)))
-;;; and all generic functions in SB-PCL have at least one specified
+;;; simple consistency checks for the SB-MOP package: all of the
+;;; functionality specified in AMOP is in functions and classes:
+(assert (null (loop for x being each external-symbol in "SB-MOP"
+		    unless (or (fboundp x) (find-class x)) collect x)))
+;;; and all generic functions in SB-MOP have at least one specified
 ;;; method, except for UPDATE-DEPENDENT
-(assert (null (loop for x being each external-symbol in "SB-PCL"
-		    unless (or (eq x 'update-dependent)
+(assert (null (loop for x being each external-symbol in "SB-MOP"
+		    unless (or (not (fboundp x))
+			       (eq x 'update-dependent)
 			       (not (typep (fdefinition x) 'generic-function))
 			       (> (length (generic-function-methods
 					   (fdefinition x)))
 				  0))
 		    collect x)))
 
+;;; make sure that ENSURE-CLASS-USING-CLASS's arguments are the right
+;;; way round (!)
+(defvar *e-c-u-c-arg-order* nil)
+(defmethod ensure-class-using-class :after
+    (class (name (eql 'e-c-u-c-arg-order)) &key &allow-other-keys)
+  (setf *e-c-u-c-arg-order* t))
+(defclass e-c-u-c-arg-orderoid () ())
+(assert (null *e-c-u-c-arg-order*))
+(defclass e-c-u-c-arg-order () ())
+(assert (eq *e-c-u-c-arg-order* t))
+
+;;; verify that FIND-CLASS works after FINALIZE-INHERITANCE
+(defclass automethod-class (standard-class) ())
+(defmethod validate-superclass ((c1 automethod-class) (c2 standard-class))
+  t)
+(defmethod finalize-inheritance :after ((x automethod-class))
+  (format t "~&~S ~S~%" x (find-class (class-name x))))
+(defclass automethod-object () ()
+  (:metaclass automethod-class))
+(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"))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)