blob: 4d8583fb31bd8ec148f812b4ddd48b3ce9b08bd7 (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2017 David Thompson <davet@gnu.org>
;;;
;;; 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 (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (chickadee queue)
#:use-module (chickadee scripting script)
#:export (make-channel
channel?
channel-get
channel-put))
;; 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)
"Retrieve a value from CHANNEL. The current script suspends until a
value is available."
(yield
(lambda (cont)
(enqueue! (channel-get-queue channel) cont)
(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)
(enqueue! (channel-put-queue channel) (cons data cont))
(maybe-deliver channel))))
|