tests/case.pure.lisp

   1 ;;;; tests of the CASE family of macros without 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 (with-test (:name :keyform-always-used)
  15   (checked-compile '(lambda (x) (case x (t 'thing)))))
  16
  17 (with-test (:name (case :duplicate-key :compile-time-warning))
  18  (loop
  19     for (expected kind . clauses) in
  20       '((nil
  21          case (1 1)
  22               (2 2)
  23               (3 3))
  24
  25         ("Duplicate key 1 in CASE form, occurring in the first clause:  (1 1), and the second clause:  (1 2)"
  26          case (1 1)
  27               (1 2))
  28
  29         ("Duplicate key 2 in CASE form, occurring in the first clause:  ((1 2) 1), and the second clause:  ((2 3) 2)"
  30          case ((1 2) 1)
  31               ((2 3) 2))
  32
  33         (nil
  34          case (#1=(1) 1)
  35               ((#1#) 2)))
  36     for form = `(lambda ()
  37                   (,kind *readtable*
  38                          ,@clauses))
  39     do
  40       (multiple-value-bind (fun failure-p warnings style-warnings)
  41           (checked-compile form :allow-style-warnings (when expected t))
  42         (declare (ignore failure-p warnings))
  43         (assert (functionp fun))
  44         (when expected
  45           (dolist (warning style-warnings)
  46             (assert (search expected
  47                             (with-standard-io-syntax
  48                               (let ((*print-right-margin* nil)
  49                                     (*print-pretty* t))
  50                                 (remove #\Newline (princ-to-string warning)))))
  51                     ()
  52                     "~S should have warned ~S, but instead warned: ~A"
  53                     form expected warning))
  54           (assert style-warnings ()
  55                   "~S should have warned ~S, but didn't."
  56                   form expected)))))
  57
  58 (with-test (:name :duplicate-cases-load)
  59   (assert (load "case-test.lisp")))
  60
  61 (with-test (:name :no-notes-e-failure)
  62   (checked-compile '(lambda (x)
  63                      (when (typep x 'sequence)
  64                        (etypecase x
  65                          (list 1)
  66                          (sequence 10))))
  67                    :allow-notes nil)
  68   (checked-compile '(lambda (x)
  69                      (when (typep x 'symbol)
  70                        (ecase x
  71                          (a 1)
  72                          (2 10))))
  73                    :allow-notes nil))
  74
  75 (with-test (:name :duplicate-typecase)
  76   (assert (nth-value 3
  77                      (checked-compile '(lambda (x)
  78                                         (typecase x (number 1) (integer 2)))
  79                                       :allow-style-warnings t))))