%port-request %run %run-at %run-delay
+ catch-8sync catch-%8sync
+
+ ;; used for introspecting the error, but a method for making
+ ;; is not exposed
+ wrapped-exception?
+ wrapped-exception-key wrapped-exception-args
+ wrapped-exception-stacks
+
print-error-and-continue
%current-agenda
"Run BODY asynchronously at a prompt, passing args to make-future.
Runs things asynchronously (8synchronously?)"
- (abort-to-prompt (current-agenda-prompt)
- async-request))
+ (propagate-%async-exceptions
+ (abort-to-prompt (current-agenda-prompt)
+ async-request)))
;; Async port request and run-request meta-requests
(define (make-async-request proc)
"Invalid request passed back via an (%8sync) procedure."
async-request))))
+(define-record-type <wrapped-exception>
+ (make-wrapped-exception key args stacks)
+ wrapped-exception?
+ (key wrapped-exception-key)
+ (args wrapped-exception-args)
+ (stacks wrapped-exception-stacks))
+
+(define-syntax-rule (propagate-%async-exceptions body)
+ (let ((body-result body))
+ (if (wrapped-exception? body-result)
+ (throw '8sync-caught-error
+ (wrapped-exception-key body-result)
+ (wrapped-exception-args body-result)
+ (wrapped-exception-stacks body-result))
+ body-result)))
+
(define-syntax-rule (%run body ...)
(%run-at body ... #f))
(define-syntax-rule (%run-at body ... when)
+ ;; Send an asynchronous request to apply a continuation to the
+ ;; following function, then handle that as a request to the agenda
(make-async-request
(lambda (kont)
+ ;; We're making a run request
(make-run-request
+ ;; Wrapping the following execution to run...
(wrap
+ ;; Once we get the result from the inner part, we'll resume
+ ;; this continuation, but first
+ ;; @@: Is this running immediately, or queueing the result
+ ;; after evaluation for the next agenda tick? It looks
+ ;; like evaluating immediately. Is that what we want?
(kont
- (begin body ...)))
+ ;; Any unhandled errors are caught
+ (let ((exception-stack #f))
+ (catch #t
+ ;; Run the actual code the user requested
+ (lambda ()
+ body ...)
+ ;; If something bad happened and we didn't catch it,
+ ;; we'll wrap it up in such a way that the continuation
+ ;; can address it
+ (lambda (key . args)
+ (cond
+ ((eq? key '8sync-caught-error)
+ (match args
+ ((orig-key orig-args orig-stacks)
+ (make-wrapped-exception
+ orig-key orig-args
+ (cons exception-stack orig-stacks)))))
+ (else
+ (make-wrapped-exception key args
+ (list exception-stack)))))
+ (lambda _
+ (set! exception-stack (make-stack #t 1 0)))))))
when))))
(define-syntax-rule (%run-delay body ... delay-time)
(lambda ()
body ...)))))
+(define-syntax-rule (catch-8sync exp (handler-key handler) ...)
+ (catch '8sync-caught-error
+ (lambda ()
+ exp)
+ (lambda (_ orig-key orig-args orig-stacks)
+ (cond
+ ((or (eq? handler-key #t)
+ (eq? orig-key handler-key))
+ (apply handler orig-stacks orig-args)) ...
+ (else (raise '8sync-caught-error
+ orig-key orig-args orig-stacks))))))
+
+;; Alias...?
+(define-syntax-rule (catch-%8sync rest ...)
+ (catch-8sync rest ...))
+
\f
;;; Execution of agenda, and current agenda
(agenda-queue agenda))
(loop agenda))))))
-(define (print-error-and-continue . args)
+(define (print-error-and-continue key . args)
"Frequently used as pre-unwind-handler for agenda"
- (format (current-error-port) "\n*** Caught exception with arguments: ~s ***\n"
- args)
+ (format (current-error-port)
+ "\n*** Caught exception with key '~s and arguments: ~s ***\n"
+ key args)
(display-backtrace (make-stack #t 1 0)
(current-error-port))
(newline (current-error-port)))