internal-test/fundamental-assertions.lisp

   1 #|
   2
   3  LISP-UNIT Internal Tests
   4
   5  Copyright (c) 2010-2012, Thomas M. Hermann
   6  All rights reserved.
   7
   8  Redistribution and  use  in  source  and  binary  forms, with or without
   9  modification, are permitted  provided  that the following conditions are
  10  met:
  11
  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.
  21
  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.
  33
  34 |#
  35
  36 (in-package :lisp-unit)
  37
  38 ;;; Internal utility functions
  39
  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))))
  53
  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)))
  58
  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))))
  63
  64 ;;; Expansions
  65
  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.")
 111
 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.")
 130
 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.")