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