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 (with-test (:name (case :duplicate-key :compile-time-warning))
  17  (loop
  18     for (expected kind . clauses) in
  19       '((nil
  20          case (1 1)
  21               (2 2)
  22               (3 3))
  23
  24         ("Duplicate key 1 in CASE form, occurring in the first clause:  (1 1), and the second clause:  (1 2)"
  25          case (1 1)
  26               (1 2))
  27
  28         ("Duplicate key 2 in CASE form, occurring in the first clause:  ((1 2) 1), and the second clause:  ((2 3) 2)"
  29          case ((1 2) 1)
  30               ((2 3) 2))
  31
  32         (nil
  33          case (#1=(1) 1)
  34               ((#1#) 2)))
  35     for form = `(lambda ()
  36                   (,kind *readtable*
  37                          ,@clauses))
  38     do
  39       (multiple-value-bind (fun failure-p warnings style-warnings)
  40           (checked-compile form :allow-style-warnings (when expected t))
  41         (declare (ignore failure-p warnings))
  42         (assert (functionp fun))
  43         (when expected
  44           (dolist (warning style-warnings)
  45             (assert (search expected
  46                             (with-standard-io-syntax
  47                               (let ((*print-right-margin* nil)
  48                                     (*print-pretty* t))
  49                                 (remove #\Newline (princ-to-string warning)))))
  50                     ()
  51                     "~S should have warned ~S, but instead warned: ~A"
  52                     form expected warning))
  53           (assert style-warnings ()
  54                   "~S should have warned ~S, but didn't."
  55                   form expected)))))
  56
  57 (with-test (:name :duplicate-cases-load)
  58   (assert (load "case-test.lisp")))