From cef48f426e254f8c05566a50669bf195560e0d96 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 9 Dec 2016 14:47:47 -0600 Subject: [PATCH] agenda: Remove 8sync macro. Despite being the namesake of the project, this turns out to have never really been important or made sense, except as a way to yield control as a form of context switching. This is moving towards renaming 8sync-nowait to 8sync, a forthcoming change. * 8sync/agenda.scm (8sync, catch-8sync): Removed. * tests/test-agenda.scm: Removed all tests calling the 8sync macro. --- 8sync/agenda.scm | 31 ++---------- tests/test-agenda.scm | 115 ------------------------------------------ 2 files changed, 5 insertions(+), 141 deletions(-) diff --git a/8sync/agenda.scm b/8sync/agenda.scm index 28df8be..ae9ddd6 100644 --- a/8sync/agenda.scm +++ b/8sync/agenda.scm @@ -60,13 +60,11 @@ run-it wrap wrap-apply run run-at run-delay - 8sync 8sync-delay + 8sync-delay 8sync-run 8sync-run-at 8sync-run-delay 8sync-nowait 8sleep - catch-8sync - ;; used for introspecting the error, but a method for making ;; is not exposed wrapped-exception? @@ -477,16 +475,6 @@ return the wrong thing via (8sync) and trip themselves up." (wrapped-exception-stacks body-result)) body-result))) -(define-syntax 8sync - (syntax-rules () - "Run BODY asynchronously (8synchronously?) at a prompt, then return. - -Possibly specify WHEN as the second argument." - ((8sync body) - (8sync-run body)) - ((8sync body when) - (8sync-run-at body when)))) - (define-syntax-rule (8sync-run body ...) (8sync-run-at body ... #f)) @@ -552,18 +540,6 @@ forge ahead in our current function!" (wrap (kont #f)) #f) (make-run-request (lambda () body) #f)))))) -(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)))))) - ;; This is sugar... and could probably be considerably ;; simplified and optimized. But whatever. (define-syntax-rule (8sleep time) @@ -829,7 +805,10 @@ based on the results" ((? write-request? write-request) (agenda-handle-write-request! agenda write-request)) ;; do nothing - ;; @@: Why not throw an error? + ;; Remember, we don't throw an error here because procedures can + ;; return a run request, eg with run-it, at the end of their + ;; evaluation to keep looping. + ;; @@: Though is this really a useful feature? (_ #f))) ;; @@: We might support delay-wrapped procedures here (match proc-result diff --git a/tests/test-agenda.scm b/tests/test-agenda.scm index 868d4ce..59c27b7 100644 --- a/tests/test-agenda.scm +++ b/tests/test-agenda.scm @@ -284,15 +284,6 @@ (test-equal (fake-kont) '("applesauce")))))) -(test-%run-and-friends (run-in-fake-agenda - (8sync (string-concatenate '("apple" "sauce")))) - #f) - -(test-%run-and-friends (run-in-fake-agenda - (8sync (string-concatenate '("apple" "sauce")) - '(8 . 0))) - '(8 . 0)) - (test-%run-and-friends (run-in-fake-agenda (8sync-delay (string-concatenate '("apple" "sauce")) 8)) @@ -300,7 +291,6 @@ ;; compare records like this (tdelta 8)) -;; TODO: test %port-request ;; TODO: test 8sync and friends! @@ -342,111 +332,6 @@ (test-equal (speaker) '("I bet I can make you say you're a dummy!\n"))) -;; delimited continuation tests - -(define (return-monkey) - (speaker "(Hint, it's a monkey...)\n") - 'monkey) - -(define (talk-about-the-zoo) - (speaker "Today I went to the zoo and I saw...\n") - (speaker - (string-concatenate - `("A " ,(symbol->string (8sync (return-monkey))) "!\n")))) - -(begin - (set! speaker (speak-it)) - ;; (enq! q talk-about-the-zoo-but-wait) - (start-agenda (make-agenda #:queue (make-q* talk-about-the-zoo)) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Today I went to the zoo and I saw...\n" - "(Hint, it's a monkey...)\n" - "A monkey!\n"))) - - -;; Error handling tests -;; -------------------- - -(define (remote-func-breaks) - (speaker "Here we go...\n") - (+ 1 2 (/ 1 0)) - (speaker "SHOULD NOT HAPPEN\n")) - -(define (indirection-remote-func-breaks) - (speaker "bebop\n") - (8sync (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 - (8sync-run (if with-indirection - (indirection-remote-func-breaks) - (remote-func-breaks))) - ('numerical-overflow - (lambda (orig-stacks . orig-args) - (set! caught-exception #t) - (speaker "in here now!\n") - (test-equal orig-args '("/" "Numerical overflow" #f #f)) - (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")) - - -(begin - (set! speaker (speak-it)) - (start-agenda (make-agenda #:queue (make-q* local-func-gets-break)) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Time for exception fun!\n" - "Here we go...\n" - "in here now!\n" - "Well that was fun :)\n"))) - -(begin - (set! speaker (speak-it)) - (start-agenda (make-agenda - #:queue (make-q* (wrap (local-func-gets-break - #:with-indirection #t)))) - #:stop-condition (true-after-n-times 10)) - (test-equal (speaker) - '("Time for exception fun!\n" - "bebop\n" - "Here we go...\n" - "in here now!\n" - "Well that was fun :)\n"))) - -;; Make sure catching tools work - -(let ((speaker (speak-it)) - (catch-result #f)) - (catch-8sync - (begin - (speaker "hello") - (throw '8sync-caught-error - 'my-orig-key '(apple orange banana) '(*fake-stack* *fake-stack* *fake-stack*)) - (speaker "no goodbyes")) - ('some-key - (lambda (stacks . rest) - (speaker "should not happen"))) - ('my-orig-key - (lambda (stacks fruit1 fruit2 fruit3) - (set! catch-result - `((fruit1 ,fruit1) - (fruit2 ,fruit2) - (fruit3 ,fruit3)))))) - (test-equal (speaker) '("hello")) - (test-equal catch-result '((fruit1 apple) - (fruit2 orange) - (fruit3 banana)))) ;; End tests -- 2.31.1