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 (cl:in-package :cl-user)
  15
  16 (loop
  17   for (expected kind . clauses) in
  18     '((nil
  19        case (1 1)
  20             (2 2)
  21             (3 3))
  22       ("Duplicate key 1 in CASE form, occurring in the first clause:  (1 1), and the second clause:  (1 2)"
  23        case (1 1)
  24             (1 2))
  25       ("Duplicate key 2 in CASE form, occurring in the first clause:  ((1 2) 1), and the second clause:  ((2 3) 2)"
  26        case ((1 2) 1)
  27             ((2 3) 2))
  28       (nil
  29        case (#1=(1) 1)
  30             ((#1#) 2)))
  31   for form = `(lambda ()
  32                 (,kind *readtable*
  33                   ,@clauses))
  34   do
  35     (multiple-value-bind (fun warnings-p failure-p)
  36         (handler-bind ((style-warning (lambda (c)
  37                         (if expected
  38                           (assert (search expected
  39                                           (with-standard-io-syntax
  40                                             (let ((*print-right-margin* nil)
  41                                                   (*print-pretty* t))
  42                                               (remove #\Newline (princ-to-string c)))))
  43                                   ()
  44                                   "~S should have warned ~S, but instead warned: ~A" form expected c)
  45                           (error "~S shouldn't give a warning, but did: ~A" form c))
  46                         (setf expected nil))))
  47           (compile nil form))
  48       (assert (functionp fun))
  49       (assert (null expected)
  50               ()
  51               "~S should have warned ~S, but didn't."
  52               form expected)
  53       (assert (not failure-p))))