From a9e932ba04d488a5492afe0dd6d88337f4b01686 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 27 Nov 2015 17:23:40 -0600 Subject: [PATCH] Properly handle %8sync to %8sync to error chains. --- eightsync/agenda.scm | 18 +++++++++++++----- tests/test-agenda.scm | 36 +++++++++++++++++++++++++++++++----- 2 files changed, 44 insertions(+), 10 deletions(-) diff --git a/eightsync/agenda.scm b/eightsync/agenda.scm index ba07536..68db42e 100644 --- a/eightsync/agenda.scm +++ b/eightsync/agenda.scm @@ -468,11 +468,11 @@ return the wrong thing via (%8sync) and trip themselves up." async-request)))) (define-record-type - (make-wrapped-exception key args stack) + (make-wrapped-exception key args stacks) wrapped-exception? (key wrapped-exception-key) (args wrapped-exception-args) - (stack wrapped-exception-stack)) + (stacks wrapped-exception-stacks)) (define-syntax-rule (propagate-%async-exceptions body) (let ((body-result body)) @@ -480,7 +480,7 @@ return the wrong thing via (%8sync) and trip themselves up." (throw '%8sync-caught-error (wrapped-exception-key body-result) (wrapped-exception-args body-result) - (wrapped-exception-stack body-result)) + (wrapped-exception-stacks body-result)) body-result))) (define-syntax-rule (%run body ...) @@ -512,8 +512,16 @@ return the wrong thing via (%8sync) and trip themselves up." ;; can address it ;; @@: For this stack to work doesn't it have to be (lambda (key . args) - (make-wrapped-exception key args - exception-stack)) + (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)))) diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index 8975b3e..6913109 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -342,21 +342,35 @@ (+ 1 2 (/ 1 0)) (speaker "SHOULD NOT HAPPEN\n")) -(define (local-func-gets-break) +(define (indirection-remote-func-breaks) + (speaker "bebop\n") + (%8sync (%run (remote-func-breaks))) + (speaker "bidop\n")) + +(define* (local-func-gets-break #:key with-indirection) (speaker "Time for exception fun!\n") (let ((caught-exception #f)) (catch '%8sync-caught-error (lambda () - (%8sync (%run (remote-func-breaks)))) - (lambda (_ orig-key orig-args orig-stack) + (%8sync (%run (if with-indirection + (indirection-remote-func-breaks) + (remote-func-breaks))))) + (lambda (_ orig-key orig-args orig-stacks) (set! caught-exception #t) (speaker "in here now!\n") (test-equal orig-key 'numerical-overflow) (test-equal orig-args '("/" "Numerical overflow" #f #f)) - (test-assert (stack? orig-stack))))) - (test-assert caught-exception) + (test-assert (list? orig-stacks)) + (test-equal (length orig-stacks) + (if with-indirection 2 1)) + (for-each + (lambda (x) + (test-assert (stack? x))) + orig-stacks))) + (test-assert caught-exception)) (speaker "Well that was fun :)\n")) + (let ((q (make-q))) (set! speaker (speak-it)) (enq! q local-func-gets-break) @@ -368,6 +382,18 @@ "in here now!\n" "Well that was fun :)\n"))) +(let ((q (make-q))) + (set! speaker (speak-it)) + (enq! q (wrap (local-func-gets-break #:with-indirection #t))) + (start-agenda (make-agenda #:queue q) + #:stop-condition (true-after-n-times 10)) + (test-assert (speaker) + '("Time for exception fun!\n" + "bebop\n" + "Here we go...\n" + "in here now!\n" + "Well that was fun :)\n"))) + ;; End tests (test-end "test-agenda") -- 2.31.1