;;;; 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.
;;;; 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.
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(defmacro raises-error? (&body body)
- `(typep (nth-value 1 (ignore-errors ,@body)) 'error))
+(defmacro raises-error? (form &optional (error-subtype-spec 'error))
+ `(typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec))
;;; EXPR is an expression to evaluate (both with EVAL and with
;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
;;; EXPR is an expression to evaluate (both with EVAL and with
;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
;;; shorthand for special cases of EXPECTED-LAMBDA.
;;;
;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
;;; shorthand for special cases of EXPECTED-LAMBDA.
;;;
-;;; Use EXPECTED-ERROR to require an error to be thrown. Use
-;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and
+;;; Use EXPECTED-ERROR to require an error to be signalled. Use
+;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
- &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))
(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)
(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)