LilyPond-Ruby 0.1.1 → 0.1.2

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

@@ -0,0 +1,37 @@
+;;;; 	Copyright (C) 1997, 2000, 2001, 2002, 2003, 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
+;;;; 
+
+
+(define-module (ice-9 syncase)
+  ;; FIXME re-export other procs
+  #:export (datum->syntax-object syntax-object->datum
+            sc-expand))
+
+(issue-deprecation-warning
+ "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.")
+
+(define datum->syntax-object datum->syntax)
+(define syntax-object->datum syntax->datum)
+(define sc-expand macroexpand)
+
+;;; Hack to make syncase macros work in the slib module
+;; FIXME wingo is this still necessary?
+;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
+;;   (if m
+;;       (set-object-property! (module-local-variable m 'define)
+;; 			    '*sc-expander*
+;; 			    '(define))))

data/share/guile/2.2/ice-9/textual-ports.scm

@@ -0,0 +1,70 @@
+;;;; textual-ports.scm --- Textual I/O on ports
+
+;;;;	Copyright (C) 2016 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:
+;;;
+;;; Code:
+
+(define-module (ice-9 textual-ports)
+  #:use-module (ice-9 ports internal)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 rdelim)
+  #:re-export (get-string-n!
+               put-char
+               put-string)
+  #:export (get-char
+            unget-char
+            unget-string
+            lookahead-char
+            get-string-n
+            get-string-all
+            get-line))
+
+(define (get-char port)
+  (read-char port))
+
+(define (lookahead-char port)
+  (peek-char port))
+
+(define (unget-char port char)
+  (unread-char char port))
+
+(define* (unget-string port string #:optional (start 0)
+                       (count (- (string-length string) start)))
+  (unread-string (if (and (zero? start)
+                          (= count (string-length string)))
+                     string
+                     (substring/shared string start (+ start count)))
+                 port))
+
+(define (get-line port)
+  (read-line port 'trim))
+
+(define (get-string-all port)
+  (read-string port))
+
+(define (get-string-n port count)
+  "Read up to @var{count} characters from @var{port}.
+If no characters could be read before encountering the end of file,
+return the end-of-file object, otherwise return a string containing
+the characters read."
+  (let* ((s (make-string count))
+         (rv (get-string-n! port s 0 count)))
+    (cond ((eof-object? rv) rv)
+          ((= rv count)     s)
+          (else             (substring/shared s 0 rv)))))

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

@@ -0,0 +1,392 @@
+;;;; 	Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011,
+;;;;      2012, 2018 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
+;;;;
+;;;; ----------------------------------------------------------------
+;;;; threads.scm -- User-level interface to Guile's thread system
+;;;; 4 March 1996, Anthony Green <green@cygnus.com>
+;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
+;;;; Modified 6 April 2001, ttn
+;;;; ----------------------------------------------------------------
+;;;;
+
+;;; Commentary:
+
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (ice-9 threads)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
+  ;; These bindings are marked as #:replace because when deprecated code
+  ;; is enabled, (ice-9 deprecated) also exports these names.
+  ;; (Referencing one of the deprecated names prints a warning directing
+  ;; the user to these bindings.)  Anyway once we can remove the
+  ;; deprecated bindings, we should use #:export instead of #:replace
+  ;; for these.
+  #:replace (call-with-new-thread
+             yield
+             cancel-thread
+             join-thread
+             thread?
+             make-mutex
+             make-recursive-mutex
+             lock-mutex
+             try-mutex
+             unlock-mutex
+             mutex?
+             mutex-owner
+             mutex-level
+             mutex-locked?
+             make-condition-variable
+             wait-condition-variable
+             signal-condition-variable
+             broadcast-condition-variable
+             condition-variable?
+             current-thread
+             all-threads
+             thread-exited?
+             total-processor-count
+             current-processor-count)
+  #:export (begin-thread
+            make-thread
+            with-mutex
+            monitor
+
+            parallel
+            letpar
+            par-map
+            par-for-each
+            n-par-map
+            n-par-for-each
+            n-for-each-par-map
+            %thread-handler))
+
+;; Note that this extension also defines %make-transcoded-port, which is
+;; not exported but is used by (rnrs io ports).
+
+(eval-when (expand eval load)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_ice_9_threads"))
+
+
+
+(define-syntax-rule (with-mutex m e0 e1 ...)
+  (let ((x m))
+    (dynamic-wind
+      (lambda () (lock-mutex x))
+      (lambda () (begin e0 e1 ...))
+      (lambda () (unlock-mutex x)))))
+
+(define cancel-tag (make-prompt-tag "cancel"))
+(define (cancel-thread thread . values)
+  "Asynchronously interrupt the target @var{thread} and ask it to
+terminate, returning the given @var{values}.  @code{dynamic-wind} post
+thunks will run, but throw handlers will not.  If @var{thread} has
+already terminated or been signaled to terminate, this function is a
+no-op."
+  (system-async-mark
+   (lambda ()
+     (catch #t
+       (lambda ()
+         (apply abort-to-prompt cancel-tag values))
+       (lambda _
+         (error "thread cancellation failed, throwing error instead???"))))
+   thread))
+
+(define thread-join-data (make-object-property))
+(define %thread-results (make-object-property))
+
+(define* (call-with-new-thread thunk #:optional handler)
+  "Call @code{thunk} in a new thread and with a new dynamic state,
+returning a new thread object representing the thread.  The procedure
+@var{thunk} is called via @code{with-continuation-barrier}.
+
+When @var{handler} is specified, then @var{thunk} is called from within
+a @code{catch} with tag @code{#t} that has @var{handler} as its handler.
+This catch is established inside the continuation barrier.
+
+Once @var{thunk} or @var{handler} returns, the return value is made the
+@emph{exit value} of the thread and the thread is terminated."
+  (let ((cv (make-condition-variable))
+        (mutex (make-mutex))
+        (thunk (if handler
+                   (lambda () (catch #t thunk handler))
+                   thunk))
+        (thread #f))
+    (define (call-with-backtrace thunk)
+      (let ((err (current-error-port)))
+        (catch #t
+          (lambda () (%start-stack 'thread thunk))
+          (lambda _ (values))
+          (lambda (key . args)
+            ;; Narrow by three: the dispatch-exception,
+            ;; this thunk, and make-stack.
+            (let ((stack (make-stack #t 3)))
+              (false-if-exception
+               (begin
+                 (when stack
+                   (display-backtrace stack err))
+                 (let ((frame (and stack (stack-ref stack 0))))
+                   (print-exception err frame key args)))))))))
+    (with-mutex mutex
+      (%call-with-new-thread
+       (lambda ()
+         (call-with-values
+             (lambda ()
+               (call-with-prompt cancel-tag
+                 (lambda ()
+                   (lock-mutex mutex)
+                   (set! thread (current-thread))
+                   (set! (thread-join-data thread) (cons cv mutex))
+                   (signal-condition-variable cv)
+                   (unlock-mutex mutex)
+                   (call-with-unblocked-asyncs
+                    (lambda () (call-with-backtrace thunk))))
+                 (lambda (k . args)
+                   (apply values args))))
+           (lambda vals
+             (lock-mutex mutex)
+             ;; Probably now you're wondering why we are going to use
+             ;; the cond variable as the key into the thread results
+             ;; object property.  It's because there is a possibility
+             ;; that the thread object itself ends up as part of the
+             ;; result, and if that happens we create a cycle whereby
+             ;; the strong reference to a thread in the value of the
+             ;; weak-key hash table used by the object property prevents
+             ;; the thread from ever being collected.  So instead we use
+             ;; the cv as the key.  Weak-key hash tables, amirite?
+             (set! (%thread-results cv) vals)
+             (broadcast-condition-variable cv)
+             (unlock-mutex mutex)
+             (apply values vals)))))
+      (let lp ()
+        (unless thread
+          (wait-condition-variable cv mutex)
+          (lp))))
+    thread))
+
+(define* (join-thread thread #:optional timeout timeoutval)
+  "Suspend execution of the calling thread until the target @var{thread}
+terminates, unless the target @var{thread} has already terminated."
+  (match (thread-join-data thread)
+    (#f (error "foreign thread cannot be joined" thread))
+    ((cv . mutex)
+     (lock-mutex mutex)
+     (let lp ()
+       (cond
+        ((%thread-results cv)
+         => (lambda (results)
+              (unlock-mutex mutex)
+              (apply values results)))
+        ((if timeout
+             (wait-condition-variable cv mutex timeout)
+             (wait-condition-variable cv mutex))
+         (lp))
+        (else timeoutval))))))
+
+(define* (try-mutex mutex)
+  "Try to lock @var{mutex}.  If the mutex is already locked, return
+@code{#f}.  Otherwise lock the mutex and return @code{#t}."
+  (lock-mutex mutex 0))
+
+
+
+;;; Macros first, so that the procedures expand correctly.
+
+(define-syntax-rule (begin-thread e0 e1 ...)
+  (call-with-new-thread
+   (lambda () e0 e1 ...)
+   %thread-handler))
+
+(define-syntax-rule (make-thread proc arg ...)
+  (call-with-new-thread
+   (lambda () (proc arg ...))
+   %thread-handler))
+
+(define monitor-mutex-table (make-hash-table))
+
+(define monitor-mutex-table-mutex (make-mutex))
+
+(define (monitor-mutex-with-id id)
+  (with-mutex monitor-mutex-table-mutex
+    (or (hashq-ref monitor-mutex-table id)
+        (let ((mutex (make-mutex)))
+          (hashq-set! monitor-mutex-table id mutex)
+          mutex))))
+
+(define-syntax monitor
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ body body* ...)
+       (let ((id (datum->syntax #'body (gensym))))
+         #`(with-mutex (monitor-mutex-with-id '#,id)
+             body body* ...))))))
+
+(define (thread-handler tag . args)
+  (let ((n (length args))
+	(p (current-error-port)))
+    (display "In thread:" p)
+    (newline p)
+    (if (>= n 3)
+        (display-error #f
+                       p
+                       (car args)
+                       (cadr args)
+                       (caddr args)
+                       (if (= n 4)
+                           (cadddr args)
+                           '()))
+        (begin
+          (display "uncaught throw to " p)
+          (display tag p)
+          (display ": " p)
+          (display args p)
+          (newline p)))
+    #f))
+
+;;; Set system thread handler
+(define %thread-handler thread-handler)
+
+(use-modules (ice-9 futures))
+
+(define-syntax parallel
+  (lambda (x)
+    (syntax-case x ()
+      ((_ e0 ...)
+       (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
+         #'(let ((tmp0 (future e0))
+                 ...)
+             (values (touch tmp0) ...)))))))
+
+(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
+  (call-with-values
+      (lambda () (parallel e ...))
+    (lambda (v ...)
+      b0 b1 ...)))
+
+(define (par-mapper mapper cons)
+  (lambda (proc . lists)
+    (let loop ((lists lists))
+      (match lists
+        (((heads tails ...) ...)
+         (let ((tail (future (loop tails)))
+               (head (apply proc heads)))
+           (cons head (touch tail))))
+        (_
+         '())))))
+
+(define par-map (par-mapper map cons))
+(define par-for-each (par-mapper for-each (const *unspecified*)))
+
+(define (n-par-map n proc . arglists)
+  (let* ((m (make-mutex))
+	 (threads '())
+	 (results (make-list (length (car arglists))))
+	 (result results))
+    (do ((i 0 (+ 1 i)))
+	((= i n)
+	 (for-each join-thread threads)
+	 results)
+      (set! threads
+	    (cons (begin-thread
+		   (let loop ()
+		     (lock-mutex m)
+		     (if (null? result)
+			 (unlock-mutex m)
+			 (let ((args (map car arglists))
+			       (my-result result))
+			   (set! arglists (map cdr arglists))
+			   (set! result (cdr result))
+			   (unlock-mutex m)
+			   (set-car! my-result (apply proc args))
+			   (loop)))))
+		  threads)))))
+
+(define (n-par-for-each n proc . arglists)
+  (let ((m (make-mutex))
+	(threads '()))
+    (do ((i 0 (+ 1 i)))
+	((= i n)
+	 (for-each join-thread threads))
+      (set! threads
+	    (cons (begin-thread
+		   (let loop ()
+		     (lock-mutex m)
+		     (if (null? (car arglists))
+			 (unlock-mutex m)
+			 (let ((args (map car arglists)))
+			   (set! arglists (map cdr arglists))
+			   (unlock-mutex m)
+			   (apply proc args)
+			   (loop)))))
+		  threads)))))
+
+;;; The following procedure is motivated by the common and important
+;;; case where a lot of work should be done, (not too much) in parallel,
+;;; but the results need to be handled serially (for example when
+;;; writing them to a file).
+;;;
+(define (n-for-each-par-map n s-proc p-proc . arglists)
+  "Using N parallel processes, apply S-PROC in serial order on the results
+of applying P-PROC on ARGLISTS."
+  (let* ((m (make-mutex))
+	 (threads '())
+	 (no-result '(no-value))
+	 (results (make-list (length (car arglists)) no-result))
+	 (result results))
+    (do ((i 0 (+ 1 i)))
+	((= i n)
+	 (for-each join-thread threads))
+      (set! threads
+	    (cons (begin-thread
+		   (let loop ()
+		     (lock-mutex m)
+		     (cond ((null? results)
+			    (unlock-mutex m))
+			   ((not (eq? (car results) no-result))
+			    (let ((arg (car results)))
+			      ;; stop others from choosing to process results
+			      (set-car! results no-result)
+			      (unlock-mutex m)
+			      (s-proc arg)
+			      (lock-mutex m)
+			      (set! results (cdr results))
+			      (unlock-mutex m)
+			      (loop)))
+			   ((null? result)
+			    (unlock-mutex m))
+			   (else
+			    (let ((args (map car arglists))
+				  (my-result result))
+			      (set! arglists (map cdr arglists))
+			      (set! result (cdr result))
+			      (unlock-mutex m)
+			      (set-car! my-result (apply p-proc args))
+			      (loop))))))
+		  threads)))))
+
+
+;; Now that thread support is loaded, make module autoloading
+;; thread-safe.
+(set! (@ (guile) call-with-module-autoload-lock)
+  (let ((mutex (make-mutex 'recursive)))
+    (lambda (thunk)
+      (with-mutex mutex
+        (thunk)))))
+
+;;; threads.scm ends here

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

@@ -0,0 +1,58 @@
+;;;; 	Copyright (C) 2001, 2004, 2006, 2018 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:
+
+;; This module exports a single macro: `time'.
+;; Usage: (time exp)
+;;
+;; Example:
+;; guile> (time (sleep 3))
+;; clock utime stime cutime cstime gctime
+;; 3.01  0.00  0.00   0.00   0.00   0.00
+;; 0
+
+;;; Code:
+
+(define-module (ice-9 time)
+  #:use-module (ice-9 format)
+  #:export (time))
+
+(define (time-proc proc)
+  (let* ((gc-start (gc-run-time))
+         (tms-start (times))
+         (results (call-with-values proc list))
+         (tms-end (times))
+         (gc-end (gc-run-time)))
+    ;; FIXME: We would probably like format ~f to accept rationals, but
+    ;; currently it doesn't so we force to a flonum with exact->inexact.
+    (define (get proc start end)
+      (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+    (display "clock utime stime cutime cstime gctime\n")
+    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+            (get tms:clock tms-start tms-end)
+            (get tms:utime tms-start tms-end)
+            (get tms:stime tms-start tms-end)
+            (get tms:cutime tms-start tms-end)
+            (get tms:cstime tms-start tms-end)
+            (get identity gc-start gc-end))
+    (apply values results)))
+
+(define-syntax-rule (time exp)
+  (time-proc (lambda () exp)))
+
+;;; time.scm ends here

data/share/guile/2.2/ice-9/top-repl.scm

@@ -0,0 +1,78 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;;;;   2005, 2006, 2007, 2008, 2009, 2010, 2011, 2013 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 top-repl)
+  #:use-module (ice-9 top-repl)
+  #:use-module ((system repl repl) #:select (start-repl))
+
+  ;; #:replace, as with deprecated code enabled these will be in the root env
+  #:replace (top-repl))
+
+(define call-with-sigint
+  (if (not (provided? 'posix))
+      (lambda (thunk) (thunk))
+      (lambda (thunk)
+        (let ((handler #f))
+          (dynamic-wind
+            (lambda ()
+              (set! handler
+                    (sigaction SIGINT
+                      (lambda (sig)
+                        (scm-error 'signal #f "User interrupt" '()
+                                   (list sig))))))
+            thunk
+            (lambda ()
+              (if handler
+                  ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+                  (sigaction SIGINT (car handler) (cdr handler))
+                  ;; restore original C handler.
+                  (sigaction SIGINT #f))))))))
+
+(define (top-repl)
+  (let ((guile-user-module (resolve-module '(guile-user))))
+
+    ;; Use some convenient modules (in reverse order)
+
+    (set-current-module guile-user-module)
+    (process-use-modules 
+     (append
+      '(((ice-9 r5rs))
+        ((ice-9 session)))
+      (if (provided? 'regex)
+          '(((ice-9 regex)))
+          '())
+      (if (provided? 'threads)
+          '(((ice-9 threads)))
+          '())))
+
+    (call-with-sigint
+     (lambda ()
+       (and (defined? 'setlocale)
+            (catch 'system-error
+              (lambda ()
+                (setlocale LC_ALL ""))
+              (lambda (key subr fmt args errno)
+                (format (current-error-port)
+                        "warning: failed to install locale: ~a~%"
+                        (strerror (car errno))))))
+
+       (let ((status (start-repl (current-language))))
+         (run-hook exit-hook)
+         status)))))

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

@@ -0,0 +1,26 @@
+;; unicode
+
+;;;; Copyright (C) 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, see
+;;;; <http://www.gnu.org/licenses/>.
+;;;; 
+
+(define-module (ice-9 unicode)
+  #:export (formal-name->char
+            char->formal-name))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_unicode"))