Initial commit

knots/queue.scm

@@ -0,0 +1,47 @@
+;;; Guile Knots
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of Guile Knots.
+;;;
+;;; The Guile Knots 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.
+;;;
+;;; The Guile Knots 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 the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (knots queue)
+  #:use-module (ice-9 q)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
+  #:use-module (fibers operations)
+  #:export (spawn-queueing-fiber))
+
+(define (spawn-queueing-fiber dest-channel)
+  (define queue (make-q))
+
+  (let ((queue-channel (make-channel)))
+    (spawn-fiber
+     (lambda ()
+       (while #t
+         (if (q-empty? queue)
+             (enq! queue
+                   (perform-operation
+                    (get-operation queue-channel)))
+             (let ((front (q-front queue)))
+               (perform-operation
+                (choice-operation
+                 (wrap-operation (get-operation queue-channel)
+                                 (lambda (val)
+                                   (enq! queue val)))
+                 (wrap-operation (put-operation dest-channel front)
+                                 (lambda _
+                                   (q-pop! queue))))))))))
+    queue-channel))