tests/clos.pure.lisp

   1 ;;;; CLOS tests with no side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; not really a test for observable behaviour, but: make sure that
  15 ;;; all generic functions on startup have lambda lists known to the
  16 ;;; system, because some functionality (e.g. &key argument checking)
  17 ;;; depends on it.  The basic functionality is tested elsewhere, but
  18 ;;; this is to investigate the internals for possible inconsistency.
  19 (with-test (:name (:builtin-generic-functions :known :lambda-list))
  20   (let ((collect '()))
  21     (sb-pcl::map-all-generic-functions
  22      (lambda (gf)
  23        (let ((arg-info (sb-pcl::gf-arg-info gf)))
  24          (when (eq (sb-pcl::arg-info-lambda-list arg-info)
  25                    :no-lambda-list)
  26            (push gf collect)))))
  27     (assert (null collect))))
  28
  29 ;;; Regressing test for invalid slot specification error printing
  30 (with-test (:name (defclass :slot :syntax-error print))
  31   (multiple-value-bind (value err)
  32       (ignore-errors (macroexpand '(defclass foo () (frob (frob bar)))))
  33     (declare (ignore value))
  34     (assert (typep err 'simple-condition))
  35     (multiple-value-bind (value format-err)
  36         (ignore-errors (apply #'format nil
  37                               (simple-condition-format-control err)
  38                               (simple-condition-format-arguments err)))
  39       (declare (ignore value))
  40       (assert (not format-err)))))
  41
  42 (with-test (:name (defclass :initform type-error))
  43   (mapc (lambda (form)
  44           (assert (nth-value 1 (checked-compile
  45                                 `(lambda () ,form) :allow-warnings t))))
  46         '(;; Special-cased initforms
  47           (defclass foo () ((%bar :type integer :initform t)))
  48           (defclass foo () ((%bar :type integer :initform nil)))
  49           (defclass foo () ((%bar :type boolean :initform 0)))
  50           ;; Ordinary initforms
  51           (defclass foo () ((%bar :type integer :initform (lisp-implementation-version))))
  52           (defclass foo () ((%bar :type boolean :initform (random 2)))))))
  53
  54 ;;; another not (user-)observable behaviour: make sure that
  55 ;;; sb-pcl::map-all-classes calls its function on each class once and
  56 ;;; exactly once.
  57 (with-test (:name (sb-pcl::map-all-classes :no-duplicates))
  58   (let ((result '()))
  59     (sb-pcl::map-all-classes (lambda (c) (push c result)))
  60     (assert (equal result (remove-duplicates result)))))
  61
  62 ;;; this one's user-observable
  63 (with-test (:name (type-of (setf class-name)))
  64   (assert (typep #'(setf class-name) 'generic-function)))
  65
  66 ;;; CLHS 1.4.4.5.  We could test for this by defining methods
  67 ;;; (i.e. portably) but it's much easier using the MOP and
  68 ;;; MAP-ALL-CLASSES.
  69 (with-test (:name :check-standard-superclasses)
  70   (flet ((standardized-class-p (c)
  71            (and (class-name c)
  72                 (eq (symbol-package (class-name c))
  73                     (find-package :cl)))))
  74     (let (result)
  75       (sb-pcl::map-all-classes
  76        (lambda (c) (when (standardized-class-p c)
  77                      (let* ((cpl (sb-mop:class-precedence-list c))
  78                             (std (position (find-class 'standard-object) cpl))
  79                             (str (position (find-class 'structure-object) cpl))
  80                             (last (position-if
  81                                    #'standardized-class-p (butlast cpl)
  82                                    :from-end t)))
  83                        (when (and std str)
  84                          (push `(:and ,c) result))
  85                        (when (and str (< str last))
  86                          (push `(:str ,c) result))
  87                        (when (and std (< std last))
  88                          (push `(:std ,c) result))))))
  89       (assert (null result)))))
  90
  91 ;; No compiler-notes for non-constant slot-names in default policy.
  92 (with-test (:name (slot-value :no sb-ext:compiler-note))
  93   (checked-compile '(lambda (x y z)
  94                      (setf (slot-value x z) (slot-value y z)))
  95                    :allow-notes nil))
  96
  97 (defun assert-no-such-slot (obj slot-name)
  98   (dolist (method '(slot-value slot-boundp))
  99     (assert (eq :win
 100                 ;; the error that I want is about a missing slot,
 101                 ;; not a missing method, so don't let the compiler turn
 102                 ;; this into (funcall #'(SLOT-ACCESSOR :GLOBAL A READER)...)
 103                 (handler-case (eval `(,method ',obj ',slot-name))
 104                   (simple-condition (c)
 105                     (and (search "slot ~S is missing"
 106                                  (simple-condition-format-control c))
 107                          :win))))))
 108   ;; and of course SLOT-EXISTS-P should just return NIL
 109   (assert (not (slot-exists-p obj slot-name))))
 110
 111 (with-test (:name :slot-table-of-builtin-classoids)
 112   (assert-no-such-slot 'some-symbol 'some-slot)
 113   (assert-no-such-slot #P"foo" 'some-slot)
 114   (let ((lpn #p"sys:contrib;"))
 115     (assert (typep lpn 'logical-pathname))
 116     (assert-no-such-slot lpn 'some-slot)))
 117
 118 (with-test (:name :funcallable-instance-sxhash)
 119   (assert
 120    (/= (sxhash (make-instance 'sb-mop:funcallable-standard-object))
 121        (sxhash (make-instance 'sb-mop:funcallable-standard-object))
 122        42)))
 123
 124 (with-test (:name (typep :literal-class))
 125   (checked-compile-and-assert ()
 126       `(lambda (x)
 127          (typep x #.(find-class 'symbol)))
 128     (('x) t)))
 129
 130 (with-test (:name :slot-value-on-not-slot-object)
 131   (checked-compile-and-assert ()
 132                               `(lambda (x)
 133                                  (slot-value x 'm))
 134     ((nil) (condition 'sb-pcl::missing-slot)))
 135   (checked-compile-and-assert ()
 136                               `(lambda (x)
 137                                  (slot-boundp x 's))
 138     ((1) (condition 'sb-pcl::missing-slot)))
 139   (checked-compile-and-assert ()
 140                               `(lambda (x)
 141                                  (setf (slot-value x 'j) 30))
 142     ((1.0) (condition 'sb-pcl::missing-slot)))
 143   (checked-compile-and-assert ()
 144                               `(lambda (x)
 145                                  (slot-makunbound x 'l))
 146     ((#\a) (condition 'sb-pcl::missing-slot))))
 147
 148
 149 (with-test (:name :illegal-class-name)
 150   (checked-compile-and-assert
 151    ()
 152    `(lambda (x)
 153       (find-class x))
 154    (('(t)) (condition 'sb-kernel::illegal-class-name-error))))