X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.pure.lisp;h=ae8b524a625b73914e1f6ebf87078927e8165e5a;hb=9b69e80c82ef126a8f9c120113d4e75b17845f13;hp=5a20e88af3531ed606721a27f48171fb03cb3e6f;hpb=b49f85124decb6b5e32e7a3919c024528680a7ac;p=sbcl.git

diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp
index 5a20e88..ae8b524 100644
--- a/tests/clos.pure.lisp
+++ b/tests/clos.pure.lisp
@@ -46,3 +46,38 @@
 (let (result)
   (sb-pcl::map-all-classes (lambda (c) (push c result)))
   (assert (equal result (remove-duplicates result))))
+
+;;; this one's user-observable
+(assert (typep #'(setf class-name) 'generic-function))
+
+;;; CLHS 1.4.4.5.  We could test for this by defining methods
+;;; (i.e. portably) but it's much easier using the MOP and
+;;; MAP-ALL-CLASSES.
+(flet ((standardized-class-p (c)
+         (eq (class-name c) (find-symbol (symbol-name (class-name c)) "CL"))))
+  (let (result)
+    (sb-pcl::map-all-classes
+     (lambda (c) (when (standardized-class-p c)
+                   (let* ((cpl (sb-mop:class-precedence-list c))
+                          (std (position (find-class 'standard-object) cpl))
+                          (str (position (find-class 'structure-object) cpl))
+                          (last (position-if
+                                 #'standardized-class-p (butlast cpl)
+                                 :from-end t)))
+                     (when (and std str)
+                       (push `(:and ,c) result))
+                     (when (and str (< str last))
+                       (push `(:str ,c) result))
+                     (when (and std (< std last))
+                       (push `(:std ,c) result))))))
+    (assert (null result))))
+
+;; No compiler-notes for non-constant slot-names in default policy.
+(handler-case
+    (compile nil '(lambda (x y z)
+                   (setf (slot-value x z)
+                         (slot-value y z))))
+  (sb-ext:compiler-note (e)
+    (error e)))
+
+