tests/test-actors.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of 8sync.
   5 ;;;
   6 ;;; 8sync is free software: you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation, either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; 8sync is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (tests test-actors)
  20   #:use-module (srfi srfi-64)
  21   #:use-module (8sync actors)
  22   #:use-module (fibers)
  23   #:use-module (fibers conditions)
  24   #:use-module (fibers operations)
  25   #:use-module (fibers timers)
  26   #:use-module (ice-9 atomic)
  27   #:use-module (ice-9 receive)
  28   #:use-module (oop goops)
  29   #:use-module (tests utils))
  30
  31 (test-begin "test-actors")
  32
  33 \f
  34 ;;; Test waiting on a response
  35
  36 (define-actor <Responder> (<actor>)
  37   ((ping-pong
  38     (lambda (actor message ping-val)
  39       ;; Returns two values to its continuation: its ping-val, and the
  40       ;; value of its own response-val slot.
  41       (values (.response-val actor) ping-val))))
  42   (response-val #:init-keyword #:response-val
  43                 #:accessor .response-val))
  44
  45 (define-actor <Requester> (<actor>)
  46   ((run requester-run))
  47   (done #:init-keyword #:done
  48         #:accessor .done)
  49   (test-box #:init-keyword #:test-box
  50             #:accessor .test-box))
  51
  52 (define (requester-run requester m)
  53   (define beeper
  54     (create-actor <Responder> #:response-val 'beep))
  55   (define booper
  56     (create-actor <Responder> #:response-val 'boop))
  57   (define bopper
  58     (create-actor <Responder> #:response-val 'bop))
  59   (define borker
  60     (create-actor <Responder> #:response-val 'bork))
  61   (receive (v1 v2)
  62       (<-wait beeper 'ping-pong 1)
  63     (test-equal v1 'beep)
  64     (test-equal v2 1))
  65   (receive (v1 v2)
  66       (<-wait booper 'ping-pong 2)
  67     (test-equal v1 'boop)
  68     (test-equal v2 2))
  69   (receive (v1 v2)
  70       (<-wait bopper 'ping-pong 3)
  71     (test-equal v1 'bop)
  72     (test-equal v2 3))
  73   (receive (v1 v2)
  74       (<-wait borker 'ping-pong 4)
  75     (test-equal v1 'bork)
  76     (test-equal v2 4))
  77   (atomic-box-set! (.test-box requester) 'we-did-it)
  78   (signal-condition! (.done requester)))
  79
  80 (let ((test-box (make-atomic-box 'not-yet))
  81       (done (make-condition)))
  82   (run-hive
  83    (lambda (hive)
  84      (define requester (create-actor <Requester>
  85                                      #:done done
  86                                      #:test-box test-box))
  87      (<- requester 'run)
  88      (perform-operation
  89       (choice-operation (wait-operation done)
  90                         ;; if somehow this times out after 5 seconds,
  91                         ;; something is deeply wrong
  92                         (sleep-operation 5)))
  93      (test-equal (atomic-box-ref test-box)
  94        'we-did-it))))
  95
  96 (test-end "test-actors")
  97 (test-exit)