X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fassertoid.lisp;h=a2bbd52248eaa0d0129c938b71f182b07985b5d2;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=f50270bb08fd379234dfa164f34175fa01450cb7;hpb=0957d59ccfaf3db9aaf79a7f4909a40ea0ca0dcd;p=sbcl.git

diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp
index f50270b..a2bbd52 100644
--- a/tests/assertoid.lisp
+++ b/tests/assertoid.lisp
@@ -7,14 +7,14 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
 (cl:defpackage "ASSERTOID"
   (:use "CL")
-  (:export "GRAB-CONDITION" "RAISES-ERROR?" "ASSERTOID"))
+  (:export "GRAB-CONDITION" "RAISES-ERROR?" "IS" "ASSERTOID"))
 
 (cl:in-package "ASSERTOID")
 
@@ -31,7 +31,7 @@
 ;;; expression to be tested in other than the default optimization
 ;;; level(s).
 ;;;
-;;; The messiness with the various flavors of EXPECTED stuff is 
+;;; The messiness with the various flavors of EXPECTED stuff is
 ;;; to handle various issues:
 ;;;   * Some things are expected to signal errors instead of returning
 ;;;     ordinary values.
@@ -48,68 +48,79 @@
 ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
 ;;; that further it satisfies the given lambda.
 (defmacro assertoid (expr
-		     &key
-		     extra-optimizations
-		     (expected-eql nil expected-eql-p)
-		     (expected-equal nil expected-equal-p)
-		     (expected-equalp nil expected-equalp-p)
-		     (expected-lambda (cond
-				       (expected-eql-p
-					(lambda (x)
-					  (eql x (eval expected-eql))))
-				       (expected-equal-p
-					(lambda (x)
-					  (equal x (eval expected-equal))))
-				       (expected-equalp-p
-					(lambda (x)
-					  (equalp x (eval expected-equalp))))
-				       (t
-					(lambda (x)
-					  x)))
-				      expected-lambda-p)
-		     (expected-error-type nil expected-error-type-p)
-		     (expected-error-lambda (if expected-error-type
-						(lambda (condition)
-						  (typep condition
-							 expected-error-type))
-					        nil)
-					    expected-error-lambda-p))
+                     &key
+                     extra-optimizations
+                     (expected-eql nil expected-eql-p)
+                     (expected-equal nil expected-equal-p)
+                     (expected-equalp nil expected-equalp-p)
+                     (expected-lambda (cond
+                                       (expected-eql-p
+                                        (lambda (x)
+                                          (eql x (eval expected-eql))))
+                                       (expected-equal-p
+                                        (lambda (x)
+                                          (equal x (eval expected-equal))))
+                                       (expected-equalp-p
+                                        (lambda (x)
+                                          (equalp x (eval expected-equalp))))
+                                       (t
+                                        (lambda (x)
+                                          x)))
+                                      expected-lambda-p)
+                     (expected-error-type nil expected-error-type-p)
+                     (expected-error-lambda (if expected-error-type
+                                                (lambda (condition)
+                                                  (typep condition
+                                                         expected-error-type))
+                                                nil)
+                                            expected-error-lambda-p))
   (when (> (count-if #'identity
-		     (vector expected-eql-p
-			     expected-equal-p
-			     expected-equalp-p
-			     expected-lambda-p
-			     expected-error-type-p
-			     expected-error-lambda-p))
-	   1)
+                     (vector expected-eql-p
+                             expected-equal-p
+                             expected-equalp-p
+                             expected-lambda-p
+                             expected-error-type-p
+                             expected-error-lambda-p))
+           1)
     (error "multiple EXPECTED-FOO arguments"))
   (when expected-error-lambda
     (error "stub: expected-error functionality not supported yet"))
   (let ((eval-expected-lambda (eval expected-lambda)))
     (flet ((frob (evaloid)
-		 (let ((result (funcall evaloid expr)))
-		   (unless (funcall eval-expected-lambda result)
-		     (error "failed assertoid" expr))))
-	   (compile-as-evaloid (optimizations)
+                 (let ((result (funcall evaloid expr)))
+                   (unless (funcall eval-expected-lambda result)
+                     (error "failed assertoid ~S" expr))))
+           (compile-as-evaloid (optimizations)
              (lambda (expr)
-	       (funcall (compile nil
-				 `(lambda ()
-				    (declare (optimize ,@optimizations))
-				    ,expr))))))
+               (funcall (compile nil
+                                 `(lambda ()
+                                    (declare (optimize ,@optimizations))
+                                    ,expr))))))
       (frob #'eval)
       (frob (compile-as-evaloid ()))
       (dolist (i extra-optimizations)
-	(frob (compile-as-evaloid i))))))
+        (frob (compile-as-evaloid i))))))
 
 ;;; examples
 (assertoid (= 2 (length (list 1 2))))
 (assertoid (= 2 (length (list 1 2)))
-	   :extra-optimizations (((speed 2) (space 3))
-				 ((speed 1) (space 3))))
+           :extra-optimizations (((speed 2) (space 3))
+                                 ((speed 1) (space 3))))
 (assertoid (cons 1 2)
-	   :expected-lambda (lambda (x) (equal x '(1 . 2))))
+           :expected-lambda (lambda (x) (equal x '(1 . 2))))
 (assertoid (cons (list 1 2) (list 1 2))
-	   :expected-equal '((1 2) 1 2))
+           :expected-equal '((1 2) 1 2))
 ;;; not implemented yet:
 #+nil (assertoid (length (eval (find-package :cl)))
-		 :expected-error-type 'type-error)
+                 :expected-error-type 'type-error)
+
+(defmacro is (form)
+  (if (consp form)
+      (destructuring-bind (op expected real) form
+        `(let ((expected-value ,expected)
+               (real-value ,real))
+           (unless (,op expected-value real-value)
+             (error "Wanted ~S, got ~S:~% ~S"
+                    expected-value real-value ',form))))
+      `(unless ,form
+         (error "~S evaluated to NIL" ',form))))