tests/specializer.impure.lisp

   1 ;;;; Tests for SBCL's extended specializers.
   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 ;;; Custom specializer 1
  15 ;;;
  16 ;;; Always signals an error when parsing the specializer specifier.
  17
  18 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  19                                                  (specializer-name (eql 'custom-1)))
  20   (error "Intentional error"))
  21
  22 ;;; Custom specializer 2
  23 ;;;
  24 ;;; Can be parsed but fails to define a method on
  25 ;;; SPECIALIZER-TYPE-SPECIFIER.
  26
  27 (defclass custom-2-impl (sb-mop:specializer)
  28   ())
  29
  30 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  31                                                  (specializer-name (eql 'custom-2)))
  32   (make-instance 'custom-2-impl))
  33
  34 ;;; Custom specializer 3
  35 ;;;
  36 ;;; Can be parsed and has a suitable method on
  37 ;;; SPECIALIZER-TYPE-SPECIFIER.
  38
  39 (defclass custom-3-impl (sb-mop:specializer)
  40   ())
  41
  42 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  43                                                  (specializer-name (eql 'custom-3)))
  44   (make-instance 'custom-3-impl))
  45
  46 (defmethod sb-pcl:specializer-type-specifier ((proto-generic-function standard-generic-function)
  47                                               (proto-method standard-method)
  48                                               (specializer custom-3-impl))
  49   'custom-3)
  50
  51 ;;; Test
  52
  53 (with-test (:name (sb-pcl:parse-specializer-using-class :smoke))
  54   (let ((proto-gf (sb-mop:class-prototype
  55                    (find-class 'standard-generic-function))))
  56     (flet ((test (specializer-name expected)
  57              (flet ((do-it ()
  58                       (sb-pcl:parse-specializer-using-class
  59                        proto-gf specializer-name)))
  60                (case expected
  61                  (sb-pcl:specializer-name-syntax-error
  62                   (assert-error (do-it) sb-pcl:specializer-name-syntax-error))
  63                  (sb-pcl:class-not-found-error
  64                   (assert-error (do-it) sb-pcl:class-not-found-error))
  65                  (t
  66                   (typecase expected
  67                     (sb-pcl::class-prototype-specializer
  68                      (assert (eq (sb-pcl::specializer-object (do-it))
  69                                  (sb-pcl::specializer-object expected))))
  70                     (t
  71                      (assert (eq (do-it) expected)))))))))
  72       ;; Atoms
  73       (test 1                                    'sb-pcl:specializer-name-syntax-error)
  74       (test nil                                  'sb-pcl:class-not-found-error)
  75
  76       (test t                                    (find-class t))
  77       (test 'null                                (find-class 'null))
  78       (test (find-class t)                       (find-class t))
  79       (test (find-class 'null)                   (find-class 'null))
  80
  81       ;; Lists
  82       (test `(1)                                 'sb-pcl:specializer-name-syntax-error)
  83       (test `(,(find-class t))                   'sb-pcl:specializer-name-syntax-error)
  84
  85       (test `(class)                             'sb-pcl:specializer-name-syntax-error)
  86       (test `(class t 2)                         'sb-pcl:specializer-name-syntax-error)
  87       (test `(class t)                           (find-class t))
  88       (test `(class ,(find-class t))             (find-class t))
  89
  90       (test `(sb-pcl::prototype)                 'sb-pcl:specializer-name-syntax-error)
  91       (test `(sb-pcl::prototype t 2)             'sb-pcl:specializer-name-syntax-error)
  92       (test `(sb-pcl::prototype t)               (make-instance 'sb-pcl::class-prototype-specializer
  93                                                                 :class (find-class t)))
  94       (test `(sb-pcl::prototype ,(find-class t)) (make-instance 'sb-pcl::class-prototype-specializer
  95                                                                 :class (find-class t)))
  96
  97       (test `(sb-pcl::class-eq)                  'sb-pcl:specializer-name-syntax-error)
  98       (test `(sb-pcl::class-eq t 2)              'sb-pcl:specializer-name-syntax-error)
  99       (test `(sb-pcl::class-eq t)                (sb-pcl::class-eq-specializer
 100                                                   (find-class t)))
 101       (test `(sb-pcl::class-eq ,(find-class t))  (sb-pcl::class-eq-specializer
 102                                                   (find-class t)))
 103
 104       (test `(eql)                               'sb-pcl:specializer-name-syntax-error)
 105       (test `(eql t 2)                           'sb-pcl:specializer-name-syntax-error)
 106       (test `(eql t)                             (sb-mop:intern-eql-specializer t)))))
 107
 108 (with-test (:name (sb-pcl:specializer-type-specifier :smoke))
 109   (let* ((proto-gf (sb-mop:class-prototype
 110                     (find-class 'standard-generic-function)))
 111          (proto-method (sb-mop:class-prototype
 112                         (find-class 'standard-method))))
 113     (flet ((parse (specializer-specifier)
 114              (sb-pcl:parse-specializer-using-class
 115               proto-gf specializer-specifier))
 116            (test (specializer expected)
 117              (flet ((compute-it ()
 118                       (sb-pcl:specializer-type-specifier
 119                        proto-gf proto-method specializer)))
 120                (case expected
 121                  (warning
 122                   (assert (null (assert-signal (compute-it) warning))))
 123                  (style-warning
 124                   (assert (null (assert-signal (compute-it) style-warning))))
 125                  (t
 126                   (assert (type-evidently-= (compute-it) expected)))))))
 127       ;; Non-parsed class specializers
 128       (test 'package                            'package)
 129       (test 'integer                            'integer)
 130       (test 'class                              nil)
 131       (test 'no-such-class                      'style-warning)
 132
 133       (test '(eql)                              'style-warning)
 134       (test '(eql 5)                            '(eql 5))
 135       (test '(eql 5 6)                          'style-warning)
 136       (test '(sb-pcl::class-eq integer)         'integer)
 137       (test '(sb-pcl::class-eq class)           nil)
 138
 139       (test 'custom-1                           'style-warning) ; fails to parse
 140       (test 'custom-2                           'warning)       ; no method
 141       (test 'custom-3                           'custom-3)
 142
 143       ;; Parsed EQL and CLASS-EQ specializers
 144       (test (parse '(eql 5))                    '(eql 5))
 145       (test (parse '(sb-pcl::class-eq integer)) 'integer)
 146       (test (parse '(sb-pcl::class-eq class))   nil)
 147
 148       ;; Parsed class specializers
 149       (test (find-class 'package)               'package)
 150       (test (find-class 'integer)               'integer)
 151       (test (find-class 'class)                 nil)
 152
 153       ;; Parsed custom specializer
 154       (test (make-instance 'custom-3-impl)      'custom-3))))