LilyPond-Ruby 0.1.1 → 0.1.2

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

@@ -0,0 +1,115 @@
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 1996, 1998, 2001, 2003, 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
+;;;; 
+
+
+
+(define-module (ice-9 lineio)
+  :use-module (ice-9 rdelim)
+  :export (unread-string read-string lineio-port?
+	   make-line-buffering-input-port))
+
+
+;;; {Line Buffering Input Ports}
+;;;
+;;; [This is a work-around to get past certain deficiencies in the capabilities
+;;;  of ports.  Eventually, ports should be fixed and this module nuked.]
+;;;
+;;; A line buffering input port supports:
+;;;
+;;; 	read-string  	which returns the next line of input
+;;;	unread-string 	which pushes a line back onto the stream
+;;; 
+;;; The implementation of unread-string is kind of limited; it doesn't
+;;; interact properly with unread-char, or any of the other port
+;;; reading functions.  Only read-string will get you back the things that
+;;; unread-string accepts.
+;;;
+;;; Normally a "line" is all characters up to and including a newline.
+;;; If lines are put back using unread-string, they can be broken arbitrarily
+;;; -- that is, read-string returns strings passed to unread-string (or 
+;;; shared substrings of them).
+;;;
+
+;; read-string port
+;; unread-string port str
+;;   Read (or buffer) a line from PORT.
+;;
+;; Not all ports support these functions -- only those with 
+;; 'unread-string and 'read-string properties, bound to hooks
+;; implementing these functions.
+;;
+(define (unread-string str line-buffering-input-port)
+  ((object-property line-buffering-input-port 'unread-string) str))
+
+;;
+(define (read-string line-buffering-input-port)
+  ((object-property line-buffering-input-port 'read-string)))
+
+
+(define (lineio-port? port)
+  (not (not (object-property port 'read-string))))
+
+;; make-line-buffering-input-port port
+;;   Return a wrapper for PORT.  The wrapper handles read-string/unread-string.
+;;
+;; The port returned by this function reads newline terminated lines from PORT.
+;; It buffers these characters internally, and parsels them out via calls
+;; to read-char, read-string, and unread-string.
+;;
+
+(define (make-line-buffering-input-port underlying-port)
+  (let* (;; buffers - a list of strings put back by unread-string or cached
+	 ;; using read-line.
+	 ;;
+	 (buffers '())
+
+	 ;; getc - return the next character from a buffer or from the underlying
+	 ;; port.
+	 ;;
+	 (getc (lambda ()
+		 (if (not buffers)
+		     (read-char underlying-port)
+		     (let ((c (string-ref (car buffers) 0)))
+		       (if (= 1 (string-length (car buffers)))
+			   (set! buffers (cdr buffers))
+			   (set-car! buffers (substring (car buffers) 1)))
+		       c))))
+
+	 (propogate-close (lambda () (close-port underlying-port)))
+
+	 (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
+
+	 (unread-string (lambda (str)
+			  (and (< 0 (string-length str))
+				   (set! buffers (cons str buffers)))))
+
+	 (read-string (lambda ()
+		       (cond
+			((not (null? buffers))
+			 (let ((answer (car buffers)))
+			   (set! buffers (cdr buffers))
+			   answer))
+			(else
+			 (read-line underlying-port 'concat)))))) ;handle-newline->concat
+
+    (set-object-property! self 'unread-string unread-string)
+    (set-object-property! self 'read-string read-string)
+    self))
+
+

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

@@ -0,0 +1,36 @@
+;;;; List functions not provided in R5RS or srfi-1
+
+;;; Copyright (C) 2003, 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
+
+(define-module (ice-9 list)
+  :export (rassoc rassv rassq))
+
+(define (generic-rassoc key alist =)
+  (let loop ((ls alist))
+      (and (not (null? ls))
+	   (if (= key (cdar ls))
+	       (car ls)
+	       (loop (cdr ls))))))
+
+(define (rassoc key alist . =)
+  (generic-rassoc key alist (if (null? =) equal? (car =))))
+
+(define (rassv key alist)
+  (generic-rassoc key alist eqv?))
+
+(define (rassq key alist)
+  (generic-rassoc key alist eq?))

data/share/guile/2.2/ice-9/local-eval.scm

@@ -0,0 +1,261 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2012, 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 local-eval)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (system base compile)
+  #:use-module (system syntax)
+  #:export (the-environment local-eval local-compile))
+
+(define-record-type lexical-environment-type
+  (make-lexical-environment scope wrapper boxes patterns)
+  lexical-environment?
+  (scope             lexenv-scope)
+  (wrapper           lexenv-wrapper)
+  (boxes             lexenv-boxes)
+  (patterns          lexenv-patterns))
+
+(set-record-type-printer!
+ lexical-environment-type
+ (lambda (e port)
+   (format port "#<lexical-environment ~S (~S bindings)>"
+           (syntax-module (lexenv-scope e))
+           (+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
+
+(define-syntax syntax-object-of
+  (lambda (form)
+    (syntax-case form ()
+      ((_ x) #`(quote #,(datum->syntax #'x #'x))))))
+
+(define-syntax-rule (make-box v)
+  (case-lambda
+   (() v)
+   ((x) (set! v x))))
+
+(define (make-transformer-from-box id trans)
+  (set-procedure-property! trans 'identifier-syntax-box id)
+  trans)
+
+(define-syntax-rule (identifier-syntax-from-box box)
+  (make-transformer-from-box
+   (syntax-object-of box)
+   (identifier-syntax (id          (box))
+                      ((set! id x) (box x)))))
+
+(define (unsupported-binding name)
+  (make-variable-transformer
+   (lambda (x)
+     (syntax-violation
+      'local-eval
+      "unsupported binding captured by (the-environment)"
+      x))))
+
+(define (within-nested-ellipses id lvl)
+  (let loop ((s id) (n lvl))
+    (if (zero? n)
+        s
+        (loop #`(#,s (... ...)) (- n 1)))))
+
+;; Analyze the set of bound identifiers IDS.  Return four values:
+;;
+;; capture: A list of forms that will be emitted in the expansion of
+;; `the-environment' to capture lexical variables.
+;;
+;; formals: Corresponding formal parameters for use in the lambda that
+;; re-introduces those variables.  These are temporary identifiers, and
+;; as such if we have a nested `the-environment', there is no need to
+;; capture them.  (See the notes on nested `the-environment' and
+;; proxies, below.)
+;;
+;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
+;; the expression to be evaluated in forms that re-introduce the
+;; variable.  The forms will be nested so that the variable shadowing
+;; semantics of the original form are maintained.
+;;
+;; patterns: A terrible hack.  The issue is that for pattern variables,
+;; we can't emit lexically nested with-syntax forms, like:
+;;
+;;   (with-syntax ((foo 1)) (the-environment))
+;;   => (with-syntax ((foo 1))
+;;        ... #'(with-syntax ((foo ...)) ... exp) ...)
+;;
+;; The reason is that the outer "foo" substitutes into the inner "foo",
+;; yielding something like:
+;;
+;;   (with-syntax ((foo 1))
+;;     ... (with-syntax ((1 ...)) ...)
+;;            
+;; Which ain't what we want.  So we hide the information needed to
+;; re-make the inner pattern binding form in the lexical environment
+;; object, and then introduce those identifiers via another with-syntax.
+;;
+;;
+;; There are four different kinds of lexical bindings: normal lexicals,
+;; macros, displaced lexicals, and pattern variables.  See the
+;; documentation of syntax-local-binding for more info on these.
+;;
+;; We capture normal lexicals via `make-box', which creates a
+;; case-lambda that can reference or set a variable.  These get
+;; re-introduced with an identifier-syntax.
+;;
+;; We can't capture macros currently.  However we do recognize our own
+;; macros that are actually proxying lexicals, so that nested
+;; `the-environment' forms are possible.  In that case we drill down to
+;; the identifier for the already-existing box, and just capture that
+;; box.
+;;
+;; And that's it: we skip displaced lexicals, and the pattern variables
+;; are discussed above.
+;;
+(define (analyze-identifiers ids)
+  (define (mktmp)
+    (datum->syntax #'here (gensym "t ")))
+  (let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
+    (cond
+     ((null? ids)
+      (values capture formals wrappers patterns))
+     (else
+      (let ((id (car ids)) (ids (cdr ids)))
+        (call-with-values (lambda () (syntax-local-binding id))
+          (lambda (type val)
+            (case type
+              ((lexical)
+               (if (or-map (lambda (x) (bound-identifier=? x id)) formals)
+                   (lp ids capture formals wrappers patterns)
+                   (let ((t (mktmp)))
+                     (lp ids
+                         (cons #`(make-box #,id) capture)
+                         (cons t formals)
+                         (cons (lambda (x)
+                                 #`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
+                                     #,x))
+                               wrappers)
+                         patterns))))
+              ((displaced-lexical)
+               (lp ids capture formals wrappers patterns))
+              ((macro)
+               (let ((b (procedure-property val 'identifier-syntax-box)))
+                 (if b
+                     (lp ids (cons b capture) (cons b formals)
+                         (cons (lambda (x)
+                                 #`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
+                                     #,x))
+                               wrappers)
+                         patterns)
+                     (lp ids capture formals
+                         (cons (lambda (x)
+                                 #`(let-syntax ((#,id (unsupported-binding '#,id)))
+                                     #,x))
+                               wrappers)
+                         patterns))))
+              ((pattern-variable)
+               (let ((t (datum->syntax id (gensym "p ")))
+                     (nested (within-nested-ellipses id (cdr val))))
+                 (lp ids capture formals
+                     (cons (lambda (x)
+                             #`(with-syntax ((#,t '#,nested))
+                                 #,x))
+                           wrappers)
+                     ;; This dance is to hide these pattern variables
+                     ;; from the expander.
+                     (cons (list (datum->syntax #'here (syntax->datum id))
+                                 (cdr val)
+                                 t)
+                           patterns))))
+              ((ellipsis)
+               (lp ids capture formals
+                   (cons (lambda (x)
+                           #`(with-ellipsis #,val #,x))
+                         wrappers)
+                   patterns))
+              (else
+               ;; Interestingly, this case can include globals (and
+               ;; global macros), now that Guile tracks which globals it
+               ;; introduces.  Not sure what to do here!  For now, punt.
+               ;; 
+               (lp ids capture formals wrappers patterns))))))))))
+
+(define-syntax the-environment
+  (lambda (x)
+    (syntax-case x ()
+      ((the-environment)
+       #'(the-environment the-environment))
+      ((the-environment scope)
+       (call-with-values (lambda ()
+                           (analyze-identifiers
+                            (syntax-locally-bound-identifiers #'scope)))
+         (lambda (capture formals wrappers patterns)
+           (define (wrap-expression x)
+             (let lp ((x x) (wrappers wrappers))
+               (if (null? wrappers)
+                   x
+                   (lp ((car wrappers) x) (cdr wrappers)))))
+           (with-syntax (((f ...) formals)
+                         ((c ...) capture)
+                         (((pname plvl pformal) ...) patterns)
+                         (wrapped (wrap-expression #'(begin #f exp))))
+             #'(make-lexical-environment
+                #'scope
+                (lambda (exp pformal ...)
+                  (with-syntax ((exp exp)
+                                (pformal pformal)
+                                ...)
+                    #'(lambda (f ...)
+                        wrapped)))
+                (list c ...)
+                (list (list 'pname plvl #'pformal) ...)))))))))
+
+(define (env-module e)
+  (cond
+   ((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
+   ((module? e) e)
+   (else (error "invalid lexical environment" e))))
+
+(define (env-boxes e)
+  (cond
+   ((lexical-environment? e) (lexenv-boxes e))
+   ((module? e) '())
+   (else (error "invalid lexical environment" e))))
+
+(define (local-wrap x e)
+  (cond
+   ((lexical-environment? e)
+    (apply (lexenv-wrapper e)
+           (datum->syntax (lexenv-scope e) x)
+           (map (lambda (l)
+                  (let ((name (car l))
+                        (lvl (cadr l))
+                        (scope (caddr l)))
+                    (within-nested-ellipses (datum->syntax scope name) lvl)))
+                (lexenv-patterns e))))
+   ((module? e) #`(lambda () #f #,x))
+   (else (error "invalid lexical environment" e))))
+
+(define (local-eval x e)
+  "Evaluate the expression @var{x} within the lexical environment @var{e}."
+  (apply (eval (local-wrap x e) (env-module e))
+         (env-boxes e)))
+
+(define* (local-compile x e #:key (opts '()))
+  "Compile and evaluate the expression @var{x} within the lexical
+environment @var{e}."
+  (apply (compile (local-wrap x e) #:env (env-module e)
+                  #:from 'scheme #:opts opts)
+         (env-boxes e)))

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

@@ -0,0 +1,94 @@
+;;;; ls.scm --- functions for browsing modules
+;;;;
+;;;; 	Copyright (C) 1995, 1996, 1997, 1999, 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
+;;;; 
+
+(define-module (ice-9 ls)
+  :use-module (ice-9 common-list)
+  :export (local-definitions-in definitions-in ls lls
+	   recursive-local-define))
+
+;;;;
+;;;	local-definitions-in root name
+;;;		Returns a list of names defined locally in the named
+;;;		subdirectory of root.
+;;;	definitions-in root name
+;;;		Returns a list of all names defined in the named
+;;;		subdirectory of root.  The list includes alll locally
+;;;		defined names as well as all names inherited from a
+;;;		member of a use-list.
+;;;
+;;; A convenient interface for examining the nature of things:
+;;;
+;;;	ls . various-names
+;;;
+;;;		With no arguments, return a list of definitions in
+;;;		`(current-module)'.
+;;;
+;;;		With just one argument, interpret that argument as the
+;;;		name of a subdirectory of the current module and
+;;;		return a list of names defined there.
+;;;
+;;;		With more than one argument, still compute
+;;;		subdirectory lists, but return a list:
+;;;			((<subdir-name> . <names-defined-there>)
+;;;			 (<subdir-name> . <names-defined-there>)
+;;;			 ...)
+;;;
+;;;     lls . various-names
+;;;
+;;;		Analogous to `ls', but with local definitions only.
+
+(define (local-definitions-in root names)
+  (let ((m (nested-ref-module root names)))
+    (if m
+        (module-map (lambda (k v) k) m)
+        (nested-ref root names))))
+
+(define (definitions-in root names)
+  (let ((m (nested-ref-module root names)))
+    (if m
+	(reduce union
+		(cons (local-definitions-in m '())
+		      (map (lambda (m2) (definitions-in m2 '()))
+			   (module-uses m))))
+        (nested-ref root names))))
+
+(define (ls . various-refs)
+  (if (pair? various-refs)
+       (if (cdr various-refs)
+	   (map (lambda (ref)
+		  (cons ref (definitions-in (current-module) ref)))
+		various-refs)
+	  (definitions-in (current-module) (car various-refs)))
+      (definitions-in (current-module) '())))
+
+(define (lls . various-refs)
+  (if (pair? various-refs)
+       (if (cdr various-refs)
+	   (map (lambda (ref)
+		  (cons ref (local-definitions-in (current-module) ref)))
+		various-refs)
+	  (local-definitions-in (current-module) (car various-refs)))
+      (local-definitions-in (current-module) '())))
+
+(define (recursive-local-define name value)
+  (let ((parent (reverse! (cdr (reverse name)))))
+    (module-define! (make-modules-in (current-module) parent)
+                    name value)))
+
+;;; ls.scm ends here

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

@@ -0,0 +1,118 @@
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 1996, 2001, 2006, 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 mapping)
+  :use-module (ice-9 poe)
+  :export (mapping-hooks-type make-mapping-hooks mapping-hooks?
+	   mapping-hooks-get-handle mapping-hooks-create-handle
+	   mapping-hooks-remove mapping-type make-mapping mapping?
+	   mapping-hooks mapping-data set-mapping-hooks! set-mapping-data!
+	   mapping-get-handle mapping-create-handle! mapping-remove!
+	   mapping-ref mapping-set!  hash-table-mapping-hooks
+	   make-hash-table-mapping hash-table-mapping))
+
+(issue-deprecation-warning
+ "(ice-9 mapping) is deprecated.  Use srfi-69 or rnrs hash tables instead.")
+
+(define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
+							      create-handle
+							      remove)))
+
+
+(define make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
+(define mapping-hooks? (record-predicate mapping-hooks-type))
+(define mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
+(define mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
+(define mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
+
+(define mapping-type (make-record-type 'mapping '(hooks data)))
+(define make-mapping (record-constructor mapping-type))
+(define mapping? (record-predicate mapping-type))
+(define mapping-hooks (record-accessor mapping-type 'hooks))
+(define mapping-data (record-accessor mapping-type 'data))
+(define set-mapping-hooks! (record-modifier mapping-type 'hooks))
+(define set-mapping-data! (record-modifier mapping-type 'data))
+
+(define (mapping-get-handle map key)
+  ((mapping-hooks-get-handle (mapping-hooks map)) map key))
+(define (mapping-create-handle! map key init)
+  ((mapping-hooks-create-handle (mapping-hooks map)) map key init))
+(define (mapping-remove! map key)
+  ((mapping-hooks-remove (mapping-hooks map)) map key))
+
+(define* (mapping-ref map key #:optional dflt)
+  (cond
+   ((mapping-get-handle map key) => cdr)
+   (else dflt)))
+
+(define (mapping-set! map key val)
+  (set-cdr! (mapping-create-handle! map key #f) val))
+
+
+
+(define hash-table-mapping-hooks
+  (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
+
+    (perfect-funcq 17
+		   (lambda (hash-proc assoc-proc)
+		     (let ((procs (list hash-proc assoc-proc)))
+		       (cond
+			((equal? procs `(,hashq ,assq))
+			 (make-mapping-hooks (wrap hashq-get-handle)
+					     (wrap hashq-create-handle!)
+					     (wrap hashq-remove!)))
+			((equal? procs `(,hashv ,assv))
+			 (make-mapping-hooks (wrap hashv-get-handle)
+					     (wrap hashv-create-handle!)
+					     (wrap hashv-remove!)))
+			((equal? procs `(,hash ,assoc))
+			 (make-mapping-hooks (wrap hash-get-handle)
+					     (wrap hash-create-handle!)
+					     (wrap hash-remove!)))
+			(else
+			 (make-mapping-hooks (wrap
+					      (lambda (table key)
+						(hashx-get-handle hash-proc assoc-proc table key)))
+					     (wrap
+					      (lambda (table key init)
+						(hashx-create-handle! hash-proc assoc-proc table key init)))
+					     (wrap
+					      (lambda (table key)
+						(hashx-remove! hash-proc assoc-proc table key)))))))))))
+
+(define (make-hash-table-mapping table hash-proc assoc-proc)
+  (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc) table))
+
+(define* (hash-table-mapping #:optional (size 71) #:key
+                             (hash-proc hash)
+                             (assoc-proc
+                              (or (assq-ref `((,hashq . ,assq)
+                                              (,hashv . ,assv)
+                                              (,hash . ,assoc))
+                                            hash-proc)
+                                  (error 'hash-table-mapping
+                                         "Hash-procedure specified with no known assoc function."
+                                         hash-proc)))
+                             (table-constructor
+                              (lambda (len) (make-vector len '()))))
+  (make-hash-table-mapping (table-constructor size)
+                           hash-proc
+                           assoc-proc))

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

@@ -0,0 +1,59 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010, 2011, 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
+
+(define-module (ice-9 match)
+  #:export (match
+            match-lambda
+            match-lambda*
+            match-let
+            match-let*
+            match-letrec))
+
+(define (error _ . args)
+  ;; Error procedure for run-time "no matching pattern" errors.
+  (apply throw 'match-error "match" args))
+
+;; Support for record matching.
+
+(define-syntax slot-ref
+  (syntax-rules ()
+    ((_ rtd rec n)
+     (struct-ref rec n))))
+
+(define-syntax slot-set!
+  (syntax-rules ()
+    ((_ rtd rec n value)
+     (struct-set! rec n value))))
+
+(define-syntax is-a?
+  (syntax-rules ()
+    ((_ rec rtd)
+     (and (struct? rec)
+          (eq? (struct-vtable rec) rtd)))))
+
+;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
+;; `match:error-control', `match:set-error-control', `match:error',
+;; `match:set-error', and all structure-related procedures.  Also,
+;; `match' doesn't support clauses of the form `(pat => exp)'.
+
+;; Unmodified public domain code by Alex Shinn retrieved from
+;; the Chibi-Scheme repository, commit 1206:acd808700e91.
+;;
+;; Note: Make sure to update `match.test.upstream' when updating this
+;; file.
+(include-from-path "ice-9/match.upstream.scm")