run-it wrap wrap-apply run run-at run-delay
%port-request %run %run-at %run-delay
- 8port-request 8run 8run-at 8run-delay
+ print-error-and-continue
+
%current-agenda
start-agenda agenda-run-once))
(define-immutable-record-type <agenda>
(make-agenda-intern queue prompt-tag
read-port-map write-port-map except-port-map
- schedule time)
+ schedule time catch-handler pre-unwind-handler)
agenda?
(queue agenda-queue)
(prompt-tag agenda-prompt-tag)
(write-port-map agenda-write-port-map)
(except-port-map agenda-except-port-map)
(schedule agenda-schedule)
- (time agenda-time))
+ (time agenda-time)
+ (catch-handler agenda-catch-handler)
+ (pre-unwind-handler agenda-pre-unwind-handler))
(define (make-async-prompt-tag)
"Make an async prompt tag for an agenda.
(write-port-map (make-hash-table))
(except-port-map (make-hash-table))
(schedule (make-schedule))
- (time (gettimeofday)))
+ (time (gettimeofday))
+ (catch-handler #f)
+ (pre-unwind-handler #f))
;; TODO: document arguments
"Make a fresh agenda."
(make-agenda-intern queue prompt
read-port-map write-port-map except-port-map
- schedule time))
+ schedule time
+ catch-handler pre-unwind-handler))
(define (current-agenda-prompt)
"Get the prompt for the current agenda; signal an error if there isn't one."
;;; Asynchronous escape to run things
;;; =================================
-;; The future's in futures
-
-(define (make-future call-first on-success on-fail on-error)
- ;; TODO: add error stuff here
- (lambda ()
- (let ((call-result (call-first)))
- ;; queue up calling the
- (run (on-success call-result)))))
-
(define (agenda-on-error agenda)
(const #f))
(define (agenda-on-fail agenda)
(const #f))
-(define* (request-future call-first on-success
- #:key
- (agenda (%current-agenda))
- (on-fail (agenda-on-fail agenda))
- (on-error (agenda-on-error agenda))
- (when #f))
- ;; TODO: error handling
- ;; do we need some distinction between expected, catchable errors,
- ;; and unexpected, uncatchable ones? Probably...?
- (make-run-request
- (make-future call-first on-success on-fail on-error)
- when))
-
(define-syntax-rule (%8sync async-request)
"Run BODY asynchronously at a prompt, passing args to make-future.
(lambda ()
body ...)))))
-;; Aliases
-(define-syntax-rule (8run args ...) (%run args ...))
-(define-syntax-rule (8run-at args ...) (%run-at args ...))
-(define-syntax-rule (8run-delay args ...) (%run-delay args ...))
-(define-syntax-rule (8port-request args ...) (%port-request args ...))
-
\f
;;; Execution of agenda, and current agenda
(agenda-queue agenda))
(loop agenda))))))
+(define (print-error-and-continue . 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)))
+
+(define-syntax-rule (maybe-catch-all (catch-handler pre-unwind-handler)
+ body ...)
+ (if (or catch-handler pre-unwind-handler)
+ (catch
+ #t
+ (lambda ()
+ body ...)
+ (or catch-handler (lambda _ #f))
+ (or pre-unwind-handler (lambda _ #f)))
+ (begin body ...)))
+
(define (agenda-run-once agenda)
"Run once through the agenda, and produce a new agenda
based on the results"
(agenda-prompt-tag agenda)
(lambda ()
(parameterize ((%current-agenda agenda))
- (proc)))
+ (maybe-catch-all
+ ((agenda-catch-handler agenda)
+ (agenda-pre-unwind-handler agenda))
+ (proc))))
(lambda (kont async-request)
(setup-async-request kont async-request))))