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

File 0001-Improve-test-suite-to-check-for-error-messages.patch, 3.5 KB (added by Vasilij Schneidermann, 3 months ago)
  • tests/run.scm

    From 75d0ad9fd2b18763e941cface6bd5e437bb84b31 Mon Sep 17 00:00:00 2001
    From: Vasilij Schneidermann <mail@vasilij.de>
    Date: Mon, 4 Apr 2022 16:51:40 +0200
    Subject: [PATCH] Improve test suite to check for error messages
    
    ---
     tests/run.scm | 41 ++++++++++++++++++++++++-----------------
     1 file changed, 24 insertions(+), 17 deletions(-)
    
    diff --git a/tests/run.scm b/tests/run.scm
    index fe582dc..00633d7 100644
    a b  
    1 (import (chicken condition) sandbox)
     1(import (chicken condition) (chicken format) (chicken irregex) (chicken port) sandbox)
    22
    33(define-syntax assert-error
    44  (syntax-rules ()
    5     ((_ x)
    6      (handle-exceptions ex
    7        (begin
    8          (print-error-message ex)
    9          #t)
    10        x #f))))
     5    ((_ expected x)
     6     (assert
     7      (handle-exceptions ex
     8        (begin
     9          (let ((error-message (with-output-to-string
     10                                 (lambda ()
     11                                   (print-error-message ex)))))
     12            (when (not (irregex-search (irregex-quote expected) error-message))
     13              (printf "Assertion message mismatch: ~s\n" error-message)
     14              #f)))
     15        x
     16        (printf "Assertion not raised: ~s\n" 'x)
     17        #f)))))
    1118
    1219(assert (= 123 (safe-eval 123)))    ;-->   123
    1320
    14 (assert-error (safe-eval 'abc))   ;-->   error
     21(assert-error "Error: unbound variable: abc" (safe-eval 'abc))
    1522
    1623(define env (make-safe-environment))
    1724
    18 (assert-error (safe-eval '(+ 3 4) environment: env))  ;-->   error: environment is empty and has no parent
     25(assert-error "Error: unbound variable: +" (safe-eval '(+ 3 4) environment: env)) ;-->   error: environment is empty and has no parent
    1926
    2027(define env2 (make-safe-environment parent: default-safe-environment))
    2128
    22 (assert (= 7 (safe-eval '(+ 3 4) environment: env2)))  ;-->   7
     29(assert (= 7 (safe-eval '(+ 3 4) environment: env2))) ;-->   7
    2330
    24 (assert-error (safe-eval '(define abc 99) environment: (make-safe-environment extendable: #f))) ;--> error
    25 (assert-error (safe-eval '(define abc 99) environment: env2)) ;--> error
     31(assert-error "Error: unbound variable: define" (safe-eval '(define abc 99) environment: (make-safe-environment extendable: #f))) ;--> error
     32(assert-error "Error: binding not mutable: abc" (safe-eval '(define abc 99) environment: env2)) ;--> error
    2633
    27 (assert-error (safe-eval '(set! + 100)))                     ;-->  error: binding not mutable
    28 (assert-error (safe-eval '(set! + 100) environment: env2))  ;-->  error: the same (binding is inherited)
    29 (assert-error (safe-eval '(set! abc 100) environment: env2)) ;-->  error
     34(assert-error "Error: binding not mutable: +" (safe-eval '(set! + 100))) ;-->  error
     35(assert-error "Error: binding not mutable: +" (safe-eval '(set! + 100) environment: env2)) ;-->  error: the same (binding is inherited)
     36(assert-error "Error: binding not mutable: abc" (safe-eval '(set! abc 100) environment: env2)) ;-->  error
    3037
    3138;(safe-eval '(let loop () (loop)))             ;-->  never terminates
    32 (assert-error (safe-eval '(let loop () (loop)) fuel: 1000))  ;-->  signals error ("out of fuel")
     39(assert-error "Error: out of fuel" (safe-eval '(let loop () (loop)) fuel: 1000))  ;-->  signals error ("out of fuel")
    3340
    3441(assert (vector? (safe-eval '(make-vector 100))))                ;-->  a 100-element vector
    35 (assert-error (safe-eval '(make-vector 100) allocation-limit: 100))  ;--> error ("allocation limit exceeded")
     42(assert-error "Error: allocation limit exceeded" (safe-eval '(make-vector 100) allocation-limit: 100))  ;--> error ("allocation limit exceeded")