From f692697929fb151e1b25964b16e769db4b32686b Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Fri, 3 Jan 2014 12:28:07 +0900
Subject: [PATCH] Adding additional R7RS exception tests from Per Bothner.

---
 tests/r7rs-tests.scm | 109 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 109 insertions(+)

diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index f0fc7678..748c51b1 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -1527,6 +1527,115 @@
 (test #t
     (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
 
+(define something-went-wrong #f)
+(define (test-exception-handler-1 v)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+      (lambda (x)
+        (set! something-went-wrong (list "condition: " x))
+        (k 'exception))
+      (lambda ()
+        (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))))
+(test 106 (test-exception-handler-1 5))
+(test #f something-went-wrong)
+(test 'exception (test-exception-handler-1 -1))
+(test '("condition: " an-error) something-went-wrong)
+
+(set! something-went-wrong #f)
+(define (test-exception-handler-2 v)
+  (guard (ex (else 'caught-another-exception))
+    (with-exception-handler
+     (lambda (x)
+       (set! something-went-wrong #t)
+       (list "exception:" x))
+     (lambda ()
+       (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
+(test 106 (test-exception-handler-2 5))
+(test #f something-went-wrong)
+(test 'caught-another-exception (test-exception-handler-2 -1))
+(test #t something-went-wrong)
+
+;; Based on an example from R6RS-lib section 7.1 Exceptions.
+;; R7RS section 6.11 Exceptions has a simplified version.
+(let* ((out (open-output-string))
+       (value (with-exception-handler
+               (lambda (con)
+                 (cond
+                  ((not (list? con))
+                   (raise con))
+                  ((list? con)
+                   (display (car con) out))
+                  (else
+                   (display "a warning has been issued" out)))
+                 42)
+               (lambda ()
+                 (+ (raise-continuable
+                     (list "should be a number"))
+                    23)))))
+  (test "should be a number" (get-output-string out))
+  (test 65 value))
+
+;; From SRFI-34 "Examples" section - #3
+(define (test-exception-handler-3 v out)
+  (guard (condition
+          (else
+           (display "condition: " out)
+           (write condition out)
+           (newline out)
+           'exception))
+         (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
+(let* ((out (open-output-string))
+       (value (test-exception-handler-3 0 out)))
+  (test 'exception value)
+  (test "condition: an-error\n" (get-output-string out)))
+
+(define (test-exception-handler-4 v out)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+      (lambda (x)
+        (display "reraised " out)
+        (write x out) (newline out)
+        (k 'zero))
+      (lambda ()
+        (guard (condition
+                ((positive? condition)
+                 'positive)
+                ((negative? condition)
+                 'negative))
+          (raise v)))))))
+
+;; From SRFI-34 "Examples" section - #5
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 1 out)))
+  (test "" (get-output-string out))
+  (test 'positive value))
+;; From SRFI-34 "Examples" section - #6
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 -1 out)))
+  (test "" (get-output-string out))
+  (test 'negative value))
+;; From SRFI-34 "Examples" section - #7
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 0 out)))
+  (test "reraised 0\n" (get-output-string out))
+  (test 'zero value))
+
+;; From SRFI-34 "Examples" section - #8
+(test 42
+    (guard (condition
+            ((assq 'a condition) => cdr)
+            ((assq 'b condition)))
+      (raise (list (cons 'a 42)))))
+
+;; From SRFI-34 "Examples" section - #9
+(test '(b . 23)
+    (guard (condition
+            ((assq 'a condition) => cdr)
+            ((assq 'b condition)))
+      (raise (list (cons 'b 23)))))
+
 (test-end)
 
 (test-begin "6.12 Environments and evaluation")