Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / 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))))