From f57d4316c2048f0c58a47c56b63d25d10511f98f Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 15 Mar 2014 19:30:26 +0100
Subject: [PATCH] Add call-with-stack-overflow-handler tests

* test-suite/tests/eval.test ("stack overflow handlers"): Add
  call-with-stack-overflow-handler tests, replacing the old stack
  overflow test.
---
 test-suite/tests/eval.test | 93 +++++++++++++++++++++++++++++++++++---
 1 file changed, 86 insertions(+), 7 deletions(-)

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 3fc1d9444..10d26690b 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -18,7 +18,7 @@
 (define-module (test-suite test-eval)
   :use-module (test-suite lib)
   :use-module ((srfi srfi-1) :select (unfold count))
-  :use-module ((system vm vm) :select (call-with-vm))
+  :use-module ((system vm vm) :select (call-with-stack-overflow-handler))
   :use-module (ice-9 documentation)
   :use-module (ice-9 local-eval))
 
@@ -442,13 +442,92 @@
 ;;; stack overflow handling
 ;;;
 
-(with-test-prefix "stack overflow"
+(with-test-prefix "stack overflow handlers"
+  (define (trigger-overflow)
+    (trigger-overflow)
+    (error "not reached"))
 
-  ;; FIXME: this test does not test what it is intending to test
-  (pass-if-exception "exception raised"
-    exception:vm-error
-    (let ((thunk (let loop () (cons 's (loop)))))
-      (call-with-vm thunk))))
+  (define (dynwind-test n)
+    (catch 'foo
+      (lambda ()
+        (call-with-stack-overflow-handler n
+          (lambda ()
+            (dynamic-wind (lambda () #t)
+                          trigger-overflow
+                          trigger-overflow))
+          (lambda ()
+            (throw 'foo))))
+      (lambda _ #t)))
+
+  (pass-if-exception "limit should be number"
+      exception:wrong-type-arg
+    (call-with-stack-overflow-handler #t
+      trigger-overflow trigger-overflow))
+
+  (pass-if-exception "limit should be exact integer"
+      exception:wrong-type-arg
+    (call-with-stack-overflow-handler 2.0
+      trigger-overflow trigger-overflow))
+
+  (pass-if-exception "limit should be nonnegative"
+      exception:out-of-range
+    (call-with-stack-overflow-handler -1
+      trigger-overflow trigger-overflow))
+
+  (pass-if-exception "limit should be positive"
+      exception:out-of-range
+    (call-with-stack-overflow-handler 0
+      trigger-overflow trigger-overflow))
+
+  (pass-if-exception "limit should be within address space"
+      exception:out-of-range
+    (call-with-stack-overflow-handler (ash 1 64)
+      trigger-overflow trigger-overflow))
+
+  (pass-if "exception on overflow"
+    (catch 'foo
+      (lambda ()
+        (call-with-stack-overflow-handler 10000
+          trigger-overflow
+          (lambda ()
+            (throw 'foo))))
+      (lambda _ #t)))
+
+  (pass-if "exception on overflow with dynwind"
+    ;; Try all limits between 1 and 200 words.
+    (let lp ((n 1))
+      (or (= n 200)
+          (and (dynwind-test n)
+               (lp (1+ n))))))
+
+  (pass-if-exception "overflow handler should return number"
+      exception:wrong-type-arg
+    (call-with-stack-overflow-handler 1000
+      trigger-overflow
+      (lambda () #t)))
+  (pass-if-exception "overflow handler should return exact integer"
+      exception:wrong-type-arg
+    (call-with-stack-overflow-handler 1000
+      trigger-overflow
+      (lambda () 2.0)))
+  (pass-if-exception "overflow handler should be nonnegative"
+      exception:out-of-range
+    (call-with-stack-overflow-handler 1000
+      trigger-overflow
+      (lambda () -1)))
+  (pass-if-exception "overflow handler should be positive"
+      exception:out-of-range
+    (call-with-stack-overflow-handler 1000
+      trigger-overflow
+      (lambda () 0)))
+
+  (letrec ((fac (lambda (n)
+                  (if (zero? n) 1 (* n (fac (1- n)))))))
+    (pass-if-equal "overflow handler can allow recursion to continue"
+        (fac 10)
+      (call-with-stack-overflow-handler 1
+        (lambda () (fac 10))
+        (lambda () 1)))))
 
 ;;;
 ;;; docstrings