X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=tests.scm;h=d56b4f2af73dbaddbf33584e75f3f09e043b0db2;hb=06111cedb79268f25fefd62e73ddb1651a66f04b;hp=c9999c6a45a784fc310fe4e9199183f2a5a35be5;hpb=8153aa3f58eba2b8bc0118d224d7e74d7b434074;p=8sync.git diff --git a/tests.scm b/tests.scm index c9999c6..d56b4f2 100644 --- a/tests.scm +++ b/tests.scm @@ -6,7 +6,7 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 q) #:use-module (ice-9 receive) - #:use-module (loopy agenda)) + #:use-module (eightsync agenda)) (test-begin "tests") @@ -14,22 +14,22 @@ ;; Timer tests ;; =========== -(test-assert (time-= '(1 . 1) '(1 . 1))) -(test-assert (not (time-= '(1 . 1) '(1 . 0)))) -(test-assert (not (time-= '(0 . 1) '(1 . 1)))) +(test-assert (time= '(1 . 1) '(1 . 1))) +(test-assert (not (time= '(1 . 1) '(1 . 0)))) +(test-assert (not (time= '(0 . 1) '(1 . 1)))) -(test-assert (time-< '(1 . 1) '(1 . 2))) -(test-assert (time-< '(7 . 2) '(8 . 2))) -(test-assert (not (time-< '(7 . 2) '(7 . 2)))) -(test-assert (not (time-< '(7 . 8) '(7 . 2)))) -(test-assert (not (time-< '(8 . 2) '(7 . 2)))) +(test-assert (time< '(1 . 1) '(1 . 2))) +(test-assert (time< '(7 . 2) '(8 . 2))) +(test-assert (not (time< '(7 . 2) '(7 . 2)))) +(test-assert (not (time< '(7 . 8) '(7 . 2)))) +(test-assert (not (time< '(8 . 2) '(7 . 2)))) (let ((tdelta (make-time-delta 8))) (test-assert (time-delta? tdelta)) (test-eqv (time-delta-sec tdelta) 8) (test-eqv (time-delta-usec tdelta) 0) (test-equal - (time-+ '(2 . 3) tdelta) + (time-delta+ '(2 . 3) tdelta) '(10 . 3))) (let ((tdelta (make-time-delta 10 1))) @@ -37,7 +37,7 @@ (test-eqv (time-delta-sec tdelta) 10) (test-eqv (time-delta-usec tdelta) 1) (test-equal - (time-+ '(2 . 3) tdelta) + (time-delta+ '(2 . 3) tdelta) '(12 . 4))) @@ -61,7 +61,7 @@ (test-assert (schedule-empty? sched)) ;; Add a segment at (10 . 0) -(schedule-add! 10 a-proc sched) +(schedule-add! sched 10 a-proc) (test-assert (not (schedule-empty? sched))) (test-equal (length (schedule-segments sched)) 1) (test-equal (time-segment-time (car (schedule-segments sched))) @@ -78,7 +78,7 @@ '((10 . 0))) ;; Add another segment at (10 . 0) -(schedule-add! '(10 . 0) b-proc sched) +(schedule-add! sched '(10 . 0) b-proc) (test-assert (not (schedule-empty? sched))) (test-equal (length (schedule-segments sched)) 1) (test-equal (time-segment-time (car (schedule-segments sched))) @@ -93,9 +93,9 @@ '((10 . 0))) ;; Add a segment to (11 . 0), (8 . 1) and (10 . 10) -(schedule-add! 11 c-proc sched) -(schedule-add! '(8 . 1) d-proc sched) -(schedule-add! '(10 . 10) e-proc sched) +(schedule-add! sched 11 c-proc) +(schedule-add! sched '(8 . 1) d-proc) +(schedule-add! sched '(10 . 10) e-proc) (test-assert (not (schedule-empty? sched))) (test-equal (length (schedule-segments sched)) 4) (assert-times-expected (schedule-segments sched) @@ -150,7 +150,7 @@ ;; Add one more and test flattening to a queue (test-assert (not (schedule-empty? sched))) -(schedule-add! '(10 . 10) f-proc sched) +(schedule-add! sched '(10 . 10) f-proc) (define remaining-segments (schedule-extract-until! sched '(9000 . 1))) (test-assert (schedule-empty? sched)) @@ -175,25 +175,25 @@ (test-assert (procedure? wrapped)) (test-equal (wrapped) 3)) -(let ((run-two-squared (run (lambda () (* 2 2))))) +(let ((run-two-squared (run-it (lambda () (* 2 2))))) (test-assert (run-request? run-two-squared)) (test-assert (procedure? (run-request-proc run-two-squared))) (test-equal ((run-request-proc run-two-squared)) 4) (test-eq (run-request-when run-two-squared) #f)) -(let ((run-two-squared (run (lambda () (* 2 2)) '(88 . 0)))) +(let ((run-two-squared (run-it (lambda () (* 2 2)) '(88 . 0)))) (test-assert (run-request? run-two-squared)) (test-assert (procedure? (run-request-proc run-two-squared))) (test-equal ((run-request-proc run-two-squared)) 4) (test-equal (run-request-when run-two-squared) '(88 . 0))) -(let ((run-two-squared (run-wrap (* 2 2)))) +(let ((run-two-squared (run (* 2 2)))) (test-assert (run-request? run-two-squared)) (test-assert (procedure? (run-request-proc run-two-squared))) (test-equal ((run-request-proc run-two-squared)) 4) (test-eq (run-request-when run-two-squared) #f)) -(let ((run-two-squared (run-wrap-at (* 2 2) '(88 . 0)))) +(let ((run-two-squared (run-at (* 2 2) '(88 . 0)))) (test-assert (run-request? run-two-squared)) (test-assert (procedure? (run-request-proc run-two-squared))) (test-equal ((run-request-proc run-two-squared)) 4) @@ -211,6 +211,12 @@ (if message (set! messages (append messages (list message)))) messages))) +(define (true-after-n-times n) + (let ((count 0)) + (lambda _ + (set! count (+ count 1)) + (if (>= count n) #t #f)))) + ;; the dummy test (define speaker (speak-it)) @@ -220,13 +226,13 @@ (define (run-dummy) (speaker "I bet I can make you say you're a dummy!\n") - (run dummy-func)) + (run-it dummy-func)) (let ((q (make-q))) (set! speaker (speak-it)) ; reset the speaker (enq! q run-dummy) (start-agenda (make-agenda #:queue q) - (true-after-n-times 2)) + #:stop-condition (true-after-n-times 2)) (test-equal (speaker) '("I bet I can make you say you're a dummy!\n" "I'm a dummy\n"))) @@ -236,10 +242,32 @@ (set! speaker (speak-it)) ; reset the speaker (enq! q run-dummy) (start-agenda (make-agenda #:queue q) - (true-after-n-times 1)) + #:stop-condition (true-after-n-times 1)) (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 (%sync (%run (return-monkey)))) "!\n")))) + +(let ((q (make-q))) + (set! speaker (speak-it)) + (enq! q talk-about-the-zoo) + ;; (enq! q talk-about-the-zoo-but-wait) + (start-agenda (make-agenda #:queue q) + #: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"))) ;; End tests