blob: 66855b2d90993a10b86f3c7b93b32da7f93e5319 (
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
|
;;; Chickadee Game Toolkit
;;; Copyright © 2017, 2018 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(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)))
|