LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/srfi/srfi-8.scm

@@ -0,0 +1,31 @@
+;;; srfi-8.scm --- receive
+
+;; Copyright (C) 2000, 2001, 2002, 2006 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 is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-8)
+  :use-module (ice-9 receive)
+  :re-export-syntax (receive))
+
+(cond-expand-provide (current-module) '(srfi-8))
+
+;;; srfi-8.scm ends here

data/share/guile/2.2/srfi/srfi-88.scm

@@ -0,0 +1,53 @@
+;;; srfi-88.scm --- Keyword Objects              -*- coding: utf-8 -*-
+
+;; Copyright (C) 2008, 2009, 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is a convenience module providing SRFI-88 "keyword object".  All it
+;; does is setup the right reader option and export keyword-related
+;; convenience procedures.
+
+;;; Code:
+
+(define-module (srfi srfi-88)
+  #:re-export (keyword?)
+  #:export (keyword->string string->keyword))
+
+(cond-expand-provide (current-module) '(srfi-88))
+
+
+;; Change the keyword syntax both at compile time and run time; the latter is
+;; useful at the REPL.
+(eval-when (expand load eval)
+  (read-set! keywords 'postfix))
+
+(define (keyword->string k)
+  "Return the name of @var{k} as a string."
+  (symbol->string (keyword->symbol k)))
+
+(define (string->keyword s)
+  "Return the keyword object whose name is @var{s}."
+  (symbol->keyword (string->symbol s)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; srfi-88.scm ends here

data/share/guile/2.2/srfi/srfi-9/gnu.scm

@@ -0,0 +1,168 @@
+;;; Extensions to SRFI-9
+
+;; 	Copyright (C) 2010, 2012 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:
+
+;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-1)
+  #:use-module (system base ck)
+  #:export (set-record-type-printer!
+            define-immutable-record-type
+            set-field
+            set-fields))
+
+(define (set-record-type-printer! type proc)
+  "Set PROC as the custom printer for TYPE."
+  (struct-set! type vtable-index-printer proc))
+
+(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
+  ((@@ (srfi srfi-9) %define-record-type)
+   #t (define-immutable-record-type name ctor pred fields ...)
+   name ctor pred fields ...))
+
+(define-syntax-rule (set-field s (getter ...) expr)
+  (%set-fields #t (set-field s (getter ...) expr) ()
+               s ((getter ...) expr)))
+
+(define-syntax-rule (set-fields s . rest)
+  (%set-fields #t (set-fields s . rest) ()
+               s . rest))
+
+;;
+;; collate-set-field-specs is a helper for %set-fields
+;; thats combines all specs with the same head together.
+;;
+;; For example:
+;;
+;;   SPECS:  (((a b c) expr1)
+;;            ((a d)   expr2)
+;;            ((b c)   expr3)
+;;            ((c)     expr4))
+;;
+;;  RESULT:  ((a ((b c) expr1)
+;;               ((d)   expr2))
+;;            (b ((c)   expr3))
+;;            (c (()    expr4)))
+;;
+(define (collate-set-field-specs specs)
+  (define (insert head tail expr result)
+    (cond ((find (lambda (tree)
+                   (free-identifier=? head (car tree)))
+                 result)
+           => (lambda (tree)
+                `((,head (,tail ,expr)
+                         ,@(cdr tree))
+                  ,@(delq tree result))))
+          (else `((,head (,tail ,expr))
+                  ,@result))))
+  (with-syntax (((((head . tail) expr) ...) specs))
+    (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
+
+(define-syntax unknown-getter
+  (lambda (x)
+    (syntax-case x ()
+      ((_ orig-form getter)
+       (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
+
+(define-syntax c-list
+  (lambda (x)
+    (syntax-case x (quote)
+      ((_ s 'v ...)
+       #'(ck s '(v ...))))))
+
+(define-syntax c-same-type-check
+  (lambda (x)
+    (syntax-case x (quote)
+      ((_ s 'orig-form '(path ...)
+          '(getter0 getter ...)
+          '(type0 type ...)
+          'on-success)
+       (every (lambda (t g)
+                (or (free-identifier=? t #'type0)
+                    (syntax-violation
+                     'set-fields
+                     (format #f
+                             "\
+field paths ~a and ~a require one object to belong to two different record types (~a and ~a)"
+                             (syntax->datum #`(path ... #,g))
+                             (syntax->datum #'(path ... getter0))
+                             (syntax->datum t)
+                             (syntax->datum #'type0))
+                     #'orig-form)))
+              #'(type ...)
+              #'(getter ...))
+       #'(ck s 'on-success)))))
+
+(define-syntax %set-fields
+  (lambda (x)
+    (with-syntax ((getter-type   #'(@@ (srfi srfi-9) getter-type))
+                  (getter-index  #'(@@ (srfi srfi-9) getter-index))
+                  (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+      (syntax-case x ()
+        ((_ check? orig-form (path-so-far ...)
+            s)
+         #'s)
+        ((_ check? orig-form (path-so-far ...)
+            s (() e))
+         #'e)
+        ((_ check? orig-form (path-so-far ...)
+            struct-expr ((head . tail) expr) ...)
+         (let ((collated-specs (collate-set-field-specs
+                                #'(((head . tail) expr) ...))))
+           (with-syntax (((getter0 getter ...)
+                          (map car collated-specs)))
+             (with-syntax ((err #'(unknown-getter
+                                   orig-form getter0)))
+               #`(ck
+                  ()
+                  (c-same-type-check
+                   'orig-form
+                   '(path-so-far ...)
+                   '(getter0 getter ...)
+                   (c-list (getter-type 'getter0 'err)
+                           (getter-type 'getter 'err) ...)
+                   '(let ((s struct-expr))
+                      ((ck () (getter-copier 'getter0 'err))
+                       check?
+                       s
+                       #,@(map (lambda (spec)
+                                 (with-syntax (((head (tail expr) ...) spec))
+                                   (with-syntax ((err #'(unknown-getter
+                                                         orig-form head)))
+                                     #'(head (%set-fields
+                                              check?
+                                              orig-form
+                                              (path-so-far ... head)
+                                              (struct-ref s (ck () (getter-index
+                                                                    'head 'err)))
+                                              (tail expr) ...)))))
+                               collated-specs)))))))))
+        ((_ check? orig-form (path-so-far ...)
+            s (() e) (() e*) ...)
+         (syntax-violation 'set-fields "duplicate field path"
+                           #'orig-form #'(path-so-far ...)))
+        ((_ check? orig-form (path-so-far ...)
+            s ((getter ...) expr) ...)
+         (syntax-violation 'set-fields "one field path is a prefix of another"
+                           #'orig-form #'(path-so-far ...)))
+        ((_ check? orig-form . rest)
+         (syntax-violation 'set-fields "invalid syntax" #'orig-form))))))

data/share/guile/2.2/srfi/srfi-9.scm

@@ -0,0 +1,351 @@
+;;; srfi-9.scm --- define-record-type
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
+;;   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
+
+;;; Commentary:
+
+;; This module exports the syntactic form `define-record-type', which
+;; is the means for creating record types defined in SRFI-9.
+;;
+;; The syntax of a record type definition is:
+;;
+;;  <record type definition>
+;;    -> (define-record-type <type name>
+;;         (<constructor name> <field tag> ...)
+;;         <predicate name>
+;;         <field spec> ...)
+;;
+;;  <field spec> -> (<field tag> <getter name>)
+;;               -> (<field tag> <getter name> <setter name>)
+;;
+;;  <field tag> -> <identifier>
+;;  <... name>  -> <identifier>
+;;
+;; Usage example:
+;;
+;; guile> (use-modules (srfi srfi-9))
+;; guile> (define-record-type :foo (make-foo x) foo?
+;;                            (x get-x) (y get-y set-y!))
+;; guile> (define f (make-foo 1))
+;; guile> f
+;; #<:foo x: 1 y: #f>
+;; guile> (get-x f)
+;; 1
+;; guile> (set-y! f 2)
+;; 2
+;; guile> (get-y f)
+;; 2
+;; guile> f
+;; #<:foo x: 1 y: 2>
+;; guile> (foo? f)
+;; #t
+;; guile> (foo? 1)
+;; #f
+
+;;; Code:
+
+(define-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
+  #:use-module (system base ck)
+  #:export (define-record-type))
+
+(cond-expand-provide (current-module) '(srfi-9))
+
+;; Roll our own instead of using the public `define-inlinable'.  This is
+;; because the public one has a different `make-procedure-name', so
+;; using it would require users to recompile code that uses SRFI-9.  See
+;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+  (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time.  This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define-syntax-rule (%%on-error err) err)
+
+(define %%type #f)   ; a private syntax literal
+(define-syntax getter-type
+  (syntax-rules (quote)
+    ((_ s 'getter 'err)
+     (getter (%%on-error err) %%type s))))
+
+(define %%index #f)  ; a private syntax literal
+(define-syntax getter-index
+  (syntax-rules (quote)
+   ((_ s 'getter 'err)
+    (getter (%%on-error err) %%index s))))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax getter-copier
+  (syntax-rules (quote)
+   ((_ s 'getter 'err)
+    (getter (%%on-error err) %%copier s))))
+
+(define-syntax define-tagged-inlinable
+  (lambda (x)
+    (define (make-procedure-name name)
+      (datum->syntax name
+                     (symbol-append '% (syntax->datum name)
+                                    '-procedure)))
+
+    (syntax-case x ()
+      ((_ ((key value) ...) (name formals ...) body ...)
+       (identifier? #'name)
+       (with-syntax ((proc-name  (make-procedure-name #'name))
+                     ((args ...) (generate-temporaries #'(formals ...))))
+         #`(begin
+             (define (proc-name formals ...)
+               body ...)
+             (define-syntax name
+               (lambda (x)
+                 (syntax-case x (%%on-error key ...)
+                   ((_ (%%on-error err) key s) #'(ck s 'value)) ...
+                   ((_ args ...)
+                    #'((lambda (formals ...)
+                         body ...)
+                       args ...))
+                   ((_ a (... ...))
+                    (syntax-violation 'name "Wrong number of arguments" x))
+                   (_
+                    (identifier? x)
+                    #'proc-name))))))))))
+
+(define (default-record-printer s p)
+  (display "#<" p)
+  (display (record-type-name (record-type-descriptor s)) p)
+  (let loop ((fields (record-type-fields (record-type-descriptor s)))
+             (off 0))
+    (cond
+     ((not (null? fields))
+      (display " " p)
+      (display (car fields) p)
+      (display ": " p)
+      (write (struct-ref s off) p)
+      (loop (cdr fields) (+ 1 off)))))
+  (display ">" p))
+
+(define-syntax-rule (throw-bad-struct s who)
+  (let ((s* s))
+    (throw 'wrong-type-arg who
+           "Wrong type argument: ~S" (list s*)
+           (list s*))))
+
+(define (make-copier-id type-name)
+  (datum->syntax type-name
+                 (symbol-append '%% (syntax->datum type-name)
+                                '-set-fields)))
+
+(define-syntax %%set-fields
+  (lambda (x)
+    (syntax-case x ()
+      ((_ type-name (getter-id ...) check? s (getter expr) ...)
+       (every identifier? #'(getter ...))
+       (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+             (getter+exprs #'((getter expr) ...))
+             (nfields (length #'(getter-id ...))))
+         (define (lookup id default-expr)
+           (let ((results
+                  (filter (lambda (g+e)
+                            (free-identifier=? id (car g+e)))
+                          getter+exprs)))
+             (case (length results)
+               ((0) default-expr)
+               ((1) (cadar results))
+               (else (syntax-violation
+                      copier-name "duplicate getter" x id)))))
+         (for-each (lambda (id)
+                     (or (find (lambda (getter-id)
+                                 (free-identifier=? id getter-id))
+                               #'(getter-id ...))
+                         (syntax-violation
+                          copier-name "unknown getter" x id)))
+                   #'(getter ...))
+         (with-syntax ((unsafe-expr
+                        #`(let ((new (allocate-struct type-name #,nfields)))
+                            #,@(map (lambda (getter index)
+                                      #`(struct-set!
+                                         new
+                                         #,index
+                                         #,(lookup getter
+                                                   #`(struct-ref s #,index))))
+                                    #'(getter-id ...)
+                                    (iota nfields))
+                            new)))
+           (if (syntax->datum #'check?)
+               #`(if (eq? (struct-vtable s) type-name)
+                     unsafe-expr
+                     (throw-bad-struct
+                      s '#,(datum->syntax #'here copier-name)))
+               #'unsafe-expr)))))))
+
+(define-syntax %define-record-type
+  (lambda (x)
+    (define (field-identifiers field-specs)
+      (map (lambda (field-spec)
+             (syntax-case field-spec ()
+               ((name getter) #'name)
+               ((name getter setter) #'name)))
+           field-specs))
+
+    (define (getter-identifiers field-specs)
+      (map (lambda (field-spec)
+             (syntax-case field-spec ()
+               ((name getter) #'getter)
+               ((name getter setter) #'getter)))
+           field-specs))
+
+    (define (constructor form type-name constructor-spec field-ids)
+      (syntax-case constructor-spec ()
+        ((ctor field ...)
+         (every identifier? #'(field ...))
+         (let ((slots (map (lambda (field)
+                             (or (list-index (lambda (x)
+                                               (free-identifier=? x field))
+                                             field-ids)
+                                 (syntax-violation
+                                  (syntax-case form ()
+                                    ((macro . args)
+                                     (syntax->datum #'macro)))
+                                  "unknown field in constructor spec"
+                                  form field)))
+                           #'(field ...))))
+           #`(define-inlinable #,constructor-spec
+               (let ((s (allocate-struct #,type-name #,(length field-ids))))
+                 #,@(map (lambda (arg slot)
+                           #`(struct-set! s #,slot #,arg))
+                         #'(field ...) slots)
+                 s))))))
+
+    (define (getters type-name getter-ids copier-id)
+      (map (lambda (getter index)
+             #`(define-tagged-inlinable
+                 ((%%type   #,type-name)
+                  (%%index  #,index)
+                  (%%copier #,copier-id))
+                 (#,getter s)
+                 (if (eq? (struct-vtable s) #,type-name)
+                     (struct-ref s #,index)
+                     (throw-bad-struct s '#,getter))))
+           getter-ids
+           (iota (length getter-ids))))
+
+    (define (copier type-name getter-ids copier-id)
+      #`(define-syntax-rule
+          (#,copier-id check? s (getter expr) (... ...))
+          (%%set-fields #,type-name #,getter-ids
+                        check? s (getter expr) (... ...))))
+
+    (define (setters type-name field-specs)
+      (filter-map (lambda (field-spec index)
+                    (syntax-case field-spec ()
+                      ((name getter) #f)
+                      ((name getter setter)
+                       #`(define-inlinable (setter s val)
+                           (if (eq? (struct-vtable s) #,type-name)
+                               (struct-set! s #,index val)
+                               (throw-bad-struct s 'setter))))))
+                  field-specs
+                  (iota (length field-specs))))
+
+    (define (functional-setters copier-id field-specs)
+      (filter-map (lambda (field-spec index)
+                    (syntax-case field-spec ()
+                      ((name getter) #f)
+                      ((name getter setter)
+                       #`(define-inlinable (setter s val)
+                           (#,copier-id #t s (getter val))))))
+                  field-specs
+                  (iota (length field-specs))))
+
+    (define (record-layout immutable? count)
+      ;; Mutability is expressed on the record level; all structs in the
+      ;; future will be mutable.
+      (string-concatenate (make-list count "pw")))
+
+    (syntax-case x ()
+      ((_ immutable? form type-name constructor-spec predicate-name
+          field-spec ...)
+       (let ()
+         (define (syntax-error message subform)
+           (syntax-violation (syntax-case #'form ()
+                               ((macro . args) (syntax->datum #'macro)))
+                             message #'form subform))
+         (and (boolean? (syntax->datum #'immutable?))
+              (or (identifier? #'type-name)
+                  (syntax-error "expected type name" #'type-name))
+              (syntax-case #'constructor-spec ()
+                ((ctor args ...)
+                 (every identifier? #'(ctor args ...))
+                 #t)
+                (_ (syntax-error "invalid constructor spec"
+                                 #'constructor-spec)))
+              (or (identifier? #'predicate-name)
+                  (syntax-error "expected predicate name" #'predicate-name))
+              (every (lambda (spec)
+                       (syntax-case spec ()
+                         ((field getter) #t)
+                         ((field getter setter) #t)
+                         (_ (syntax-error "invalid field spec" spec))))
+                     #'(field-spec ...))))
+       (let* ((field-ids   (field-identifiers  #'(field-spec ...)))
+              (getter-ids  (getter-identifiers #'(field-spec ...)))
+              (field-count (length field-ids))
+              (immutable?  (syntax->datum #'immutable?))
+              (layout      (record-layout immutable? field-count))
+              (ctor-name   (syntax-case #'constructor-spec ()
+                             ((ctor args ...) #'ctor)))
+              (copier-id   (make-copier-id #'type-name)))
+         #`(begin
+             #,(constructor #'form #'type-name #'constructor-spec field-ids)
+
+             (define type-name
+               (let ((rtd (make-struct/no-tail
+                           record-type-vtable
+                           '#,(datum->syntax #'here (make-struct-layout layout))
+                           default-record-printer
+                           'type-name
+                           '#,field-ids)))
+                 (set-struct-vtable-name! rtd 'type-name)
+                 (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
+                 rtd))
+
+             (define-inlinable (predicate-name obj)
+               (and (struct? obj)
+                    (eq? (struct-vtable obj) type-name)))
+
+             #,@(getters #'type-name getter-ids copier-id)
+             #,(copier #'type-name getter-ids copier-id)
+             #,@(if immutable?
+                    (functional-setters copier-id #'(field-spec ...))
+                    (setters #'type-name #'(field-spec ...))))))
+      ((_ immutable? form . rest)
+       (syntax-violation
+        (syntax-case #'form ()
+          ((macro . args) (syntax->datum #'macro)))
+        "invalid record definition syntax"
+        #'form)))))
+
+(define-syntax-rule (define-record-type name ctor pred fields ...)
+  (%define-record-type #f (define-record-type name ctor pred fields ...)
+                       name ctor pred fields ...))
+
+;;; srfi-9.scm ends here

data/share/guile/2.2/srfi/srfi-98.scm

@@ -0,0 +1,44 @@
+;;; srfi-98.scm --- An interface to access environment variables
+
+;; Copyright (C) 2009 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
+
+;;; Author: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2009-05-26
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-98 (An interface to access environment 
+;; variables).
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-98)
+  :use-module (srfi srfi-1)
+  :export (get-environment-variable
+	   get-environment-variables))
+
+(cond-expand-provide (current-module) '(srfi-98))
+
+(define get-environment-variable getenv)
+(define (get-environment-variables)
+  (define (string->alist-entry str)
+    (let ((pvt (string-index str #\=))
+	  (len (string-length str)))
+      (and pvt (cons (substring str 0 pvt) (substring str (+ pvt 1) len)))))
+  (filter-map string->alist-entry (environ)))