diff --git a/assert-chicken.scm b/assert-chicken.scm index ed9ae7a..2ff294d 100644 --- a/assert-chicken.scm +++ b/assert-chicken.scm @@ -1,23 +1,19 @@ ;;; -;;; Unit test framework for Scheme R5RS, Chicken extension. +;;; Unit test framework for Scheme R5RS, SRFI-12 extension (e.g. Chicken) ;;; Copyright (c) 2015, Peter Kofler, http://www.code-cop.org/ ;;; BSD licensed. ;;; (include "assert-r5rs.scm") (define (-error->string ex) - (cond ((symbol? ex) (symbol->string ex)) - ((string? ex) ex) - ;; Chicken specific code - ;; TODO Chicken Scheme exception types - ;; ((type-exception? ex) (string-append "expected " (-error->string (type-exception-type-id ex)))) ; type name - ;; ((exn ex) "xxx") - ;; see https://wiki.call-cc.org/man/4/Exceptions#exception-handlers - (else (pp ex) - ""))) + (cond ((symbol? ex) (symbol->string ex)) + ((string? ex) ex) + ;; SRFI-12/Chicken specific code + ((condition? ex) (-error->string ((condition-property-accessor 'exn 'message) ex))) + (else ""))) (define (-run-with-exception-handler handler body) - ;; Chicken specific code + ;; SRFI-12 specific code (let ((exn-message-comparison '())) (handle-exceptions exn (set! exn-message-comparison (handler exn)) diff --git a/assert-test-chicken.scm b/assert-test-chicken.scm index beff540..e2f00d5 100644 --- a/assert-test-chicken.scm +++ b/assert-test-chicken.scm @@ -37,7 +37,7 @@ (assert-inexact= 1. 1.1 0.11)) (test-failure "(assert-inexact=) fails" - "in range expected:<[.99-1.01]> but was:<1.1>" + "in range expected:<[0.99-1.01]> but was:<1.1>" (assert-inexact= 1. 1.1 0.01)) (test-case "(assert-list=)" @@ -124,12 +124,12 @@ (assert-not-null '())) (test-case "(assert-raise) on raise symbol" - (assert-raise 'a (lambda () + (assert-raise "unbound variable" (lambda () (raise 'a)))) (test-case "(assert-raise) on raise string" - (assert-raise "a" (lambda () - (raise 'a)))) + (assert-raise "unbound variable" (lambda () + (raise "a")))) (test-case "(assert-raise) on error symbol" (assert-raise 'a (lambda () @@ -140,7 +140,7 @@ (error "a")))) (test-failure "(assert-raise) fails" - "raise expected: but was:" + "raise expected: but was:" (assert-raise 'a (lambda () (raise 'b)))) @@ -150,11 +150,11 @@ (+ 1 1)))) (test-case "(assert-raise) on unbound global variable" - (assert-raise 'unbound-global-variable (lambda () + (assert-raise "unbound variable" (lambda () (unbound-global-variable)))) (test-case "(assert-raise) on type error" - (assert-raise "expected number" (lambda () + (assert-raise "bad argument type" (lambda () (+ 1 "1")))) (test-case "(assert-all) allows several assertions"