Compatibility version 0.8.1.
[lisp-unit.git] / internal-test / fundamental-assertions.lisp
blob818d40117ea6a95c6124a4c3ef15c6557d2cfc79
1 #|
3 LISP-UNIT Internal Tests
5 Copyright (c) 2010-2012, Thomas M. Hermann
6 All rights reserved.
8 Redistribution and use in source and binary forms, with or without
9 modification, are permitted provided that the following conditions are
10 met:
12 o Redistributions of source code must retain the above copyright
13 notice, this list of conditions and the following disclaimer.
14 o Redistributions in binary form must reproduce the above copyright
15 notice, this list of conditions and the following disclaimer in
16 the documentation and/or other materials provided with the
17 distribution.
18 o The names of the contributors may not be used to endorse or promote
19 products derived from this software without specific prior written
20 permission.
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
25 PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
26 OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
27 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
28 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 (in-package :lisp-unit)
38 ;;; Internal utility functions
40 (defun %expansion-equal (form1 form2)
41 "Descend into the forms checking for equality."
42 (let ((item1 (first form1))
43 (item2 (first form2)))
44 (cond
45 ((and (null item1) (null item2)))
46 ((and (listp item1) (listp item2))
47 (and (%expansion-equal item1 item2)
48 (%expansion-equal (rest form1) (rest form2))))
49 ((and (symbolp item1) (symbolp item2))
50 (and (string= (symbol-name item1) (symbol-name item2))
51 (%expansion-equal (rest form1) (rest form2))))
52 (t nil))))
54 (defun expansion-equal (macro-form expansion)
55 "MACROEXPAND-1 the macro-form and compare with the expansion."
56 (let ((*gensym-counter* 1))
57 (%expansion-equal (macroexpand-1 macro-form) expansion)))
59 (defun test-macro-expansions (expansions)
60 "Test each fundamental assertion and report the results."
61 (loop for (assertion macro-form expansion) in expansions collect
62 (list assertion (expansion-equal macro-form expansion))))
64 ;;; Expansions
66 (defvar *expand-assert-expansions*
67 '(("EXPAND-ASSERT-BASIC"
68 (expand-assert
69 :equal form form expected (extra1 extra2) :test #'eq)
70 (INTERNAL-ASSERT :EQUAL
71 (QUOTE FORM)
72 (LAMBDA NIL FORM)
73 (LAMBDA NIL EXPECTED)
74 (EXPAND-EXTRAS (EXTRA1 EXTRA2))
75 (FUNCTION EQ)))
76 ("EXPAND-ASSERT-ERROR"
77 (expand-assert
78 :error form (expand-error-form form) condition (extra1 extra2))
79 (INTERNAL-ASSERT :ERROR
80 (QUOTE FORM)
81 (LAMBDA NIL (HANDLER-CASE FORM (CONDITION (ERROR) ERROR)))
82 (LAMBDA NIL (QUOTE CONDITION))
83 (EXPAND-EXTRAS (EXTRA1 EXTRA2))
84 (FUNCTION EQL)))
85 ("EXPAND-ASSERT-MACRO"
86 (expand-assert
87 :macro form
88 (expand-macro-form form nil)
89 expansion (extra1 extra2))
90 (INTERNAL-ASSERT :MACRO
91 (QUOTE FORM)
92 (LAMBDA NIL (MACROEXPAND-1 (QUOTE FORM) NIL))
93 (LAMBDA NIL EXPANSION)
94 (EXPAND-EXTRAS (EXTRA1 EXTRA2))
95 (FUNCTION EQL)))
96 ("EXPAND-ASSERTS-PRINT"
97 (expand-assert
98 :output form (expand-output-form form) output (extra1 extra2))
99 (INTERNAL-ASSERT :OUTPUT
100 (QUOTE FORM)
101 (LAMBDA NIL
102 (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM))
103 (*STANDARD-OUTPUT* (MAKE-BROADCAST-STREAM
104 *STANDARD-OUTPUT* #:G1)))
105 FORM
106 (GET-OUTPUT-STREAM-STRING #:G1)))
107 (LAMBDA NIL OUTPUT)
108 (EXPAND-EXTRAS (EXTRA1 EXTRA2))
109 (FUNCTION EQL))))
110 "The correct expansions for the expand-assert macro.")
112 (defvar *expansion-macros*
113 '(("EXPAND-ERROR-FORM"
114 (expand-error-form form)
115 (HANDLER-CASE FORM (CONDITION (ERROR) ERROR)))
116 ("EXPAND-OUTPUT-FORM"
117 (expand-output-form form)
118 (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM))
119 (*STANDARD-OUTPUT*
120 (MAKE-BROADCAST-STREAM *STANDARD-OUTPUT* #:G1)))
121 FORM
122 (GET-OUTPUT-STREAM-STRING #:G1)))
123 ("EXPAND-MACRO-FORM"
124 (expand-macro-form form env)
125 (MACROEXPAND-1 'FORM ENV))
126 ("EXPAND-EXTRAS"
127 (expand-extras (extra1 extra2))
128 (LAMBDA NIL (LIST (QUOTE EXTRA1) EXTRA1 (QUOTE EXTRA2) EXTRA2))))
129 "The correct expansions for macros that expand forms.")
131 (defvar *fundamental-assertion-expansions*
132 '(("ASSERT-EQ"
133 (assert-eq expected form extra1 extra2)
134 (EXPAND-ASSERT
135 :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQ)))
136 ("ASSERT-EQL"
137 (assert-eql expected form extra1 extra2)
138 (EXPAND-ASSERT
139 :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQL)))
140 ("ASSERT-EQUAL"
141 (assert-equal expected form extra1 extra2)
142 (EXPAND-ASSERT
143 :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUAL)))
144 ("ASSERT-EQUALP"
145 (assert-equalp expected form extra1 extra2)
146 (EXPAND-ASSERT
147 :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUALP)))
148 ("ASSERT-ERROR"
149 (assert-error 'condition form extra1 extra2)
150 (EXPAND-ASSERT
151 :ERROR FORM (EXPAND-ERROR-FORM FORM) 'CONDITION (EXTRA1 EXTRA2)))
152 ("ASSERT-EXPANDS"
153 (assert-expands expansion form extra1 extra2)
154 (EXPAND-ASSERT
155 :MACRO FORM (EXPAND-MACRO-FORM FORM NIL) EXPANSION (EXTRA1 EXTRA2)))
156 ("ASSERT-FALSE"
157 (assert-false form extra1 extra2)
158 (EXPAND-ASSERT :RESULT FORM FORM NIL (EXTRA1 EXTRA2)))
159 ("ASSERT-EQUALITY"
160 (assert-equality test expected form extra1 extra2)
161 (EXPAND-ASSERT
162 :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST TEST))
163 ("ASSERT-PRINTS"
164 (assert-prints output form extra1 extra2)
165 (EXPAND-ASSERT
166 :OUTPUT FORM (expand-output-form form) OUTPUT (EXTRA1 EXTRA2)))
167 ("ASSERT-TRUE"
168 (assert-true form extra1 extra2)
169 (EXPAND-ASSERT :RESULT FORM FORM T (EXTRA1 EXTRA2))))
170 "The correct expansions for the fundamental assertions.")