blob: 6b3901ad36b9f12e191cc3303a3bf83c1cb7e143 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2018 David Thompson <dthompson2@worcester.edu>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (chickadee scripting channel)
#:use-module (chickadee data queue)
#:use-module (chickadee scripting script)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (make-channel
channel?
channel-get!
channel-get
channel-put!
channel-put
channel-clear!))
;; A very simplified notion of channels compared to guile-fibers. In
;; our case, everything is cooperative and on the same thread, so we
;; have less to worry about.
(define-record-type <channel>
(%make-channel get-queue put-queue)
channel?
(get-queue channel-get-queue)
(put-queue channel-put-queue))
(define (display-channel channel port)
(display "<channel>" port))
(set-record-type-printer! <channel> display-channel)
(define (make-channel)
"Return a new channel."
(%make-channel (make-queue) (make-queue)))
(define (maybe-deliver channel)
(let ((getq (channel-get-queue channel))
(putq (channel-put-queue channel)))
(if (and (not (queue-empty? getq))
(not (queue-empty? putq)))
(match (dequeue! putq)
((data . put-cont)
(let ((get-cont (dequeue! getq)))
(get-cont data)
(put-cont)))))))
(define (channel-get! channel proc)
"Asynchronously retrieve a value from CHANNEL and call PROC with
that value."
(enqueue! (channel-get-queue channel) proc)
(maybe-deliver channel))
(define (channel-get channel)
"Retrieve a value from CHANNEL. The current script suspends until a
value is available."
(yield
(lambda (cont)
(channel-get! channel cont))))
(define noop (lambda () #t))
(define* (channel-put! channel data #:optional (thunk noop))
"Asynchronously send DATA to CHANNEL and call THUNK after it has
been received."
(enqueue! (channel-put-queue channel) (cons data thunk))
(maybe-deliver channel))
(define (channel-put channel data)
"Send DATA to CHANNEL. The current script suspends until another
script is available to retrieve the value."
(yield
(lambda (cont)
(channel-put! channel data cont))))
(define (channel-clear! channel)
"Clear all messages and scripts awaiting messages in CHANNEL."
(queue-clear! (channel-get-queue channel))
(queue-clear! (channel-put-queue channel)))
|
