X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.pure.lisp;h=425a0b2c96892d63304ef6d81a6baa72cf74bf5c;hb=9fb454f1a8211073b0e8446107e5abcba9ad2049;hp=a6a032d9f4623a423b038d303f1c3c57f5e1c7a5;hpb=9b87691b28b108737dd9eb3ff87abb98d1aed2c4;p=sbcl.git

diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp
index a6a032d..425a0b2 100644
--- a/tests/clos.pure.lisp
+++ b/tests/clos.pure.lisp
@@ -6,7 +6,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -19,11 +19,33 @@
 ;;; depends on it.  The basic functionality is tested elsewhere, but
 ;;; this is to investigate the internals for possible inconsistency.
 (assert (null
-	 (let (collect)
-	   (sb-pcl::map-all-generic-functions
-	    (lambda (gf)
-	      (let ((arg-info (sb-pcl::gf-arg-info gf)))
-		(when (eq (sb-pcl::arg-info-lambda-list arg-info)
-			  :no-lambda-list)
-		  (push gf collect)))))
-	   (print (nreverse collect)))))
+         (let (collect)
+           (sb-pcl::map-all-generic-functions
+            (lambda (gf)
+              (let ((arg-info (sb-pcl::gf-arg-info gf)))
+                (when (eq (sb-pcl::arg-info-lambda-list arg-info)
+                          :no-lambda-list)
+                  (push gf collect)))))
+           (print (nreverse collect)))))
+
+;;; Regressing test for invalid slot specification error printing
+(multiple-value-bind (value err)
+    (ignore-errors (macroexpand '(defclass foo () (frob (frob bar)))))
+  (declare (ignore value))
+  (assert (typep err 'simple-condition))
+  (multiple-value-bind (value format-err)
+      (ignore-errors (apply #'format nil
+                            (simple-condition-format-control err)
+                            (simple-condition-format-arguments err)))
+    (declare (ignore value))
+    (assert (not format-err))))
+
+;;; another not (user-)observable behaviour: make sure that
+;;; sb-pcl::map-all-classes calls its function on each class once and
+;;; exactly once.
+(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))