X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.pure.lisp;h=b35f47da2e967f79e2cff31bc54aba0c97f5e61f;hb=8a19ff566e3a1a43cb3b2d11d2781a1c89981f43;hp=f7a5e33e97d36000c37ed4161a971ef21be5b6f1;hpb=feea06ce0acba516d739867b23341509e9c36d50;p=sbcl.git

diff --git a/tests/mop.pure.lisp b/tests/mop.pure.lisp
index f7a5e33..b35f47d 100644
--- a/tests/mop.pure.lisp
+++ b/tests/mop.pure.lisp
@@ -30,3 +30,66 @@
   (assert (find (find-class 'sb-mop:metaobject)
                 (sb-mop:class-direct-superclasses (find-class name))))
   (assert (subtypep name 'sb-mop:metaobject)))
+
+;;; No portable class Cp may inherit, by virtue of being a direct or
+;;; indirect subclass of a specified class, any slot for which the
+;;; name is a symbol accessible in the common-lisp-user package or
+;;; exported by any package defined in the ANSI Common Lisp standard.
+(let ((specified-class-names
+       '(sb-mop:built-in-class
+         sb-mop:class
+         sb-mop:direct-slot-definition
+         sb-mop:effective-slot-definition
+         sb-mop:eql-specializer
+         sb-mop:forward-referenced-class
+         sb-mop:funcallable-standard-class
+         sb-mop:funcallable-standard-object
+         sb-mop:generic-function
+         sb-mop:metaobject
+         sb-mop:method
+         sb-mop:method-combination
+         sb-mop:slot-definition
+         sb-mop:specializer
+         sb-mop:standard-accessor-method
+         sb-mop:standard-class
+         sb-mop:standard-direct-slot-definition
+         sb-mop:standard-effective-slot-definition
+         sb-mop:standard-generic-function
+         sb-mop:standard-method
+         sb-mop:standard-object
+         sb-mop:standard-reader-method
+         sb-mop:standard-slot-definition
+         sb-mop:standard-writer-method)))
+  (labels ((slot-name-ok (name)
+             (dolist (package (mapcar #'find-package
+                                      '("CL" "CL-USER" "KEYWORD" "SB-MOP"))
+                      t)
+               (when (multiple-value-bind (symbol status)
+                         (find-symbol (symbol-name name) package)
+                       (and (eq symbol name)
+                            (or (eq package (find-package "CL-USER"))
+                                (eq status :external))))
+                 (return nil))))
+           (test-class-slots (class)
+             (loop for slot in (sb-mop:class-slots class)
+                   for slot-name = (sb-mop:slot-definition-name slot)
+                   unless (slot-name-ok slot-name)
+                   collect (cons class slot-name))))
+    (loop for class-name in specified-class-names
+          for class = (find-class class-name)
+          for results = (test-class-slots class)
+          when results do (cerror "continue" "~A" results))))
+
+;;; AMOP says these are the defaults
+(assert (equal (list (find-class 'standard-object))
+               (sb-mop:class-direct-superclasses (make-instance 'standard-class))))
+(assert (equal (list (find-class 'sb-mop:funcallable-standard-object))
+               (sb-mop:class-direct-superclasses (make-instance 'sb-mop:funcallable-standard-class))))
+
+(with-test (:name :bug-936513)
+  ;; This used to fail as ENSURE-GENERIC-FUNCTION wanted a list specifying
+  ;; the method combination, and didn't accept the actual object
+  (let ((mc (sb-pcl:find-method-combination #'make-instance 'standard nil)))
+    (ensure-generic-function 'make-instance :method-combination mc))
+  ;; Let's make sure the list works too...
+  (ensure-generic-function 'make-instance :method-combination '(standard)))