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 (in-package :cl-user)
  15
  16 (defun type= (left right)
  17   (and (subtypep left right) (subtypep right left)))
  18
  19 ;;; Custom specializer 1
  20 ;;;
  21 ;;; Always signals an error when parsing the specializer specifier.
  22
  23 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  24                                                  (specializer-name (eql 'custom-1)))
  25   (error "Intentional error"))
  26
  27 ;;; Custom specializer 2
  28 ;;;
  29 ;;; Can be parsed but fails to define a method on
  30 ;;; SPECIALIZER-TYPE-SPECIFIER.
  31
  32 (defclass custom-2-impl (sb-pcl:specializer)
  33   ())
  34
  35 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  36                                                  (specializer-name (eql 'custom-2)))
  37   (make-instance 'custom-2-impl))
  38
  39 ;;; Custom specializer 3
  40 ;;;
  41 ;;; Can be parsed and has a suitable method on
  42 ;;; SPECIALIZER-TYPE-SPECIFIER.
  43
  44 (defclass custom-3-impl (sb-pcl:specializer)
  45   ())
  46
  47 (defmethod sb-pcl:parse-specializer-using-class ((generic-function standard-generic-function)
  48                                                  (specializer-name (eql 'custom-3)))
  49   (make-instance 'custom-3-impl))
  50
  51 (defmethod sb-pcl:specializer-type-specifier ((proto-generic-function standard-generic-function)
  52                                               (proto-method standard-method)
  53                                               (specializer custom-3-impl))
  54   'custom-3)
  55
  56 ;;; Test
  57
  58 (with-test (:name (sb-pcl:specializer-type-specifier :smoke))
  59   (let* ((proto-gf (sb-pcl:class-prototype
  60                     (find-class 'standard-generic-function)))
  61          (proto-method (sb-pcl:class-prototype
  62                         (find-class 'standard-method))))
  63     (flet ((parse (specializer-specifier)
  64              (sb-pcl:parse-specializer-using-class
  65               proto-gf specializer-specifier))
  66            (test (specializer expected)
  67              (flet ((compute-it ()
  68                       (sb-pcl:specializer-type-specifier
  69                        proto-gf proto-method specializer)))
  70                (case expected
  71                  (error
  72                   (assert-error (compute-it)))
  73                  (warning
  74                   (assert (null (assert-signal (compute-it) warning))))
  75                  (style-warning
  76                   (assert (null (assert-signal (compute-it) style-warning))))
  77                  (t
  78                   (assert (type= (compute-it) expected)))))))
  79       ;; Non-parsed class specializers
  80       (test 'package                            'package)
  81       (test 'integer                            'integer)
  82       (test 'class                              nil)
  83       (test 'no-such-class                      'style-warning)
  84
  85       (test '(eql 5)                            '(eql 5))
  86       (test '(sb-pcl::class-eq integer)         'integer)
  87       (test '(sb-pcl::class-eq class)           nil)
  88
  89       (test 'custom-1                           'style-warning) ; fails to parse
  90       (test 'custom-2                           'warning)       ; no method
  91       (test 'custom-3                           'custom-3)
  92
  93       ;; Parsed EQL and CLASS-EQ specializers
  94       (test (parse '(eql 5))                    '(eql 5) )
  95       (test (parse '(sb-pcl::class-eq integer)) 'integer)
  96       (test (parse '(sb-pcl::class-eq class))   nil)
  97
  98       ;; Parsed class specializers
  99       (test (find-class 'package)               'package)
 100       (test (find-class 'integer)               'integer)
 101       (test (find-class 'class)                 nil)
 102
 103       ;; Parsed custom specializer
 104       (test (make-instance 'custom-3-impl)      'custom-3))))