Simplify and factor out carefully checking for stack overflows.

diff --git a/tests/runtime/test-list.scm b/tests/runtime/test-list.scm
index 438e723eb87129918b7a2035ef7ba721bca7f714..8fe5c174dd0c3f41623898ed18eb9568adddcf50 100644 (file)
--- a/tests/runtime/test-list.scm
+++ b/tests/runtime/test-list.scm
@@ -28,47 +28,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (carefully procedure if-overflow if-timeout)
-  (let ((thread #f)
-        (mutex (make-thread-mutex))
-        (condvar (make-condition-variable))
-        (gc-env (->environment '(runtime garbage-collector))))
-    (define (start-it)
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (do () (thread)
-            (condition-variable-wait! condvar mutex))))
-      (let ((default/stack-overflow (access default/stack-overflow gc-env)))
-        (define (give-up)
-          (if (eq? thread (current-thread))
-              (exit-current-thread (if-overflow))
-              (default/stack-overflow)))
-        (call-with-current-continuation
-          (lambda (abort)
-            (fluid-let (((access hook/stack-overflow gc-env)
-                         (lambda () (within-continuation abort give-up))))
-              (exit-current-thread (procedure)))))))
-    (define (stop-it)
-      (assert thread)
-      (signal-thread-event thread
-                           (lambda ()
-                             (exit-current-thread (if-timeout)))))
-    (let ((t (create-thread #f start-it)))
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (set! thread t)
-          (condition-variable-broadcast! condvar))))
-    (let ((result #f))
-      (define (done-it thread* value)
-        (assert (eq? thread* thread))
-        (set! result value))
-      (join-thread thread done-it)
-      (let ((timer))
-        (dynamic-wind
-          (lambda () (set! timer (register-timer-event 1000 stop-it)))
-          (lambda () (do () (result) (suspend-current-thread)))
-          (lambda () (deregister-timer-event (set! timer))))))))
-
 (define (words-in-stack)
   (let ((status (gc-space-status)))
     (let ((bytes-per-word (vector-ref status 0))

diff --git a/tests/runtime/test-pp.scm b/tests/runtime/test-pp.scm
index 4667ef44a3583ef3034f4679b120e28d2f627a20..33ca650dc0aeef74ff7fb47cf8b450f553729640 100644 (file)
--- a/tests/runtime/test-pp.scm
+++ b/tests/runtime/test-pp.scm
@@ -31,47 +31,6 @@ USA.
 (define assert-string
   (predicate-assertion string? "string"))
 
-(define (carefully procedure if-overflow if-timeout)
-  (let ((thread #f)
-        (mutex (make-thread-mutex))
-        (condvar (make-condition-variable))
-        (gc-env (->environment '(runtime garbage-collector))))
-    (define (start-it)
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (do () (thread)
-            (condition-variable-wait! condvar mutex))))
-      (let ((default/stack-overflow (access default/stack-overflow gc-env)))
-        (define (give-up)
-          (if (eq? thread (current-thread))
-              (exit-current-thread (if-overflow))
-              (default/stack-overflow)))
-        (call-with-current-continuation
-          (lambda (abort)
-            (fluid-let (((access hook/stack-overflow gc-env)
-                         (lambda () (within-continuation abort give-up))))
-              (exit-current-thread (procedure)))))))
-    (define (stop-it)
-      (assert thread)
-      (signal-thread-event thread
-                           (lambda ()
-                             (exit-current-thread (if-timeout)))))
-    (let ((t (create-thread #f start-it)))
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (set! thread t)
-          (condition-variable-broadcast! condvar))))
-    (let ((result #f))
-      (define (done-it thread* value)
-        (assert (eq? thread* thread))
-        (set! result value))
-      (join-thread thread done-it)
-      (let ((timer))
-        (dynamic-wind
-          (lambda () (set! timer (register-timer-event 1000 stop-it)))
-          (lambda () (do () (result) (suspend-current-thread)))
-          (lambda () (deregister-timer-event (set! timer))))))))
-
 (define-test 'circular/simple
   (lambda ()
     (define (doit)

diff --git a/tests/runtime/test-promise.scm b/tests/runtime/test-promise.scm
index 123cfa5eccdb35653a46ef60122f5becfe8a8423..dbd4b06850add6fc00b853c6d6f6732819a51569 100644 (file)
--- a/tests/runtime/test-promise.scm
+++ b/tests/runtime/test-promise.scm
@@ -28,47 +28,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (carefully procedure if-overflow if-timeout)
-  (let ((thread #f)
-        (mutex (make-thread-mutex))
-        (condvar (make-condition-variable))
-        (gc-env (->environment '(runtime garbage-collector))))
-    (define (start-it)
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (do () (thread)
-            (condition-variable-wait! condvar mutex))))
-      (let ((default/stack-overflow (access default/stack-overflow gc-env)))
-        (define (give-up)
-          (if (eq? thread (current-thread))
-              (exit-current-thread (if-overflow))
-              (default/stack-overflow)))
-        (call-with-current-continuation
-          (lambda (abort)
-            (fluid-let (((access hook/stack-overflow gc-env)
-                         (lambda () (within-continuation abort give-up))))
-              (exit-current-thread (procedure)))))))
-    (define (stop-it)
-      (assert thread)
-      (signal-thread-event thread
-                           (lambda ()
-                             (exit-current-thread (if-timeout)))))
-    (let ((t (create-thread #f start-it)))
-      (with-thread-mutex-lock mutex
-        (lambda ()
-          (set! thread t)
-          (condition-variable-broadcast! condvar))))
-    (let ((result #f))
-      (define (done-it thread* value)
-        (assert (eq? thread* thread))
-        (set! result value))
-      (join-thread thread done-it)
-      (let ((timer))
-        (dynamic-wind
-          (lambda () (set! timer (register-timer-event 1000 stop-it)))
-          (lambda () (do () (result) (suspend-current-thread)))
-          (lambda () (deregister-timer-event (set! timer))))))))
-
 (define-test 'delay-force-loop
   (lambda ()
     (assert-error

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 1bc25a7ba8b4e7867bc009b3f947a8feb01baaee..c50a087bc9926eea07dff33b084fea05e42fa88f 100644 (file)
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -698,4 +698,34 @@ USA.
                    (list "an object" (if- "not") "matching" (marker))))
 
 (define-for-tests assert-matches (match-assertion #f))
-(define-for-tests assert-!matches (match-assertion #t))
\ No newline at end of file
+(define-for-tests assert-!matches (match-assertion #t))
+\f
+(define-for-tests (carefully procedure if-overflow if-timeout)
+  (let ((gc-env (->environment '(runtime garbage-collector))))
+    (define (start-it)
+      (let ((default/stack-overflow (access default/stack-overflow gc-env))
+           (thread (current-thread)))
+        (define (give-up)
+          (if (eq? thread (current-thread))
+              (exit-current-thread (if-overflow))
+              (default/stack-overflow)))
+        (call-with-current-continuation
+          (lambda (abort)
+            (fluid-let (((access hook/stack-overflow gc-env)
+                         (lambda () (within-continuation abort give-up))))
+              (exit-current-thread (procedure)))))))
+    (let ((thread (create-thread #f start-it)))
+      (define (stop-it)
+       (signal-thread-event thread
+         (lambda ()
+           (exit-current-thread (if-timeout)))))
+      (let ((result #f))
+       (define (done-it thread* value)
+         (assert (eq? thread* thread))
+         (set! result value))
+       (join-thread thread done-it)
+       (let ((timer))
+         (dynamic-wind
+           (lambda () (set! timer (register-timer-event 1000 stop-it)))
+           (lambda () (do () (result) (suspend-current-thread)))
+           (lambda () (deregister-timer-event (set! timer)))))))))
\ No newline at end of file