;;;; 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.
;;; 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))
+
+;;; 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)
+ (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))))