tests/clos-call-next-method.impure.lisp

   1 ;;;; Testing CALL-NEXT-METHOD.
   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 ;;; CALL-NEXT-METHOD arguments are only fully checked on high safety.
  15 (declaim (optimize (safety 3)))
  16
  17 ;;; Utilities
  18 ;;;
  19 ;;; It makes sense to cover all permutations of arguments since the
  20 ;;; order of calls can affect the construction of the CALL-NEXT-METHOD
  21 ;;; argument checker.
  22
  23 ;;; Assumes unique elements in SEQUENCE.
  24 (defun map-permutations (function sequence)
  25   (labels ((rec (partial-permutation remainder)
  26              (if (null remainder)
  27                  (funcall function partial-permutation)
  28                  (map nil (lambda (element)
  29                             (rec (list* element partial-permutation)
  30                                  (remove element remainder)))
  31                       remainder))))
  32     (rec '() sequence)))
  33
  34 ;;; RESET-FUNCTION is used to reset the generic function between
  35 ;;; permutations so caches are built up from scratch according to the
  36 ;;; following call sequence.
  37 (defun map-test-case-permutations (reset-function check-function test-cases)
  38   (map-permutations
  39    (lambda (permutation)
  40      (funcall reset-function)
  41      (map nil (lambda (arguments-and-expected)
  42                 (destructuring-bind (arguments expected) arguments-and-expected
  43                   (funcall check-function arguments expected)))
  44           permutation))
  45    test-cases))
  46
  47 ;;; Make sure CALL-NEXT-METHOD calls that result in different sets of
  48 ;;; applicable methods signal errors.
  49
  50 (defgeneric different-applicable-methods (thing)
  51   (:method ((thing t))
  52     (list 't thing))
  53   (:method ((thing null))
  54     (list 'null thing))
  55   (:method ((thing list))
  56     (list 'list (call-next-method (rest thing))))
  57   (:method ((thing cons))
  58     (list 'cons (call-next-method (rest thing)))))
  59
  60 (with-test (:name (call-next-method :different-applicable-methods))
  61   (map-test-case-permutations
  62    (lambda ()
  63      (sb-pcl::update-dfun #'different-applicable-methods ))
  64    (lambda (arguments expected)
  65      (flet ((do-it ()
  66               (apply #'different-applicable-methods arguments)))
  67        (case expected
  68          (error (assert-error (do-it)))
  69          (t (assert (equal (do-it) expected))))))
  70    '((((1 2 3)) (cons (list (t (3)))))
  71      (((1 2))   error)
  72      (((1))     error)
  73      ((nil)     (null nil)))))
  74
  75 ;;; Test calling the next method with non-EQL arguments of the same
  76 ;;; class.
  77
  78 (defgeneric non-eql-arguments (x)
  79   (:method ((x t))
  80     (list 't x))
  81   (:method ((x number))
  82     (list 'number (call-next-method (1+ x))))
  83   (:method ((x real))
  84     (list 'real (call-next-method (1+ x))))
  85   (:method ((x integer))
  86     (list 'integer (call-next-method (1+ x)))))
  87
  88 (with-test (:name (call-next-method :same-applicable-methods :non-eql-arguments))
  89   (map-test-case-permutations
  90    (lambda ()
  91      (sb-pcl::update-dfun #'non-eql-arguments))
  92    (lambda (arguments expected)
  93      (assert (equal (apply #'non-eql-arguments arguments) expected)))
  94    '(((1)       (integer (real (number (t 4)))))
  95      ((1/2)     (real (number (t 5/2))))
  96      ((#C(1 2)) (number (t #C(2 2)))))))
  97
  98 ;;; Test EQL specializers which always require a dedicated method in
  99 ;;; the CALL-NEXT-METHOD argument checker.
 100
 101 (defgeneric eql-specializer (x)
 102   (:method ((x t))
 103     (list 't x))
 104   (:method ((x number))
 105     (list 'number (call-next-method (1+ x))))
 106   (:method ((x real))
 107     (list 'real (call-next-method (1+ x))))
 108   (:method ((x integer))
 109     (list 'integer (call-next-method (1+ x))))
 110   (:method ((x (eql 4)))
 111     (list 'eql 4 (call-next-method (1+ x))))
 112   (:method ((x (eql 5)))
 113     (list 'eql 5 (call-next-method (1+ x)))))
 114
 115 (with-test (:name (call-next-method :eql-specializer))
 116   (map-test-case-permutations
 117    (lambda ()
 118      (sb-pcl::update-dfun #'eql-specializer))
 119    (lambda (arguments expected)
 120      (flet ((do-it ()
 121               (apply #'eql-specializer arguments)))
 122        (case expected
 123          (error (assert-error (do-it)))
 124          (t (assert (equal (do-it) expected))))))
 125    '(((0)       (integer (real (number (t 3)))))
 126      ((1)       error)
 127      ;; ((2)       error) ; too slow otherwise (exponential scaling)
 128      ((3)       error)
 129      ;; ((4)       error)
 130      ((5)       error)
 131      ((6)       (integer (real (number (t 9)))))
 132      ((1/2)     (real (number (t 5/2))))
 133      ((#C(1 2)) (number (t #C(2 2))))
 134      ((:foo)    (t :foo)))))