[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
From: |
Ludovic Courtès |
Date: |
Thu, 8 Feb 2018 12:47:37 -0500 (EST) |
branch: master
commit ef3801b3ccb3db8e9f2c327015b2aca8cfb67a4e
Author: Ludovic Courtès <address@hidden>
Date: Thu Feb 8 18:46:46 2018 +0100
utils: 'non-blocking' forwards exceptions to the calling fiber.
* src/cuirass/utils.scm (%non-blocking): Forward exceptions to the
calling fiber.
---
src/cuirass/utils.scm | 17 +++++++++++++----
1 file changed, 13 insertions(+), 4 deletions(-)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 56dfced..947bf71 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -71,10 +71,19 @@ value."
(let ((channel (make-channel)))
(call-with-new-thread
(lambda ()
- (call-with-values thunk
- (lambda values
- (put-message channel values)))))
- (apply values (get-message channel))))
+ (catch #t
+ (lambda ()
+ (call-with-values thunk
+ (lambda values
+ (put-message channel `(values ,@values)))))
+ (lambda args
+ (put-message channel `(exception ,@args))))))
+
+ (match (get-message channel)
+ (('values . results)
+ (apply values results))
+ (('exception . args)
+ (apply throw args)))))
(define-syntax-rule (non-blocking exp ...)
"Evalaute EXP... in a separate thread so that it doesn't block the execution