LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/ice-9/rdelim.scm

@@ -0,0 +1,208 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013,
+;;;;   2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+;;; This is the Scheme part of the module for delimited I/O.  It's
+;;; similar to (scsh rdelim) but somewhat incompatible.
+
+(define-module (ice-9 rdelim)
+  #:export (read-line
+            read-line!
+            read-delimited
+            read-delimited!
+            read-string
+            read-string!
+            %read-delimited!
+            %read-line
+            write-line))
+
+
+(%init-rdelim-builtins)
+
+(define* (read-line! string #:optional (port current-input-port))
+  ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+  (define scm-line-incrementors "\n")
+  (let* ((rv (%read-delimited! scm-line-incrementors
+                               string
+                               #t
+                               port))
+         (terminator (car rv))
+         (nchars (cdr rv)))
+    (cond ((and (= nchars 0)
+                (eof-object? terminator))
+           terminator)
+          ((not terminator) #f)
+          (else nchars))))
+
+(define* (read-delimited! delims buf #:optional
+                          (port (current-input-port)) (handle-delim 'trim)
+                          (start 0) (end (string-length buf)))
+  (let* ((rv (%read-delimited! delims
+                               buf
+                               (not (eq? handle-delim 'peek))
+                               port
+                               start
+                               end))
+         (terminator (car rv))
+         (nchars (cdr rv)))
+    (cond ((or (not terminator)         ; buffer filled
+               (eof-object? terminator))
+           (if (zero? nchars)
+               (if (eq? handle-delim 'split)
+                   (cons terminator terminator)
+                   terminator)
+               (if (eq? handle-delim 'split)
+                   (cons nchars terminator)
+                   nchars)))
+          (else
+           (case handle-delim
+             ((trim peek) nchars)
+             ((concat) (string-set! buf (+ nchars start) terminator)
+              (+ nchars 1))
+             ((split) (cons nchars terminator))
+             (else (error "unexpected handle-delim value: " 
+                          handle-delim)))))))
+  
+(define* (read-delimited delims #:optional (port (current-input-port))
+                         (handle-delim 'trim))
+  (let loop ((substrings '())
+             (total-chars 0)
+             (buf-size 100))		; doubled each time through.
+    (let* ((buf (make-string buf-size))
+           (rv (%read-delimited! delims
+                                 buf
+                                 (not (eq? handle-delim 'peek))
+                                 port))
+           (terminator (car rv))
+           (nchars (cdr rv))
+           (new-total (+ total-chars nchars)))
+      (cond
+       ((not terminator)
+        ;; buffer filled.
+        (loop (cons (substring buf 0 nchars) substrings)
+              new-total
+              (* buf-size 2)))
+       ((and (eof-object? terminator) (zero? new-total))
+        (if (eq? handle-delim 'split)
+            (cons terminator terminator)
+            terminator))
+       (else
+        (let ((joined
+               (string-concatenate-reverse
+                (cons (substring buf 0 nchars) substrings))))
+          (case handle-delim
+            ((concat)
+             (if (eof-object? terminator)
+                 joined
+                 (string-append joined (string terminator))))
+            ((trim peek) joined)
+            ((split) (cons joined terminator))
+            (else (error "unexpected handle-delim value: "
+                         handle-delim)))))))))
+
+(define-syntax-rule (check-arg exp message arg ...)
+  (unless exp
+    (error message arg ...)))
+
+(define (index? n)
+  (and (integer? n) (exact? n) (>= n 0)))
+
+(define* (read-string! buf #:optional
+                       (port (current-input-port))
+                       (start 0) (end (string-length buf)))
+  "Read all of the characters out of PORT and write them to BUF.
+Returns the number of characters read.
+
+This function only reads out characters from PORT if it will be able to
+write them to BUF.  That is to say, if BUF is smaller than the number of
+available characters, then BUF will be filled, and characters will be
+left in the port."
+  (check-arg (string? buf) "not a string" buf)
+  (check-arg (index? start) "bad index" start)
+  (check-arg (index? end) "bad index" end)
+  (check-arg (<= start end) "start beyond end" start end)
+  (check-arg (<= end (string-length buf)) "end beyond string length" end)
+  (let lp ((n start))
+    (if (< n end)
+        (let ((c (read-char port)))
+          (if (eof-object? c)
+              (- n start)
+              (begin
+                (string-set! buf n c)
+                (lp (1+ n)))))
+        (- n start))))
+
+(define* read-string
+  (case-lambda*
+   "Read all of the characters out of PORT and return them as a string.
+If the COUNT argument is present, treat it as a limit to the number of
+characters to read.  By default, there is no limit."
+   ((#:optional (port (current-input-port)))
+    ;; Fast path.
+    (let loop ((head (make-string 30)) (pos 0) (tail '()))
+      (let ((char (read-char port)))
+        (cond
+         ((eof-object? char)
+          (let ((head (substring head 0 pos)))
+            (if (null? tail)
+                (substring head 0 pos)
+                (string-concatenate-reverse tail head pos))))
+         (else
+          (string-set! head pos char)
+          (if (< (1+ pos) (string-length head))
+              (loop head (1+ pos) tail)
+              (loop (make-string (* (string-length head) 2)) 0
+                    (cons head tail))))))))
+   ((port count)
+    ;; Slower path.
+    (let loop ((chars '())
+               (total 0))
+      (let ((char (read-char port)))
+        (if (or (eof-object? char) (>= total count))
+            (list->string (reverse chars))
+            (loop (cons char chars) (+ 1 total))))))))
+
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'.  If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned.  If `concat', the string is
+;;; returned with the trailing newline intact.  If `peek', the newline
+;;; is left in the input port buffer and the string is returned.  If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+
+(define* (read-line #:optional (port (current-input-port))
+                    (handle-delim 'trim))
+  (let* ((line/delim	(%read-line port))
+	 (line		(car line/delim))
+	 (delim		(cdr line/delim)))
+    (case handle-delim
+      ((trim) line)
+      ((split) line/delim)
+      ((concat) (if (and (string? line) (char? delim))
+		    (string-append line (string delim))
+		    line))
+      ((peek) (if (char? delim)
+		  (unread-char delim port))
+	      line)
+      (else
+       (error "unexpected handle-delim value: " handle-delim)))))

data/share/guile/2.2/ice-9/receive.scm

@@ -0,0 +1,26 @@
+;;;; SRFI-8
+
+;;; Copyright (C) 2000, 2001, 2004, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (ice-9 receive)
+  #:export (receive))
+
+(define-syntax-rule (receive vars vals . body)
+  (call-with-values (lambda () vals)
+    (lambda vars . body)))
+
+(cond-expand-provide (current-module) '(srfi-8))

data/share/guile/2.2/ice-9/regex.scm

@@ -0,0 +1,229 @@
+;;;;    Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006, 2008, 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+
+;; These procedures are exported:
+;;  (match:count match)
+;;  (match:string match)
+;;  (match:prefix match)
+;;  (match:suffix match)
+;;  (regexp-match? match)
+;;  (regexp-quote string)
+;;  (match:start match . submatch-num)
+;;  (match:end match . submatch-num)
+;;  (match:substring match . submatch-num)
+;;  (string-match pattern str . start)
+;;  (regexp-substitute port match . items)
+;;  (fold-matches regexp string init proc . flags)
+;;  (list-matches regexp string . flags)
+;;  (regexp-substitute/global port regexp string . items)
+
+;;; Code:
+
+;;;; POSIX regex support functions.
+
+(define-module (ice-9 regex)
+  #:export (match:count match:string match:prefix match:suffix
+           regexp-match? regexp-quote match:start match:end match:substring
+           string-match regexp-substitute fold-matches list-matches
+           regexp-substitute/global))
+
+;; References:
+;;
+;; POSIX spec:
+;; http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html
+
+;;; FIXME:
+;;;   It is not clear what should happen if a `match' function
+;;;   is passed a `match number' which is out of bounds for the
+;;;   regexp match: return #f, or throw an error?  These routines
+;;;   throw an out-of-range error.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; These procedures are not defined in SCSH, but I found them useful.
+
+(define (match:count match)
+  (- (vector-length match) 1))
+
+(define (match:string match)
+  (vector-ref match 0))
+
+(define (match:prefix match)
+  (substring (match:string match) 0 (match:start match 0)))
+
+(define (match:suffix match)
+  (substring (match:string match) (match:end match 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; SCSH compatibility routines.
+
+(define (regexp-match? match)
+  (and (vector? match)
+       (string? (vector-ref match 0))
+       (let loop ((i 1))
+         (cond ((>= i (vector-length match)) #t)
+               ((and (pair? (vector-ref match i))
+                     (integer? (car (vector-ref match i)))
+                     (integer? (cdr (vector-ref match i))))
+                (loop (+ 1 i)))
+               (else #f)))))
+
+;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
+;; can be backslash escaped.
+;;
+;; ( ) + ? { } and | are special in regexp/extended so must be quoted.  But
+;; that can't be done with a backslash since in regexp/basic where they're
+;; not special, adding a backslash makes them become special.  Character
+;; class forms [(] etc are used instead.
+;;
+;; ) is not special when not preceded by a (, and * and ? are not special at
+;; the start of a string, but we quote all of these always, so the result
+;; can be concatenated or merged into some larger regexp.
+;;
+;; ] is not special outside a [ ] character class, so doesn't need to be
+;; quoted.
+;;
+(define (regexp-quote string)
+  (call-with-output-string
+   (lambda (p)
+     (string-for-each (lambda (c)
+                        (case c
+                          ((#\* #\. #\\ #\^ #\$ #\[)
+                           (write-char #\\ p)
+                           (write-char c p))
+                          ((#\( #\) #\+ #\? #\{ #\} #\|)
+                           (write-char #\[ p)
+                           (write-char c p)
+                           (write-char #\] p))
+                          (else
+                           (write-char c p))))
+                      string))))
+
+(define* (match:start match #:optional (n 0))
+  (let ((start (car (vector-ref match (1+ n)))))
+    (if (= start -1) #f start)))
+
+(define* (match:end match #:optional (n 0))
+  (let* ((end (cdr (vector-ref match (1+ n)))))
+    (if (= end -1) #f end)))
+
+(define* (match:substring match #:optional (n 0))
+  (let* ((start (match:start match n))
+         (end   (match:end match n)))
+    (and start end (substring (match:string match) start end))))
+
+(define (string-match pattern str . args)
+  (let ((rx (make-regexp pattern))
+        (start (if (pair? args) (car args) 0)))
+    (regexp-exec rx str start)))
+
+(define (regexp-substitute port match . items)
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+         (apply regexp-substitute p match items)))
+
+      ;; Otherwise, process each substitution argument in `items'.
+      (for-each (lambda (obj)
+                  (cond ((string? obj)   (display obj port))
+                        ((integer? obj)  (display (match:substring match obj) port))
+                        ((eq? 'pre obj)  (display (match:prefix match) port))
+                        ((eq? 'post obj) (display (match:suffix match) port))
+                        (else (error 'wrong-type-arg obj))))
+                items)))
+
+;;; If we call fold-matches, below, with a regexp that can match the
+;;; empty string, it's not obvious what "all the matches" means.  How
+;;; many empty strings are there in the string "a"?  Our answer:
+;;;
+;;;     This function applies PROC to every non-overlapping, maximal
+;;;     match of REGEXP in STRING.
+;;;
+;;; "non-overlapping": There are two non-overlapping matches of "" in
+;;; "a" --- one before the `a', and one after.  There are three
+;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
+;;; before `a' and after `b', and `q'.  The two empty strings before
+;;; and after `q' don't count, because they overlap with the match of
+;;; "q".
+;;;
+;;; "maximal": There are three distinct maximal matches of "x*" in
+;;; "axxxb": one before the `a', one covering `xxx', and one after the
+;;; `b'.  Around or within `xxx', only the match covering all three
+;;; x's counts, because the rest are not maximal.
+
+(define* (fold-matches regexp string init proc #:optional (flags 0))
+  (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp))))
+    (let loop ((start 0)
+               (value init)
+               (abuts #f))              ; True if start abuts a previous match.
+      (define bol (if (zero? start) 0 regexp/notbol))
+      (let ((m (if (> start (string-length string)) #f
+                   (regexp-exec regexp string start (logior flags bol)))))
+        (cond
+         ((not m) value)
+         ((and (= (match:start m) (match:end m)) abuts)
+          ;; We matched an empty string, but that would overlap the
+          ;; match immediately before.  Try again at a position
+          ;; further to the right.
+          (loop (+ start 1) value #f))
+         (else
+          (loop (match:end m) (proc m value) #t)))))))
+
+(define* (list-matches regexp string #:optional (flags 0))
+  (reverse! (fold-matches regexp string '() cons flags)))
+
+(define (regexp-substitute/global port regexp string . items)
+
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+         (apply regexp-substitute/global p regexp string items)))
+
+      ;; Walk the set of non-overlapping, maximal matches.
+      (let next-match ((matches (list-matches regexp string))
+                       (start 0))
+        (if (null? matches)
+            (display (substring string start) port)
+            (let ((m (car matches)))
+
+              ;; Process all of the items for this match.  Don't use
+              ;; for-each, because we need to make sure 'post at the
+              ;; end of the item list is a tail call.
+              (let next-item ((items items))
+
+                (define (do-item item)
+                  (cond
+                   ((string? item)    (display item port))
+                   ((integer? item)   (display (match:substring m item) port))
+                   ((procedure? item) (display (item m) port))
+                   ((eq? item 'pre)
+                    (display
+                     (substring string start (match:start m))
+                     port))
+                   ((eq? item 'post)
+                    (next-match (cdr matches) (match:end m)))
+                   (else (error 'wrong-type-arg item))))
+
+                (if (pair? items)
+                    (if (null? (cdr items))
+                        (do-item (car items)) ; This is a tail call.
+                        (begin
+                          (do-item (car items)) ; This is not.
+                          (next-item (cdr items)))))))))))

data/share/guile/2.2/ice-9/runq.scm

@@ -0,0 +1,241 @@
+;;;; runq.scm --- the runq data structure
+;;;;
+;;;; 	Copyright (C) 1996, 2001, 2006, 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+
+;;; One way to schedule parallel computations in a serial environment is
+;;; to explicitly divide each task up into small, finite execution time,
+;;; strips.  Then you interleave the execution of strips from various
+;;; tasks to achieve a kind of parallelism.  Runqs are a handy data
+;;; structure for this style of programming.
+;;;
+;;; We use thunks (nullary procedures) and lists of thunks to represent
+;;; strips.  By convention, the return value of a strip-thunk must either
+;;; be another strip or the value #f.
+;;;
+;;; A runq is a procedure that manages a queue of strips.  Called with no
+;;; arguments, it processes one strip from the queue.  Called with
+;;; arguments, the arguments form a control message for the queue.  The
+;;; first argument is a symbol which is the message selector.
+;;;
+;;; A strip is processed this way: If the strip is a thunk, the thunk is
+;;; called -- if it returns a strip, that strip is added back to the
+;;; queue.  To process a strip which is a list of thunks, the CAR of that
+;;; list is called.  After a call to that CAR, there are 0, 1, or 2 strips
+;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
+;;; original strip if that CDR is not nil.  The runq puts whichever of
+;;; these strips exist back on the queue.  (The exact order in which
+;;; strips are put back on the queue determines the scheduling behavior of
+;;; a particular queue -- it's a parameter.)
+
+;;; Code:
+
+(define-module (ice-9 runq)
+  :use-module (ice-9 q)
+  :export (runq-control make-void-runq make-fair-runq
+	   make-exclusive-runq make-subordinate-runq-to strip-sequence
+	   fair-strip-subtask))
+
+;;;;
+;;; 	(runq-control q msg . args)
+;;;
+;;; 		processes in the default way the control messages that
+;;; 		can be sent to a runq.  Q should be an ordinary
+;;; 		Q (see utils/q.scm).
+;;;
+;;; 		The standard runq messages are:
+;;;
+;;; 		'add! strip0 strip1...		;; to enqueue one or more strips
+;;; 		'enqueue! strip0 strip1...	;; to enqueue one or more strips
+;;; 		'push! strip0 ...		;; add strips to the front of the queue
+;;; 		'empty?				;; true if it is
+;;; 		'length				;; how many strips in the queue?
+;;; 		'kill!				;; empty the queue
+;;; 		else				;; throw 'not-understood
+;;;
+(define (runq-control q msg . args)
+  (case msg
+    ((add!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+    ((enqueue!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+    ((push!)			(for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
+    ((empty?)			(q-empty? q))
+    ((length)			(q-length q))
+    ((kill!)			(set! q (make-q)))
+    (else			(throw 'not-understood msg args))))
+
+(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
+
+;;;;
+;;; make-void-runq
+;;;
+;;; Make a runq that discards all messages except "length", for which
+;;; it returns 0.
+;;;
+(define (make-void-runq)
+  (lambda opts
+    (and opts
+	(apply-to-args opts
+	  (lambda (msg . args)
+	    (case msg
+	      ((length)		0)
+	      (else		#f)))))))
+
+;;;;
+;;; 	(make-fair-runq)
+;;;
+;;; 		Returns a runq procedure.
+;;; 		Called with no arguments, the procedure processes one strip from the queue.
+;;; 		Called with arguments, it uses runq-control.
+;;;
+;;; 		In a fair runq, if a strip returns a new strip X, X is added
+;;; 		to the end of the queue, meaning it will be the last to execute
+;;; 		of all the remaining procedures.
+;;;
+(define (make-fair-runq)
+  (letrec ((q (make-q))
+	   (self
+	    (lambda ctl
+	      (if ctl
+		  (apply runq-control q ctl)
+		  (and (not (q-empty? q))
+		       (let ((next-strip (deq! q)))
+			 (cond
+			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
+							  (and k (enq! q k))))
+			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+						(and k (enq! q k)))
+					      (if (not (null? (cdr next-strip)))
+						  (enq! q (cdr next-strip)))))
+			 self))))))
+    self))
+
+
+;;;;
+;;; 	(make-exclusive-runq)
+;;;
+;;; 		Returns a runq procedure.
+;;; 		Called with no arguments, the procedure processes one strip from the queue.
+;;; 		Called with arguments, it uses runq-control.
+;;;
+;;; 		In an exclusive runq, if a strip W returns a new strip X, X is added
+;;; 		to the front of the queue, meaning it will be the next to execute
+;;; 		of all the remaining procedures.
+;;;
+;;; 		An exception to this occurs if W was the CAR of a list of strips.
+;;; 		In that case, after the return value of W is pushed onto the front
+;;; 	 	of the queue, the CDR of the list of strips is pushed in front
+;;; 		of that (if the CDR is not nil).   This way, the rest of the thunks
+;;; 		in the list that contained W have priority over the return value of W.
+;;;
+(define (make-exclusive-runq)
+  (letrec ((q (make-q))
+	   (self
+	    (lambda ctl
+	      (if ctl
+		  (apply runq-control q ctl)
+		  (and (not (q-empty? q))
+		       (let ((next-strip (deq! q)))
+			 (cond
+			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
+							  (and k (q-push! q k))))
+			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+						(and k (q-push! q k)))
+					      (if (not (null? (cdr next-strip)))
+						  (q-push! q (cdr next-strip)))))
+			 self))))))
+    self))
+
+
+;;;;
+;;; 	(make-subordinate-runq-to superior basic-inferior)
+;;;
+;;; 		Returns a runq proxy for the runq basic-inferior.
+;;;
+;;; 		The proxy watches for operations on the basic-inferior that cause
+;;; 		a transition from a queue length of 0 to a non-zero length and
+;;; 		vice versa.   While the basic-inferior queue is not empty,
+;;; 		the proxy installs a task on the superior runq.  Each strip
+;;; 		of that task processes N strips from the basic-inferior where
+;;; 		N is the length of the basic-inferior queue when the proxy
+;;; 		strip is entered.  [Countless scheduling variations are possible.]
+;;;
+(define (make-subordinate-runq-to superior-runq basic-runq)
+  (let ((runq-task (cons #f #f)))
+    (set-car! runq-task
+	      (lambda ()
+		(if (basic-runq 'empty?)
+		    (set-cdr! runq-task #f)
+		    (do ((n (basic-runq 'length) (1- n)))
+			((<= n 0)		 #f)
+		      (basic-runq)))))
+    (letrec ((self
+	      (lambda ctl
+		(if (not ctl)
+		    (let ((answer (basic-runq)))
+		      (self 'empty?)
+		      answer)
+		    (begin
+		      (case (car ctl)
+			((suspend)		(set-cdr! runq-task #f))
+			(else		      	(let ((answer (apply basic-runq ctl)))
+						  (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
+						      (begin
+							(set-cdr! runq-task runq-task)
+							(superior-runq 'add! runq-task)))
+						  answer))))))))
+      self)))
+
+;;;;
+;;;	(define fork-strips (lambda args args))
+;;;		Return a strip that starts several strips in
+;;;		parallel.   If this strip is enqueued on a fair
+;;;		runq, strips of the parallel subtasks will run
+;;;		round-robin style.
+;;;
+
+
+;;;;
+;;; 	(strip-sequence . strips)
+;;;
+;;; 		Returns a new strip which is the concatenation of the argument strips.
+;;;
+(define (strip-sequence . strips)
+  (lambda ()
+    (let loop ((st (let ((a strips)) (set! strips #f) a)))
+      (and (not (null? st))
+           (let ((then ((car st))))
+             (if then
+                 (lambda () (loop (cons then (cdr st))))
+                 (lambda () (loop (cdr st)))))))))
+
+
+;;;;
+;;; 	(fair-strip-subtask . initial-strips)
+;;;
+;;; 		Returns a new strip which is the synchronos, fair,
+;;; 		parallel execution of the argument strips.
+;;;
+;;;
+;;;
+(define (fair-strip-subtask . initial-strips)
+  (let ((st (make-fair-runq)))
+    (apply st 'add! initial-strips)
+    st))
+
+;;; runq.scm ends here