%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
;;; Asynchronous escape to run things
;;; =================================
-(define (agenda-on-error agenda)
- (const #f))
-
-(define (agenda-on-fail agenda)
- (const #f))
-
(define-syntax-rule (%8sync async-request)
"Run BODY asynchronously at a prompt, passing args to make-future.
(define-syntax-rule (propagate-%async-exceptions body)
(let ((body-result body))
(if (wrapped-exception? body-result)
- (throw '%8sync-caught-error
+ (throw '8sync-caught-error
(wrapped-exception-key body-result)
(wrapped-exception-args body-result)
(wrapped-exception-stacks body-result))
;; 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
- ;; @@: For this stack to work doesn't it have to be
(lambda (key . args)
(cond
- ((eq? key '%8sync-caught-error)
+ ((eq? key '8sync-caught-error)
(match args
((orig-key orig-args orig-stacks)
(make-wrapped-exception
(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)
- (display-backtrace (make-stack #t 1 0)
- (current-error-port))
- (newline (current-error-port)))
+ (cond
+ ((eq? key '8sync-caught-error)
+ (match args
+ ((orig-key orig-args stacks)
+ (display "\n*** Caught async exception. ***\n")
+ (format (current-error-port)
+ "* Original key '~s and arguments: ~s *\n"
+ orig-key orig-args)
+ (display "* Caught stacks below (ending with original) *\n\n")
+ (for-each
+ (lambda (s)
+ (display-backtrace s (current-error-port))
+ (newline (current-error-port)))
+ stacks))))
+ (else
+ (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)))))
(define-syntax-rule (maybe-catch-all (catch-handler pre-unwind-handler)
body ...)