diff --git a/knots.scm b/knots.scm index ee38ee4..765db5a 100644 --- a/knots.scm +++ b/knots.scm @@ -1,10 +1,12 @@ (define-module (knots) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (ice-9 binary-ports) #:use-module (ice-9 suspendable-ports) #:use-module (rnrs bytevectors) #:use-module (fibers) + #:use-module (fibers channels) #:use-module (fibers conditions) #:use-module (system repl debug) #:export (call-with-default-io-waiters @@ -57,6 +59,42 @@ ;; restore original C handler. (sigaction SIGINT #f)))))) +(define (call-with-temporary-thread thunk) + (let ((channel (make-channel))) + (call-with-new-thread + (lambda () + (call-with-default-io-waiters + (lambda () + (with-exception-handler + (lambda (exn) + (put-message channel `(exception . ,exn))) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + (lambda () + (call-with-values thunk + (lambda values + (put-message channel `(values ,@values))))))) + #:unwind? #t))))) + + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) + (define* (display/knots obj #:optional (port (current-output-port))) (put-bytevector port