LilyPond-Ruby 0.0.2.1 → 0.1.2

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

@@ -0,0 +1,234 @@
+;;; srfi-37.scm --- args-fold
+
+;; 	Copyright (C) 2007, 2008, 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
+
+
+;;; Commentary:
+;;
+;; To use this module with Guile, use (cdr (program-arguments)) as
+;; the ARGS argument to `args-fold'.  Here is a short example:
+;;
+;;  (args-fold (cdr (program-arguments))
+;; 	    (let ((display-and-exit-proc
+;; 		   (lambda (msg)
+;; 		     (lambda (opt name arg)
+;; 		       (display msg) (quit) (values)))))
+;; 	      (list (option '(#\v "version") #f #f
+;; 			    (display-and-exit-proc "Foo version 42.0\n"))
+;; 		    (option '(#\h "help") #f #f
+;; 			    (display-and-exit-proc
+;; 			     "Usage: foo scheme-file ..."))))
+;; 	    (lambda (opt name arg)
+;; 	      (error "Unrecognized option `~A'" name))
+;; 	    (lambda (op) (load op) (values)))
+;;
+;;; Code:
+
+
+;;;; Module definition & exports
+(define-module (srfi srfi-37)
+  #:use-module (srfi srfi-9)
+  #:export (option option-names option-required-arg?
+	    option-optional-arg? option-processor
+	    args-fold))
+
+(cond-expand-provide (current-module) '(srfi-37))
+
+;;;; args-fold and periphery procedures
+
+;;; An option as answered by `option'.  `names' is a list of
+;;; characters and strings, representing associated short-options and
+;;; long-options respectively that should use this option's
+;;; `processor' in an `args-fold' call.
+;;;
+;;; `required-arg?' and `optional-arg?' are mutually exclusive
+;;; booleans and indicate whether an argument must be or may be
+;;; provided.  Besides the obvious, this affects semantics of
+;;; short-options, as short-options with a required or optional
+;;; argument cannot be followed by other short options in the same
+;;; program-arguments string, as they will be interpreted collectively
+;;; as the option's argument.
+;;;
+;;; `processor' is called when this option is encountered.  It should
+;;; accept the containing option, the element of `names' (by `equal?')
+;;; encountered, the option's argument (or #f if none), and the seeds
+;;; as variadic arguments, answering the new seeds as values.
+(define-record-type srfi-37:option
+  (option names required-arg? optional-arg? processor)
+  option?
+  (names option-names)
+  (required-arg? option-required-arg?)
+  (optional-arg? option-optional-arg?)
+  (processor option-processor))
+
+(define (error-duplicate-option option-name)
+  (scm-error 'program-error "args-fold"
+	     "Duplicate option name `~A~A'"
+	     (list (if (char? option-name) #\- "--")
+		   option-name)
+	     #f))
+
+(define (build-options-lookup options)
+  "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
+to the containing options, signalling an error if a name is
+encountered more than once."
+  (let ((lookup (make-hash-table (* 2 (length options)))))
+    (for-each
+     (lambda (opt)
+       (for-each (lambda (name)
+		   (let ((assoc (hash-create-handle!
+				 lookup name #f)))
+		     (if (cdr assoc)
+			 (error-duplicate-option (car assoc))
+			 (set-cdr! assoc opt))))
+		 (option-names opt)))
+     options)
+    lookup))
+
+(define (args-fold args options unrecognized-option-proc
+		   operand-proc . seeds)
+  "Answer the results of folding SEEDS as multiple values against the
+program-arguments in ARGS, as decided by the OPTIONS'
+`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
+  (let ((lookup (build-options-lookup options)))
+    ;; I don't like Guile's `error' here
+    (define (error msg . args)
+      (scm-error 'misc-error "args-fold" msg args #f))
+
+    (define (mutate-seeds! procedure . params)
+      (set! seeds (call-with-values
+		      (lambda ()
+			(apply procedure (append params seeds)))
+		    list)))
+
+    ;; Clean up the rest of ARGS, assuming they're all operands.
+    (define (rest-operands)
+      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
+		args)
+      (set! args '()))
+
+    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
+    ;; and the seeds.  Depending on OPT's *-arg? specification, get
+    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
+    ;; if no argument is allowed, call NO-ARG-PROC thunk.
+    (define (invoke-option-processor
+	     opt name req-arg-proc opt-arg-proc no-arg-proc)
+      (mutate-seeds!
+       (option-processor opt) opt name
+       (cond ((option-required-arg? opt) (req-arg-proc))
+	     ((option-optional-arg? opt) (opt-arg-proc))
+	     (else (no-arg-proc) #f))))
+
+    ;; Compute and answer a short option argument, advancing ARGS as
+    ;; necessary, for the short option whose character is at POSITION
+    ;; in the current ARG.
+    (define (short-option-argument position)
+      (cond ((< (1+ position) (string-length (car args)))
+	     (let ((result (substring (car args) (1+ position))))
+	       (set! args (cdr args))
+	       result))
+	    ((pair? (cdr args))
+	     (let ((result (cadr args)))
+	       (set! args (cddr args))
+	       result))
+            ((pair? args)
+             (set! args (cdr args))
+             #f)
+	    (else #f)))
+
+    ;; Interpret the short-option at index POSITION in (car ARGS),
+    ;; followed by the remaining short options in (car ARGS).
+    (define (short-option position)
+      (if (>= position (string-length (car args)))
+          (begin
+            (set! args (cdr args))
+            (next-arg))
+	  (let* ((opt-name (string-ref (car args) position))
+		 (option-here (hash-ref lookup opt-name)))
+	    (cond ((not option-here)
+		   (mutate-seeds! unrecognized-option-proc
+				  (option (list opt-name) #f #f
+					  unrecognized-option-proc)
+				  opt-name #f)
+		   (short-option (1+ position)))
+		  (else
+		   (invoke-option-processor
+		    option-here opt-name
+		    (lambda ()
+		      (or (short-option-argument position)
+			  (error "Missing required argument after `-~A'" opt-name)))
+		    (lambda ()
+		      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
+		      ;; GNU getopt_long resolves these like I do
+		      (short-option-argument position))
+		    (lambda () #f))
+		   (if (not (or (option-required-arg? option-here)
+				(option-optional-arg? option-here)))
+		       (short-option (1+ position))))))))
+
+    ;; Process the long option in (car ARGS).  We make the
+    ;; interesting, possibly non-standard assumption that long option
+    ;; names might contain #\=, so keep looking for more #\= in (car
+    ;; ARGS) until we find a named option in lookup.
+    (define (long-option)
+      (let ((arg (car args)))
+	(let place-=-after ((start-pos 2))
+	  (let* ((index (string-index arg #\= start-pos))
+		 (opt-name (substring arg 2 (or index (string-length arg))))
+		 (option-here (hash-ref lookup opt-name)))
+	    (if (not option-here)
+		;; look for a later #\=, unless there can't be one
+		(if index
+		    (place-=-after (1+ index))
+		    (mutate-seeds!
+		     unrecognized-option-proc
+		     (option (list opt-name) #f #f unrecognized-option-proc)
+		     opt-name #f))
+		(invoke-option-processor
+		 option-here opt-name
+		 (lambda ()
+		   (if index
+		       (substring arg (1+ index))
+		       (error "Missing required argument after `--~A'" opt-name)))
+		 (lambda () (and index (substring arg (1+ index))))
+		 (lambda ()
+		   (if index
+		       (error "Extraneous argument after `--~A'" opt-name))))))))
+      (set! args (cdr args)))
+
+    ;; Process the remaining in ARGS.  Basically like calling
+    ;; `args-fold', but without having to regenerate `lookup' and the
+    ;; funcs above.
+    (define (next-arg)
+      (if (null? args)
+	  (apply values seeds)
+	  (let ((arg (car args)))
+	    (cond ((or (string-null? arg)
+		       (not (char=? #\- (string-ref arg 0)))
+		       (= 1 (string-length arg))) ;"-"
+		   (mutate-seeds! operand-proc arg)
+		   (set! args (cdr args)))
+		  ((char=? #\- (string-ref arg 1))
+		   (if (= 2 (string-length arg)) ;"--"
+		       (begin (set! args (cdr args)) (rest-operands))
+		       (long-option)))
+		  (else (short-option 1)))
+	    (next-arg))))
+
+    (next-arg)))
+
+;;; srfi-37.scm ends here

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

@@ -0,0 +1,207 @@
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) Ray Dillinger 2003. All Rights Reserved.
+;;
+;; Contains code based upon Alex Shinn's public-domain implementation of
+;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-38)
+  #:export (write-with-shared-structure
+            read-with-shared-structure)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-69)
+  #:use-module (system vm trap-state))
+
+(cond-expand-provide (current-module) '(srfi-38))
+
+;; A printer that shows all sharing of substructures.  Uses the Common
+;; Lisp print-circle notation: #n# refers to a previous substructure
+;; labeled with #n=.   Takes O(n^2) time.
+
+;; Code attributed to Al Petrofsky, modified by Ray Dillinger.
+
+;; Modified in 2010 by Andreas Rottmann to use SRFI 69 hashtables,
+;; making the time O(n), and adding some of Guile's data types to the
+;; `interesting' objects.
+
+(define* (write-with-shared-structure obj
+                                      #:optional
+                                      (outport (current-output-port))
+                                      (optarg #f))
+
+  ;; We only track duplicates of pairs, vectors, strings, bytevectors,
+  ;; structs (which subsume R6RS and SRFI-9 records), ports and (native)
+  ;; hash-tables.  We ignore zero-length vectors and strings because
+  ;; r5rs doesn't guarantee that eq? treats them sanely (and they aren't
+  ;; very interesting anyway).
+
+  (define (interesting? obj)
+    (or (pair? obj)
+        (and (vector? obj) (not (zero? (vector-length obj))))
+        (and (string? obj) (not (zero? (string-length obj))))
+        (bytevector? obj)
+        (struct? obj)
+        (port? obj)
+        (hash-table? obj)))
+  
+  ;; (write-obj OBJ STATE):
+  ;;
+  ;; STATE is a hashtable which has an entry for each interesting part
+  ;; of OBJ.  The associated value will be:
+  ;;
+  ;;  -- a number if the part has been given one,
+  ;;  -- #t if the part will need to be assigned a number but has not been yet,
+  ;;  -- #f if the part will not need a number.
+  ;; The entry `counter' in STATE should be the most recently
+  ;; assigned number.
+  ;;
+  ;; Mutates STATE for any parts that had numbers assigned.
+  (define (write-obj obj state)
+    (define (write-interesting)
+      (cond ((pair? obj)
+             (display "(" outport)
+             (write-obj (car obj) state)
+             (let write-cdr ((obj (cdr obj)))
+               (cond ((and (pair? obj) (not (hash-table-ref state obj)))
+                      (display " " outport)
+                      (write-obj (car obj) state)
+                      (write-cdr (cdr obj)))
+                     ((null? obj)
+                      (display ")" outport))
+                     (else
+                      (display " . " outport)
+                      (write-obj obj state)
+                      (display ")" outport)))))
+            ((vector? obj)
+             (display "#(" outport)
+             (let ((len (vector-length obj)))
+               (write-obj (vector-ref obj 0) state)
+               (let write-vec ((i 1))
+                 (cond ((= i len) (display ")" outport))
+                       (else (display " " outport)
+                             (write-obj (vector-ref obj i) state)
+                             (write-vec (+ i 1)))))))
+            ;; else it's a string
+            (else (write obj outport))))
+    (cond ((interesting? obj)
+           (let ((val (hash-table-ref state obj)))
+             (cond ((not val) (write-interesting))
+                   ((number? val) 
+                    (begin (display "#" outport)
+                           (write val outport)
+                           (display "#" outport)))
+                   (else
+                    (let ((n (+ 1 (hash-table-ref state 'counter))))
+                      (display "#" outport)
+                      (write n outport)
+                      (display "=" outport)
+                      (hash-table-set! state 'counter n)
+                      (hash-table-set! state obj n)
+                      (write-interesting))))))
+          (else
+           (write obj outport))))
+
+  ;; Scan computes the initial value of the hash table, which maps each
+  ;; interesting part of the object to #t if it occurs multiple times,
+  ;; #f if only once.
+  (define (scan obj state)
+    (cond ((not (interesting? obj)))
+          ((hash-table-exists? state obj)
+           (hash-table-set! state obj #t))
+          (else
+           (hash-table-set! state obj #f)
+           (cond ((pair? obj)
+                  (scan (car obj) state)
+                  (scan (cdr obj) state))
+                 ((vector? obj)
+                  (let ((len (vector-length obj)))
+                    (do ((i 0 (+ 1 i)))
+                        ((= i len))
+                      (scan (vector-ref obj i) state))))))))
+
+  (let ((state (make-hash-table eq?)))
+    (scan obj state)
+    (hash-table-set! state 'counter 0)
+    (write-obj obj state)))
+
+;; A reader that understands the output of the above writer.  This has
+;; been written by Andreas Rottmann to re-use Guile's built-in reader,
+;; with inspiration from Alex Shinn's public-domain implementation of
+;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
+
+(define* (read-with-shared-structure #:optional (port (current-input-port)))
+  (let ((parts-table (make-hash-table eqv?)))
+    
+    ;; reads chars that match PRED and returns them as a string.
+    (define (read-some-chars pred initial)
+      (let iter ((chars initial))
+        (let ((c (peek-char port)))
+          (if (or (eof-object? c) (not (pred c)))
+              (list->string (reverse chars))
+              (iter (cons (read-char port) chars))))))
+
+    (define (read-hash c port)
+      (let* ((n (string->number (read-some-chars char-numeric? (list c))))
+             (c (read-char port))
+             (thunk (hash-table-ref/default parts-table n #f)))
+        (case c
+          ((#\=)
+           (if thunk
+               (error "Double declaration of part " n))
+           (let* ((cell (list #f))
+                  (thunk (lambda () (car cell))))
+             (hash-table-set! parts-table n thunk)
+             (let ((obj (read port)))
+               (set-car! cell obj)
+               obj)))
+          ((#\#)
+           (or thunk
+               (error "Use of undeclared part " n)))
+          (else
+           (error "Malformed shared part specifier")))))
+
+    (with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures)
+      (lambda ()
+        (for-each (lambda (digit)
+                    (read-hash-extend digit read-hash))
+                  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+        (let ((result (read port)))
+          (if (< 0 (hash-table-size parts-table))
+              (patch! result))
+          result)))))
+
+(define (hole? x) (procedure? x))
+(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
+
+(define (patch! x)
+  (cond
+   ((pair? x)
+    (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch! (car x)))
+    (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch! (cdr x))))
+   ((vector? x)
+    (do ((i (- (vector-length x) 1) (- i 1)))
+        ((< i 0))
+      (let ((elt (vector-ref x i)))
+        (if (hole? elt)
+            (vector-set! x i (fill-hole elt))
+            (patch! elt)))))))

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

@@ -0,0 +1,55 @@
+;;; srfi-39.scm --- Parameter objects
+
+;; 	Copyright (C) 2004, 2005, 2006, 2008, 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
+
+;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;;; Date: 2004-05-05
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-39 (Parameter objects).
+;;
+;; The implementation is based on Guile's fluid objects, and is, therefore,
+;; thread-safe (parameters are thread-local).
+;;
+;; In addition to the forms defined in SRFI-39 (`make-parameter',
+;; `parameterize'), a new procedure `with-parameters*' is provided.
+;; This procedures is analogous to `with-fluids*' but taking as first
+;; argument a list of parameter objects instead of a list of fluids.
+;;
+
+;;; Code:
+
+(define-module (srfi srfi-39)
+  ;; helper procedure not in srfi-39.
+  #:export (with-parameters*)
+  #:re-export (make-parameter
+               parameterize
+               current-input-port current-output-port current-error-port))
+
+(cond-expand-provide (current-module) '(srfi-39))
+
+(define (with-parameters* params values thunk)
+  (let more ((params params)
+	     (values values)
+	     (fluids '())     ;; fluids from each of PARAMS
+	     (convs  '()))    ;; VALUES with conversion proc applied
+    (if (null? params)
+	(with-fluids* fluids convs thunk)
+        (more (cdr params) (cdr values)
+              (cons (parameter-fluid (car params)) fluids)
+              (cons ((parameter-converter (car params)) (car values)) convs)))))

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

@@ -0,0 +1,80 @@
+;;; Extensions to SRFI-4
+
+;; Copyright (C) 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:
+
+;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4 gnu)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-4)
+  #:export (;; Complex numbers with 32- and 64-bit components.
+            c32vector? make-c32vector c32vector c32vector-length c32vector-ref
+            c32vector-set! c32vector->list list->c32vector
+
+            c64vector? make-c64vector c64vector c64vector-length c64vector-ref
+            c64vector-set! c64vector->list list->c64vector
+
+            make-srfi-4-vector
+
+            ;; Somewhat polymorphic conversions.
+            any->u8vector any->s8vector any->u16vector any->s16vector
+            any->u32vector any->s32vector any->u64vector any->s64vector
+            any->f32vector any->f64vector any->c32vector any->c64vector))
+
+
+(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
+
+(define (bytevector-c32-native-ref v i)
+  (make-rectangular (bytevector-ieee-single-native-ref v i)
+                    (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-native-set! v i x)
+  (bytevector-ieee-single-native-set! v i (real-part x))
+  (bytevector-ieee-single-native-set! v (+ i 4) (imag-part x)))
+(define (bytevector-c64-native-ref v i)
+  (make-rectangular (bytevector-ieee-double-native-ref v i)
+                    (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-native-set! v i x)
+  (bytevector-ieee-double-native-set! v i (real-part x))
+  (bytevector-ieee-double-native-set! v (+ i 8) (imag-part x)))
+
+((@@ (srfi srfi-4) define-bytevector-type) c32 c32-native 8)
+((@@ (srfi srfi-4) define-bytevector-type) c64 c64-native 16)
+
+(define-macro (define-any->vector . tags)
+  `(begin
+     ,@(map (lambda (tag)
+              `(define (,(symbol-append 'any-> tag 'vector) obj)
+                 (cond ((,(symbol-append tag 'vector?) obj) obj)
+                       ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
+                       ((and (array? obj) (eqv? 1 (array-rank obj)))
+                        (let* ((len (array-length obj))
+                               (v (,(symbol-append 'make- tag 'vector) len)))
+                          (let lp ((i 0))
+                            (if (< i len)
+                                (begin
+                                  (,(symbol-append tag 'vector-set!)
+                                   v i (array-ref obj i))
+                                  (lp (1+ i)))
+                                v))))
+                       (else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
+            tags)))
+
+(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64)

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

@@ -0,0 +1,118 @@
+;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
+
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
+;;   2012, 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
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+;;; Commentary:
+
+;; This module exports the homogeneous numeric vector procedures as
+;; defined in SRFI-4.  They are fully documented in the Guile
+;; Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4)
+  #:use-module (rnrs bytevectors)
+  #:export (;; Unsigned 8-bit vectors.
+            u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+            u8vector-set! u8vector->list list->u8vector
+
+            ;; Signed 8-bit vectors.
+            s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+            s8vector-set! s8vector->list list->s8vector
+
+            ;; Unsigned 16-bit vectors.
+            u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+            u16vector-set! u16vector->list list->u16vector
+
+            ;; Signed 16-bit vectors.
+            s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+            s16vector-set! s16vector->list list->s16vector
+
+            ;; Unsigned 32-bit vectors.
+            u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+            u32vector-set! u32vector->list list->u32vector
+
+            ;; Signed 32-bit vectors.
+            s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+            s32vector-set! s32vector->list list->s32vector
+
+            ;; Unsigned 64-bit vectors.
+            u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+            u64vector-set! u64vector->list list->u64vector
+
+            ;; Signed 64-bit vectors.
+            s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+            s64vector-set! s64vector->list list->s64vector
+
+            ;; 32-bit floating point vectors.
+            f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+            f32vector-set! f32vector->list list->f32vector
+
+            ;; 64-bit floating point vectors.
+            f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+            f64vector-set! f64vector->list list->f64vector))
+
+(cond-expand-provide (current-module) '(srfi-4))
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+  `(begin
+     (define (,(symbol-append tag 'vector?) obj)
+       (and (bytevector? obj) (eq? (array-type obj) ',tag)))
+     (define (,(symbol-append 'make- tag 'vector) len . fill)
+       (apply make-srfi-4-vector ',tag len fill))
+     (define (,(symbol-append tag 'vector-length) v)
+       (let ((len (/ (bytevector-length v) ,size)))
+         (if (integer? len)
+             len
+             (error "fractional length" v ',tag ,size))))
+     (define (,(symbol-append tag 'vector) . elts)
+       (,(symbol-append 'list-> tag 'vector) elts))
+     (define (,(symbol-append 'list-> tag 'vector) elts)
+       (let* ((len (length elts))
+              (v (,(symbol-append 'make- tag 'vector) len)))
+         (let lp ((i 0) (elts elts))
+           (if (and (< i len) (pair? elts))
+               (begin
+                 (,(symbol-append tag 'vector-set!) v i (car elts))
+                 (lp (1+ i) (cdr elts)))
+               v))))
+     (define (,(symbol-append tag 'vector->list) v)
+       (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+         (if (< i 0)
+             elts
+             (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+     (define (,(symbol-append tag 'vector-ref) v i)
+       (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+     (define (,(symbol-append tag 'vector-set!) v i x)
+       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+     (define (,(symbol-append tag 'vector-set!) v i x)
+       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define-bytevector-type u8 u8 1)
+(define-bytevector-type s8 s8 1)
+(define-bytevector-type u16 u16-native 2)
+(define-bytevector-type s16 s16-native 2)
+(define-bytevector-type u32 u32-native 4)
+(define-bytevector-type s32 s32-native 4)
+(define-bytevector-type u64 u64-native 8)
+(define-bytevector-type s64 s64-native 8)
+(define-bytevector-type f32 ieee-single-native 4)
+(define-bytevector-type f64 ieee-double-native 8)