Ticket #1754: 0001-Improve-test-suite-to-check-for-error-messages.patch

tests/run.scm

@@ -1 @@
-(import (chicken condition) sandbox) 
+(import (chicken condition) (chicken format) (chicken irregex) (chicken port) sandbox) 
 
 (define-syntax assert-error
   (syntax-rules ()
-    ((_ x)
-     (handle-exceptions ex 
-       (begin
-         (print-error-message ex)
-         #t)
-       x #f))))
+    ((_ expected x)
+     (assert
+      (handle-exceptions ex
+        (begin
+          (let ((error-message (with-output-to-string
+                                 (lambda ()
+                                   (print-error-message ex)))))
+            (when (not (irregex-search (irregex-quote expected) error-message))
+              (printf "Assertion message mismatch: ~s\n" error-message)
+              #f)))
+        x
+        (printf "Assertion not raised: ~s\n" 'x)
+        #f)))))
 
 (assert (= 123 (safe-eval 123)))    ;-->   123
 
-(assert-error (safe-eval 'abc))   ;-->   error
+(assert-error "Error: unbound variable: abc" (safe-eval 'abc))
 
 (define env (make-safe-environment))
 
-(assert-error (safe-eval '(+ 3 4) environment: env))   ;-->   error: environment is empty and has no parent
+(assert-error "Error: unbound variable: +" (safe-eval '(+ 3 4) environment: env)) ;-->   error: environment is empty and has no parent
 
 (define env2 (make-safe-environment parent: default-safe-environment))
 
-(assert (= 7 (safe-eval '(+ 3 4) environment: env2)))  ;-->   7
+(assert (= 7 (safe-eval '(+ 3 4) environment: env2))) ;-->   7
 
-(assert-error (safe-eval '(define abc 99) environment: (make-safe-environment extendable: #f))) ;--> error
-(assert-error (safe-eval '(define abc 99) environment: env2)) ;--> error
+(assert-error "Error: unbound variable: define" (safe-eval '(define abc 99) environment: (make-safe-environment extendable: #f))) ;--> error
+(assert-error "Error: binding not mutable: abc" (safe-eval '(define abc 99) environment: env2)) ;--> error
 
-(assert-error (safe-eval '(set! + 100)))                     ;-->  error: binding not mutable
-(assert-error (safe-eval '(set! + 100) environment: env2))   ;-->  error: the same (binding is inherited)
-(assert-error (safe-eval '(set! abc 100) environment: env2))  ;-->  error
+(assert-error "Error: binding not mutable: +" (safe-eval '(set! + 100))) ;-->  error
+(assert-error "Error: binding not mutable: +" (safe-eval '(set! + 100) environment: env2)) ;-->  error: the same (binding is inherited)
+(assert-error "Error: binding not mutable: abc" (safe-eval '(set! abc 100) environment: env2)) ;-->  error
 
 ;(safe-eval '(let loop () (loop)))             ;-->  never terminates
-(assert-error (safe-eval '(let loop () (loop)) fuel: 1000))  ;-->  signals error ("out of fuel")
+(assert-error "Error: out of fuel" (safe-eval '(let loop () (loop)) fuel: 1000))  ;-->  signals error ("out of fuel")
 
 (assert (vector? (safe-eval '(make-vector 100))))                ;-->  a 100-element vector
-(assert-error (safe-eval '(make-vector 100) allocation-limit: 100))  ;--> error ("allocation limit exceeded")
+(assert-error "Error: allocation limit exceeded" (safe-eval '(make-vector 100) allocation-limit: 100))  ;--> error ("allocation limit exceeded")