From 1f2a1719d69ffbf73c6f5d7e1ea691360525a901 Mon Sep 17 00:00:00 2001
From: Peter Kofler <peter.kofler@code-cop.org>
Date: Thu, 14 Feb 2019 18:18:58 +0100
Subject: [PATCH] Make Chicken/SRFI 12 code work.

---
 assert-chicken.scm      | 18 +++++++-----------
 assert-test-chicken.scm | 14 +++++++-------
 2 files changed, 14 insertions(+), 18 deletions(-)

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)
-                                 "<unknown exception type>")))
+    (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            "<unknown exception type>")))
 
 (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:<a> but was:<b>"
+    "raise expected:<a> but was:<unbound variable>"
     (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"