1 files changed, 132358 insertions, 0 deletions

diff --git a/src/test/data/parser-torture.scm b/src/test/data/parser-torture.scm
new file mode 100644
index 0000000..d475379
--- /dev/null
+++ b/src/test/data/parser-torture.scm
@@ -0,0 +1,132358 @@
+;;; rnrs exceptions (6) --- R6RS exceptions
+
+;; Copyright (C) 2013  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: ffi struct bytevector bytestructure
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A clean implementation of (rnrs exceptions (6)).  The dynamic environment
+;; capturing operations are noteworthy.
+
+
+;;; Code:
+
+(library
+ (rnrs exceptions (6))
+ (export with-exception-handler raise raise-continuable guard)
+ (import (rnrs base (6))
+         (srfi 39))
+
+;;; Helpers
+
+;;; Ignores any extra `else' clauses.
+;;; Helps to generate cond clauses with a default `else' clause.
+ (define-syntax cond+
+   (syntax-rules (else)
+     ((cond+ clause ... (else else1) (else else2))
+      (cond+ clause ... (else else1)))
+     ((cond+ clause ...)
+      (cond clause ...))))
+
+;;; Captures the current dynamic environment.  It is reified as a procedure that
+;;; accepts a thunk and executes it in the captured dynenv.
+ (define (capture-dynenv)
+   ((call/cc
+     (lambda (captured-env)
+       (lambda ()
+         (lambda (proc)
+           (call/cc
+            (lambda (go-back)
+              (captured-env
+               (lambda ()
+                 (call-with-values proc go-back)))))))))))
+
+;;; Captures the current dynamic environment and returns a procedure that
+;;; accepts as many arguments as PROC and applies PROC to them in that dynenv.
+;;; In other words, returns a version of PROC that's tied to the current dynenv.
+ (define (dynenv-proc proc)
+   (let ((env (capture-dynenv)))
+     (lambda args
+       (env (lambda () (apply proc args))))))
+
+;;; Returns a procedure that's always executed in the current dynamic
+;;; environment and not the one from which it's called.
+ (define-syntax dynenv-lambda
+   (syntax-rules ()
+     ((_ args body body* ...)
+      (dynenv-proc (lambda args body body* ...)))))
+
+ 
+;;; Main code:
+
+ (define handlers (make-parameter '()))
+
+ (define &non-continuable '&non-continuable)
+
+ (define (with-exception-handler handler thunk)
+   (parameterize ((handlers (cons handler (handlers))))
+     (thunk)))
+
+ (define (%raise condition continuable?)
+   (if (null? (handlers))
+       (error "unhandled exception" condition)
+       (let ((handler (car (handlers))))
+         (parameterize ((handlers (cdr (handlers))))
+           (if continuable?
+               (handler condition)
+               (begin
+                 (handler condition)
+                 (%raise &non-continuable #f)))))))
+
+ (define (raise-continuable condition)
+   (%raise condition #t))
+
+ (define (raise condition)
+   (%raise condition #f))
+
+ (define-syntax guard
+   (syntax-rules ()
+     ((guard (var clause clause* ...)
+             body body* ...)
+      (call/cc
+       (lambda (return)
+         (let ((handler (dynenv-lambda (var re-raise)
+                          (return
+                           (cond+ clause
+                                  clause*
+                                  ...
+                                  (else (re-raise)))))))
+           (with-exception-handler
+            (lambda (condition)
+              (let ((re-raise (dynenv-lambda ()
+                                (raise condition))))
+                (handler condition re-raise)))
+            (lambda ()
+              body body* ...))))))))
+ )
+(define-module (test)
+  #\use-module (bytestructures guile))
+
+(display cstring-pointer)
+(newline)
+;;; align.scm --- Alignment calculation helpers.
+
+;; Copyright © 2018 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+;;; Either remains at 'position' or rounds up to the next multiple of
+;;; 'alignment' depending on whether 'size' (if not greater than 'alignment')
+;;; would fit.  Returns three values: the chosen position, the start of the
+;;; alignment boundary of the chosen position, and the bit offset of the chosen
+;;; position from the start of the alignment boundary.  A bit is represented by
+;;; the value 1/8.
+(define (align position size alignment)
+  (let* ((integer (floor position))
+         (fraction (- position integer)))
+    (let-values (((prev-boundary-index offset) (floor/ integer alignment)))
+      (let* ((prev-boundary (* prev-boundary-index alignment))
+             (next-boundary (+ prev-boundary alignment)))
+        (if (< next-boundary (+ position (min size alignment)))
+            (values next-boundary next-boundary 0)
+            (values position prev-boundary (* 8 (+ offset fraction))))))))
+
+;;; Returns 'position' if it's already a multiple of 'alignment'; otherwise
+;;; returns the next multiple.
+(define (next-boundary position alignment)
+  (align position +inf.0 alignment))
+
+;;; align.scm ends here
+;;; bytestructures --- Structured access to bytevector contents.
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the base of the module, defining the data types and procedures that
+;; make up the bytestructures framework.
+
+
+;;; Code:
+
+;;; Descriptors
+
+(define-record-type <bytestructure-descriptor>
+  (%make-bytestructure-descriptor size alignment unwrapper getter setter meta)
+  bytestructure-descriptor?
+  (size       bd-size)
+  (alignment  bd-alignment)
+  (unwrapper  bd-unwrapper)
+  (getter     bd-getter)
+  (setter     bd-setter)
+  (meta       bd-meta))
+
+(define make-bytestructure-descriptor
+  (case-lambda
+    ((size alignment unwrapper getter setter)
+     (%make-bytestructure-descriptor
+      size alignment unwrapper getter setter #f))
+    ((size alignment unwrapper getter setter meta)
+     (%make-bytestructure-descriptor
+      size alignment unwrapper getter setter meta))))
+
+(define bytestructure-descriptor-size
+  (case-lambda
+    ((descriptor) (bytestructure-descriptor-size descriptor #f #f))
+    ((descriptor bytevector offset)
+     (let ((size (bd-size descriptor)))
+       (if (procedure? size)
+           (size #f bytevector offset)
+           size)))))
+
+(define (bytestructure-descriptor-size/syntax bytevector offset descriptor)
+  (let ((size (bd-size descriptor)))
+    (if (procedure? size)
+        (size #t bytevector offset)
+        size)))
+
+(define bytestructure-descriptor-alignment bd-alignment)
+(define bytestructure-descriptor-unwrapper bd-unwrapper)
+(define bytestructure-descriptor-getter bd-getter)
+(define bytestructure-descriptor-setter bd-setter)
+(define bytestructure-descriptor-metadata bd-meta)
+
+
+;;; Bytestructures
+
+(define-record-type <bytestructure>
+  (make-bytestructure bytevector offset descriptor)
+  bytestructure?
+  (bytevector bytestructure-bytevector)
+  (offset     bytestructure-offset)
+  (descriptor bytestructure-descriptor))
+
+(define bytestructure
+  (case-lambda ((descriptor)        (%bytestructure descriptor #f #f))
+               ((descriptor values) (%bytestructure descriptor #t values))))
+
+(define (%bytestructure descriptor init? values)
+  (let ((bytevector (make-bytevector
+                     (bytestructure-descriptor-size descriptor))))
+    (when init?
+      (bytestructure-primitive-set! bytevector 0 descriptor values))
+    (make-bytestructure bytevector 0 descriptor)))
+
+(define (bytestructure-size bytestructure)
+  (bytestructure-descriptor-size (bytestructure-descriptor bytestructure)
+                                 (bytestructure-bytevector bytestructure)
+                                 (bytestructure-offset bytestructure)))
+
+(define-syntax-rule (bytestructure-unwrap <bytestructure> <index> ...)
+  (let ((bytestructure <bytestructure>))
+    (let ((bytevector (bytestructure-bytevector bytestructure))
+          (offset     (bytestructure-offset     bytestructure))
+          (descriptor (bytestructure-descriptor bytestructure)))
+      (bytestructure-unwrap* bytevector offset descriptor <index> ...))))
+
+(define-syntax bytestructure-unwrap*
+  (syntax-rules ()
+    ((_ <bytevector> <offset> <descriptor>)
+     (values <bytevector> <offset> <descriptor>))
+    ((_ <bytevector> <offset> <descriptor> <index> <indices> ...)
+     (let ((bytevector <bytevector>)
+           (offset <offset>)
+           (descriptor <descriptor>))
+       (let ((unwrapper (bd-unwrapper descriptor)))
+         (when (not unwrapper)
+           (error "Cannot index through this descriptor." descriptor))
+         (let-values (((bytevector* offset* descriptor*)
+                       (unwrapper #f bytevector offset <index>)))
+           (bytestructure-unwrap*
+            bytevector* offset* descriptor* <indices> ...)))))))
+
+(define-syntax-rule (bytestructure-ref <bytestructure> <index> ...)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap <bytestructure> <index> ...)))
+    (bytestructure-primitive-ref bytevector offset descriptor)))
+
+(define-syntax-rule (bytestructure-ref*
+                     <bytevector> <offset> <descriptor> <index> ...)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap*
+                 <bytevector> <offset> <descriptor> <index> ...)))
+    (bytestructure-primitive-ref bytevector offset descriptor)))
+
+(define (bytestructure-primitive-ref bytevector offset descriptor)
+  (let ((getter (bd-getter descriptor)))
+    (if getter
+        (getter #f bytevector offset)
+        (make-bytestructure bytevector offset descriptor))))
+
+(define-syntax-rule (bytestructure-set! <bytestructure> <index> ... <value>)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap <bytestructure> <index> ...)))
+    (bytestructure-primitive-set! bytevector offset descriptor <value>)))
+
+(define-syntax-rule (bytestructure-set!*
+                     <bytevector> <offset> <descriptor> <index> ... <value>)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap*
+                 <bytevector> <offset> <descriptor> <index> ...)))
+    (bytestructure-primitive-set! bytevector offset descriptor <value>)))
+
+(define (bytestructure-primitive-set! bytevector offset descriptor value)
+  (let ((setter (bd-setter descriptor)))
+    (if setter
+        (setter #f bytevector offset value)
+        (if (bytevector? value)
+            (bytevector-copy! bytevector offset value 0
+                              (bytestructure-descriptor-size
+                               descriptor bytevector offset))
+            (error "Cannot write value with this bytestructure descriptor."
+                   value descriptor)))))
+
+(define (bytestructure-ref/dynamic bytestructure . indices)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap bytestructure)))
+    (let loop ((bytevector bytevector)
+               (offset offset)
+               (descriptor descriptor)
+               (indices indices))
+      (if (null? indices)
+          (bytestructure-primitive-ref bytevector offset descriptor)
+          (let-values (((bytevector* offset* descriptor*)
+                        (bytestructure-unwrap*
+                         bytevector offset descriptor (car indices))))
+            (loop bytevector*
+                  offset*
+                  descriptor*
+                  (cdr indices)))))))
+
+(define (bytestructure-set!/dynamic bytestructure . args)
+  (let-values (((bytevector offset descriptor)
+                (bytestructure-unwrap bytestructure)))
+    (let loop ((bytevector bytevector)
+               (offset offset)
+               (descriptor descriptor)
+               (args args))
+      (if (null? (cdr args))
+          (bytestructure-primitive-set! bytevector offset descriptor (car args))
+          (let-values (((bytevector* offset* descriptor*)
+                        (bytestructure-unwrap*
+                         bytevector offset descriptor (car args))))
+            (loop bytevector*
+                  offset*
+                  descriptor*
+                  (cdr args)))))))
+
+(define-syntax-case-stubs
+  bytestructure-unwrap/syntax
+  bytestructure-ref/syntax
+  bytestructure-set!/syntax
+  define-bytestructure-accessors)
+
+(cond-expand
+ (guile       (include-from-path "bytestructures/body/base.syntactic.scm"))
+ (syntax-case (include "base.syntactic.scm"))
+ (else))
+
+;;; base.scm ends here
+;;; bytestructures --- Structured access to bytevector contents.
+
+;; Copyright © 2015 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is an extension to the base of the module which allows using the API
+;; purely in the macro-expand phase, which puts some limitations on its use but
+;; reduces run-time overhead to zero or nearly zero.
+
+
+;;; Code:
+
+(define-syntax-rule (syntax-case-lambda <pattern> <body>)
+  (lambda (stx)
+    (syntax-case stx ()
+      (<pattern> <body>))))
+
+(define syntax-car (syntax-case-lambda (car . cdr) #'car))
+(define syntax-cdr (syntax-case-lambda (car . cdr) #'cdr))
+(define syntax-null? (syntax-case-lambda stx (null? (syntax->datum #'stx))))
+
+(define (syntactic-unwrap bytevector offset descriptor indices)
+  (let loop ((bytevector bytevector)
+             (offset offset)
+             (descriptor descriptor)
+             (indices indices))
+    (if (not (syntax-null? indices))
+        (let ((unwrapper (bd-unwrapper descriptor)))
+          (when (not unwrapper)
+            (error "Cannot index through this descriptor." descriptor))
+          (let-values (((bytevector* offset* descriptor*)
+                        (unwrapper #t bytevector offset (syntax-car indices))))
+            (loop bytevector* offset* descriptor* (syntax-cdr indices))))
+        (let ((getter (bd-getter descriptor))
+              (setter (bd-setter descriptor)))
+          (values bytevector offset descriptor getter setter)))))
+
+(define (bytestructure-unwrap/syntax bytevector offset descriptor indices)
+  (let-values (((bytevector* offset* _descriptor _getter _setter)
+                (syntactic-unwrap bytevector offset descriptor indices)))
+    #`(values #,bytevector* #,offset*)))
+
+(define (bytestructure-ref/syntax bytevector offset descriptor indices)
+  (let-values (((bytevector* offset* descriptor* getter _setter)
+                (syntactic-unwrap bytevector offset descriptor indices)))
+    (if getter
+        (getter #t bytevector* offset*)
+        (error "The indices given to bytestructure-ref/syntax do not lead to a
+bytestructure descriptor that can decode values.  You must have used the wrong
+getter macro, forgot to provide some of the indices, or meant to use the
+unwrapper instead of the getter.  The given indices follow." indices))))
+
+(define (bytestructure-set!/syntax bytevector offset descriptor indices value)
+  (let-values (((bytevector* offset* descriptor* _getter setter)
+                (syntactic-unwrap bytevector offset descriptor indices)))
+    (if setter
+        (setter #t bytevector* offset* value)
+        (error "The indices given to bytestructure-set!/syntax do not lead to a
+bytestructure descriptor that can encode values.  You must have used the wrong
+setter macro, or forgot to provide some of the indices.  The given indices
+follow." indices))))
+
+(define-syntax-rule (define-bytestructure-unwrapper <name> <descriptor>)
+  (define-syntax <name>
+    (let ((descriptor <descriptor>))
+      (syntax-case-lambda (_ <bytevector> <offset> . <indices>)
+        (bytestructure-unwrap/syntax
+         #'<bytevector> #'<offset> descriptor #'<indices>)))))
+
+(define-syntax-rule (define-bytestructure-getter* <name> <descriptor>)
+  (define-syntax <name>
+    (let ((descriptor <descriptor>))
+      (syntax-case-lambda (_ <bytevector> <offset> . <indices>)
+        (bytestructure-ref/syntax
+         #'<bytevector> #'<offset> descriptor #'<indices>)))))
+
+(define-syntax-rule (define-bytestructure-setter* <name> <descriptor>)
+  (define-syntax <name>
+    (let ((descriptor <descriptor>))
+      (syntax-case-lambda (_ <bytevector> <offset> <index> (... ...) <value>)
+        (bytestructure-set!/syntax
+         #'<bytevector> #'<offset> descriptor #'(<index> (... ...)) #'<value>)))))
+
+(define-syntax-rule (define-bytestructure-getter <name> <descriptor>)
+  (define-syntax <name>
+    (let ((descriptor <descriptor>))
+      (syntax-case-lambda (_ <bytevector> . <indices>)
+        (bytestructure-ref/syntax #'<bytevector> 0 descriptor #'<indices>)))))
+
+(define-syntax-rule (define-bytestructure-setter <name> <descriptor>)
+  (define-syntax <name>
+    (let ((descriptor <descriptor>))
+      (syntax-case-lambda (_ <bytevector> <index> (... ...) <value>)
+        (bytestructure-set!/syntax
+         #'<bytevector> 0 descriptor #'(<index> (... ...)) #'<value>)))))
+
+(define-syntax define-bytestructure-accessors
+  (syntax-rules ()
+    ((_ <descriptor> <unwrapper> <getter> <setter>)
+     (begin
+       (define-bytestructure-unwrapper <unwrapper> <descriptor>)
+       (define-bytestructure-getter <getter> <descriptor>)
+       (define-bytestructure-setter <setter> <descriptor>)))
+    ((_ <descriptor> <unwrapper> <getter> <setter> <getter*> <setter*>)
+     (begin
+       (define-bytestructure-unwrapper <unwrapper> <descriptor>)
+       (define-bytestructure-getter <getter> <descriptor>)
+       (define-bytestructure-setter <setter> <descriptor>)
+       (define-bytestructure-getter* <getter*> <descriptor>)
+       (define-bytestructure-setter* <setter*> <descriptor>)))))
+
+;; Local Variables:
+;; eval: (put (quote syntax-case-lambda) (quote scheme-indent-function) 1)
+;; End:
+
+;;; base.syntactic.scm ends here
+;;; bitfields.scm --- Struct bitfield constructor.
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is complementary to the struct module.  It isn't used on its own.
+
+;; This code partly uses rational numbers for byte counts and offsets, to
+;; represent granularity down to bits.  I.e. 1/8 is a size or offset of one bit.
+
+
+;;; Code:
+
+;;; Only a macro for efficiency reasons.
+(define-syntax bit-field/signed
+  (syntax-rules ()
+    ((_ <num> <width> <start> <end> <signed?>)
+     (let ((unsigned-value (bit-field <num> <start> <end>)))
+       (if (not <signed?>)
+           unsigned-value
+           (let ((sign (bit-set? (- <width> 1) unsigned-value)))
+             (if sign
+                 (- unsigned-value (expt 2 <width>))
+                 unsigned-value)))))))
+
+(define (validate-integer-descriptor descriptor)
+  (when (not (assq descriptor integer-descriptors))
+    (error "Invalid descriptor for bitfield." descriptor)))
+
+(define (integer-descriptor-signed? descriptor)
+  (assq descriptor signed-integer-descriptors))
+
+(define integer-descriptor-signed->unsigned-mapping
+  (map cons
+       (map car signed-integer-descriptors)
+       (map car unsigned-integer-descriptors)))
+
+(define (integer-descriptor-signed->unsigned descriptor)
+  (cdr (assq descriptor integer-descriptor-signed->unsigned-mapping)))
+
+(define (unsigned-integer-descriptor integer-descriptor)
+  (if (integer-descriptor-signed? integer-descriptor)
+      (integer-descriptor-signed->unsigned integer-descriptor)
+      integer-descriptor))
+
+(define-record-type <bitfield-metadata>
+  (make-bitfield-metadata int-descriptor width)
+  bitfield-metadata?
+  (int-descriptor bitfield-metadata-int-descriptor)
+  (width          bitfield-metadata-width))
+
+(define (bitfield-descriptor int-descriptor bit-offset width)
+  (validate-integer-descriptor int-descriptor)
+  (let ((signed? (integer-descriptor-signed? int-descriptor))
+        (uint-descriptor (unsigned-integer-descriptor int-descriptor)))
+    (let ((num-getter (bytestructure-descriptor-getter uint-descriptor))
+          (num-setter (bytestructure-descriptor-setter uint-descriptor)))
+      (define start bit-offset)
+      (define end (+ start width))
+      (define (getter syntax? bytevector offset)
+        (let ((num (num-getter syntax? bytevector offset)))
+          (if syntax?
+              (quasisyntax
+               (bit-field/signed (unsyntax num) (unsyntax width)
+                                 (unsyntax start) (unsyntax end)
+                                 (unsyntax signed?)))
+              (bit-field/signed num width start end signed?))))
+      (define (setter syntax? bytevector offset value)
+        (let* ((oldnum (num-getter syntax? bytevector offset))
+               (newnum (if syntax?
+                           (quasisyntax
+                            (copy-bit-field (unsyntax oldnum) (unsyntax value)
+                                            (unsyntax start) (unsyntax end)))
+                           (copy-bit-field oldnum value start end))))
+          (num-setter syntax? bytevector offset newnum)))
+      (define meta (make-bitfield-metadata int-descriptor width))
+      (make-bytestructure-descriptor #f #f #f getter setter meta))))
+
+;;; bitfields.scm ends here
+;;; explicit-endianness.scm --- Auxiliary bytevector operations.
+
+;; Copyright © 2015 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The numeric module requires top-level bindings to bytevector procedures with
+;; an explicit endianness, instead of the ones that take an endianness
+;; argument.  This library provides them.
+
+
+;;; Code:
+
+(define-syntax define-explicit-endianness-getters
+  (syntax-rules ()
+    ((_ (original le-name be-name) ...)
+     (begin
+       (begin
+         (define (le-name bytevector index)
+           (original bytevector index (endianness little)))
+         (define (be-name bytevector index)
+           (original bytevector index (endianness big))))
+       ...))))
+
+(define-explicit-endianness-getters
+  (bytevector-ieee-single-ref bytevector-ieee-single-le-ref
+                              bytevector-ieee-single-be-ref)
+  (bytevector-ieee-double-ref bytevector-ieee-double-le-ref
+                              bytevector-ieee-double-be-ref)
+  (bytevector-s16-ref bytevector-s16le-ref
+                      bytevector-s16be-ref)
+  (bytevector-u16-ref bytevector-u16le-ref
+                      bytevector-u16be-ref)
+  (bytevector-s32-ref bytevector-s32le-ref
+                      bytevector-s32be-ref)
+  (bytevector-u32-ref bytevector-u32le-ref
+                      bytevector-u32be-ref)
+  (bytevector-s64-ref bytevector-s64le-ref
+                      bytevector-s64be-ref)
+  (bytevector-u64-ref bytevector-u64le-ref
+                      bytevector-u64be-ref))
+
+(define-syntax define-explicit-endianness-setters
+  (syntax-rules ()
+    ((_ (original le-name be-name) ...)
+     (begin
+       (begin
+         (define (le-name bytevector index value)
+           (original bytevector index value (endianness little)))
+         (define (be-name bytevector index value)
+           (original bytevector index value (endianness big))))
+       ...))))
+
+(define-explicit-endianness-setters
+  (bytevector-ieee-single-set! bytevector-ieee-single-le-set!
+                               bytevector-ieee-single-be-set!)
+  (bytevector-ieee-double-set! bytevector-ieee-double-le-set!
+                               bytevector-ieee-double-be-set!)
+  (bytevector-s16-set! bytevector-s16le-set!
+                       bytevector-s16be-set!)
+  (bytevector-u16-set! bytevector-u16le-set!
+                       bytevector-u16be-set!)
+  (bytevector-s32-set! bytevector-s32le-set!
+                       bytevector-s32be-set!)
+  (bytevector-u32-set! bytevector-u32le-set!
+                       bytevector-u32be-set!)
+  (bytevector-s64-set! bytevector-s64le-set!
+                       bytevector-s64be-set!)
+  (bytevector-u64-set! bytevector-u64le-set!
+                       bytevector-u64be-set!))
+
+;;; explicit-endianness.scm ends here
+;;; numeric.scm --- Numeric types as supported by (rnrs bytevectors).
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module defines descriptors for numeric types of specific size, and
+;; native or specific endianness, as made possible by the bytevector referencing
+;; and assigning procedures in the (rnrs bytevectors) module.
+
+;; We use the strange cond-expand/runtime macro to make sure that certain checks
+;; for CPU architecture and data model are done at library-load-time and not
+;; compile time, since one might cross-compile the library.
+
+
+;;; Code:
+
+(define base-environment
+  (cond-expand
+   (guile-2
+    (current-module))
+   (else
+    (environment '(scheme base)))))
+
+(define-syntax cond-expand/runtime
+  (syntax-rules ()
+    ((_ (<cond> <expr>) ...)
+     (let ((const (eval '(cond-expand (<cond> '<expr>) ...)
+                        base-environment)))
+       (cond
+        ((equal? const '<expr>) <expr>)
+        ...)))))
+
+(define i8align 1)
+
+(define i16align 2)
+
+(define i32align 4)
+
+(define i64align
+  (cond-expand/runtime
+   (i386 4)
+   (else 8)))
+
+(define f32align 4)
+
+(define f64align
+  (cond-expand/runtime
+   (i386 4)
+   (else 8)))
+
+(define-syntax-rule (make-numeric-descriptor <size> <align> <getter> <setter>)
+  (let ()
+    (define size <size>)
+    (define alignment <align>)
+    (define (getter syntax? bytevector offset)
+      (if syntax?
+          (quasisyntax
+           (<getter> (unsyntax bytevector) (unsyntax offset)))
+          (<getter> bytevector offset)))
+    (define (setter syntax? bytevector offset value)
+      (if syntax?
+          (quasisyntax
+           (<setter> (unsyntax bytevector) (unsyntax offset) (unsyntax value)))
+          (<setter> bytevector offset value)))
+    (make-bytestructure-descriptor size alignment #f getter setter)))
+
+(define-syntax-rule (define-numeric-descriptors <list>
+                      (<name> <size> <align> <getter> <setter>)
+                      ...)
+  (begin
+    (define <name>
+      (make-numeric-descriptor <size> <align> <getter> <setter>))
+    ...
+    (define <list> (list (list <name> '<name> <getter> <setter>) ...))))
+
+(define-numeric-descriptors
+  signed-integer-native-descriptors
+  (int8   1 i8align  bytevector-s8-ref bytevector-s8-set!)
+  (int16  2 i16align bytevector-s16-native-ref bytevector-s16-native-set!)
+  (int32  4 i32align bytevector-s32-native-ref bytevector-s32-native-set!)
+  (int64  8 i64align bytevector-s64-native-ref bytevector-s64-native-set!))
+
+(define-numeric-descriptors
+  unsigned-integer-native-descriptors
+  (uint8  1 i8align bytevector-u8-ref bytevector-u8-set!)
+  (uint16 2 i16align bytevector-u16-native-ref bytevector-u16-native-set!)
+  (uint32 4 i32align bytevector-u32-native-ref bytevector-u32-native-set!)
+  (uint64 8 i64align bytevector-u64-native-ref bytevector-u64-native-set!))
+
+(define-numeric-descriptors
+  float-native-descriptors
+  (float32 4 f32align
+           bytevector-ieee-single-native-ref
+           bytevector-ieee-single-native-set!)
+  (float64 8 f64align
+           bytevector-ieee-double-native-ref
+           bytevector-ieee-double-native-set!))
+
+(define-syntax-rule (define-with-endianness <list> <endianness>
+                      (<name> <size> <align> <native-name> <getter> <setter>)
+                      ...)
+  (begin
+    (define <name>
+      (if (equal? <endianness> (native-endianness))
+          <native-name>
+          (make-numeric-descriptor <size> <align> <getter> <setter>)))
+    ...
+    (define <list> (list (list <name> '<name> <getter> <setter>) ...))))
+
+(define-with-endianness
+  signed-integer-le-descriptors (endianness little)
+  (int16le 2 i16align int16 bytevector-s16le-ref bytevector-s16le-set!)
+  (int32le 4 i32align int32 bytevector-s32le-ref bytevector-s32le-set!)
+  (int64le 8 i64align int64 bytevector-s64le-ref bytevector-s64le-set!))
+
+(define-with-endianness
+  signed-integer-be-descriptors (endianness big)
+  (int16be 2 i16align int16 bytevector-s16be-ref bytevector-s16be-set!)
+  (int32be 4 i32align int32 bytevector-s32be-ref bytevector-s32be-set!)
+  (int64be 8 i64align int64 bytevector-s64be-ref bytevector-s64be-set!))
+
+(define-with-endianness
+  unsigned-integer-le-descriptors (endianness little)
+  (uint16le 2 i16align uint16 bytevector-u16le-ref bytevector-u16le-set!)
+  (uint32le 4 i32align uint32 bytevector-u32le-ref bytevector-u32le-set!)
+  (uint64le 8 i64align uint64 bytevector-u64le-ref bytevector-u64le-set!))
+
+(define-with-endianness
+  unsigned-integer-be-descriptors (endianness big)
+  (uint16be 2 i16align uint16 bytevector-u16be-ref bytevector-u16be-set!)
+  (uint32be 4 i32align uint32 bytevector-u32be-ref bytevector-u32be-set!)
+  (uint64be 8 i64align uint64 bytevector-u64be-ref bytevector-u64be-set!))
+
+(define-with-endianness
+  float-le-descriptors (endianness little)
+  (float32le 4 f32align float32
+             bytevector-ieee-single-le-ref
+             bytevector-ieee-single-le-set!)
+  (float64le 8 f64align float64
+             bytevector-ieee-double-le-ref
+             bytevector-ieee-double-le-set!))
+
+(define-with-endianness
+  float-be-descriptors (endianness big)
+  (float32be 4 f32align float32
+             bytevector-ieee-single-be-ref
+             bytevector-ieee-single-be-set!)
+  (float64be 8 f64align float64
+             bytevector-ieee-double-be-ref
+             bytevector-ieee-double-be-set!))
+
+(define-syntax-rule (make-complex-descriptor
+                     <float-size> <float-align> <float-getter> <float-setter>)
+  (let ()
+    (define size (* 2 <float-size>))
+    (define alignment <float-align>)
+    (define (getter syntax? bytevector offset)
+      (if syntax?
+          (quasisyntax
+           (let ((real (<float-getter> (unsyntax bytevector)
+                                       (unsyntax offset)))
+                 (imag (<float-getter> (unsyntax bytevector)
+                                       (+ (unsyntax offset) <float-size>))))
+             (make-rectangular real imag)))
+          (let ((real (<float-getter> bytevector offset))
+                (imag (<float-getter> bytevector (+ offset <float-size>))))
+            (make-rectangular real imag))))
+    (define (setter syntax? bytevector offset value)
+      (if syntax?
+          (quasisyntax
+           (let ((val (unsyntax value)))
+             (let ((real (real-part val))
+                   (imag (imag-part val)))
+               (<float-setter> (unsyntax bytevector)
+                               (unsyntax offset)
+                               real)
+               (<float-setter> (unsyntax bytevector)
+                               (+ (unsyntax offset) <float-size>)
+                               imag))))
+          (let ((real (real-part value))
+                (imag (imag-part value)))
+            (<float-setter> bytevector offset real)
+            (<float-setter> bytevector (+ offset <float-size>) imag))))
+    (make-bytestructure-descriptor size alignment #f getter setter)))
+
+(define-syntax-rule (define-complex-descriptors <list>
+                      (<name> <float-size> <float-align>
+                              <float-getter> <float-setter>)
+                      ...)
+  (begin
+    (define <name>
+      (make-complex-descriptor <float-size> <float-align>
+                               <float-getter> <float-setter>))
+    ...
+    (define <list> (list (list <name> '<name> <float-getter> <float-setter>)
+                         ...))))
+
+(define-complex-descriptors
+  complex-native-descriptors
+  (complex64  4 f32align
+              bytevector-ieee-single-native-ref
+              bytevector-ieee-single-native-set!)
+  (complex128 8 f64align
+              bytevector-ieee-double-native-ref
+              bytevector-ieee-double-native-set!))
+
+(define-syntax-rule (define-complex-with-endianness <list> <endianness>
+                      (<name> <float-size> <float-align> <native-name>
+                              <float-getter> <float-setter>)
+                      ...)
+  (begin
+    (define <name>
+      (if (equal? <endianness> (native-endianness))
+          <native-name>
+          (make-complex-descriptor <float-size> <float-align>
+                                   <float-getter> <float-setter>)))
+    ...
+    (define <list> (list (list <name> '<name> <float-getter> <float-setter>)
+                         ...))))
+
+(define-complex-with-endianness
+  complex-le-descriptors (endianness little)
+  (complex64le  4 f32align complex64
+                bytevector-ieee-single-le-ref
+                bytevector-ieee-single-le-set!)
+  (complex128le 8 f64align complex128
+                bytevector-ieee-double-le-ref
+                bytevector-ieee-double-le-set!))
+
+(define-complex-with-endianness
+  complex-be-descriptors (endianness big)
+  (complex64be  4 f32align complex64
+                bytevector-ieee-single-be-ref
+                bytevector-ieee-single-be-set!)
+  (complex128be 8 f64align complex128
+                bytevector-ieee-double-be-ref
+                bytevector-ieee-double-be-set!))
+
+(define signed-integer-descriptors
+  (append signed-integer-native-descriptors
+          signed-integer-le-descriptors
+          signed-integer-be-descriptors))
+
+(define unsigned-integer-descriptors
+  (append unsigned-integer-native-descriptors
+          unsigned-integer-le-descriptors
+          unsigned-integer-be-descriptors))
+
+(define integer-descriptors
+  (append signed-integer-descriptors unsigned-integer-descriptors))
+
+(define float-descriptors
+  (append float-native-descriptors
+          float-le-descriptors
+          float-be-descriptors))
+
+(define complex-descriptors
+  (append complex-native-descriptors
+          complex-le-descriptors
+          complex-be-descriptors))
+
+(define numeric-descriptors
+  (append integer-descriptors float-descriptors complex-descriptors))
+
+(define short int16)
+(define unsigned-short uint16)
+
+(define int (cond-expand/runtime
+             (lp32  int16)
+             (ilp64 int64)
+             (else  int32)))
+
+(define unsigned-int (cond-expand/runtime
+                      (lp32  uint16)
+                      (ilp64 uint64)
+                      (else  uint32)))
+
+(define long (cond-expand/runtime
+              (ilp64 int64)
+              (lp64  int64)
+              (else  int32)))
+
+(define unsigned-long (cond-expand/runtime
+                       (ilp64 uint64)
+                       (lp64  uint64)
+                       (else  uint32)))
+
+(define long-long int64)
+(define unsigned-long-long uint64)
+
+(define arch32bit? (cond-expand/runtime
+                    (lp32  #t)
+                    (ilp32 #t)
+                    (else  #f)))
+
+(define intptr_t (if arch32bit?
+                     int32
+                     int64))
+
+(define uintptr_t (if arch32bit?
+                      uint32
+                      uint64))
+
+(define size_t uintptr_t)
+
+(define ssize_t intptr_t)
+
+(define ptrdiff_t intptr_t)
+
+(define float float32)
+(define double float64)
+
+;;; numeric.scm ends here
+;;; string.scm --- Strings in encodings supported by (rnrs bytevectors).
+
+;; Copyright © 2017 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module defines descriptors for strings encoded in various encodings, as
+;; supported by (rnrs bytevectors).
+
+
+;;; Code:
+
+(define (ascii->string bytevector start end)
+  (let ((string (utf8->string bytevector start end)))
+    (when (not (= (string-length string) (bytevector-length bytevector)))
+      (error "Bytevector contains non-ASCII characters." bytevector))
+    string))
+
+(define (string->ascii string)
+  (let ((bytevector (string->utf8 string)))
+    (when (not (= (string-length string) (bytevector-length bytevector)))
+      (error "String contains non-ASCII characters." string))
+    bytevector))
+
+(define (bytevector->string bytevector offset size encoding)
+  (case encoding
+    ((ascii) (ascii->string bytevector offset (+ offset size)))
+    ((utf8) (utf8->string bytevector offset (+ offset size)))
+    (else
+     (let ((bytevector (bytevector-copy bytevector offset (+ offset size))))
+       (case encoding
+         ((utf16le) (utf16->string bytevector 'little #t))
+         ((utf16be) (utf16->string bytevector 'big #t))
+         ((utf32le) (utf32->string bytevector 'little #t))
+         ((utf32be) (utf32->string bytevector 'big #t))
+         (else (error "Unknown string encoding." encoding)))))))
+
+(define (string->bytevector string encoding)
+  (case encoding
+    ((ascii) (string->ascii string))
+    ((utf8) (string->utf8 string))
+    ((utf16le) (string->utf16 string 'little))
+    ((utf16be) (string->utf16 string 'big))
+    ((utf32le) (string->utf32 string 'little))
+    ((utf32be) (string->utf32 string 'big))))
+
+;;; Note: because macro output may not contain raw symbols, we cannot output
+;;; (quote foo) for raw symbol foo either, so there's no way to inject symbol
+;;; literals into macro output.  Hence we inject references to the following
+;;; variables instead.
+
+(define ascii 'ascii)
+(define utf8 'utf8)
+(define utf16le 'utf16le)
+(define utf16be 'utf16be)
+(define utf32le 'utf32le)
+(define utf32be 'utf32be)
+
+;;; Make sure this returns a boolean and not any other type of value, as the
+;;; output will be part of macro output.
+(define (fixed-width-encoding? encoding)
+  (not (not (memq encoding '(ascii utf32le utf32be)))))
+
+(define (bytevector-zero! bv start end)
+  (do ((i start (+ i 1)))
+      ((= i end))
+    (bytevector-u8-set! bv i #x00)))
+
+(define (bs:string size encoding)
+  (define alignment 1)
+  (define (getter syntax? bytevector offset)
+    (if syntax?
+        (quasisyntax
+         (bytevector->string (unsyntax bytevector)
+                             (unsyntax offset)
+                             (unsyntax size)
+                             (unsyntax
+                              (datum->syntax (syntax utf8) encoding))))
+        (bytevector->string bytevector offset size encoding)))
+  (define (setter syntax? bytevector offset string)
+    (if syntax?
+        (quasisyntax
+         (let* ((bv (string->bytevector
+                     (unsyntax string)
+                     (unsyntax
+                      (datum->syntax (syntax utf8) encoding))))
+                (length (bytevector-length bv)))
+           (when (> length (unsyntax size))
+             (error "String too long." (unsyntax string)))
+           (when (and (unsyntax (fixed-width-encoding? encoding))
+                      (< length (unsyntax size)))
+             (error "String too short." (unsyntax string)))
+           (bytevector-copy! (unsyntax bytevector)
+                             (unsyntax offset)
+                             bv)
+           (when (not (unsyntax (fixed-width-encoding? encoding)))
+             (bytevector-zero! (unsyntax bytevector)
+                               (+ (unsyntax offset) (bytevector-length bv))
+                               (+ (unsyntax offset) (unsyntax size))))))
+        (let* ((bv (string->bytevector string encoding))
+               (length (bytevector-length bv)))
+          (when (> length size)
+            (error "String too long." string))
+          (when (and (fixed-width-encoding? encoding) (< length size))
+            (error "String too short." string))
+          (bytevector-copy! bytevector offset bv)
+          (when (not (fixed-width-encoding? encoding))
+            (bytevector-zero! bytevector
+                              (+ offset (bytevector-length bv))
+                              (+ offset size))))))
+  (make-bytestructure-descriptor size alignment #f getter setter))
+
+;;; string.scm ends here
+;;; struct.scm --- Struct descriptor constructor.
+
+;; Copyright © 2015, 2016, 2021 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This constructor allows the creation of struct descriptors with named and
+;; ordered fields with a specific content descriptor.
+
+;; This code partly uses rational numbers for byte counts and offsets, to
+;; represent granularity down to bits.  I.e. 1/8 is a size or offset of one bit.
+
+
+;;; Code:
+
+(define (pack-alignment pack alignment)
+  (case pack
+    ((#t) 1)
+    ((#f) alignment)
+    (else (min pack alignment))))
+
+(define-record-type <field>
+  (make-field name descriptor size alignment position)
+  field?
+  (name field-name)
+  (descriptor field-descriptor)
+  (size field-size)
+  (alignment field-alignment)
+  (position field-position))
+
+(define (construct-normal-field pack position name descriptor)
+  (let*-values
+      (((size)
+        (bytestructure-descriptor-size descriptor))
+       ((alignment)
+        (pack-alignment pack (bytestructure-descriptor-alignment descriptor)))
+       ((position _boundary _bit-offset)
+        (align position size alignment)))
+    (values (make-field name descriptor size alignment position)
+            (+ position size))))
+
+(define (construct-bit-field pack position name descriptor width)
+  (if (zero? width)
+      (let* ((alignment (bytestructure-descriptor-alignment descriptor))
+             (position (next-boundary position alignment)))
+        (values (make-field #f descriptor 0 1 position)
+                position))
+      (let*-values
+          (((int-size)
+            (bytestructure-descriptor-size descriptor))
+           ((size)
+            (* 1/8 width))
+           ((int-alignment)
+            (bytestructure-descriptor-alignment descriptor))
+           ((alignment)
+            (pack-alignment pack int-alignment))
+           ((position boundary offset)
+            (align position size alignment))
+           ((descriptor)
+            (bitfield-descriptor descriptor offset width)))
+        (values (make-field name descriptor int-size alignment boundary)
+                (+ position size)))))
+
+(define (construct-fields pack field-specs)
+  (let loop ((field-specs field-specs)
+             (position 0)
+             (fields '()))
+    (if (null? field-specs)
+        (reverse fields)
+        (let* ((field-spec (car field-specs))
+               (field-specs (cdr field-specs))
+               (name-or-type (car field-spec)))
+          (if (and (eq? name-or-type 'union)
+                   (pair? (cadr field-spec)))
+              (let-values (((next-position fields)
+                            (add-union-fields pack
+                                              position
+                                              (cadr field-spec)
+                                              fields)))
+                (loop field-specs
+                      next-position
+                      fields))
+              (let-values (((field next-position)
+                            (construct-field pack position field-spec)))
+                (loop field-specs
+                      next-position
+                      (cons field fields))))))))
+
+(define (add-union-fields pack position field-specs fields)
+  (define (field-spec-alignment field-spec)
+    (let ((descriptor (cadr field-spec)))
+      (bytestructure-descriptor-alignment descriptor)))
+  (define (field-spec-size field-spec)
+    (let ((descriptor (cadr field-spec)))
+      (bytestructure-descriptor-size descriptor)))
+  (let* ((alignment (apply max (map field-spec-alignment field-specs)))
+         (alignment (pack-alignment pack alignment))
+         (size (apply max (map field-spec-size field-specs)))
+         (position (align position size alignment)))
+    (let loop ((field-specs field-specs)
+               (next-position position)
+               (fields fields))
+      (if (null? field-specs)
+          (values next-position fields)
+          (let ((field-spec (car field-specs))
+                (field-specs (cdr field-specs)))
+            (let-values (((field next-position)
+                          (construct-field pack position field-spec)))
+              (loop field-specs
+                    (max position next-position)
+                    (cons field fields))))))))
+
+(define (construct-field pack position field-spec)
+  (let* ((name (car field-spec))
+         (descriptor (cadr field-spec))
+         (bitfield? (not (null? (cddr field-spec))))
+         (width (if bitfield?
+                    (car (cddr field-spec))
+                    #f)))
+    (if bitfield?
+        (construct-bit-field pack position name descriptor width)
+        (construct-normal-field pack position name descriptor))))
+
+(define-record-type <struct-metadata>
+  (make-struct-metadata field-alist)
+  struct-metadata?
+  (field-alist struct-metadata-field-alist))
+
+(define bs:struct
+  (case-lambda
+    ((field-specs)
+     (bs:struct #f field-specs))
+    ((pack field-specs)
+     (define %fields (construct-fields pack field-specs))
+     (define fields (filter field-name %fields))
+     (define field-alist (map (lambda (field)
+                                (cons (field-name field) field))
+                              fields))
+     (define alignment (apply max (map field-alignment fields)))
+     (define (field-end field)
+       (+ (field-position field) (field-size field)))
+     (define size (let ((end (apply max (map field-end %fields))))
+                    (let-values (((size . _) (next-boundary end alignment)))
+                      size)))
+     (define (unwrapper syntax? bytevector offset index)
+       (let* ((index (if syntax? (syntax->datum index) index))
+              (field-entry (assq index field-alist))
+              (field (if field-entry
+                         (cdr field-entry)
+                         (error "No such struct field." index))))
+         (let* ((descriptor (field-descriptor field))
+                (position (field-position field))
+                (offset (if syntax?
+                            (quasisyntax
+                             (+ (unsyntax offset) (unsyntax position)))
+                            (+ offset position))))
+           (values bytevector offset descriptor))))
+     (define (setter syntax? bytevector offset value)
+       (define (count-error fields values)
+         (error "Mismatch between number of struct fields and given values."
+                fields values))
+       (when syntax?
+         (error "Writing into struct not supported with macro API."))
+       (cond
+        ((bytevector? value)
+         (bytevector-copy! bytevector offset value 0 size))
+        ((vector? value)
+         (let loop ((fields fields)
+                    (values (vector->list value)))
+           (if (null? values)
+               (when (not (null? fields))
+                 (count-error fields value))
+               (begin
+                 (when (null? fields)
+                   (count-error fields value))
+                 (let* ((field (car fields))
+                        (value (car values))
+                        (descriptor (field-descriptor field))
+                        (position (field-position field))
+                        (offset (+ offset position)))
+                   (bytestructure-set!* bytevector offset descriptor value)
+                   (loop (cdr fields) (cdr values)))))))
+        ((pair? value)
+         ;; Assumed to be a pseudo-alist like ((k1 v1) (k2 v2) ...).
+         (for-each
+          (lambda (pair)
+            (let ((key (car pair))
+                  (value (cadr pair)))
+              (let-values (((bytevector offset descriptor)
+                            (unwrapper #f bytevector offset key)))
+                (bytestructure-set!* bytevector offset descriptor value))))
+          value))
+        (else
+         (error "Invalid value for writing into struct." value))))
+     (define meta
+       (let ((simple-field-alist (map (lambda (field)
+                                        (cons (field-name field)
+                                              (field-descriptor field)))
+                                      fields)))
+         (make-struct-metadata simple-field-alist)))
+     (make-bytestructure-descriptor size alignment unwrapper #f setter meta))))
+
+(define debug-alignment
+  (case-lambda
+   ((fields) (debug-alignment #f fields))
+   ((pack fields)
+    (let* ((fields (construct-fields pack fields))
+         (alignment (apply max (map field-alignment fields)))
+         (size (let* ((field (last fields))
+                      (end (+ (field-position field) (field-size field))))
+                 (let-values (((size . _) (next-boundary end alignment)))
+                   size))))
+    (format #t "{\n")
+    (for-each (lambda (field)
+                (let ((name (field-name field))
+                      (pos (* 8 (field-position field)))
+                      (size (* 8 (field-size field)))
+                      (align (* 8 (field-alignment field))))
+                  (format #t "  ~a - ~a: ~a (~a, ~a)\n"
+                          pos (+ pos size) name size align)))
+              fields)
+    (format #t "} = ~a\n" (* 8 size))
+    (values)))))
+
+;;; struct.scm ends here
+;;; union.scm --- Union descriptor constructor.
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This constructor allows the creation of union descriptors with named fields
+;; with a specific content descriptor.
+
+
+;;; Code:
+
+(define make-field cons)
+(define field-name car)
+(define field-content cdr)
+(define find-field assq)
+
+(define (construct-fields fields)
+  (map (lambda (field)
+         (make-field (car field) (cadr field)))
+       fields))
+
+(define-record-type <union-metadata>
+  (make-union-metadata field-alist)
+  union-metadata?
+  (field-alist union-metadata-field-alist))
+
+(define (bs:union %fields)
+  (define fields (construct-fields %fields))
+  (define alignment (apply max (map (lambda (field)
+                                      (bytestructure-descriptor-alignment
+                                       (field-content field)))
+                                    fields)))
+  (define size (let ((max-element
+                      (apply max (map (lambda (field)
+                                        (bytestructure-descriptor-size
+                                         (field-content field)))
+                                      fields))))
+                 (let-values (((size . _) (next-boundary max-element alignment)))
+                   size)))
+  (define (unwrapper syntax? bytevector offset index)
+    (let ((index (if syntax? (syntax->datum index) index)))
+      (values bytevector
+              offset
+              (field-content (find-field index fields)))))
+  (define (setter syntax? bytevector offset value)
+    (when syntax?
+      (error "Writing into union not supported with macro API."))
+    (cond
+     ((bytevector? value)
+      (bytevector-copy! bytevector offset value 0 size))
+     ((and (list? value) (= 2 (length value)))
+      (let-values (((bytevector* offset* descriptor)
+                    (unwrapper #f bytevector offset (car value))))
+        (bytestructure-set!* bytevector* offset* descriptor (cadr value))))
+     (else
+      (error "Invalid value for writing into union." value))))
+  (define meta (make-union-metadata fields))
+  (make-bytestructure-descriptor size alignment unwrapper #f setter meta))
+
+;;; union.scm ends here
+;;; utils.scm --- Utility library for bytestructures.
+
+;; Copyright © 2015 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Just some utility procedures and macros.
+
+
+;;; Code:
+
+(define-syntax define-syntax-rule
+  (syntax-rules ()
+    ((_ (<name> . <args>) <expr>)
+     (define-syntax <name>
+       (syntax-rules ()
+         ((_ . <args>)
+          <expr>))))))
+
+(cond-expand
+ ((or guile syntax-case)
+  (define-syntax-rule (if-syntax-case <then> <else>)
+    <then>))
+ (else
+  (define-syntax-rule (if-syntax-case <then> <else>)
+    <else>)))
+
+(define-syntax-rule (define-syntax-case-stubs <name> ...)
+  (if-syntax-case
+   (begin)
+   (begin
+     (define (<name> . rest)
+       (error "Not supported.  You need syntax-case."))
+     ...)))
+
+(define-syntax-case-stubs
+  syntax
+  quasisyntax
+  unsyntax
+  unsyntax-splicing
+  syntax->datum
+  datum->syntax)
+
+;;; utils.scm ends here
+;;; vector.scm --- Vector descriptor constructor.
+
+;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This constructor allows the creation of vector descriptors with a specific
+;; length and element descriptor.
+
+;; Be careful with identifier names here; don't confuse vector descriptor and
+;; Scheme vector APIs and variables.
+
+
+;;; Code:
+
+(define-record-type <vector-metadata>
+  (make-vector-metadata length element-descriptor)
+  vector-metadata?
+  (length             vector-metadata-length)
+  (element-descriptor vector-metadata-element-descriptor))
+
+(define (bs:vector length descriptor)
+  (define element-size (bytestructure-descriptor-size descriptor))
+  (define size (* length element-size))
+  (define alignment (bytestructure-descriptor-alignment descriptor))
+  (define (unwrapper syntax? bytevector offset index)
+    (values bytevector
+            (if syntax?
+                (quasisyntax
+                 (+ (unsyntax offset)
+                    (* (unsyntax index) (unsyntax element-size))))
+                (+ offset (* index element-size)))
+            descriptor))
+  (define (setter syntax? bytevector offset value)
+    (when syntax?
+      (error "Writing into vector not supported with macro API."))
+    (cond
+     ((bytevector? value)
+      (bytevector-copy! bytevector offset value 0 size))
+     ((vector? value)
+      (do ((i 0 (+ i 1))
+           (offset offset (+ offset element-size)))
+          ((= i (vector-length value)))
+        (bytestructure-set!*
+         bytevector offset descriptor (vector-ref value i))))
+     (else
+      (error "Invalid value for writing into vector." value))))
+  (define meta (make-vector-metadata length descriptor))
+  (make-bytestructure-descriptor size alignment unwrapper #f setter meta))
+
+;;; vector.scm ends here
+(define-module (bytestructures guile base))
+(import
+ (srfi 9)
+ (srfi 11)
+ (ice-9 format)
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils))
+(include-from-path "bytestructures/body/base.scm")
+(include-from-path "bytestructures/r7/base.exports.sld")
+
+(import (srfi srfi-9 gnu))
+
+(set-record-type-printer!
+ <bytestructure-descriptor>
+ (lambda (record port)
+   (format port "#<bytestructure-descriptor 0x~x>" (object-address record))))
+
+(set-record-type-printer!
+ <bytestructure>
+ (lambda (record port)
+   (format port "#<bytestructure 0x~x>" (object-address record))))
+(define-module (bytestructures guile bitfields))
+(import
+ (srfi 9)
+ (srfi 60)
+ (bytestructures guile utils)
+ (bytestructures guile base)
+ (bytestructures guile numeric-metadata))
+(include-from-path "bytestructures/body/bitfields.scm")
+(include-from-path "bytestructures/r7/bitfields.exports.sld")
+;;; Compatibility shim for Guile, because its implementation of utf16->string
+;;; and utf32->string doesn't conform to R6RS.
+(define-module (bytestructures guile bytevectors))
+
+(import
+ (rnrs base)
+ (rnrs control)
+ (bytestructures r6 bytevectors))
+
+(re-export
+ endianness native-endianness bytevector?
+ make-bytevector bytevector-length bytevector=? bytevector-fill!
+ bytevector-copy!
+ bytevector-copy
+
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+ u8-list->bytevector
+ bytevector-uint-ref bytevector-uint-set!
+ bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list
+ uint-list->bytevector sint-list->bytevector
+
+ bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set!
+ bytevector-u16-native-ref bytevector-s16-native-ref
+ bytevector-u16-native-set! bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set!
+ bytevector-u32-native-ref bytevector-s32-native-ref
+ bytevector-u32-native-set! bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set!
+ bytevector-u64-native-ref bytevector-s64-native-ref
+ bytevector-u64-native-set! bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref
+ bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set!
+
+ bytevector-ieee-double-ref
+ bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set!
+
+ string->utf8
+ utf8->string
+ string->utf16 string->utf32)
+
+(export
+ (r6rs-utf16->string . utf16->string)
+ (r6rs-utf32->string . utf32->string))
+
+(define (read-bom16 bv)
+  (let ((c0 (bytevector-u8-ref bv 0))
+        (c1 (bytevector-u8-ref bv 1)))
+    (cond
+     ((and (= c0 #xFE) (= c1 #xFF))
+      'big)
+     ((and (= c0 #xFF) (= c1 #xFE))
+      'little)
+     (else
+      #f))))
+
+(define r6rs-utf16->string
+  (case-lambda
+    ((bv default-endianness)
+     (let ((bom-endianness (read-bom16 bv)))
+       (if (not bom-endianness)
+           (utf16->string bv default-endianness)
+           (substring/shared (utf16->string bv bom-endianness) 1))))
+    ((bv endianness endianness-mandatory?)
+     (if endianness-mandatory?
+         (utf16->string bv endianness)
+         (r6rs-utf16->string bv endianness)))))
+
+(define (read-bom32 bv)
+  (let ((c0 (bytevector-u8-ref bv 0))
+        (c1 (bytevector-u8-ref bv 1))
+        (c2 (bytevector-u8-ref bv 2))
+        (c3 (bytevector-u8-ref bv 3)))
+    (cond
+     ((and (= c0 #x00) (= c1 #x00) (= c2 #xFE) (= c3 #xFF))
+      'big)
+     ((and (= c0 #xFF) (= c1 #xFE) (= c2 #x00) (= c3 #x00))
+      'little)
+     (else
+      #f))))
+
+(define r6rs-utf32->string
+  (case-lambda
+    ((bv default-endianness)
+     (let ((bom-endianness (read-bom32 bv)))
+       (if (not bom-endianness)
+           (utf32->string bv default-endianness)
+           (substring/shared (utf32->string bv bom-endianness) 1))))
+    ((bv endianness endianness-mandatory?)
+     (if endianness-mandatory?
+         (utf32->string bv endianness)
+         (r6rs-utf32->string bv endianness)))))
+;;; cstring-pointer.scm --- Pointers to null-terminated strings.
+
+;; Copyright © 2017 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The cstring-pointer descriptor represents a pointer to a null-terminated
+;; string, and will return the string as a Scheme string upon a reference
+;; operation.  Its setter however does not take Scheme strings, only addresses
+;; to existing strings in memory.  The reason is: Guile's string->pointer
+;; creates a new C string in memory, returning an FFI pointer object holding its
+;; address; the string is freed when the pointer object is garbage collected.
+;; We have no means of holding a reference to the FFI pointer object; we can
+;; only write the address it holds into our bytevector, which won't protect the
+;; pointer object from GC.
+
+
+;;; Code:
+
+(define-module (bytestructures guile cstring-pointer))
+(import
+ (bytestructures guile base)
+ (bytestructures guile numeric)
+ (prefix (system foreign) ffi-))
+(export cstring-pointer)
+
+(define (bytevector-address-ref bv offset)
+  (bytestructure-ref* bv offset uintptr_t))
+
+(define (bytevector-address-set! bv offset address)
+  (bytestructure-set!* bv offset uintptr_t address))
+
+(define cstring-pointer
+  (let ()
+    (define size (bytestructure-descriptor-size intptr_t))
+    (define alignment (bytestructure-descriptor-alignment intptr_t))
+    (define unwrapper #f)
+    (define (getter syntax? bv offset)
+      (if syntax?
+          #`(let* ((address (bytevector-address-ref #,bv #,offset))
+                   (pointer (ffi-make-pointer address)))
+              (ffi-pointer->string pointer))
+          (let* ((address (bytevector-address-ref bv offset))
+                 (pointer (ffi-make-pointer address)))
+            (ffi-pointer->string pointer))))
+    (define (setter syntax? bv offset address)
+      (if syntax?
+          #`(bytevector-address-set! #,bv #,offset #,address)
+          (bytevector-address-set! bv offset address)))
+    (make-bytestructure-descriptor size alignment unwrapper getter setter)))
+(define-module (bytestructures guile explicit-endianness))
+(import
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils))
+(include-from-path "bytestructures/body/explicit-endianness.scm")
+(include-from-path "bytestructures/r7/explicit-endianness.exports.sld")
+;;; ffi.scm --- Convert bytestructure descriptors to Guile/libffi types.
+
+;; Copyright © 2016 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module offers a way to convert bytestructure descriptors to Guile/libffi
+;; type objects.  For instance, the bytestructure descriptor created with
+;; (bs:struct `((x ,uint8) (y ,uint16))) gets converted into a two-element list
+;; containing the libffi codes for uint8 and uint16.
+
+
+;;; Code:
+
+(define-module (bytestructures guile ffi))
+(import
+ (ice-9 match)
+ (prefix (system foreign) ffi-)
+ (bytestructures guile base)
+ (bytestructures guile numeric)
+ (bytestructures guile vector)
+ (bytestructures guile struct)
+ (bytestructures guile union)
+ (bytestructures guile pointer)
+ (bytestructures guile bitfields))
+(export
+ bytestructure-descriptor->ffi-descriptor
+ bs:pointer->proc
+ )
+
+(define numeric-type-mapping
+  `((,int8 . ,ffi-int8)
+    (,uint8 . ,ffi-uint8)
+    (,int16 . ,ffi-int16)
+    (,uint16 . ,ffi-uint16)
+    (,int32 . ,ffi-int32)
+    (,uint32 . ,ffi-uint32)
+    (,int64 . ,ffi-int64)
+    (,uint64 . ,ffi-uint64)
+    (,float32 . ,ffi-float)
+    (,float64 . ,ffi-double)))
+
+(define (bytestructure-descriptor->ffi-descriptor descriptor)
+  (define (convert descriptor)
+    (cond
+     ((assq descriptor numeric-type-mapping)
+      => (match-lambda ((key . val) val)))
+     (else
+      (let ((metadata (bytestructure-descriptor-metadata descriptor)))
+        (cond
+         ((vector-metadata? metadata)
+          (make-list
+           (vector-metadata-length metadata)
+           (convert (vector-metadata-element-descriptor metadata))))
+         ((struct-metadata? metadata)
+          (map convert (map cdr (struct-metadata-field-alist metadata))))
+         ((union-metadata? metadata)
+          ;; TODO: Add support once Guile/libffi supports this.
+          (error "Unions not supported." descriptor))
+         ((pointer-metadata? metadata)
+          '*)
+         ((bitfield-metadata? metadata)
+          ;; TODO: Add support once Guile/libffi supports this.
+          (error "Bitfields not supported." descriptor))
+         (else
+          (error "Unsupported bytestructure descriptor." descriptor)))))))
+  (cond
+   ((eq? descriptor 'void)
+    ffi-void)
+   ((vector-metadata? (bytestructure-descriptor-metadata descriptor))
+    '*)
+   (else
+    (convert descriptor))))
+
+(define (bs:pointer->proc ret-type func-ptr arg-types)
+  (define (type->raw-type type)
+    (if (bytestructure-descriptor? type)
+        (bytestructure-descriptor->ffi-descriptor type)
+        type))
+  (define (value->raw-value value)
+    (if (bytestructure? value)
+        (ffi-bytevector->pointer (bytestructure-bytevector value))
+        value))
+  (define (raw-value->value raw-value type)
+    (if (bytestructure-descriptor? type)
+        (make-bytestructure (ffi-pointer->bytevector
+                             raw-value
+                             (bytestructure-descriptor-size type))
+                            0
+                            type)
+        raw-value))
+  (let* ((raw-ret-type (type->raw-type ret-type))
+         (raw-arg-types (map type->raw-type arg-types))
+         (raw-proc (ffi-pointer->procedure
+                    raw-ret-type func-ptr raw-arg-types)))
+    (lambda args
+      (let* ((raw-args (map value->raw-value args))
+             (raw-ret-val (apply raw-proc raw-args)))
+        (raw-value->value raw-ret-val ret-type)))))
+(define-module (bytestructures guile numeric-all))
+(import
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base)
+ (bytestructures guile explicit-endianness)
+ (bytestructures guile numeric-data-model))
+(include-from-path "bytestructures/body/numeric.scm")
+(include-from-path "bytestructures/r7/numeric.exports.sld")
+(include-from-path "bytestructures/r7/numeric-metadata.exports.sld")
+(define-module (bytestructures guile numeric-data-model))
+
+(import (system foreign))
+(import (system base target))
+
+(define architecture
+  (let ((cpu (target-cpu)))
+    (cond
+     ((member cpu '("i386" "i486" "i586" "i686"))
+      'i386)
+     ((string=? "x86_64" cpu)
+      'x86-64)
+     ((string-prefix? "arm" cpu)
+      'arm)
+     ((string-prefix? "aarch64" cpu)
+      'aarch64))))
+
+(define data-model
+  (if (= 4 (sizeof '*))
+      (if (= 2 (sizeof int))
+          'lp32
+          'ilp32)
+      (cond
+       ((= 8 (sizeof int))  'ilp64)
+       ((= 4 (sizeof long)) 'llp64)
+       (else                'lp64))))
+
+(cond-expand-provide
+ (current-module)
+ (list architecture data-model))
+(define-module (bytestructures guile numeric-metadata))
+(import (bytestructures guile numeric-all))
+(re-export
+ signed-integer-native-descriptors
+ signed-integer-le-descriptors
+ signed-integer-be-descriptors
+ signed-integer-descriptors
+ unsigned-integer-native-descriptors
+ unsigned-integer-le-descriptors
+ unsigned-integer-be-descriptors
+ unsigned-integer-descriptors
+ float-native-descriptors
+ float-le-descriptors
+ float-be-descriptors
+ integer-descriptors
+ float-descriptors
+ numeric-descriptors
+ )
+(define-module (bytestructures guile numeric))
+(import (bytestructures guile numeric-all))
+(re-export
+
+ int8 uint8 int16 uint16 int32 uint32 int64 uint64
+ int16le uint16le int32le uint32le int64le uint64le
+ int16be uint16be int32be uint32be int64be uint64be
+ float32 float64 float32le float64le float32be float64be
+
+ short unsigned-short
+ int unsigned-int
+ long unsigned-long
+ long-long unsigned-long-long
+ intptr_t uintptr_t
+ size_t ssize_t ptrdiff_t
+ float double
+
+ complex64 complex128
+ complex64le complex128le
+ complex64be complex128be
+ )
+;;; pointer.scm --- Pointer descriptor constructor.
+
+;; Copyright © 2015 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This constructor allows the creation of pointer descriptors with a specific
+;; pointed-to descriptor.
+
+
+;;; Code:
+
+(define-module (bytestructures guile pointer))
+(import
+ (srfi 9)
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base)
+ (prefix (system foreign) ffi-))
+(export
+ bs:pointer
+ pointer-metadata? pointer-metadata-content-descriptor
+ )
+
+(define pointer-size (ffi-sizeof '*))
+
+(define bytevector-address-ref
+  (case pointer-size
+    ((1) bytevector-u8-ref)
+    ((2) bytevector-u16-native-ref)
+    ((4) bytevector-u32-native-ref)
+    ((8) bytevector-u64-native-ref)))
+
+(define bytevector-address-set!
+  (case pointer-size
+    ((1) bytevector-u8-set!)
+    ((2) bytevector-u16-native-set!)
+    ((4) bytevector-u32-native-set!)
+    ((8) bytevector-u64-native-set!)))
+
+(define (pointer-ref bytevector offset index content-size)
+  (let* ((base-address (bytevector-address-ref bytevector offset))
+         (address (+ base-address (* index content-size))))
+    (if (zero? base-address)
+        (error "Tried to dereference null-pointer.")
+        (ffi-pointer->bytevector (ffi-make-pointer address) content-size))))
+
+(define (pointer-set! bytevector offset value)
+  (cond
+   ((exact-integer? value)
+    (bytevector-address-set! bytevector offset value))
+   ((bytevector? value)
+    (bytevector-address-set! bytevector offset
+                             (ffi-pointer-address
+                              (ffi-bytevector->pointer value))))
+   ((bytestructure? value)
+    (bytevector-address-set! bytevector offset
+                             (ffi-pointer-address
+                              (ffi-bytevector->pointer
+                               (bytestructure-bytevector value)))))))
+
+(define-record-type <pointer-metadata>
+  (make-pointer-metadata content-descriptor)
+  pointer-metadata?
+  (content-descriptor pointer-metadata-content-descriptor))
+
+(define (bs:pointer %descriptor)
+  (define (get-descriptor)
+    (if (promise? %descriptor)
+        (force %descriptor)
+        %descriptor))
+  (define size pointer-size)
+  (define alignment size)
+  (define (unwrapper syntax? bytevector offset index)
+    (define (syntax-list id . elements)
+      (datum->syntax id (map syntax->datum elements)))
+    (let ((descriptor (get-descriptor)))
+      (when (eq? 'void descriptor)
+        (error "Tried to follow void pointer."))
+      (let* ((size (bytestructure-descriptor-size descriptor))
+             (index-datum (if syntax? (syntax->datum index) index))
+             (index (if (eq? '* index-datum) 0 index-datum))
+             (bytevector*
+              (if syntax?
+                  #`(pointer-ref #,bytevector #,offset #,index #,size)
+                  (pointer-ref bytevector offset index size))))
+        (values bytevector* 0 descriptor))))
+  (define (getter syntax? bytevector offset)
+    (if syntax?
+        #`(bytevector-address-ref #,bytevector #,offset)
+        (bytevector-address-ref bytevector offset)))
+  (define (setter syntax? bytevector offset value)
+    (if syntax?
+        #`(pointer-set! #,bytevector #,offset #,value)
+        (pointer-set! bytevector offset value)))
+  (define meta (make-pointer-metadata %descriptor))
+  (make-bytestructure-descriptor size alignment unwrapper getter setter meta))
+
+;;; pointer.scm ends here
+(define-module (bytestructures guile string))
+(import
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base))
+(include-from-path "bytestructures/body/string.scm")
+(include-from-path "bytestructures/r7/string.exports.sld")
+(define-module (bytestructures guile struct))
+(import
+ (srfi 1)
+ (srfi 9)
+ (srfi 11)
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base)
+ (bytestructures guile bitfields))
+(include-from-path "bytestructures/body/align.scm")
+(include-from-path "bytestructures/body/struct.scm")
+(include-from-path "bytestructures/r7/struct.exports.sld")
+(define-module (bytestructures guile union))
+(import
+ (srfi 9)
+ (srfi 11)
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base))
+(include-from-path "bytestructures/body/align.scm")
+(include-from-path "bytestructures/body/union.scm")
+(include-from-path "bytestructures/r7/union.exports.sld")
+(define-module (bytestructures guile utils))
+(include-from-path "bytestructures/body/utils.scm")
+(export
+ if-syntax-case
+ define-syntax-case-stubs
+ )
+(define-module (bytestructures guile vector))
+(import
+ (srfi 9)
+ (bytestructures guile bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile base))
+(include-from-path "bytestructures/body/vector.scm")
+(include-from-path "bytestructures/r7/vector.exports.sld")
+;;; Compatibility shim for R6RS systems, because R6RS and R7RS have different
+;;; semantics for some procedures of the same name.  We use R7RS semantics
+;;; everywhere, so implement them in terms of R6RS.
+(library (bytestructures r6 bytevectors)
+  (export
+   endianness native-endianness bytevector?
+   make-bytevector bytevector-length bytevector=? bytevector-fill!
+   (rename (r7rs-bytevector-copy! bytevector-copy!))
+   (rename (r7rs-bytevector-copy bytevector-copy))
+
+   bytevector-u8-ref bytevector-s8-ref
+   bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+   u8-list->bytevector
+   bytevector-uint-ref bytevector-uint-set!
+   bytevector-sint-ref bytevector-sint-set!
+   bytevector->sint-list bytevector->uint-list
+   uint-list->bytevector sint-list->bytevector
+
+   bytevector-u16-ref bytevector-s16-ref
+   bytevector-u16-set! bytevector-s16-set!
+   bytevector-u16-native-ref bytevector-s16-native-ref
+   bytevector-u16-native-set! bytevector-s16-native-set!
+
+   bytevector-u32-ref bytevector-s32-ref
+   bytevector-u32-set! bytevector-s32-set!
+   bytevector-u32-native-ref bytevector-s32-native-ref
+   bytevector-u32-native-set! bytevector-s32-native-set!
+
+   bytevector-u64-ref bytevector-s64-ref
+   bytevector-u64-set! bytevector-s64-set!
+   bytevector-u64-native-ref bytevector-s64-native-ref
+   bytevector-u64-native-set! bytevector-s64-native-set!
+
+   bytevector-ieee-single-ref
+   bytevector-ieee-single-set!
+   bytevector-ieee-single-native-ref
+   bytevector-ieee-single-native-set!
+
+   bytevector-ieee-double-ref
+   bytevector-ieee-double-set!
+   bytevector-ieee-double-native-ref
+   bytevector-ieee-double-native-set!
+
+   (rename (r7rs-string->utf8 string->utf8))
+   (rename (r7rs-utf8->string utf8->string))
+   string->utf16 string->utf32
+   utf16->string utf32->string
+   )
+  (import
+   (rnrs base)
+   (rnrs control)
+   (rnrs bytevectors))
+  (define r7rs-bytevector-copy!
+    (case-lambda
+      ((to at from)
+       (bytevector-copy! from 0 to at (bytevector-length from)))
+      ((to at from start)
+       (bytevector-copy! from start to at (- (bytevector-length from) start)))
+      ((to at from start end)
+       (bytevector-copy! from start to at (- end start)))))
+  (define r7rs-bytevector-copy
+    (case-lambda
+      ((bytevector)
+       (bytevector-copy bytevector))
+      ((bytevector start)
+       (r7rs-bytevector-copy bytevector start (bytevector-length bytevector)))
+      ((bytevector start end)
+       (let* ((size (- end start))
+              (bytevector* (make-bytevector size)))
+         (bytevector-copy! bytevector start bytevector* 0 size)
+         bytevector*))))
+  (define r7rs-string->utf8
+    (case-lambda
+      ((string)
+       (string->utf8 string))
+      ((string start)
+       (string->utf8 (substring string start (string-length string))))
+      ((string start end)
+       (string->utf8 (substring string start end)))))
+  (define r7rs-utf8->string
+    (case-lambda
+      ((bytevector)
+       (utf8->string bytevector))
+      ((bytevector start)
+       (utf8->string (r7rs-bytevector-copy bytevector start)))
+      ((bytevector start end)
+       (utf8->string (r7rs-bytevector-copy bytevector start end))))))
+(export
+ make-bytestructure-descriptor
+ bytestructure-descriptor?
+ bytestructure-descriptor-size
+ bytestructure-descriptor-size/syntax
+ bytestructure-descriptor-alignment
+ bytestructure-descriptor-unwrapper
+ bytestructure-descriptor-getter
+ bytestructure-descriptor-setter
+ bytestructure-descriptor-metadata
+ make-bytestructure
+ bytestructure?
+ bytestructure-bytevector
+ bytestructure-offset
+ bytestructure-descriptor
+ bytestructure-size
+ bytestructure
+ bytestructure-unwrap
+ bytestructure-unwrap*
+ bytestructure-ref
+ bytestructure-ref*
+ bytestructure-set!
+ bytestructure-set!*
+ bytestructure-ref/dynamic
+ bytestructure-set!/dynamic
+ bytestructure-unwrap/syntax
+ bytestructure-ref/syntax
+ bytestructure-set!/syntax
+ define-bytestructure-accessors
+ )
+(define-library (bytestructures r7 base)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (bytestructures r7 utils))
+  (cond-expand
+   ((library (rnrs syntax-case))
+    (import (rnrs syntax-case)))
+   (else))
+  (include-library-declarations "base.exports.sld")
+  (include "body/base.scm"))
+(export
+ bitfield-descriptor
+ bitfield-metadata?
+ bitfield-metadata-int-descriptor
+ bitfield-metadata-width
+ )
+(define-library (bytestructures r7 bitfields)
+  (import
+   (scheme base)
+   (srfi 60)
+   (bytestructures r7 utils)
+   (bytestructures r7 base)
+   (bytestructures r7 numeric-metadata))
+  (include-library-declarations "bitfields.exports.sld")
+  (include "body/bitfields.scm"))
+(define-library (bytestructures r7 bytevectors)
+  (cond-expand
+   ((library (rnrs bytevectors))
+    (import (except (rnrs bytevectors)
+                    bytevector?
+                    make-bytevector
+                    bytevector-length
+                    bytevector-u8-ref
+                    bytevector-u8-set!
+                    bytevector-copy
+                    bytevector-copy!
+                    string->utf8
+                    utf8->string)))
+   (else
+    (import (except (r6rs bytevectors)
+                    bytevector?
+                    make-bytevector
+                    bytevector-length
+                    bytevector-u8-ref
+                    bytevector-u8-set!
+                    bytevector-copy
+                    bytevector-copy!
+                    string->utf8
+                    utf8->string))))
+  (export
+   endianness
+   native-endianness
+
+   bytevector=?
+   bytevector-fill!
+
+   bytevector-s8-ref
+   bytevector-s8-set!
+   bytevector->u8-list u8-list->bytevector
+
+   bytevector-uint-ref bytevector-sint-ref
+   bytevector-uint-set! bytevector-sint-set!
+   bytevector->uint-list bytevector->sint-list
+   uint-list->bytevector sint-list->bytevector
+
+   bytevector-u16-ref bytevector-s16-ref
+   bytevector-u16-native-ref bytevector-s16-native-ref
+   bytevector-u16-set! bytevector-s16-set!
+   bytevector-u16-native-set! bytevector-s16-native-set!
+
+   bytevector-u32-ref bytevector-s32-ref
+   bytevector-u32-native-ref bytevector-s32-native-ref
+   bytevector-u32-set! bytevector-s32-set!
+   bytevector-u32-native-set! bytevector-s32-native-set!
+
+   bytevector-u64-ref bytevector-s64-ref
+   bytevector-u64-native-ref bytevector-s64-native-ref
+   bytevector-u64-set! bytevector-s64-set!
+   bytevector-u64-native-set! bytevector-s64-native-set!
+
+   bytevector-ieee-single-native-ref
+   bytevector-ieee-single-ref
+   bytevector-ieee-double-native-ref
+   bytevector-ieee-double-ref
+   bytevector-ieee-single-native-set!
+   bytevector-ieee-single-set!
+   bytevector-ieee-double-native-set!
+   bytevector-ieee-double-set!
+
+   string->utf16 string->utf32
+   utf16->string utf32->string
+   ))
+(export
+ bytevector-ieee-single-le-ref  bytevector-ieee-single-be-ref
+ bytevector-ieee-single-le-set! bytevector-ieee-single-be-set!
+ bytevector-ieee-double-le-ref  bytevector-ieee-double-be-ref
+ bytevector-ieee-double-le-set! bytevector-ieee-double-be-set!
+ bytevector-s16le-ref           bytevector-s16be-ref
+ bytevector-s16le-set!          bytevector-s16be-set!
+ bytevector-u16le-ref           bytevector-u16be-ref
+ bytevector-u16le-set!          bytevector-u16be-set!
+ bytevector-s32le-ref           bytevector-s32be-ref
+ bytevector-s32le-set!          bytevector-s32be-set!
+ bytevector-u32le-ref           bytevector-u32be-ref
+ bytevector-u32le-set!          bytevector-u32be-set!
+ bytevector-s64le-ref           bytevector-s64be-ref
+ bytevector-s64le-set!          bytevector-s64be-set!
+ bytevector-u64le-ref           bytevector-u64be-ref
+ bytevector-u64le-set!          bytevector-u64be-set!
+ )
+(define-library (bytestructures r7 explicit-endianness)
+  (import
+   (scheme base)
+   (bytestructures r7 utils)
+   (bytestructures r7 bytevectors))
+  (include-library-declarations "explicit-endianness.exports.sld")
+  (include "body/explicit-endianness.scm"))
+(define-library (bytestructures r7 numeric-all)
+  (import
+   (scheme base)
+   (scheme complex)
+   (scheme eval)
+   (bytestructures r7 utils)
+   (bytestructures r7 base)
+   (bytestructures r7 bytevectors)
+   (bytestructures r7 explicit-endianness))
+  (include-library-declarations "numeric.exports.sld")
+  (include-library-declarations "numeric-metadata.exports.sld")
+  (include "body/numeric.scm"))
+(export
+ signed-integer-native-descriptors
+ signed-integer-le-descriptors
+ signed-integer-be-descriptors
+ signed-integer-descriptors
+ unsigned-integer-native-descriptors
+ unsigned-integer-le-descriptors
+ unsigned-integer-be-descriptors
+ unsigned-integer-descriptors
+ float-native-descriptors
+ float-le-descriptors
+ float-be-descriptors
+ complex-native-descriptors
+ complex-le-descriptors
+ complex-be-descriptors
+ integer-descriptors
+ float-descriptors
+ complex-descriptors
+ numeric-descriptors
+ )
+(define-library (bytestructures r7 numeric-metadata)
+  (import (bytestructures r7 numeric-all))
+  (include-library-declarations "numeric-metadata.exports.sld"))
+(export
+ int8 int16 int32 int64
+ uint8 uint16 uint32 uint64
+ int16le int32le int64le
+ uint16le uint32le uint64le
+ int16be int32be int64be
+ uint16be uint32be uint64be
+ float32 float64
+ float32le float64le
+ float32be float64be
+
+ short unsigned-short
+ int unsigned-int
+ long unsigned-long
+ long-long unsigned-long-long
+ intptr_t uintptr_t
+ size_t ssize_t ptrdiff_t
+ float double
+
+ complex64 complex128
+ complex64le complex128le
+ complex64be complex128be
+ )
+(define-library (bytestructures r7 numeric)
+  (import (bytestructures r7 numeric-all))
+  (include-library-declarations "numeric.exports.sld"))
+(export bs:string)
+(cond-expand
+ (r6rs
+  (export bytevector->string string->bytevector
+          ascii utf8 utf16le utf16be utf32le utf32be
+          bytevector-zero!))
+ (else))
+(define-library (bytestructures r7 string)
+  (import
+   (scheme base)
+   (bytestructures r7 bytevectors)
+   (bytestructures r7 utils)
+   (bytestructures r7 base))
+  (cond-expand
+   ((library (rnrs syntax-case))
+    (import (rnrs syntax-case)))
+   (else))
+  (include-library-declarations "string.exports.sld")
+  (include "body/string.scm"))
+(export
+ bs:struct
+ struct-metadata?
+ struct-metadata-field-alist
+ )
+(define-library (bytestructures r7 struct)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (srfi 1)
+   (srfi 28)
+   (bytestructures r7 utils)
+   (bytestructures r7 base)
+   (bytestructures r7 bitfields))
+  (include-library-declarations "struct.exports.sld")
+  (include "body/align.scm")
+  (include "body/struct.scm"))
+(export
+ bs:union
+ union-metadata?
+ union-metadata-field-alist
+ )
+(define-library (bytestructures r7 union)
+  (import
+   (scheme base)
+   (bytestructures r7 utils)
+   (bytestructures r7 base))
+  (include-library-declarations "union.exports.sld")
+  (include "body/align.scm")
+  (include "body/union.scm"))
+(define-library (bytestructures r7 utils)
+  (import (scheme base))
+  (cond-expand
+   ((library (rnrs syntax-case))
+    (import (rnrs syntax-case)))
+   (else))
+  (export
+   define-syntax-rule
+   if-syntax-case
+   define-syntax-case-stubs
+   quasisyntax
+   unsyntax
+   unsyntax-splicing
+   syntax->datum
+   datum->syntax
+   )
+  (include "body/utils.scm"))
+(export
+ bs:vector
+ vector-metadata?
+ vector-metadata-length
+ vector-metadata-element-descriptor
+ )
+(define-library (bytestructures r7 vector)
+  (import
+   (scheme base)
+   (bytestructures r7 utils)
+   (bytestructures r7 base))
+  (include-library-declarations "vector.exports.sld")
+  (include "body/vector.scm"))
+(define-module (bytestructures guile))
+
+;;; Note: cstring-pointer import/export hack: Guile 2.0.x has a problem when a
+;;; module has the same name as an identifier defined in it, and the identifier
+;;; is imported and re-exported.  To work around it, we import `cstring-pointer'
+;;; with a rename to `_cstring-pointer', define `cstring-pointer' explicitly in
+;;; this module, and export that.
+
+(import
+ (bytestructures guile base)
+ (bytestructures guile vector)
+ (bytestructures guile struct)
+ (bytestructures guile union)
+ (bytestructures guile pointer)
+ (bytestructures guile numeric)
+ (bytestructures guile string)
+ (rename (bytestructures guile cstring-pointer)
+         (cstring-pointer _cstring-pointer)))
+(re-export
+ make-bytestructure-descriptor
+ bytestructure-descriptor?
+ bytestructure-descriptor-size
+ bytestructure-descriptor-size/syntax
+ bytestructure-descriptor-alignment
+ bytestructure-descriptor-unwrapper
+ bytestructure-descriptor-getter
+ bytestructure-descriptor-setter
+ bytestructure-descriptor-metadata
+ make-bytestructure
+ bytestructure?
+ bytestructure-bytevector
+ bytestructure-offset
+ bytestructure-descriptor
+ bytestructure-size
+ bytestructure
+ bytestructure-unwrap
+ bytestructure-unwrap*
+ bytestructure-ref
+ bytestructure-ref*
+ bytestructure-set!
+ bytestructure-set!*
+ bytestructure-ref/dynamic
+ bytestructure-set!/dynamic
+ bytestructure-unwrap/syntax
+ bytestructure-ref/syntax
+ bytestructure-set!/syntax
+ define-bytestructure-accessors
+
+ bs:vector
+ vector-metadata? vector-metadata-length vector-metadata-element-descriptor
+
+ bs:struct
+ struct-metadata? struct-metadata-field-alist
+
+ bs:union
+ union-metadata? union-metadata-field-alist
+
+ bs:pointer
+ pointer-metadata? pointer-metadata-content-descriptor
+
+ int8 int16 int32 int64
+ int16le int32le int64le
+ int16be int32be int64be
+ uint8 uint16 uint32 uint64
+ uint16le uint32le uint64le
+ uint16be uint32be uint64be
+ float32 float64
+ float32le float64le
+ float32be float64be
+
+ short unsigned-short
+ int unsigned-int
+ long unsigned-long
+ long-long unsigned-long-long
+ intptr_t uintptr_t
+ size_t ssize_t ptrdiff_t
+ float double
+
+ complex64 complex128
+ complex64le complex128le
+ complex64be complex128be
+
+ bs:string
+ )
+
+(define cstring-pointer _cstring-pointer)
+
+(export cstring-pointer)
+(define-library (bytestructures r7)
+  (import
+   (bytestructures r7 base)
+   (bytestructures r7 vector)
+   (bytestructures r7 struct)
+   (bytestructures r7 union)
+   (bytestructures r7 numeric)
+   (bytestructures r7 string))
+  (include-library-declarations "r7/base.exports.sld")
+  (include-library-declarations "r7/vector.exports.sld")
+  (include-library-declarations "r7/struct.exports.sld")
+  (include-library-declarations "r7/union.exports.sld")
+  (include-library-declarations "r7/numeric.exports.sld")
+  (include-library-declarations "r7/string.exports.sld"))
+;;; Warning: nasal demons.
+;;;
+;;; Will output differences between GCC's behavior and our behavior, but not in
+;;; a very nice format.  Zero output is good.  The C code and Scheme procedure
+;;; we generate are fairly straightforward so read the code to understand.
+
+(define-module (bytestructures bitfield-tests))
+
+(export run-bitfield-tests)
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-9)
+             (ice-9 rdelim)
+             (bytestructures r6 bytevectors)
+             (bytestructures guile))
+
+(define-record-type <struct>
+  (make-struct name fields)
+  struct?
+  (name   struct-name)
+  (fields struct-fields))
+
+(define-record-type <field>
+  (make-field name int-size bit-size signed? value)
+  struct?
+  (name     field-name)
+  (int-size field-int-size)
+  (bit-size field-bit-size)
+  (signed?  field-signed?)
+  (value    field-value))
+
+(define *keep-files* (make-parameter #f))
+
+(define (run-bitfield-tests count random-seed-string keep-files)
+  (set! *random-state* (seed->random-state random-seed-string))
+  (parameterize ((*keep-files* keep-files))
+    (test-structs (generate-structs count))))
+
+(define (generate-structs n)
+  (remove-bad-structs (map random-struct (iota n))))
+
+(define (remove-bad-structs structs)
+  (filter (lambda (struct)
+            (find (lambda (field)
+                    (not (zero? (field-bit-size field))))
+                  (struct-fields struct)))
+          structs))
+
+(define (random-struct i)
+  (let ((field-count (+ 1 (random 50))))
+    (make-struct (format #f "s~a" i)
+                 (map random-field (iota field-count)))))
+
+(define (random-field i)
+  (let* ((name (format #f "f~a" i))
+         (int-size (* 8 (expt 2 (random 4))))
+         (bit-size (random (+ 1 int-size)))
+         (signed? (= 0 (random 2)))
+         (value (random (expt 2 bit-size)))
+         (value (if (and signed? (> value (+ -1 (expt 2 (- bit-size 1)))))
+                    (- value (expt 2 bit-size))
+                    value)))
+    (make-field name int-size bit-size signed? value)))
+
+(define (test-structs structs)
+  (let* ((c-code (c-code-for-structs structs))
+         (c-output (get-c-output c-code))
+         (scm-code (scm-code-for-structs structs))
+         (scm-output (get-scm-output scm-code)))
+    (diff-outputs c-output scm-output)))
+
+(define (c-code-for-structs structs)
+  (string-concatenate
+   (append
+    (list "#include <stdio.h>\n"
+          "#include <stdint.h>\n"
+          "#include <strings.h>\n"
+          "int main(){\n")
+    (map c-code-for-struct structs)
+    (list "return 0;}"))))
+
+(define (c-code-for-struct struct)
+  (let ((name (struct-name struct))
+        (fields (struct-fields struct)))
+    (string-concatenate
+     (append
+      (list (format #f "struct ~a {\n" name))
+      (map c-decl-for-field fields)
+      (list "};\n"
+            (format #f "{ struct ~a foo;\n" name)
+            (format #f "  bzero((void*)&foo, sizeof(foo));\n"))
+      (map c-assignment-for-field fields)
+      (list (format #f "  printf(\"struct ~a:\\n\");\n" name)
+            "  uint8_t *ptr = (void*)&foo;\n"
+            "  for (int i = 0; i < sizeof(foo); ++i) {\n"
+            "    printf(\"%d \", *(ptr+i));\n"
+            "  }\n"
+            "  printf(\"\\n\");\n"
+            "}\n")))))
+
+(define (c-decl-for-field field)
+  (let ((name (field-name field))
+        (int-size (field-int-size field))
+        (bit-size (field-bit-size field))
+        (signed? (field-signed? field)))
+    (format #f "  ~aint~a_t ~a:~a;\n"
+            (if signed? "" "u")
+            int-size
+            (if (zero? bit-size) "" name)
+            bit-size)))
+
+(define (c-assignment-for-field field)
+  (let ((name (field-name field))
+        (bit-size (field-bit-size field))
+        (signed? (field-signed? field))
+        (value (field-value field)))
+    (if (zero? bit-size)
+        ""
+        (format #f "  foo.~a = ~a~a;\n" name value (if signed? "" "u")))))
+
+(define (get-c-output code)
+  (let* ((port (mkstemp! (string-copy "/tmp/bitfield-XXXXXX")))
+         (file (port-filename port))
+         (exe-port (mkstemp! (string-copy "/tmp/bitfield-compiled-XXXXXX")))
+         (exe-file (port-filename exe-port))
+         (output-port (mkstemp! (string-copy "/tmp/bitfield-output-XXXXXX")))
+         (output-file (port-filename output-port)))
+    (close-port exe-port)
+    (close-port output-port)
+    (display code port)
+    (force-output port)
+    (unless (zero? (system* "gcc" "-x" "c" "-std=c11" file "-o" exe-file))
+      (error "gcc failed"))
+    (unless (zero? (system (format #f "~a > ~a" exe-file output-file)))
+      (error "exe failed"))
+    (let ((out (read-string (open output-file O_RDONLY))))
+      (unless (*keep-files*)
+        (for-each delete-file (list file exe-file output-file)))
+      out)))
+
+(define (scm-code-for-structs structs)
+  (lambda ()
+    (string-concatenate
+     (map scm-code-for-struct structs))))
+
+(define (scm-code-for-struct struct)
+  (let* ((name (struct-name struct))
+         (fields (struct-fields struct))
+         (descriptor (struct->descriptor struct))
+         (values (map field-value (filter-nonzero-fields fields)))
+         (bs (bytestructure descriptor (list->vector values))))
+    (string-concatenate
+     (append
+      (list (format #f "struct ~a:\n" name))
+      (let ((bv (bytestructure-bytevector bs)))
+        (map (lambda (i)
+               (format #f "~a " (bytevector-u8-ref bv i)))
+             (iota (bytevector-length bv))))
+      (list "\n")))))
+
+(define (struct->descriptor struct)
+  (let ((fields (struct-fields struct)))
+    (bs:struct (map field->struct-descriptor-field fields))))
+
+(define (field->struct-descriptor-field field)
+  (let ((name (field-name field))
+        (int-size (field-int-size field))
+        (bit-size (field-bit-size field))
+        (signed? (field-signed? field)))
+    (list name
+          (module-ref (resolve-module
+                       '(bytestructures bitfield-tests))
+                      (string->symbol
+                       (format #f "~aint~a"
+                               (if signed? "" "u")
+                               int-size)))
+          bit-size)))
+
+(define (filter-nonzero-fields fields)
+  (filter (lambda (field)
+            (not (zero? (field-bit-size field))))
+          fields))
+
+(define (get-scm-output code)
+  (code))
+
+(define (diff-outputs o1 o2)
+  (let* ((p1 (mkstemp! (string-copy "/tmp/bitfield-out1-XXXXXX")))
+         (f1 (port-filename p1))
+         (p2 (mkstemp! (string-copy "/tmp/bitfield-out2-XXXXXX")))
+         (f2 (port-filename p2)))
+    (display o1 p1)
+    (display o2 p2)
+    (flush-all-ports)
+    (close-port p1)
+    (close-port p2)
+    (let ((retval (system* "diff" "-y" "--suppress-common" f1 f2)))
+      (unless (*keep-files*)
+        (for-each delete-file (list f1 f2)))
+      retval)))
+;;; Use this in the REPL.  It produces wrong results when ran as a script.
+
+(use-modules (system vm coverage)
+             (system vm vm)
+             (srfi srfi-11))
+
+(let ((output-directory
+       (string-append
+        (getenv "HOME") "/srv/http/htdocs/lcov/scheme-bytestructures")))
+  (let-values (((data . values)
+                (with-code-coverage (the-vm)
+                  (lambda ()
+                    (load "run-tests.guile.scm")))))
+    (let* ((port (mkstemp! (string-copy "/tmp/bytestructures-coverage-XXXXXX")))
+           (file (port-filename port)))
+      (coverage-data->lcov data port)
+      (close port)
+      (when (not (zero? (system* "genhtml" file "-o" output-directory)))
+        (error  "genhtml failed"))
+      (delete-file file))))
+;;; run-tests.body.scm --- Bytestructures test suite.
+
+;; Copyright © 2015, 2021 Taylan Kammer <taylan.kammer@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A relatively simple SRFI-64 test suite.
+
+
+;;; Code:
+
+(define-syntax-rule (test-= name expected expr)
+  (test-approximate name expected expr 0))
+
+(define-syntax-rule (maybe-skip-syntax . <body>)
+  (if-syntax-case
+   (begin . <body>)
+   (begin)))
+
+(test-begin "bytestructures")
+
+(test-group "numeric"
+  (define-syntax test-numeric-descriptors
+    (syntax-rules ()
+      ((_ <descriptor-id> ...)
+       (let ()
+         (define (destructure-numeric-descriptor-entry descriptor-entry proc)
+           (define descriptor (list-ref descriptor-entry 0))
+           (define name (list-ref descriptor-entry 1))
+           (define getter (list-ref descriptor-entry 2))
+           (define setter (list-ref descriptor-entry 3))
+           (define size (bytestructure-descriptor-size descriptor))
+           (define float? (assq descriptor float-descriptors))
+           (define signed? (or float? (assq descriptor signed-integer-descriptors)))
+           (proc descriptor name getter setter size float? signed?))
+         (define (get-min/max float? signed? size)
+           (cond
+            (float?  (inexact (expt 2 (case size ((4) 24) ((8) 53)))))
+            (signed? (- (expt 256 (- size 1))))
+            (else    (- (expt 256 size) 1))))
+         (destructure-numeric-descriptor-entry
+          (assq <descriptor-id> numeric-descriptors)
+          (lambda (descriptor name getter setter size float? signed?)
+            (test-group (symbol->string name)
+              (let ((test-value-1 (if float? 1.0 1))
+                    (test-value-2 (if float? 2.0 1)))
+                (test-group "procedural"
+                  (define min/max (get-min/max float? signed? size))
+                  (define bs (bytestructure descriptor))
+                  (test-eqv "size" size (bytevector-length
+                                         (bytestructure-bytevector bs)))
+                  (test-= "ref" test-value-1
+                    (begin
+                      (setter (bytestructure-bytevector bs) 0 test-value-1)
+                      (bytestructure-ref bs)))
+                  (test-= "set" test-value-2
+                    (begin
+                      (bytestructure-set! bs test-value-2)
+                      (getter (bytestructure-bytevector bs) 0)))
+                  (test-= "min/max" min/max
+                    (begin
+                      (bytestructure-set! bs min/max)
+                      (bytestructure-ref bs))))
+                (maybe-skip-syntax
+                 (test-group "syntactic"
+                   (define min/max (get-min/max float? signed? size))
+                   ;; Must insert the top-level reference <descriptor-id> here.
+                   (define-bytestructure-accessors <descriptor-id>
+                     bs-unwrapper bs-getter bs-setter)
+                   (define bv (make-bytevector size))
+                   (test-= "ref" test-value-1
+                     (begin
+                       (setter bv 0 test-value-1)
+                       (bs-getter bv)))
+                   (test-= "set" test-value-2
+                     (begin
+                       (bs-setter bv test-value-2)
+                       (getter bv 0)))
+                   (test-= "min/max" min/max
+                     (begin
+                       (bs-setter bv min/max)
+                       (bs-getter bv)))))))))
+         ...))))
+  (test-numeric-descriptors
+   float32 float32le float32be
+   float64 float64le float64be
+   int8 int16 int32 int64
+   int16le int32le int64le
+   int16be int32be int64be
+   uint8 uint16 uint32 uint64
+   uint16le uint32le uint64le
+   uint16be uint32be uint64be))
+
+(test-group "vector"
+  (test-assert "create" (bs:vector 3 uint16))
+  (test-group "procedural"
+    (define bs (bytestructure (bs:vector 3 uint16)))
+    (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321)
+    (test-eqv "ref" 321 (bytestructure-ref bs 1))
+    (test-eqv "set" 456 (begin (bytestructure-set! bs 1 456)
+                               (bytestructure-ref bs 1)))
+    (test-eqv "init" 321
+      (let ((bs (bytestructure (bs:vector 3 uint16) '#(321 123 321))))
+        (bytestructure-ref bs 2))))
+  (maybe-skip-syntax
+   (test-group "syntactic"
+     (define-bytestructure-accessors (bs:vector 3 uint16)
+       unwrapper getter setter)
+     (define bv (make-bytevector 6))
+     (bytevector-u16-native-set! bv 2 321)
+     (test-eqv "ref" 321 (getter bv 1))
+     (test-eqv "set" 456 (begin (setter bv 1 456)
+                                (getter bv 1))))))
+
+(test-group "struct"
+  (test-group "aligned"
+    (test-assert "create" (bs:struct `((x ,uint8) (y ,uint16))))
+    (test-group "procedural"
+      (define bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16)))))
+      (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321)
+      (test-eqv "ref" 321 (bytestructure-ref bs 'y))
+      (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456)
+                                 (bytestructure-ref bs 'y)))
+      (test-eqv "init" 321
+        (let ((bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16)))
+                                 '#(123 321))))
+          (bytestructure-ref bs 'y))))
+    (maybe-skip-syntax
+     (test-group "syntactic"
+       (define-bytestructure-accessors (bs:struct `((x ,uint8) (y ,uint16)))
+         unwrapper getter setter)
+       (define bv (make-bytevector 4))
+       (bytevector-u16-native-set! bv 2 321)
+       (test-eqv "ref" 321 (getter bv y))
+       (test-eqv "set" 456 (begin (setter bv y 456)
+                                  (getter bv y))))))
+  (test-group "packed"
+    (test-assert "create" (bs:struct #t `((x ,uint8) (y ,uint16))))
+    (test-group "procedural"
+      (define bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16)))))
+      ;; u16-native-set! may error on non-aligned access.
+      (guard (err (else (test-skip 3)))
+        (bytevector-u16-native-set! (bytestructure-bytevector bs) 1 321))
+      (test-eqv "ref" 321 (bytestructure-ref bs 'y))
+      (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456)
+                                 (bytestructure-ref bs 'y)))
+      (test-eqv "init" 321
+        (let ((bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16)))
+                                 '#(123 321))))
+          (bytestructure-ref bs 'y))))
+    (maybe-skip-syntax
+     (test-group "syntactic"
+       (define-bytestructure-accessors (bs:struct #t `((x ,uint8) (y ,uint16)))
+         unwrapper getter setter)
+       (define bv (make-bytevector 4))
+       ;; u16-native-set! may error on non-aligned access.
+       (guard (err (else (test-skip 2)))
+         (bytevector-u16-native-set! bv 1 321))
+       (test-eqv "ref" 321 (getter bv y))
+       (test-eqv "set" 456 (begin (setter bv y 456)
+                                  (getter bv y))))))
+
+  (test-group "anonymous-union"
+    (test-assert "create"
+      (bs:struct
+       `((x ,uint8)
+         (union
+          ((a ,uint16)
+           (b ,uint32))))))
+    ;; Don't use 64-bit ints; their alignment differs between platforms.
+    (test-group "aligned"
+      (define bs
+        (bytestructure
+         (bs:struct
+          `((union
+             ((x ,uint8)
+              (y ,uint16)))
+            (union
+             ((a ,uint16)
+              (b ,uint32)))))))
+      (test-eqv "size" 8 (bytevector-length (bytestructure-bytevector bs)))
+      (bytevector-u16-native-set! (bytestructure-bytevector bs) 4 321)
+      (test-eqv "ref1" 321 (bytestructure-ref bs 'a))
+      (bytevector-u32-native-set! (bytestructure-bytevector bs) 4 456)
+      (test-eqv "ref2" 456 (bytestructure-ref bs 'b))
+      (test-eqv "set1" 789 (begin (bytestructure-set! bs 'a 789)
+                                  (bytestructure-ref bs 'a)))
+      (test-eqv "set2" 987 (begin (bytestructure-set! bs 'b 987)
+                                  (bytestructure-ref bs 'b))))
+    (test-group "packed"
+      (define bs
+        (bytestructure
+         (bs:struct
+          #t
+          `((union
+             ((x ,uint8)
+              (y ,uint16)))
+            (union
+             ((a ,uint16)
+              (b ,uint32)))))))
+      (test-eqv "size" 6 (bytevector-length (bytestructure-bytevector bs)))
+      (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321)
+      (test-eqv "ref1" 321 (bytestructure-ref bs 'a))
+      (bytevector-u32-native-set! (bytestructure-bytevector bs) 2 456)
+      (test-eqv "ref2" 456 (bytestructure-ref bs 'b))
+      (test-eqv "set1" 789 (begin (bytestructure-set! bs 'a 789)
+                                  (bytestructure-ref bs 'a)))
+      (test-eqv "set2" 987 (begin (bytestructure-set! bs 'b 987)
+                                  (bytestructure-ref bs 'b))))))
+
+(test-group "union"
+  (test-assert "create" (bs:union `((x ,uint8) (y ,uint16))))
+  (test-group "procedural"
+    (define bs (bytestructure (bs:union `((x ,uint8) (y ,uint16)))))
+    (bytevector-u16-native-set! (bytestructure-bytevector bs) 0 321)
+    (test-eqv "ref" 321 (bytestructure-ref bs 'y))
+    (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456)
+                               (bytestructure-ref bs 'y))))
+  (maybe-skip-syntax
+   (test-group "syntactic"
+     (define-bytestructure-accessors (bs:union `((x ,uint8) (y ,uint16)))
+       unwrapper getter setter)
+     (define bv (make-bytevector 2))
+     (bytevector-u16-native-set! bv 0 321)
+     (test-eqv "ref" 321 (getter bv y))
+     (test-eqv "set" 456 (begin (setter bv y 456)
+                                (getter bv y))))))
+
+(test-group "string"
+  (test-group "ascii"
+    (test-assert "create" (bs:string 4 'ascii))
+    (test-group "procedural"
+      (define bsd (bs:string 4 'ascii))
+      (define bs (make-bytestructure (string->utf8 "1234") 0 bsd))
+      (test-equal "ref" "1234" (bytestructure-ref bs))
+      (test-equal "set" "4321" (begin
+                                 (bytestructure-set! bs "4321")
+                                 (bytestructure-ref bs)))
+      (test-error "too-long" #t (bytestructure-set! bs "12345"))
+      (test-error "too-short" #t (bytestructure-set! bs "123"))
+      (set! bs (make-bytestructure (string->utf8 "äåãø") 0 bsd))
+      (test-error "decoding-error" #t (bytestructure-ref bs))
+      (test-error "encoding-error" #t (bytestructure-set! bs "øãåä")))
+    (test-group "syntactic"
+      (define-bytestructure-accessors (bs:string 4 'ascii)
+        unwrapper getter setter)
+      (define bv (string->utf8 "1234"))
+      (test-equal "ref" "1234" (getter bv))
+      (test-equal "set" "4321" (begin
+                                 (setter bv "4321")
+                                 (getter bv)))
+      (test-error "too-long" #t (setter bv "12345"))
+      (test-error "too-short" #t (setter bv "123"))
+      (set! bv (string->utf8 "äåãø"))
+      (test-error "ref-error" #t (getter bv))
+      (test-error "set-error" #t (setter bv "øãåä"))))
+  (test-group "utf8"
+    (test-assert "create" (bs:string 4 'utf8))
+    (test-group "procedural"
+      (define bsd (bs:string 4 'utf8))
+      (define bs (make-bytestructure (string->utf8 "1234") 0 bsd))
+      (test-equal "ref" "1234" (bytestructure-ref bs))
+      (test-equal "set" "4321" (begin
+                                 (bytestructure-set! bs "4321")
+                                 (bytestructure-ref bs)))
+      (test-error "too-long" #t (bytestructure-set! bs "äåãø"))
+      (test-equal (string-append "123" (string #\nul))
+                  (begin
+                    (bytestructure-set! bs "123")
+                    (bytestructure-ref bs))))
+    (test-group "syntactic"
+      (define-bytestructure-accessors (bs:string 4 'utf8)
+        unwrapper getter setter)
+      (define bv (string->utf8 "1234"))
+      (test-equal "ref" "1234" (getter bv))
+      (test-equal "set" "4321" (begin
+                                 (setter bv "4321")
+                                 (getter bv)))
+      (test-error "too-long" #t (setter bv "äåãø"))
+      (test-equal (string-append "123" (string #\nul))
+                  (begin
+                    (setter bv "123")
+                    (getter bv)))))
+  (let ()
+    (define-syntax-rule
+      (test-string-encodings
+       (<name> <encoding> <endianness> <size> <fixed-width?> <string->utf>)
+       ...)
+      (begin
+        (test-group <name>
+          (test-assert "create" (bs:string <size> '<encoding>))
+          (test-group "procedural"
+            (define bs (make-bytestructure (<string->utf> "1234" '<endianness>)
+                                           0
+                                           (bs:string <size> '<encoding>)))
+            (test-equal "ref" "1234" (bytestructure-ref bs))
+            (test-equal "set" "4321" (begin
+                                       (bytestructure-set! bs "4321")
+                                       (bytestructure-ref bs)))
+            (test-error "too-long" #t (bytestructure-set! bs "12345"))
+            (if <fixed-width?>
+                (test-error "too-short" #t (bytestructure-set! bs "123"))
+                (test-equal (string-append "123" (string #\nul))
+                            (begin
+                              (bytestructure-set! bs "123")
+                              (bytestructure-ref bs)))))
+          (test-group "syntactic"
+            (define-bytestructure-accessors (bs:string <size> '<encoding>)
+              unwrapper getter setter)
+            (define bv (<string->utf> "1234" '<endianness>))
+            (test-equal "ref" "1234" (getter bv))
+            (test-equal "set" "4321" (begin
+                                       (setter bv "4321")
+                                       (getter bv)))
+            (test-error "too-long" #t (setter bv "12345"))
+            (if <fixed-width?>
+                (test-error "too-short" #t (setter bv "123"))
+                (test-equal (string-append "123" (string #\nul))
+                            (begin
+                              (setter bv "123")
+                              (getter bv))))))
+        ...))
+    (test-string-encodings
+     ("utf16le" utf16le little 8 #f string->utf16)
+     ("utf16be" utf16be big 8 #f string->utf16)
+     ("utf32le" utf32le little 16 #t string->utf32)
+     ("utf32be" utf32be big 16 #t string->utf32))))
+
+(cond-expand
+ (guile
+  (let ()
+
+    (define (protect-from-gc-upto-here obj)
+      (with-output-to-file *null-device*
+        (lambda ()
+          (display (eq? #f obj)))))
+
+    (define pointer-size (ffi-sizeof '*))
+    (define bytevector-address-set!
+      (case pointer-size
+        ((1) bytevector-u8-set!)
+        ((2) bytevector-u16-native-set!)
+        ((4) bytevector-u32-native-set!)
+        ((8) bytevector-u64-native-set!)))
+
+    (test-group "pointer"
+      (test-assert "create" (bs:pointer uint16))
+      (test-group "procedural"
+        (define bs (bytestructure (bs:pointer uint16)))
+        (define bv1 (make-bytevector 2))
+        (define bv2 (make-bytevector 4))
+        (define address1 (ffi-pointer-address (ffi-bytevector->pointer bv1)))
+        (define address2 (ffi-pointer-address (ffi-bytevector->pointer bv2)))
+        (bytevector-address-set! (bytestructure-bytevector bs) 0 address1)
+        (bytevector-u16-native-set! bv1 0 321)
+        (test-eqv "ref1" 321 (bytestructure-ref bs '*))
+        (test-eqv "set1" 456 (begin (bytestructure-set! bs '* 456)
+                                    (bytestructure-ref bs '*)))
+        (test-eqv "ref2" address1 (bytestructure-ref bs))
+        (test-eqv "set2" address2 (begin (bytestructure-set! bs address2)
+                                         (bytestructure-ref bs)))
+        (bytevector-address-set! (bytestructure-bytevector bs) 0 address2)
+        (bytevector-u16-native-set! bv2 2 456)
+        (test-eqv "ref3" 456 (bytestructure-ref bs 1))
+        (test-eqv "set3" 789 (begin (bytestructure-set! bs 1 789)
+                                    (bytestructure-ref bs 1)))
+        (protect-from-gc-upto-here bv1)
+        (protect-from-gc-upto-here bv2))
+      (test-group "syntactic"
+        (define-bytestructure-accessors (bs:pointer uint16)
+          unwrapper getter setter)
+        (define bv (make-bytevector pointer-size))
+        (define bv1 (make-bytevector 2))
+        (define bv2 (make-bytevector 4))
+        (define address1 (ffi-pointer-address (ffi-bytevector->pointer bv1)))
+        (define address2 (ffi-pointer-address (ffi-bytevector->pointer bv2)))
+        (bytevector-address-set! bv 0 address1)
+        (bytevector-u16-native-set! bv1 0 321)
+        (test-eqv "ref" 321 (getter bv *))
+        (test-eqv "set" 456 (begin (setter bv * 456)
+                                   (getter bv *)))
+        (test-eqv "ref2" address1 (getter bv))
+        (test-eqv "set2" address1 (begin (setter bv address1)
+                                         (getter bv)))
+        (bytevector-address-set! bv 0 address2)
+        (bytevector-u16-native-set! bv2 2 456)
+        (test-eqv "ref3" 456 (getter bv 1))
+        (test-eqv "set3" 789 (begin (setter bv 1 789)
+                                    (getter bv 1)))
+        (protect-from-gc-upto-here bv1)
+        (protect-from-gc-upto-here bv2)))
+
+    (test-group "cstring-pointer"
+      (let* ((cstr1-ptr (ffi-string->pointer "abc"))
+             (cstr2-ptr (ffi-string->pointer "cba"))
+             (cstr1-addr (ffi-pointer-address cstr1-ptr))
+             (cstr2-addr (ffi-pointer-address cstr2-ptr)))
+        (test-group "procedural"
+          (define bs (bytestructure cstring-pointer))
+          (bytevector-address-set! (bytestructure-bytevector bs) 0 cstr1-addr)
+          (test-equal "ref" "abc" (bytestructure-ref bs))
+          (test-equal "set" "cba" (begin (bytestructure-set! bs cstr2-addr)
+                                         (bytestructure-ref bs))))
+        (test-group "syntactic"
+          (define-bytestructure-accessors cstring-pointer
+            unwrapper getter setter)
+          (define bv (make-bytevector pointer-size))
+          (bytevector-address-set! bv 0 cstr1-addr)
+          (test-equal "ref" "abc" (getter bv))
+          (test-equal "set" "cba" (begin (setter bv cstr2-addr)
+                                         (getter bv))))))))
+
+ (else
+  ))
+
+;; Do this before test-end since it removes the auto-inserted test runner.
+(define success
+  (let ((runner (test-runner-current)))
+    (and (zero? (test-runner-xpass-count runner))
+         (zero? (test-runner-fail-count runner)))))
+
+(test-end "bytestructures")
+
+(exit (if success 0 1))
+
+;; Local Variables:
+;; eval: (put (quote test-group) (quote scheme-indent-function) 1)
+;; eval: (put (quote test-=) (quote scheme-indent-function) 2)
+;; End:
+
+(use-modules
+ (srfi srfi-11)
+ (srfi srfi-64)
+ ((rnrs exceptions) #\select (guard))
+ ((system foreign) #\prefix ffi-)
+ (bytestructures r6 bytevectors)
+ (bytestructures guile utils)
+ (bytestructures guile)
+ (bytestructures guile numeric-metadata))
+
+(define inexact exact->inexact)
+
+(include-from-path "run-tests.body.scm")
+(import
+ (scheme base)
+ (srfi 64)
+ (bytestructures r7 utils)
+ (bytestructures r7)
+ (bytestructures r7 numeric-metadata)
+ (bytestructures r7 bytevectors)
+ (bytestructures r7 explicit-endianness))
+
+(include "run-tests.body.scm")
+;;; commonmark.scm --- An implementation of CommonMark markdown
+
+;; Copyright (C) 2014  Taylan Ulrich Bayirli/Kammer
+
+;; Author: Taylan Ulrich Bayirli/Kammer <taylanbayirli@gmail.com>
+;; Keywords: 
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
+
+(define (parse port)
+  (let* ((lines (preprocess port))
+         (blocks (parse-blocks lines)))
+    blocks))
+
+(define (preprocess port)
+  (do ((line (read-line port) (read-line port))
+       (lines '() (cons (preprocess-line line) lines)))
+      ((eof-object? line) (reverse lines))))
+
+(define (preprocess-line line)
+  (do ((chars (string->list line) (cdr chars))
+       (processed-chars '() (let ((char (car chars)))
+                              (if (char=? char #\tab)
+                                  (append (make-list 4 #\space)
+                                          processed-chars)
+                                  (cons char processed-chars)))))
+      ((null? chars) (apply string (reverse processed-chars)))))
+
+(define (parse-blocks lines)
+  (do ((lines lines (cdr lines))
+       (blocks '() (let ((blocks* (add-line blocks (car lines))))
+                     (if blocks*
+                         blocks*
+                         (begin (close-block! (car blocks))
+                                blocks))))))
+      ((null? lines) (reverse blocks)))
+
+;;; BLOCKS is in reverse here.
+(define (add-line blocks line)
+  (if (null? blocks)
+      (cons (new-block line) blocks)
+      (let ((last-block (car blocks)))
+        (cond
+         ((and (open-text-block? last-block)
+               (plain-text-line? line))
+          (add-line-to-text-block last-block line))
+         ((and (open-container-block? last-block)
+               ()))))))
+
+;;; commonmark.scm ends here
+(export
+ 
+ )
+(define-library (commonmark r7rs)
+  (import (scheme base))
+  (include-library-declarations "r7rs-exports.scm")
+  (include "commonmark.scm"))
+;;; generic-ref-set --- Generic accessor and modifier operators.
+
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; 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.
+
+;;; Helpers
+
+(define-syntax push!
+  (syntax-rules ()
+    ((_ <list-var> <x>)
+     (set! <list-var> (cons <x> <list-var>)))))
+
+(define (alist->hashtable alist)
+  (let ((table (make-eqv-hashtable 100)))
+    (for-each (lambda (entry)
+                (hashtable-set! table (car entry) (cdr entry)))
+              alist)
+    table))
+
+;;; Main
+
+(define ref
+  (case-lambda
+    ((object field)
+     (let ((getter (lookup-getter object))
+           (sparse? (sparse-type? object)))
+       (if sparse?
+           (let* ((not-found (cons #f #f))
+                  (result (getter object field not-found)))
+             (if (eqv? result not-found)
+                 (error "Object has no entry for field." object field)
+                 result))
+           (getter object field))))
+    ((object field default)
+     (let ((getter (lookup-getter object)))
+       (getter object field default)))))
+
+(define-syntax set!
+  (syntax-rules ()
+    ((set! <place> <expression>)
+     (%set! <place> <expression>))
+    ((set! <object> <field> <value>)
+     (let* ((object <object>)
+            (setter (lookup-setter object)))
+       (setter object <field> <value>)))))
+
+(set! (setter ref) (lambda (object field value) (set! object field value)))
+
+(define (lookup-getter object)
+  (or (hashtable-ref getter-table (type-of object) #f)
+      (error "No generic getter for object's type." object)))
+
+(define (lookup-setter object)
+  (or (hashtable-ref setter-table (type-of object) #f)
+      (error "No generic setter for object's type." object)))
+
+(define (sparse-type? object)
+  (memv (type-of object) sparse-types))
+
+(define (type-of object)
+  (find (lambda (pred) (pred object)) type-list))
+
+(define getter-table
+  (alist->hashtable
+   (list (cons bytevector? bytevector-u8-ref)
+         (cons hashtable? hashtable-ref)
+         (cons pair? list-ref)
+         (cons string? string-ref)
+         (cons vector? vector-ref))))
+
+(define setter-table
+  (alist->hashtable
+   (list (cons bytevector? bytevector-u8-set!)
+         (cons hashtable? hashtable-set!)
+         (cons pair? list-set!)
+         (cons string? string-set!)
+         (cons vector? vector-set!))))
+
+(define sparse-types
+  (list hashtable?))
+
+(define type-list
+  (list boolean? bytevector? char? eof-object? hashtable? null? number? pair?
+        port? procedure? string? symbol? vector?))
+
+(define-syntax define-record-type
+  (syntax-rules ()
+    ((_ <name> <constructor> <pred> <field> ...)
+     (begin
+       (%define-record-type <name> <constructor> <pred> <field> ...)
+       (push! type-list <pred>)
+       (register-record-getter <pred> <field> ...)
+       (register-record-setter <pred> <field> ...)))))
+
+(define-syntax register-record-getter
+  (syntax-rules ()
+    ((_ <pred> (<field> <getter> . <rest>) ...)
+     (let ((getters (alist->hashtable (list (cons '<field> <getter>) ...))))
+       (define (getter record field)
+         (let ((getter (or (ref getters field #f)
+                           (error "No such field of record." record field))))
+           (getter record field)))
+       (set! getter-table <pred> getter)))))
+
+(define-syntax register-record-setter
+  (syntax-rules ()
+    ((_ . <rest>)
+     (%register-record-setter () . <rest>))))
+
+(define-syntax %register-record-setter
+  (syntax-rules ()
+    ((_ <setters> <pred> (<field> <getter>) . <rest>)
+     (%register-record-setter <setters> <pred> . <rest>))
+    ((_ <setters> <pred> (<field> <getter> <setter>) . <rest>)
+     (%register-record-setter ((<field> <setter>) . <setters>) <pred> . <rest>))
+    ((_ ((<field> <setter>) ...) <pred>)
+     (let ((setters (alist->hashtable (list (cons '<field> <setter>) ...))))
+       (define (setter record field value)
+         (let ((setter (or (ref setters field #f)
+                           (error "No such assignable field of record."
+                                  record field))))
+           (setter record value)))
+       (set! setter-table <pred> setter)))))
+
+;;; generic-ref-set.body.scm ends here
+(define-library (generic-ref-set)
+  (export
+   ref set! define-record-type (rename ref $bracket-apply$))
+  (import
+   (rename (except (scheme base) set!)
+           (define-record-type %define-record-type))
+   (scheme case-lambda)
+   (r6rs hashtables)
+   (srfi 1)
+   (rename (srfi 17) (set! %set!)))
+  (include "generic-ref-set.body.scm"))
+(define-module (ie-reader cre))
+
+(use-modules
+ (bytestructures guile))
+
+(define cre-header
+  (bs:struct
+   `((signature ,(bs:string 4 'ascii))
+     (version ,(bs:string 4 'ascii))
+     (long-name ))))
+;; One advantage of dlists is that they allow you to write more
+;; efficient programs, while keeping the lucidity of the less
+;; efficient version. Take the naïve version of 'reverse'
+
+(define (reverse l)
+  (if (null? l)
+      '()
+      (append (reverse (cdr l))
+              (list (car l)))))
+
+;; The definition is obviously correct, however it isn't very
+;; efficient. For a given step, the cost of the non-trivial case is
+;; dependant on the size of the list we have gotten from the recursive
+;; call. That is, it takes time proportional to the square of its
+;; input list.
+;; Of course, no self respecting functional programmer would write
+;; reverse in this manner, as the trick of using an accumulating
+;; parameter is so well established. Instead we would write
+
+(define (reverse l)
+  (define (reverse-helper from to)
+    (if (null? from)
+        to
+        (reverse-helper (cdr from)
+                        (cons (car from) to))))
+  (reverse-helper l '()))
+
+;; By introducing this additional parameter, we have reclaimed a more
+;; reasonable complexity of constant time at each recursive call,
+;; giving us linear complexity overall.
+;; This is a big improvement, and with a little practice, it becomes
+;; easy to convince yourself of the correctness of code written in
+;; this manner.
+
+;; However, why should you have to practice? Why can't there be a
+;; definition as obviously correct as the former, with the efficiency
+;; of the latter?
+;; Turns out, it is possible to do this, by using a different
+;; representation for lists.
+
+(define (reverse* l)
+  (if (null? l)
+      (dlist)
+      (dlist-append (reverse* (cdr l))
+                    (dlist (car l)))))
+
+(define (reverse l)
+  (dlist->list (reverse* l)))
+
+;; Difference lists, or representing lists as functions, gives us a
+;; constant time version of append, thus reducing the complexity of
+;; reverse* to O(n), and the definition differs from the original,
+;; only in the names we use for the append and list procedures. The
+;; final result of this function, however, is a dlist rather than a
+;; list, so we must convert back. This also has linear complexity, so
+;; the overall complexity is still linear.
+
+;; How does this work? Well, let's replace dlist and dlist-append with
+;; their definitions
+(define (reverse* l)
+  (if (null? l)
+      (lambda (x) (append '() x))
+      (compose (reverse* (cdr l))
+               (lambda (x) (append (list (car l)) x)))))
+
+(define (reverse l)
+  ((reverse* l) '()))
+
+;; Now, we replace compose with its definition
+(define (reverse* l)
+  (if (null? l)
+      (lambda (x) (append '() x))
+      (lambda (x)
+        ((reverse* (cdr l))
+         ((lambda (x) (append (list (car l)) x)) x)))))
+
+(define (reverse l)
+  ((reverse* l) '()))
+
+;; With a few simplifications: substituting x for its definition,
+;; x for (append '() x), and (cons x y) for (append (list x) y)
+(define (reverse* l)
+  (if (null? l)
+      (lambda (x) x)
+      (lambda (x)
+        ((reverse* (cdr l))
+         (cons (car l) x)))))
+
+(define (reverse l)
+  ((reverse* l) '()))
+
+;; Now, if we uncurry reverse*
+(define (reverse* l x)
+  (if (null? l)
+      x
+      (reverse* (cdr l) (cons (car l) x))))
+
+(define (reverse l)
+  (reverse* l '()))
+
+;; Then, it turns out the dlist version is the traditional O(n)
+;; implementation in disguise.
+
+;; As an exercise, you can try doing the same thing for the flatten
+;; function
+(define (flatten xs)
+  (cond ((null? xs) '())
+        ((pair? xs)
+         (append (flatten (car xs))
+                 (flatten (cdr xs))))
+        (else (list xs))))
+;;; Functional Breadth First Search
+(import (rnrs)
+        (pfds queues))
+
+;; This is the traditional solution using Queues, for a more
+;; interesting solution, see "The Under-Appreciated Unfold" by Jeremy
+;; Gibbons and Geraint Jones.
+
+;; We'll need a tree type, we'll use #f for an empty child.
+(define-record-type tree
+  (fields value left right))
+
+;; A small section of the Stern-Brocot Tree
+;; https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree
+(define stern-brocot
+  (make-tree 1
+             (make-tree 1/2
+                        (make-tree 1/3
+                                   (make-tree 1/4 #f #f)
+                                   (make-tree 2/5 #f #f))
+                        (make-tree 2/3
+                                   (make-tree 3/5 #f #f)
+                                   (make-tree 3/4 #f #f)))
+             (make-tree 2
+                        (make-tree 3/2
+                                   (make-tree 4/3 #f #f)
+                                   (make-tree 5/3 #f #f))
+                        (make-tree 3
+                                   (make-tree 5/2 #f #f)
+                                   (make-tree 4 #f #f)))))
+
+;; We'll search it breadth-first for the first fraction expressed in
+;; fifths.
+(define (fifth? f)
+  (= 5 (denominator f)))
+
+;; The queue search
+(define (bfs p? tree)
+  (define (step queue)
+    (if (queue-empty? queue)
+        #f
+        (let-values ([(head queue*) (dequeue queue)])
+          (cond ((not head)                 ; empty-tree, skip
+                 (step queue*))
+                ((p? (tree-value head)) (tree-value head))
+                (else
+                 (step (enqueue (enqueue queue* (tree-left head))
+                                (tree-right head))))))))
+
+  (step (enqueue (make-queue) tree)))
+
+(equal? 2/5 (bfs fifth? stern-brocot))
+(define-library (pfds assert)
+  (export assert assertion-violation)
+  (import (scheme base))
+  (begin
+    ()))
+;;; bbtrees.sls --- Bounded Balance trees
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+;; Copyright (C) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;; Documentation:
+;;
+;; Note: For all procedures which take a key as an argument, the key
+;; must be comparable with the ordering procedure of the bbtree.
+;;
+;; make-bbtree : (any -> any -> boolean) -> bbtree
+;; returns an empty bbtree. bbtrees derived from this one will use the
+;; procedure argument for ordering keys.
+;;
+;; bbtree? : any -> bool
+;; returns #t if the argument is a bbtree, #f otherwise
+;;
+;; bbtree-size : bbtree -> non-negative integer
+;; returns the number of elements in a bbtree
+;;
+;; bbtree-ref : bbtree any [any] -> any
+;; returns the value associated with the key in the bbtree.  If the
+;; value is not in the tree, then, if the optional third argument is
+;; passed, it is returned, otherwise an &assertion-violation condition
+;; is raised.
+;;
+;; bbtree-set : bbtree any any -> bbtree
+;; returns a new bbtree with the key associated with the value. If the
+;; key is already in the bbtree, its associated value is replaced with
+;; the new value in the returned bbtree.
+;;
+;; bbtree-update : bbtree any (any -> any) any -> bbtree
+;; returns a new bbtree with the value associated with the key updated
+;; according to the update procedure. If the key was not already in
+;; the bbtree, the update procedure is called on the default value,
+;; and the association is added to the bbtree.
+;;
+;; bbtree-delete : bbtree any -> bbtree
+;; returns a new bbtree with the key and its associated value
+;; removed. If the key is not in the bbtree, the returned bbtree is a
+;; copy of the original
+;;
+;; bbtree-contains? : bbtree any -> boolean
+;; returns #t if there is association for key in the bbtree, false
+;; otherwise
+;;
+;; bbtree-traverse : (any any (any -> any) (any -> any) any) any bbtree -> any
+;; A general tree traversal procedure. Returns the value of applying
+;; the traverser procedure to the current node's key, value, a
+;; procedure to traverse the left subtree, a procedure to traverse the
+;; right subtree, and a base value. The subtree traversal procedures
+;; both take a base argument, and call bbtree-traverse recursively on
+;; the appropriate subtree. It is mostly useful for implementing
+;; other, more specific tree traversal procedures. For example,
+;;   (define (l-to-r-pre-order cons base bbtree)
+;;     (bbtree-traverse (lambda (key value left right base)
+;;                        (right (left (cons key value base))))
+;;                      base
+;;                      bbtree))
+;; implements a left-to-right pre-order traversal variant of bbtree-fold
+;;
+;; bbtree-fold : (any any any -> any) any bbtree -> any
+;; returns the value obtained by the iterating the combine procedure
+;; over each node in the tree. The combine procedure takes three
+;; arguments, the key and value of the current node, and an
+;; accumulator value, and its return value is used as the accumulator
+;; value for the next node. The initial accumulator value is provided
+;; by the base argument. bbtree-fold performs an left-to-right
+;; in-order traversal or "minimum key to maximum key".
+;;
+;; bbtree-fold-right : (any any any -> any) any bbtree -> any
+;; like bbtree-fold, but it performs a right-to-left in-order
+;; traversal instead (i.e. maximum to minimum).
+;;
+;; bbtree-map : (any -> any) bbtree -> bbtree
+;; returns the tree obtained by updating the value of each node with
+;; the result of applying the procedure to its value.
+;;
+;; bbtree->alist : bbtree -> Listof(Pairs)
+;; returns the key value associations of the bbtree as a list of
+;; pairs. The list returned is in sorted order according to the
+;; ordering procedure of the bbtree. A consequence of this is that one
+;; could write a sort procedure for lists of pairs as
+;;   (define (alist-sort alist <)
+;;     (bbtree->alist (alist->bbtree alist <)))
+;;
+;; alist->bbtree : Listof(Pairs) -> (any any -> boolean) -> bbtree
+;; returns the bbtree containing each of the key value pairs in the
+;; alist, using the < argument as the ordering procedure.
+;;
+;; bbtree-keys : bbtree -> Listof(any)
+;; returns a list containing all the keys of the bbtree. The keys are
+;; sorted according to the bbtree's ordering procedure.
+;;
+;; bbtree-union : bbtree bbtree -> bbtree
+;; returns a bbtree containing the union of the associations in
+;; bbtree1 and bbtree2. Where the same key occurs in both, the value
+;; in bbtree1 is preferred.
+;; 
+;; bbtree-difference : bbtree bbtree -> bbtree
+;; returns a bbtree containing the all the associations in bbtree1,
+;; which do not occur in bbtree2.
+;;
+;; bbtree-intersection : bbtree bbtree -> bbtree
+;; returns a bbtree containing all the associations which appear in
+;; both bbtree1 and bbtree2. The value in bbtree1 are preferred over
+;; those in bbtree2.
+;;
+;; bbtree-index bbtree any -> non-negative integer
+;; returns the index of the key in the bbtree. Index is an integer
+;; between 0 and size - 1, with the a key having a lower index than
+;; another if first-key < second-key, according to the bbtree ordering
+;; procedure.
+;;
+;; bbtree-ref/index bbtree non-negative-integer -> any any
+;; returns the key and value of the association in the bbtree at the
+;; given index.
+;;
+;; bbtree-ordering-procedure : bbtree -> (any any -> bool)
+;; returns the ordering procedure used internally to order the
+;; bbtree.
+(define-library (pfds bbtrees)
+(export make-bbtree
+        bbtree?
+        bbtree-size
+        bbtree-ref
+        bbtree-set
+        bbtree-update
+        bbtree-delete
+        bbtree-contains?
+        bbtree-ordering-procedure
+        bbtree-traverse
+        bbtree-fold
+        bbtree-fold-right
+        bbtree-map
+        bbtree->alist
+        alist->bbtree
+        bbtree-keys
+        bbtree-union
+        bbtree-difference
+        bbtree-intersection
+        bbtree-index
+        bbtree-ref/index
+        )
+
+(import (except (scheme base) min member))
+
+(begin
+
+(define weight 4)
+
+;;; bbtree is the wrapper that you interact with from outside the
+;;; module, so there is no need to deal with empty and node record types
+(define-record-type (bbtree %make-bbtree bbtree?)
+  (fields tree ordering-procedure))
+
+(define (update-tree bbtree new-tree)
+  (%make-bbtree new-tree (bbtree-ordering-procedure bbtree)))
+
+;;; inner representation of trees
+;;; all non exposed methods can assume a valid tree
+(define-record-type empty)
+
+(define-record-type node
+  (fields key value length left right))
+
+;;; smart constructor for nodes, automatically fills in size field
+(define (node* key value left right)
+  (make-node key value (+ 1 (size left) (size right)) left right))
+
+(define (size tree)
+  (if (empty? tree)
+      0
+      (node-length tree)))
+
+;; looks key up in the tree, and applies proc to the value if it finds
+;; it, and calls failure otherwise
+(define (lookup tree key proc failure <)
+  (define (search tree)
+    (cond ((empty? tree) (failure))
+          ((< (node-key tree) key)
+           (search (node-right tree)))
+          ((< key (node-key tree))
+           (search (node-left tree)))
+          (else (proc tree))))
+  (search tree))
+
+;; returns the key and value of the minimum element in the tree
+(define (min tree)
+  (cond ((empty? tree)
+         (assertion-violation 'min "Can't take the minimum value of an empty tree"))
+        ((empty? (node-left tree))
+         (values (node-key tree)
+                 (node-value tree)))
+        (else
+         (min (node-left tree)))))
+
+;;; rotations
+(define (rotate-left key value left right)
+  (let ((r-key   (node-key right))
+        (r-value (node-value right))
+        (r-left  (node-left right))
+        (r-right (node-right right)))
+    (node* r-key
+           r-value
+           (node* key value left r-left)
+           r-right)))
+
+(define (rotate-right key value left right)
+  (let ((l-key   (node-key left))
+        (l-value (node-value left))
+        (l-left  (node-left left))
+        (l-right (node-right left)))
+    (node* l-key
+           l-value
+           l-left
+           (node* key value l-right right))))
+
+(define (rotate-left/double key value left right)
+  (let ((r-key   (node-key right))
+        (r-value (node-value right))
+        (r-left  (node-left right))
+        (r-right (node-right right)))
+    (let ((rl-key   (node-key r-left))
+          (rl-value (node-value r-left))
+          (rl-left  (node-left r-left))
+          (rl-right (node-right r-left)))
+      (node* rl-key
+             rl-value
+             (node* key value left rl-left)
+             (node* r-key r-value rl-right r-right)))))
+
+(define (rotate-right/double key value left right)
+  (let ((l-key   (node-key left))
+        (l-value (node-value left))
+        (l-left  (node-left left))
+        (l-right (node-right left)))
+    (let ((lr-key   (node-key l-right))
+          (lr-value (node-value l-right))
+          (lr-left  (node-left l-right))
+          (lr-right (node-right l-right)))
+      (node* lr-key
+             lr-value
+             (node* l-key l-value l-left lr-left)
+             (node* key value lr-right right)))))
+
+;;; smart constructor for after adding/removing a node
+(define (T key value left right)
+  (let ((l-size (size left))
+        (r-size (size right)))
+    (cond ((< (+ l-size r-size) 2)
+           (node* key value left right))
+          ((> r-size (* weight l-size))
+           (let ((r-left (node-left right))
+                 (r-right (node-right right)))
+             (if (< (size r-left) (size r-right))
+                 (rotate-left key value left right)
+                 (rotate-left/double key value left right))))
+          ((> l-size (* weight r-size))
+           (let ((l-left (node-left left))
+                 (l-right (node-right left)))
+             (if (< (size l-right) (size l-left))
+                 (rotate-right key value left right)
+                 (rotate-right/double key value left right))))
+          (else
+           (node* key value left right)))))
+
+(define (update tree key proc default <)
+  (define (add-to tree)
+    (if (empty? tree)
+        (make-node key (proc default) 1 (make-empty) (make-empty))
+        (let ((k (node-key tree))
+              (v (node-value tree))
+              (l (node-left tree))
+              (r (node-right tree)))
+          (cond ((< key k)
+                 (T k v (add-to l) r))
+                ((< k key)
+                 (T k v l (add-to r)))
+                (else
+                 (node* key (proc v) l r))))))
+  (add-to tree))
+
+(define (add tree key value <)
+  (define (replace _) value)
+  (update tree key replace #f <))
+
+(define (delete tree key <)
+  (define (delete-from tree)
+    (if (empty? tree)
+        tree
+        (let ((k (node-key tree))
+              (v (node-value tree))
+              (l (node-left tree))
+              (r (node-right tree)))
+          (cond ((< key k)
+                 (T k v (delete-from l) r))
+                ((< k key)
+                 (T k v l (delete-from r)))
+                (else
+                 (delete* l r))))))
+  (delete-from tree))
+
+(define (delete* left right)
+  (cond ((empty? left) right)
+        ((empty? right) left)
+        (else
+         (let-values (((k v) (min right)))
+           (T k v left (delete-min right))))))
+
+(define (delete-min tree)
+  (cond ((empty? tree)
+         (assertion-violation 'delete-min
+                              "Can't delete the minimum value of an empty tree"))
+        ((empty? (node-left tree))
+         (node-right tree))
+        (else
+         (T (node-key tree)
+            (node-value tree)
+            (delete-min (node-left tree))
+            (node-right tree)))))
+
+(define (concat3 key value left right lt)
+  (cond ((empty? left)
+         (add right key value lt))
+        ((empty? right)
+         (add left key value lt))
+        ((< (* weight (size left)) (size right))
+         (T (node-key right)
+            (node-value right)
+            (concat3 key value left (node-left right) lt)
+            (node-right right)))
+        ((< (* weight (size right)) (size left))
+         (T (node-key left)
+            (node-value left)
+            (node-left left)
+            (concat3 key value (node-right left) right lt)))
+        (else
+         (node* key value left right))))
+
+(define (split-lt tree key <)
+  (cond ((empty? tree) tree)
+        ((< key (node-key tree))
+         (split-lt (node-left tree) key <))
+        ((< (node-key tree) key)
+         (concat3 (node-key tree)
+                  (node-value tree)
+                  (node-left tree)
+                  (split-lt (node-right tree) key <)
+                  <))
+        (else (node-left tree))))
+
+(define (split-gt tree key <)
+  (cond ((empty? tree) tree)
+        ((< key (node-key tree))
+         (concat3 (node-key tree)
+                  (node-value tree)
+                  (split-gt (node-left tree) key <)
+                  (node-right tree)
+                  <))
+        ((< (node-key tree) key)
+         (split-gt (node-right tree) key <))
+        (else (node-right tree))))
+
+(define (difference tree1 tree2 <)
+  (cond ((empty? tree1) tree1)
+        ((empty? tree2) tree1)
+        (else
+         (let ((l* (split-lt tree1 (node-key tree2) <))
+               (r* (split-gt tree1 (node-key tree2) <)))
+           (concat (difference l* (node-left tree2) <)
+                   (difference r* (node-right tree2) <))))))
+
+(define (concat left right)
+  (cond ((empty? left) right)
+        ((empty? right) left)
+        ((< (* weight (size left)) (size right))
+         (T (node-key right)
+            (node-value right)
+            (concat left (node-left right))
+            (node-right right)))
+        ((< (* weight (size right)) (size left))
+         (T (node-key left)
+            (node-value left)
+            (node-left left)
+            (concat (node-right left) right)))
+        (else
+         (let-values (((k v) (min right)))
+           (T k v left (delete-min right))))))
+
+(define (member key tree <)
+  (define (yes x) #t)
+  (define (no) #f)
+  (lookup tree key yes no <))
+
+(define (intersection t1 t2 <)
+  (cond ((empty? t1) t1)
+        ((empty? t2) t2)
+        (else
+         (let ((l* (split-lt t2 (node-key t1) <))
+               (r* (split-gt t2 (node-key t1) <)))
+           (if (member (node-key t1) t2 <)
+               (concat3 (node-key t1)
+                        (node-value t1)
+                        (intersection (node-left t1) l* <)
+                        (intersection (node-right t1) r* <)
+                        <)
+               (concat (intersection (node-left t1) l* <)
+                       (intersection (node-right t1) r* <)))))))
+
+;;; hedge union
+
+;; ensures that tree is either empty, or root lies in range low--high
+(define (trim low high tree <)
+  (cond ((empty? tree) tree)
+        ((< low (node-key tree))
+         (if (< (node-key tree) high)
+             tree
+             (trim low high (node-left tree) <)))
+        (else
+         (trim low high (node-right tree) <))))
+
+(define (uni-bd tree1 tree2 low high <)
+  (cond ((empty? tree2) tree1)
+        ((empty? tree1)
+         (concat3 (node-key tree2)
+                  (node-value tree2)
+                  (split-gt (node-left tree2) low <)
+                  (split-lt (node-right tree2) high <)
+                  <))
+        (else
+         (let ((key (node-key tree1)))
+           (concat3 key
+                    (node-value tree1)
+                    (uni-bd (node-left tree1) (trim low key tree2 <) low key <)
+                    (uni-bd (node-right tree1) (trim key high tree2 <) key high <)
+                    <)))))
+
+;; specialisation of trim for high=+infinity
+(define (trim-low low tree <)
+  (cond ((empty? tree) tree)
+        ((< low (node-key tree)) tree)
+        (else
+         (trim-low low (node-right tree) <))))
+
+;; trim for low=-infinity
+(define (trim-high high tree <)
+  (cond ((empty? tree) tree)
+        ((< (node-key tree) high) tree)
+        (else
+         (trim-high high (node-left tree) <))))
+
+;; uni-bd for low=-infinity
+(define (uni-high tree1 tree2 high <)
+  (cond ((empty? tree2) tree1)
+        ((empty? tree1)
+         (concat3 (node-key tree2)
+                  (node-value tree2)
+                  (node-left tree2)
+                  (split-lt (node-right tree2) high <)
+                  <))
+        (else
+         (let ((key (node-key tree1)))
+           (concat3 key
+                    (node-value tree1)
+                    (uni-high (node-left tree1) (trim-high key tree2 <) key <)
+                    (uni-bd (node-right tree1) (trim key high tree2 <) key high <)
+                    <)))))
+
+;; uni-bd for high=+infinity
+(define (uni-low tree1 tree2 low <)
+  (cond ((empty? tree2) tree1)
+        ((empty? tree1)
+         (concat3 (node-key tree2)
+                  (node-value tree2)
+                  (split-gt (node-left tree2) low <)
+                  (node-right tree2)
+                  <))
+        (else
+         (let ((key (node-key tree1)))
+           (concat3 key
+                    (node-value tree1)
+                    (uni-bd (node-left tree1) (trim low key tree2 <) low key <)
+                    (uni-low (node-right tree1) (trim-low key tree2 <) key <)
+                    <)))))
+
+(define (hedge-union tree1 tree2 <)
+  (cond ((empty? tree2) tree1)
+        ((empty? tree1) tree2)
+        (else
+         (let ((key (node-key tree1)))
+           (concat3 key
+                    (node-value tree1)
+                    (uni-high (node-left tree1) (trim-high key tree2 <) key <)
+                    (uni-low (node-right tree1) (trim-low key tree2 <) key <)
+                    <)))))
+
+;;; rank and indexing
+
+(define (rank tree key <)
+  (cond ((empty? tree);; error
+         (assertion-violation 'rank "Key is not in the tree" key))
+        ((< key (node-key tree))
+         (rank (node-left tree) key <))
+        ((< (node-key tree) key)
+         (+ (rank (node-right tree) key <)
+            (size (node-left tree))
+            1))
+        (else
+         (size (node-left tree)))))
+
+(define (index tree idx)
+  (if (empty? tree)
+      (assertion-violation 'index "No value at index" idx)
+      (let ((l-size (size (node-left tree))))
+        (cond ((< idx l-size)
+               (index (node-left tree) idx))
+              ((< l-size idx)
+               (index (node-right tree)
+                      (- idx l-size 1)))
+              (else
+               (values (node-key tree)
+                       (node-value tree)))))))
+
+;;; External procedures
+
+(define (make-bbtree <)
+  (assert (procedure? <))
+  (%make-bbtree (make-empty) <))
+
+(define (bbtree-size bbtree)
+  (assert (bbtree? bbtree))
+  (size (bbtree-tree bbtree)))
+
+(define bbtree-ref
+  (let ((ref (lambda (bbtree key failure)
+               (assert (bbtree? bbtree))
+               (lookup (bbtree-tree bbtree)
+                       key
+                       node-value
+                       failure
+                       (bbtree-ordering-procedure bbtree)))))
+    (case-lambda
+      ((bbtree key)
+       (define (fail)
+         (assertion-violation 'bbtree-ref "Key is not in the tree" key))
+       (ref bbtree key fail))
+      ((bbtree key ret)
+       (ref bbtree key (lambda () ret))))))
+
+(define (bbtree-set bbtree key value)
+  (assert (bbtree? bbtree))
+  (update-tree bbtree
+               (add (bbtree-tree bbtree)
+                    key
+                    value
+                    (bbtree-ordering-procedure bbtree))))
+
+(define (bbtree-update bbtree key proc default)
+  (assert (bbtree? bbtree))
+  (update-tree bbtree
+               (update (bbtree-tree bbtree)
+                       key
+                       proc
+                       default
+                       (bbtree-ordering-procedure bbtree))))
+
+(define (bbtree-delete bbtree key)
+  (assert (bbtree? bbtree))
+  (update-tree bbtree
+               (delete (bbtree-tree bbtree)
+                       key
+                       (bbtree-ordering-procedure bbtree))))
+
+(define (bbtree-contains? bbtree key)
+  (assert (bbtree? bbtree))
+  (lookup (bbtree-tree bbtree)
+          key
+          (lambda (_) #t)
+          (lambda () #f)
+          (bbtree-ordering-procedure bbtree)))
+
+;; iterators
+
+(define (traverse traverser base tree)
+  (define (left base)
+    (traverse traverser base (node-left tree)))
+  (define (right base)
+    (traverse traverser base (node-right tree)))
+  (if (empty? tree)
+      base
+      (traverser (node-key tree)
+                 (node-value tree)
+                 left
+                 right
+                 base)))
+
+(define (bbtree-traverse traverser base bbtree)
+  (assert (bbtree? bbtree))
+  (traverse traverser base (bbtree-tree bbtree)))
+
+(define (bbtree-fold combine base bbtree)
+  (assert (bbtree? bbtree))
+  (traverse (lambda (k v l r n)
+              (r (combine k v (l n))))
+            base
+            (bbtree-tree bbtree)))
+
+(define (bbtree-fold-right combine base bbtree)
+  (assert (bbtree? bbtree))
+  (traverse (lambda (k v l r n)
+              (l (combine k v (r n))))
+            base
+            (bbtree-tree bbtree)))
+
+;; I could do this more efficiently, but is it worth it?
+(define (bbtree-map mapper bbtree)
+  (bbtree-fold (lambda (key value tree)
+                 (bbtree-set tree key (mapper value)))
+               (make-bbtree (bbtree-ordering-procedure bbtree))
+               bbtree))
+
+(define (alist-cons a b c)
+  (cons (cons a b) c))
+
+(define (bbtree->alist bbtree)
+  (bbtree-fold-right alist-cons '() bbtree))
+
+(define (alist->bbtree list <)
+  (fold-left (lambda (tree kv-pair)
+               (bbtree-set tree (car kv-pair) (cdr kv-pair)))
+             (make-bbtree <)
+             list))
+
+(define (bbtree-keys bbtree)
+  (bbtree-fold-right (lambda (key value base)
+                       (cons key base))
+                     '()
+                     bbtree))
+
+(define (bbtree-union bbtree1 bbtree2)
+  (update-tree bbtree1
+               (hedge-union (bbtree-tree bbtree1)
+                            (bbtree-tree bbtree2)
+                            (bbtree-ordering-procedure bbtree1))))
+
+(define (bbtree-difference bbtree1 bbtree2)
+  (update-tree bbtree1
+               (difference (bbtree-tree bbtree1)
+                           (bbtree-tree bbtree2)
+                           (bbtree-ordering-procedure bbtree1))))
+
+(define (bbtree-intersection bbtree1 bbtree2)
+  (update-tree bbtree1
+               (intersection (bbtree-tree bbtree1)
+                             (bbtree-tree bbtree2)
+                             (bbtree-ordering-procedure bbtree1))))
+
+(define (bbtree-index bbtree key)
+  ;; maybe this should return #f instead of throwing an exception?
+  (assert (bbtree? bbtree))
+  (rank (bbtree-tree bbtree)
+        key
+        (bbtree-ordering-procedure bbtree)))
+
+(define (bbtree-ref/index bbtree idx)
+  (assert (bbtree? bbtree))
+  (let ((tree (bbtree-tree bbtree)))
+    (unless (and (integer? idx)
+                 (<= 0 idx (- (size tree) 1)))
+      (assertion-violation 'bbtree-ref/index
+                           "Not a valid index into the bbtree"
+                           idx))
+    (index tree idx)))
+
+))
+
+;;; deques.sls --- Purely functional deques
+
+;; Copyright (C) 2011,2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;; Documentation:
+;;
+;; make-deque : () -> deque
+;; returns a deque containing to items
+;;
+;; deque? : any -> boolean
+;; tests if an object is a deque
+;;
+;; deque-length : deque -> non-negative integer
+;; returns the number of items in the deque
+;;
+;; deque-empty? : deque -> boolean
+;; returns true if there are no items in the deque, false otherwise
+;;
+;; enqueue-front : deque any -> deque
+;; returns a new deque with the inserted item at the front
+;;
+;; enqueue-rear : deque any -> deque
+;; returns a new deque with the inserted item at the rear
+;;
+;; dequeue-front : deque -> any queue
+;; returns two values, the item at the front of the deque, and a new
+;; deque containing all the other items
+;; raises a &deque-empty condition if the deque is empty
+;;
+;; dequeue-rear : deque -> any queue
+;; returns two values, the item at the rear of the deque, and a new
+;; deque containing all the other items
+;; raises a &deque-empty condition if the deque is empty
+;;
+;; deque-empty-condition? : object -> boolean
+;; tests if an object is a &deque-empty condition
+;;
+;; deque->list : deque -> listof(any)
+;; returns a list containing all the elements of the deque. The order
+;; of the elements in the list is the same as the order they would be
+;; dequeued from the front of the deque.
+;;
+;; list->deque : listof(any) -> deque
+;; returns a deque containing all of the elements in the list. The
+;; order of the elements in the deque is the same as the order of the
+;; elements in the list.
+;;
+(library (pfds deques)
+(export make-deque
+        deque?
+        deque-length
+        deque-empty?
+        enqueue-front
+        enqueue-rear
+        dequeue-front
+        dequeue-rear
+        deque-empty-condition?
+        deque->list
+        list->deque
+        )
+(import (except (rnrs) cons*)
+        (pfds deques private condition)
+        (pfds private lazy-lists))
+
+(define c 2)
+
+(define (rot1 n l r)
+  (if (>= n c)
+      (cons* (head l)
+             (rot1 (- n c) (tail l) (drop c r)))
+      (rot2 l (drop n r) '())))
+
+(define (rot2 l r a)
+  (if (empty? l)
+      (append* (rev r) a)
+      (cons* (head l)
+             (rot2 (tail l)
+                   (drop c r)
+                   (append* (rev (take c r)) a)))))
+
+(define-record-type (deque %make-deque deque?)
+  (fields
+   (immutable length)
+   (immutable lenL)
+   (immutable lenR)
+   (immutable l)
+   (immutable r)
+   (immutable l^)
+   (immutable r^)))
+
+(define (make-deque)
+  (%make-deque 0 0 0 '() '() '() '()))
+
+(define (deque-empty? deque)
+  (zero? (deque-length deque)))
+
+(define (enqueue-front deque item)
+  (let ((len (deque-length deque))
+        (l (deque-l deque))
+        (r (deque-r deque))
+        (lenL (deque-lenL deque))
+        (lenR (deque-lenR deque))
+        (l^ (deque-l^ deque))
+        (r^ (deque-r^ deque)))
+    (makedq (+ 1 len) (+ 1 lenL) lenR (cons* item l) r (tail l^) (tail r^))))
+
+(define (enqueue-rear deque item)
+  (let ((len (deque-length deque))
+        (l (deque-l deque))
+        (r (deque-r deque))
+        (lenL (deque-lenL deque))
+        (lenR (deque-lenR deque))
+        (l^ (deque-l^ deque))
+        (r^ (deque-r^ deque)))
+    (makedq (+ 1 len) lenL (+ 1 lenR) l (cons* item r) (tail l^) (tail r^))))
+
+(define (dequeue-front deque)
+  (when (deque-empty? deque)
+    (raise (condition
+            (make-deque-empty-condition)
+            (make-who-condition 'dequeue-front)
+            (make-message-condition "There are no elements to remove")
+            (make-irritants-condition (list deque)))))
+  (let ((len (deque-length deque))
+        (lenL (deque-lenL deque))
+        (lenR (deque-lenR deque))
+        (l (deque-l deque))
+        (r (deque-r deque))
+        (l^ (deque-l^ deque))
+        (r^ (deque-r^ deque)))
+    (if (empty? l)
+        (values (head r) (make-deque))
+        (values (head l)
+                (makedq (- len 1)
+                        (- lenL 1)
+                        lenR
+                        (tail l)
+                        r
+                        (tail (tail l^))
+                        (tail (tail r^)))))))
+
+(define (dequeue-rear deque)
+  (when (deque-empty? deque)
+    (raise (condition
+            (make-deque-empty-condition)
+            (make-who-condition 'dequeue-rear)
+            (make-message-condition "There are no elements to remove")
+            (make-irritants-condition (list deque)))))
+  (let ((len (deque-length deque))
+        (lenL (deque-lenL deque))
+        (lenR (deque-lenR deque))
+        (l (deque-l deque))
+        (r (deque-r deque))
+        (l^ (deque-l^ deque))
+        (r^ (deque-r^ deque)))
+    (if (empty? r)
+        (values (head l) (make-deque))
+        (values (head r)
+                (makedq (- len 1)
+                        lenL
+                        (- lenR 1)
+                        l
+                        (tail r)
+                        (tail (tail l^))
+                        (tail (tail r^)))))))
+
+
+
+(define (makedq len lenL lenR l r l^ r^)
+  (cond ((> lenL (+ 1 (* c lenR)))
+         (let* ((n  (floor (/ (+ lenL lenR) 2)))
+                (l* (take n l))
+                (r* (rot1 n r l)))
+           (%make-deque len n (- len n) l* r* l* r*)))
+        ((> lenR (+ 1 (* c lenL)))
+         (let* ((n  (floor (/ (+ lenL lenR) 2)))
+                (l* (rot1 n l r))
+                (r* (take n r)))
+           (%make-deque len (- len n) n l* r* l* r*)))
+        (else
+         (%make-deque len lenL lenR l r l^ r^))))
+
+(define (list->deque l)
+  (fold-left enqueue-rear (make-deque) l))
+
+(define (deque->list deq)
+  (define (recur deq l)
+    (if (deque-empty? deq)
+        l
+        (let-values ([(last deq*) (dequeue-rear deq)])
+          (recur deq* (cons last l)))))
+  (recur deq '()))
+
+)
+
+;;; dlists.sls --- Difference Lists
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;; Commentary:
+;;
+;; Repeatedly appending to a list is a common, if inefficient pattern
+;; in functional programs. Usually the trick we use is to build up the
+;; list in reverse, and then to reverse it as the last action of a
+;; function.
+;;
+;; Dlists are a representation of lists as functions that provide for
+;; constant time append to either the front or end of a dlist that may
+;; be used instead.
+
+;;; Documentation:
+;;
+;; dlist : any ... -> dlist
+;; returns a dlist containing all its arguments.
+;;
+;; dlist? : any -> boolean
+;; returns #t if its argument is a dlist, #f otherwise.
+;;
+;; dlist-cons : any dlist -> dlist
+;; returns a new dlist created by prepending the element to the head
+;; of the dlist argument.
+;;
+;; dlist-snoc : dlist any -> dlist
+;; returns a new dlist created by appending the element to the tail of
+;; the dlist argument.
+;;
+;; dlist-append : dlist dlist -> dlist
+;; returns a new dlist consisting of all the elements of the first
+;; dlist, followed by all the items of the second dlist.
+;;
+;; dlist->list : dlist -> listof(any)
+;; returns a list consisting of all the elements of the dlist.
+;;
+;; list->dlist : listof(any) -> dlist
+;; returns a dlist consisting of all the elements of the list.
+(library (pfds dlists)
+(export (rename (%dlist dlist))
+        dlist?
+        dlist-cons
+        dlist-snoc
+        dlist-append
+        dlist->list
+        list->dlist
+        )
+(import (rnrs))
+
+(define-record-type dlist
+  (fields
+   (immutable proc undl)))
+
+(define (%dlist . args)
+  (list->dlist args))
+
+(define (compose f g)
+  (lambda (x)
+    (f (g x))))
+
+(define (singleton x)
+  (list->dlist (list x)))
+
+(define (dlist-append dl1 dl2)
+  (make-dlist (compose (undl dl1) (undl dl2))))
+
+(define (dlist-cons element dlist)
+  (dlist-append (singleton element) dlist))
+
+(define (dlist-snoc dlist element)
+  (dlist-append dlist (singleton element)))
+
+(define (dlist->list dlist)
+  ((undl dlist) '()))
+
+(define (list->dlist list)
+  (make-dlist
+   (lambda (rest)
+     (append list rest))))
+
+)
+
+;;; fingertrees.sls --- A Simple General-Purpose Data Structure
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;; Commentary:
+;;
+;; Fingertrees are a generalised form of deque, that you can parameterise
+;; to compute a value, called the "measure" of a fingertree. This measure
+;; will be updated incrementally as you add and remove elements from the
+;; fingertree. Among other things, this allows fingertrees to be used
+;; where you otherwise might have written a custom data structure.
+;;
+;; To compute the measure, fingertrees require pieces of information: a
+;; converter, a combiner, and an identity.
+;;
+;; The converter is a procedure of one argument, that maps values in the
+;; fingertree to other values which are used for computing the measure.
+;;
+;; The combiner is a procedure of two arguments, and combines these into
+;; one value representing them both. A combiner must be associative
+;; i.e. (combine A (combine B C)) must be equivalent to (combine (combine
+;; A B) C) for all values A, B and C.
+;;
+;; An identity is a value that represents the measure of an empty
+;; fingertree. It must obey the rule that (combine X identity), (combine
+;; identity X) and X are always the same.
+;;
+;; To make things more concrete, a simple use of a fingertree is as a
+;; deque that keeps a running total. In this case, the converter can
+;; simply be the function (lambda (x) x) if it is a deque of integers,
+;; the combiner would be +, and the identity 0.
+;;
+;; (define l '(3 1 4 1 5 9))
+;;
+;; (define ft (list->fingertree l 0 + (lambda (x) x)))
+;;
+;; (fingertree-measure ft)
+;; ; => 23
+;; (fingertree-measure (fingertree-snoc ft 2))
+;; ; => 25
+;; (let-values (((head tail) (fingertree-uncons ft)))
+;;   (fingertree-measure tail))
+;; ; => 20
+;;
+;; Mathematically speaking, the _return type_ of the converter, the
+;; combiner and the identity element are expected to form a
+;; monoid.
+;;
+;; Below, I use the slightly incorrect terminology of referring to the
+;; combiner, the converter, and the identity, together as a
+;; monoid. Mathematicians, please forgive me. Programmers please forgive
+;; me even more. If you can provide a better name (from a programmers,
+;; not a mathematicians, point of view) that works in most circumstances,
+;; I will be happy to use it.
+;;
+;; (FWIW the Haskell Data.Fingertree package uses odd name of Measured
+;; (which are expected to be instances of Monoid))
+;;
+;; fingertree? : any -> bool
+;; returns #t if argument is a fingertree, #f otherwise.
+;;
+;; fingertree-empty? : fingertree -> bool
+;; returns #t if there are no items in the fingertree, #f otherwise.
+;;
+;; make-fingertree : id combine measure -> fingertree
+;; returns a new fingertree, parameterised by the given monoid.
+;;
+;; fingertree-cons : any fingertree -> fingertree
+;; returns the new fingertree created by adding the element to the front
+;; of the argument fingertree.
+;;
+;; fingertree-snoc : fingertree any -> fingertree
+;; returns the new fingertree created by adding the element to the end of
+;; the fingertree.
+;;
+;; fingertree-uncons : fingertree -> any + fingertree
+;; returns two values: the element at the front of the fingertree, and a
+;; new fingertree containing all but the front element. If the fingertree
+;; is empty, a &fingertree-empty condition is raised.
+;;
+;; fingertree-unsnoc : fingertree -> fingertree + any
+;; returns two values: a new fingertree containing all but the rear
+;; element of the argument fingertree, and the rear element itself. If
+;; the fingertree is empty, a &fingertree-empty-condition is raised.
+;;
+;; fingertree-append : fingertree fingertree -> fingertree
+;; returns a new fingertree which contains all of the elements of the
+;; first fingertree argument, followed by all the elements of the
+;; second. The argument fingertrees are assumed to be parameterised by
+;; the same monoid.
+;;
+;; list->fingertree : (list->fingertree l id append convert)
+;; returns a fingertree containing all of the elements of the argument
+;; list, in the same order.
+;;
+;; fingertree->list : fingertree -> Listof(Any)
+;; returns a list of all the elements in the fingertree, in the order
+;; they would be unconsed.
+;;
+;; fingertree-measure : fingertree -> any
+;; returns the measure of the fingertree, as defined by the fingertree's
+;; monoid.
+;;
+;; fingertree-split : (any -> bool) fingertree -> fingertree + fingertree
+;; returns two values: the first is the largest prefix of the fingertree for
+;; which applying the predicate to it's accumulated measure returns
+;; #f. The second values is a fingertree containing all those elements
+;; not in the first fingertree.
+;;
+;; fingertree-split3: (any -> bool) fingertree -> fingertree + value + fingertree
+;; similar to fingertree-split, however, instead of returning the
+;; remainder as the second argument, it returns the head of the remainder
+;; as the second argument, and tail of the remainder as the third
+;; argument.
+;; TODO: what error should I give if the remainder was empty?
+;;
+;; fingertree-fold : (any -> any -> any) any fingertree
+;; returns the value obtained by iterating the combiner procedure over
+;; the fingertree in left-to-right order. This procedure takes two
+;; arguments, the current value from the fingertree, and an accumulator,
+;; and it's return value is used as the accumulator for the next
+;; iteration. The initial value for the accumulator is given by the base
+;; argument.
+;;
+;; fingertree-fold-right : (any -> any -> any) any fingertree
+;; similar to fingertree-fold, but iterates in right-to-left order.
+;;
+;; fingertree-reverse : fingertree -> fingertree
+;; returns a new fingertree in which the elements are in the opposite
+;; order from the argument fingertree.
+;;
+;; fingertree-empty-condition? : condition -> bool
+;; returns #t if the argument is a &fingertree-empty condition, #f otherwise.
+;;
+(library (pfds fingertrees)
+(export fingertree?
+        fingertree-empty?
+        make-fingertree
+        fingertree-cons
+        fingertree-snoc
+        fingertree-uncons
+        fingertree-unsnoc
+        fingertree-append
+        list->fingertree
+        fingertree->list
+        fingertree-measure
+        fingertree-split
+        fingertree-split3
+        fingertree-fold
+        fingertree-fold-right
+        fingertree-reverse
+        fingertree-empty-condition?
+        )
+(import (rnrs))
+
+;;; List helpers
+
+(define (snoc l val)
+  (append l (list val)))
+
+(define (take l n)
+  (if (or (null? l) (zero? n))
+      '()
+      (cons (car l)
+            (take (cdr l) (- n 1)))))
+
+(define (last list)
+  (if (null? (cdr list))
+      (car list)
+      (last (cdr list))))
+
+(define (but-last list)
+  (if (null? (cdr list))
+      '()
+      (cons (car list)
+            (but-last (cdr list)))))
+
+(define (map-reverse f l)
+  (fold-left (lambda (o n) (cons (f n) o)) '() l))
+
+;;; Node type
+
+(define-record-type node2
+  (protocol
+   (lambda (new)
+     (lambda (monoid a b)
+       (define app (mappend monoid))
+       (new (app (measure-nodetree a monoid)
+                 (measure-nodetree b monoid))
+            a
+            b))))
+  (fields measure a b))
+
+(define-record-type node3
+  (protocol
+   (lambda (new)
+     (lambda (monoid a b c)
+       (define app (mappend monoid))
+       (new (app (app (measure-nodetree a monoid)
+                      (measure-nodetree b monoid))
+                 (measure-nodetree c monoid))
+            a
+            b
+            c))))
+  (fields measure a b c))
+
+(define (node-case node k2 k3)
+  (if (node2? node)
+      (k2 (node2-a node) (node2-b node))
+      (k3 (node3-a node) (node3-b node) (node3-c node))))
+
+(define (node-fold-right f base node)
+  (node-case node
+     (lambda (a b)
+       (f a (f b base)))
+     (lambda (a b c)
+       (f a (f b (f c base))))))
+
+(define (node->list node)
+  (node-fold-right cons '() node))
+
+(define (nodetree-fold-right f base nodetree)
+  (define (foldr node base)
+    (cond ((node2? node)
+           (foldr (node2-a node)
+                  (foldr (node2-b node) base)))
+          ((node3? node)
+           (foldr (node3-a node)
+                  (foldr (node3-b node)
+                         (foldr (node3-c node) base))))
+          (else (f node base))))
+  (foldr nodetree base))
+
+(define (nodetree-fold-left f base nodetree)
+  (define (foldl node base)
+    (cond ((node2? node)
+           (foldl (node2-b node)
+                  (foldl (node2-a node) base)))
+          ((node3? node)
+           (foldl (node3-c node)
+                  (foldl (node3-b node)
+                         (foldl (node3-a node) base))))
+          (else (f node base))))
+  (foldl nodetree base))
+
+;;; Tree type
+
+(define-record-type empty)
+
+(define-record-type single
+  (fields value))
+
+(define-record-type rib
+  (protocol
+   (lambda (new)
+     (lambda (monoid left middle right)
+       (define app (mappend monoid))
+       (new (app (app (measure-digit left monoid)
+                      (measure-ftree middle monoid))
+                 (measure-digit right monoid))
+            left
+            middle
+            right)
+       )))
+  ;; left and right expected to be lists of length 0 < l < 5
+  (fields measure left middle right))
+
+(define (ftree-case ftree empty-k single-k rib-k)
+  (cond ((empty? ftree) (empty-k))
+        ((single? ftree)
+         (single-k (single-value ftree)))
+        (else
+         (rib-k (rib-left ftree)
+                (rib-middle ftree)
+                (rib-right ftree)))))
+
+(define (digits-fold-right f b d)
+  (fold-right (lambda (ntree base)
+                (nodetree-fold-right f base ntree))
+              b
+              d))
+
+(define (digits-fold-left f b d)
+  (fold-left (lambda (base ntree)
+                (nodetree-fold-left f base ntree))
+              b
+              d))
+
+(define (ftree-fold-right proc base ftree)
+  (ftree-case ftree
+    (lambda () base)
+    (lambda (x) (nodetree-fold-right proc base x))
+    (lambda (l x r)
+      (define base* (digits-fold-right proc base r))
+      (define base** (ftree-fold-right proc base* x))
+      (digits-fold-right proc base** l))))
+
+(define (ftree-fold-left proc base ftree)
+  (ftree-case ftree
+    (lambda () base)
+    (lambda (x) (nodetree-fold-left proc base x))
+    (lambda (l x r)
+      (define base* (digits-fold-left proc base l))
+      (define base** (ftree-fold-left proc base* x))
+      (digits-fold-left proc base** r))))
+
+(define (insert-front ftree val monoid)
+  (ftree-case ftree
+    (lambda ()
+      (make-single val))
+    (lambda (a)
+      (make-rib monoid (list val) (make-empty) (list a)))
+    (lambda (l m r)
+      (if (= (length l) 4)
+          (make-rib monoid
+                    (list val (car l))
+                    (insert-front m (apply make-node3 monoid (cdr l)) monoid)
+                    r)
+          (make-rib monoid (cons val l) m r)))))
+
+(define (view-front ftree empty-k cons-k monoid)
+  (ftree-case ftree
+              empty-k
+              (lambda (a)
+                (cons-k a (make-empty)))
+              (lambda (l r m)
+                (cons-k (car l)
+                        (rib-l (cdr l) r m monoid)))))
+
+(define (list->tree l monoid)
+  (fold-right (lambda (val tree)
+                (insert-front tree val monoid))
+              (make-empty)
+              l))
+
+(define (rib-l l m r monoid)
+  (if (null? l)
+      (view-front m
+        (lambda ()
+          (list->tree r monoid))
+        (lambda (x xs)
+          (make-rib monoid
+                    (node->list x)
+                    xs
+                    r))
+        monoid)
+      (make-rib monoid l m r)))
+
+(define (remove-front ftree monoid)
+  (view-front ftree
+    (lambda ()
+      (error 'remove-front "can't remove from an empty tree"))
+    values
+    monoid))
+
+(define (insert-rear ftree val monoid)
+  (ftree-case ftree
+    (lambda ()
+      (make-single val))
+    (lambda (a)
+      (make-rib monoid (list a) (make-empty) (list val)))
+    (lambda (l m r)
+      ;; TODO: should r be maintained in reverse order, rather than
+      ;; normal?
+      ;; yes! it will make concatenation slightly slower, but will
+      ;; speed up inserts and removals
+      (if (= (length r) 4)
+          (make-rib monoid
+                    l
+                    (insert-rear m (apply make-node3 monoid (take r 3)) monoid)
+                    (list (list-ref r 3) val))
+          (make-rib monoid l m (snoc r val))))))
+
+(define (remove-rear ftree monoid)
+  (view-rear ftree
+    (lambda ()
+      (error 'remove-rear "can't remove from an empty tree"))
+    values
+    monoid))
+
+(define (view-rear ftree empty-k snoc-k monoid)
+  (ftree-case ftree
+              empty-k
+              (lambda (a)
+                (snoc-k (make-empty) a))
+              (lambda (l r m)
+                (snoc-k (rib-r l r (but-last m) monoid)
+                        (last m)))))
+
+(define (rib-r l m r monoid)
+  (if (null? r)
+      (view-rear m
+        (lambda ()
+          (list->tree l monoid))
+        (lambda (m* r*)
+          (make-rib monoid l m* (node->list r*)))
+        monoid)
+      (make-rib monoid l m r)))
+
+(define (insert-front/list tree l monoid)
+  (fold-right (lambda (val tree)
+                (insert-front tree val monoid))
+              tree
+              l))
+
+(define (insert-rear/list tree l monoid)
+  (fold-left (lambda (tree val)
+                (insert-rear tree val monoid))
+              tree
+              l))
+
+(define (app3 ftree1 ts ftree2 monoid)
+  (cond ((empty? ftree1)
+         (insert-front/list ftree2 ts monoid))
+        ((empty? ftree2)
+         (insert-rear/list ftree1 ts monoid))
+        ((single? ftree1)
+         (insert-front (insert-front/list ftree2 ts monoid)
+                       (single-value ftree1)
+                       monoid))
+        ((single? ftree2)
+         (insert-rear (insert-rear/list ftree1 ts monoid)
+                      (single-value ftree2)
+                      monoid))
+        (else
+         (let ((l1 (rib-left ftree1))
+               (m1 (rib-middle ftree1))
+               (r1 (rib-right ftree1))
+               (l2 (rib-left ftree2))
+               (m2 (rib-middle ftree2))
+               (r2 (rib-right ftree2)))
+           (make-rib monoid
+                     l1
+                     (app3 m1
+                           (nodes (append r1 ts l2) monoid)
+                           m2
+                           monoid)
+                     r2)))))
+
+(define (nodes lst monoid)
+  ;; *sigh*
+  (let ((a (car lst))
+        (b (cadr lst)))
+    (cond ((null? (cddr lst))
+           (list (make-node2 monoid a b)))
+          ((null? (cdddr lst))
+           (list (make-node3 monoid a b (caddr lst))))
+          ((null? (cddddr lst))
+           (list (make-node2 monoid a b)
+                 (make-node2 monoid (caddr lst) (cadddr lst))))
+          (else
+           (cons (make-node3 monoid a b (caddr lst))
+                 (nodes (cdddr lst) monoid))))))
+
+(define (reverse-tree tree monoid)
+  (ftree-case tree
+    (lambda () (make-empty))
+    (lambda (x) (make-single (reverse-nodetree x monoid)))
+    (lambda (l x r)
+      (make-rib monoid
+                (reverse-digit r monoid)
+                (reverse-tree x monoid)
+                (reverse-digit l monoid)))))
+
+(define (reverse-digit l monoid)
+  (map-reverse (lambda (a) (reverse-nodetree a monoid)) l))
+
+(define (reverse-nodetree l monoid)
+  (cond ((node2? l)
+         (make-node2 monoid
+                     (reverse-nodetree (node2-b l) monoid)
+                     (reverse-nodetree (node2-a l) monoid)))
+        ((node3? l)
+         (make-node3 monoid
+                     (reverse-nodetree (node3-c l) monoid)
+                     (reverse-nodetree (node3-b l) monoid)
+                     (reverse-nodetree (node3-a l) monoid)))
+        (else l)))
+
+;; generalising fingertrees with monoids
+
+;; I think I'm going to need a "configuration" type and pass it around
+;; in order to generalize over arbitrary monoids
+;; call the type iMeasured or something
+
+(define-record-type monoid*
+  ;; a monoid, but augmented with a procedure to convert objects into the
+  ;; monoid type
+  (fields (immutable empty mempty)
+          (immutable append mappend)
+          (immutable convert mconvert)))
+
+(define (measure-digit obj monoid)
+  (fold-left (lambda (i a)
+               ((mappend monoid) i (measure-nodetree a monoid)))
+             (mempty monoid)
+             obj))
+
+(define (measure-ftree obj monoid)
+  (cond ((empty? obj)
+         (mempty monoid))
+        ((single? obj)
+         (measure-nodetree (single-value obj) monoid))
+        (else
+         (rib-measure obj))))
+
+(define (measure-nodetree obj monoid)
+  (cond ((node2? obj) (node2-measure obj))
+        ((node3? obj) (node3-measure obj))
+        (else ((mconvert monoid) obj))))
+
+(define (split proc tree monoid)
+  (if (empty? tree)
+      (values (make-empty) (make-empty))
+      (if (proc (measure-ftree tree monoid))
+          (let-values (((l x r) (split-tree proc (mempty monoid) tree monoid)))
+            (values l (insert-front r x monoid)))
+          (values tree (make-empty)))))
+
+(define (split-tree proc i tree monoid)
+  (ftree-case tree
+    (lambda ()
+      (error 'split-tree "shouldn't happen?"))
+    (lambda (a)
+      (values (make-empty) a (make-empty)))
+    (lambda (l m r)
+      (define app (mappend monoid))
+      (define vpr (app i (measure-digit l monoid)))
+      (define vm  (app vpr (measure-ftree m monoid)))
+      (cond ((proc vpr)
+             (let-values (((l* x* r*) (split-digit proc i l monoid)))
+               (values (list->tree l* monoid)
+                       x*
+                       (rib-l r* m r monoid))))
+            ((proc vm)
+             (let*-values (((ml xs mr) (split-tree proc vpr m monoid))
+                           ((l* x* r*)
+                            (split-digit proc
+                                         (app vpr (measure-ftree ml monoid))
+                                         (node->list xs)
+                                         monoid)))
+               (values (rib-r l ml l* monoid)
+                       x*
+                       (rib-l r* mr r monoid))))
+            (else
+             (let-values (((l* x* r*) (split-digit proc vm r monoid)))
+               (values (rib-r l m l* monoid)
+                       x*
+                       (list->tree r* monoid))))))))
+
+(define (split-digit proc i xs monoid)
+  (if (null? (cdr xs))
+      (values '() (car xs) '())
+      (let ((i* ((mappend monoid) i (measure-nodetree (car xs) monoid))))
+        (if (proc i*)
+            (values '() (car xs) (cdr xs))
+            (let-values (((l x r)
+                          (split-digit proc i* (cdr xs) monoid)))
+              (values (cons (car xs) l) x r))))))
+
+;; exported interface
+(define-condition-type &fingertree-empty
+  &assertion
+  make-fingertree-empty-condition
+  fingertree-empty-condition?)
+
+(define-record-type (fingertree %make-fingertree fingertree?)
+  (fields tree monoid))
+
+(define (%wrap fingertree tree)
+  (%make-fingertree tree
+                    (fingertree-monoid fingertree)))
+
+(define (make-fingertree id append convert)
+  (%make-fingertree (make-empty)
+                    (make-monoid* id append convert)))
+
+(define (fingertree-cons a fingertree)
+  ;; TODO: should it obey normal cons interface, or have fingertree
+  ;; first?
+  (%wrap fingertree
+         (insert-front (fingertree-tree fingertree)
+                       a
+                       (fingertree-monoid fingertree))))
+
+(define (fingertree-snoc fingertree a)
+  (%wrap fingertree
+         (insert-rear (fingertree-tree fingertree)
+                      a
+                      (fingertree-monoid fingertree))))
+
+(define (fingertree-uncons fingertree)
+  (call-with-values
+      (lambda ()
+        (define t (fingertree-tree fingertree))
+        (when (empty? t)
+          (raise
+           (condition
+            (make-fingertree-empty-condition)
+            (make-who-condition 'fingertree-uncons)
+            (make-message-condition "There are no elements to uncons")
+            (make-irritants-condition (list fingertree)))))
+        (remove-front t (fingertree-monoid fingertree)))
+    (lambda (val rest)
+      (values val
+              (%wrap fingertree rest)))))
+
+(define (fingertree-unsnoc fingertree)
+  (call-with-values
+      (lambda ()
+        (define t (fingertree-tree fingertree))
+        (when (empty? t)
+          (raise
+           (condition
+            (make-fingertree-empty-condition)
+            (make-who-condition 'fingertree-unsnoc)
+            (make-message-condition "There are no elements to unsnoc")
+            (make-irritants-condition (list fingertree)))))
+        (remove-rear t (fingertree-monoid fingertree)))
+    (lambda (rest val)
+      (values (%wrap fingertree rest) val))))
+
+(define (fingertree-empty? fingertree)
+  (empty? (fingertree-tree fingertree)))
+
+(define (fingertree-append fingertree1 fingertree2)
+  (%wrap fingertree1
+         (app3 (fingertree-tree fingertree1)
+               '()
+               (fingertree-tree fingertree2)
+               (fingertree-monoid fingertree1))))
+
+;; TODO: fix this
+(define (list->fingertree l id append convert)
+  (define monoid (make-monoid* id append convert))
+  (%make-fingertree (list->tree l monoid) monoid))
+
+(define (fingertree->list t)
+  (fingertree-fold-right cons '() t))
+
+(define (fingertree-measure fingertree)
+  (measure-ftree (fingertree-tree fingertree)
+                 (fingertree-monoid fingertree)))
+
+
+(define (fingertree-split p fingertree)
+  (call-with-values
+      (lambda ()
+        (split p
+               (fingertree-tree fingertree)
+               (fingertree-monoid fingertree)))
+    (lambda (a b)
+      (values (%wrap fingertree a)
+              (%wrap fingertree b)))))
+
+(define (fingertree-split3 p fingertree)
+  (call-with-values
+      (lambda ()
+        (define monoid (fingertree-monoid fingertree))
+        (split-tree p
+                    (mempty monoid)
+                    (fingertree-tree fingertree)
+                    monoid))
+    (lambda (a b c)
+      (values (%wrap fingertree a)
+              b
+              (%wrap fingertree c)))))
+
+(define (fingertree-fold f b fingertree)
+  (ftree-fold-left f b (fingertree-tree fingertree)))
+
+(define (fingertree-fold-right f b fingertree)
+  (ftree-fold-right f b (fingertree-tree fingertree)))
+
+(define (fingertree-reverse fingertree)
+  (%wrap fingertree
+         (reverse-tree (fingertree-tree fingertree)
+                       (fingertree-monoid fingertree))))
+
+)
+
+;;; hamts.sls --- Hash Array Mapped Tries
+
+;; Copyright (C) 2014 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;; Documentation:
+;;
+;; Note: For all procedures which take a key as an argument, the key
+;; must be hashable with the hamt hash function, and comparable with
+;; the hamt equivalence predicate.
+;;
+;; make-hamt : (any -> non-negative integer) (any -> any -> boolean) -> hamt
+;; returns a new empty hamt using the given hash and equivalence functions.
+;;
+;; hamt? : any -> boolean
+;; returns #t if argument is a hamt, #f otherwise.
+;;
+;; hamt-size : hamt -> non-negative integer
+;; returns the number of associations in the hamt.
+;;
+;; hamt-ref : hamt any [any] -> any
+;; returns the value associated with the key in the hamt. If there is
+;; no value associated with the key, it returns the default value if
+;; provided, or raises an &assertion-violation if it isn't.
+;;
+;; hamt-contains? : hamt any -> boolean
+;; returns #t if there is an association for the key in the hamt, #f
+;; otherwise.
+;;
+;; hamt-set : hamt any any -> hamt
+;; returns a new hamt with the key associated to the value. If the key
+;; is already associated with a value, it is replaced.
+;;
+;; hamt-update : hamt any (any -> any) any -> hamt
+;; returns a new hamt with the valued associated with the key updated
+;; by the update procedure. If the hamt does not already have a value
+;; associated with the key, then it applies the update procedure to
+;; the default value, and associates the key with that.
+;;
+;; hamt-delete : hamt any -> hamt
+;; returns a hamt with the key and its associated value removed. If
+;; the key is not in the hamt, a copy of the original hamt is
+;; returned.
+;;
+;; hamt-fold : (any any any -> any) any hamt -> hamt
+;; returns the value obtained by iterating the combine procedure over
+;; each key value pair in the hamt. The combine procedure takes three
+;; arguments, the key and value of an association, and an accumulator,
+;; and returns a new accumulator value. The initial value of the
+;; accumulator is provided by the base argument. The order in which
+;; the hamt is traversed is not guaranteed.
+;;
+;; hamt-map : (any -> any) hamt -> hamt
+;; returns the hamt obtained by applying the update procedure to each
+;; of the values in the hamt.
+;;
+;; hamt->alist : hamt -> Listof(Pairs)
+;; returns the key/value associations of the hamt as a list of pairs.
+;; The order of the list is not guaranteed.
+;;
+;; alist->hamt : Listof(Pairs) (any -> non-negative integer) (any -> any -> boolean) -> hamt
+;; returns the hamt containing the associations specified by the pairs
+;; in the alist. If the same key appears in the alist multiple times,
+;; its leftmost value is the one that is used.
+;;
+;; hamt-equivalence-predicate : hamt -> (any -> any -> boolean)
+;; returns the procedure used internally by the hamt to compare keys.
+;;
+;; hamt-hash-function : hamt -> (any -> non-negative integer)
+;; returns the hash procedure used internally by the hamt.
+;;
+(library (pfds hamts)
+(export make-hamt
+        hamt?
+        hamt-size
+        hamt-ref
+        hamt-set
+        hamt-update
+        hamt-delete
+        hamt-contains?
+        hamt-equivalence-predicate
+        hamt-hash-function
+        hamt-fold
+        hamt-map
+        hamt->alist
+        alist->hamt
+        )
+(import (rnrs)
+        (pfds private vectors)
+        (pfds private alists)
+        (pfds private bitwise))
+
+;;; Helpers
+
+(define cardinality 32) ; 64
+
+(define (mask key level)
+  (bitwise-arithmetic-shift-right (bitwise-and key (- (expt 2 5) 1)) level))
+
+(define (level-up level)
+  (+ level 5))
+
+(define (ctpop key index)
+  (bitwise-bit-count (bitwise-arithmetic-shift-right key (+ 1 index))))
+
+;;; Node types
+
+(define-record-type (subtrie %make-subtrie subtrie?)
+  (fields size bitmap vector))
+
+(define (make-subtrie bitmap vector)
+  (define vecsize
+    (vector-fold (lambda (val accum)
+                   (+ (size val) accum))
+                 0
+                 vector))
+  (%make-subtrie vecsize bitmap vector))
+
+(define-record-type leaf
+  (fields key value))
+
+(define-record-type (collision %make-collision collision?)
+  (fields size hash alist))
+
+(define (make-collision hash alist)
+  (%make-collision (length alist) hash alist))
+
+;;; Main
+
+(define (lookup vector key default hash eqv?)
+  (define (handle-subtrie node level)
+    (define bitmap (subtrie-bitmap node))
+    (define vector (subtrie-vector node))
+    (define index (mask h level))
+    (if (not (bitwise-bit-set? bitmap index))
+        default
+        (let ((node (vector-ref vector (ctpop bitmap index))))
+          (cond ((leaf? node)
+                 (handle-leaf node))
+                ((collision? node)
+                 (handle-collision node))
+                (else
+                 (handle-subtrie node (level-up level)))))))
+
+  (define (handle-leaf node)
+    (if (eqv? key (leaf-key node))
+        (leaf-value node)
+        default))
+
+  (define (handle-collision node)
+    (alist-ref (collision-alist node) key default eqv?))
+  
+  (define h (hash key))
+  (define node (vector-ref vector (mask h 0)))
+
+  (cond ((not node) default)
+        ((leaf? node) (handle-leaf node))
+        ((collision? node) (handle-collision node))
+        (else
+         (handle-subtrie node (level-up 0)))))
+
+(define (insert hvector key update base hash eqv?)
+  (define (handle-subtrie subtrie level)
+    (define bitmap (subtrie-bitmap subtrie))
+    (define vector (subtrie-vector subtrie))
+    (define index (mask h level))
+    (define (fixup node)
+      (make-subtrie bitmap (vector-set vector index node)))
+    (if (not (bitwise-bit-set? bitmap index))
+        (make-subtrie (bitwise-bit-set bitmap index)
+                      (vector-insert vector
+                                     (ctpop bitmap index)
+                                     (make-leaf key (update base))))
+        (let ((node (vector-ref vector (ctpop bitmap index))))
+          (cond ((leaf? node)
+                 (fixup (handle-leaf node level)))
+                ((collision? node)
+                 (fixup (handle-collision node level)))
+                (else
+                 (fixup (handle-subtrie node (level-up level))))))))
+
+  (define (handle-leaf node level)
+    (define lkey  (leaf-key node))
+    (define khash (bitwise-arithmetic-shift-right h level))
+    (define lhash (bitwise-arithmetic-shift-right (hash lkey) level))
+    (cond ((eqv? key lkey)
+           (make-leaf key (update (leaf-value node))))
+          ((equal? khash lhash)
+           (make-collision lhash
+                           (list (cons lkey (leaf-value node))
+                                 (cons key (update base)))))
+          (else
+           (handle-subtrie (wrap-subtrie node lhash) (level-up level)))))
+
+  (define (handle-collision node level)
+    (define khash (bitwise-arithmetic-shift-right h level))
+    (define chash (bitwise-arithmetic-shift-right (collision-hash node) level))
+    (if (equal? khash chash)
+        (make-collision (collision-hash node)
+                        (alist-update (collision-alist node) key update base eqv?))
+        ;; TODO: there may be a better (more efficient) way to do this
+        ;; but simple is better for now (see also handle-leaf)
+        (handle-subtrie (wrap-subtrie node chash) (level-up level))))
+
+  (define (wrap-subtrie node chash)
+    (make-subtrie (bitwise-bit-set 0 (mask chash 0)) (vector node)))
+
+  (define h (hash key))
+  (define idx (mask h 0))
+  (define node (vector-ref hvector idx))
+  (define initial-level (level-up 0))
+
+  (cond ((not node)
+         (vector-set hvector idx (make-leaf key (update base))))
+        ((leaf? node)
+         (vector-set hvector idx (handle-leaf node initial-level)))
+        ((collision? node)
+         (vector-set hvector idx (handle-collision node initial-level)))
+        (else
+         (vector-set hvector idx (handle-subtrie node initial-level)))))
+
+(define (delete vector key hash eqv?)
+  (define (handle-subtrie subtrie level)
+    (define bitmap  (subtrie-bitmap subtrie))
+    (define vector  (subtrie-vector subtrie))
+    (define index   (mask h level))
+    (define (fixup node)
+      (update bitmap vector index node))
+    (if (not (bitwise-bit-set? bitmap index))
+        subtrie
+        (let ((node (vector-ref vector (ctpop bitmap index))))
+          (cond ((leaf? node)
+                 (fixup (handle-leaf node)))
+                ((collision? node)
+                 (fixup (handle-collision node)))
+                (else
+                 (fixup (handle-subtrie node (level-up level))))))))
+
+  (define (update bitmap vector index value)
+    (if value
+        (make-subtrie bitmap (vector-set vector index value))
+        (let ((vector* (vector-remove vector index)))
+          (if (equal? '#() vector)
+              #f
+              (make-subtrie (bitwise-bit-unset bitmap index)
+                            vector*)))))
+
+  (define (handle-leaf node)
+    (if (eqv? key (leaf-key node))
+        #f
+        node))
+
+  (define (handle-collision node)
+    (let ((al (alist-delete (collision-alist node) key eqv?)))
+      (cond ((null? (cdr al))
+             (make-leaf (car (car al)) (cdr (car al))))
+            (else
+             (make-collision (collision-hash node) al)))))
+  
+  (define h (hash key))
+  (define idx (mask h 0))
+  (define node (vector-ref vector idx))
+
+  (cond ((not node) vector)
+        ((leaf? node)
+         (vector-set vector idx (handle-leaf node)))
+        ((collision? node)
+         (vector-set vector idx (handle-collision node)))
+        (else
+         (vector-set vector idx (handle-subtrie node (level-up 0))))))
+
+(define (vec-map mapper vector)
+  (define (handle-subtrie trie)
+    (make-subtrie (subtrie-bitmap trie)
+                  (vector-map dispatch (subtrie-vector vector))))
+
+  (define (handle-leaf leaf)
+    (make-leaf (leaf-key leaf)
+               (mapper (leaf-value leaf))))
+
+  (define (handle-collision collision)
+    (make-collision (collision-hash collision)
+                    (map (lambda (pair)
+                           (cons (car pair) (mapper (cdr pair))))
+                         (collision-alist collision))))
+
+  (define (dispatch val)
+    (cond ((leaf? val)
+           (handle-leaf val))
+          ((collision? val)
+           (handle-collision val))
+          (else
+           (handle-subtrie val))))
+
+  (vector-map (lambda (val)
+                ;; top can have #f values
+                (and val (dispatch val)))
+              vector))
+
+(define (fold combine initial vector)
+  (define (handle-subtrie trie accum)
+    (vector-fold dispatch accum (subtrie-vector vector)))
+
+  (define (handle-leaf leaf accum)
+    (combine (leaf-key leaf) (leaf-value leaf) accum))
+
+  (define (handle-collision collision accum)
+    (fold-right (lambda (pair acc)
+                  (combine (car pair) (cdr pair) acc))
+                accum
+                (collision-alist collision)))
+
+  (define (dispatch val accum)
+    (cond ((leaf? val)
+           (handle-leaf val accum))
+          ((collision? val)
+           (handle-collision val accum))
+          (else
+           (handle-subtrie val accum))))
+
+  (vector-fold (lambda (val accum)
+                 ;; top level can have false values
+                 (if (not val) accum (dispatch val accum)))
+               initial
+               vector))
+
+(define (size node)
+  (cond ((not node) 0)
+        ((leaf? node) 1)
+        ((collision? node) (collision-size node))
+        (else (subtrie-size node))))
+
+;;; Exported Interface
+
+(define-record-type (hamt %make-hamt hamt?)
+  (fields size root hash-function equivalence-predicate))
+
+(define (wrap-root root hamt)
+  (define vecsize
+    (vector-fold (lambda (val accum)
+                   (+ (size val) accum))
+                 0
+                 root))
+  (%make-hamt vecsize
+              root
+              (hamt-hash-function hamt)
+              (hamt-equivalence-predicate hamt)))
+
+(define (make-hamt hash eqv?)
+  (%make-hamt 0 (make-vector cardinality #f) hash eqv?))
+
+(define hamt-ref
+  (case-lambda
+    ((hamt key)
+     (define token (cons #f #f))
+     (define return-val (hamt-ref hamt key token))
+     (when (eqv? token return-val)
+       (assertion-violation 'hamt-ref "Key is not in the hamt" key))
+     return-val)
+    ((hamt key default)
+     ;; assert hamt?
+     (lookup (hamt-root hamt)
+             key
+             default
+             (hamt-hash-function hamt)
+             (hamt-equivalence-predicate hamt)))))
+
+(define (hamt-set hamt key value)
+  (define root
+    (insert (hamt-root hamt)
+            key
+            (lambda (old) value)
+            'dummy
+            (hamt-hash-function hamt)
+            (hamt-equivalence-predicate hamt)))
+  (wrap-root root hamt))
+
+(define (hamt-update hamt key proc default)
+  (define root
+    (insert (hamt-root hamt)
+            key
+            proc
+            default
+            (hamt-hash-function hamt)
+            (hamt-equivalence-predicate hamt)))
+  (wrap-root root hamt))
+
+(define (hamt-delete hamt key)
+  (define root
+    (delete (hamt-root hamt)
+            key
+            (hamt-hash-function hamt)
+            (hamt-equivalence-predicate hamt)))
+  (wrap-root root hamt))
+
+(define (hamt-contains? hamt key)
+  (define token (cons #f #f))
+  (if (eqv? token (hamt-ref hamt key token))
+      #f
+      #t))
+
+(define (hamt-map mapper hamt)
+  (%make-hamt (hamt-size hamt)
+              (vec-map mapper (hamt-root hamt))
+              (hamt-hash-function hamt)
+              (hamt-equivalence-predicate hamt)))
+
+(define (hamt-fold combine initial hamt)
+  (fold combine initial (hamt-root hamt)))
+
+(define (hamt->alist hamt)
+  (hamt-fold (lambda (key value accumulator)
+               (cons (cons key value) accumulator))
+             '()
+             hamt))
+
+(define (alist->hamt alist hash eqv?)
+  (fold-right (lambda (kv-pair hamt)
+                (hamt-set hamt (car kv-pair) (cdr kv-pair)))
+              (make-hamt hash eqv?)
+              alist))
+
+)
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;; Documentation:
+;;
+;; make-heap : (any any -> bool) -> heap
+;; returns a new empty heap which uses the ordering procedure.
+;;
+;; heap : (any any -> bool) any ... -> heap
+;; return a new heap, ordered by the procedure argument, that contains
+;; all the other arguments as elements.
+;;
+;; heap? : any -> bool
+;; returns #t if the argument is a heap, #f otherwise.
+;;
+;; heap-size : heap -> non-negative integer
+;; returns the number of elements in the heap.
+;;
+;; heap-empty? : heap -> bool
+;; returns #t if the heap contains no elements, #f otherwise.
+;;
+;; heap-min : heap -> any
+;; returns the minimum element in the heap, according the heap's
+;; ordering procedure. If there are no elements, a
+;; &heap-empty-condition is raised.
+;;
+;; heap-delete-min : heap -> heap
+;; returns a new heap containing all the elements of the heap
+;; argument, except for the minimum argument, as determined by the
+;; heap's ordering procedure. If there are no elements, a
+;; &heap-empty-condition is raised.
+;;
+;; heap-pop : any + heap
+;; returns two values: the the minimum value, and a heap obtained by
+;; removing the minimum value from the original heap. If the heap is
+;; empty, a &heap-empty-condition is raised.
+;;
+;; heap-insert : heap any -> heap
+;; returns the new heap obtained by adding the element to those in the
+;; argument heap.
+;;
+;; heap->list : heap -> Listof(any)
+;; returns the heap containing all the elements of the heap. The
+;; elements of the list are ordered according to the heap's ordering
+;; procedure.
+;;
+;; list->heap : Listof(any) (any any -> boolean) -> heap
+;; returns the heap containing all the elements of the list, and using
+;; the procedure argument to order the elements.
+;;
+;; heap-merge : heap heap -> heap
+;; returns the heap containing all the elements of the argument
+;; heaps. The argument heaps are assumed to be using the same ordering
+;; procedure.
+;;
+;; heap-sort : (any any -> bool) list -> list
+;; returns a new list that is a permutation of the argument list, such
+;; that all the elements are ordered by the given procedure.
+;;
+;; heap-ordering-procedure : heap -> (any any -> boolean)
+;; returns the ordering procedure used internally by the heap.
+;;
+;; heap-empty-condition? : any -> bool
+;; returns #t if argument is a &heap-empty condition, #f otherwise.
+;;
+(library (pfds heaps)
+(export make-heap
+        (rename (%heap heap))
+        heap?
+        heap-size
+        heap-empty?
+        heap-min
+        heap-delete-min
+        heap-insert
+        heap-pop
+        heap->list
+        list->heap
+        heap-merge
+        heap-sort
+        (rename (heap-ordering-predicate heap-ordering-procedure))
+        heap-empty-condition?
+        )
+(import (rnrs))
+
+(define-record-type (node %make-node node?)
+  (fields size height value left right))
+
+(define-record-type leaf)
+
+(define (height x)
+  (if (leaf? x)
+      0
+      (node-height x)))
+
+(define (size x)
+  (if (leaf? x)
+      0
+      (node-size x)))
+
+(define (make-node v l r)
+  (define sl (height l))
+  (define sr (height r))
+  (define m (+ 1 (min sl sr)))
+  (define sz (+ 1 (size l) (size r)))
+  (if (< sl sr)
+      (%make-node sz m v r l)
+      (%make-node sz m v l r)))
+
+(define (singleton v)
+  (%make-node 1 0 v (make-leaf) (make-leaf)))
+
+(define (insert tree value prio<?)
+  (merge-trees tree (singleton value) prio<?))
+
+(define (delete-min tree prio<?)
+  (merge-trees (node-left tree)
+               (node-right tree)
+               prio<?))
+
+(define (merge-trees tree1 tree2 prio<?)
+  (cond ((leaf? tree1) tree2)
+        ((leaf? tree2) tree1)
+        ((prio<? (node-value tree2)
+                 (node-value tree1))
+         (make-node (node-value tree2)
+                    (node-left tree2)
+                    (merge-trees tree1
+                                 (node-right tree2)
+                                 prio<?)))
+        (else
+         (make-node (node-value tree1)
+                    (node-left tree1)
+                    (merge-trees (node-right tree1)
+                                 tree2
+                                 prio<?)))))
+
+
+;; outside interface
+(define-record-type (heap %make-heap heap?)
+  (fields tree ordering-predicate))
+
+(define (make-heap priority<?)
+  (%make-heap (make-leaf) priority<?))
+
+(define (%heap < . vals)
+  (list->heap vals <))
+
+(define (heap-size heap)
+  (size (heap-tree heap)))
+
+(define (heap-empty? heap)
+  (leaf? (heap-tree heap)))
+
+(define (heap-min heap)
+  (when (heap-empty? heap)
+    (raise (condition
+            (make-heap-empty-condition)
+            (make-who-condition 'heap-min)
+            (make-message-condition "There is no minimum element.")
+            (make-irritants-condition (list heap)))))
+  (node-value (heap-tree heap)))
+
+(define (heap-delete-min heap)
+  (when (heap-empty? heap)
+    (raise (condition
+            (make-heap-empty-condition)
+            (make-who-condition 'heap-delete-min)
+            (make-message-condition "There is no minimum element.")
+            (make-irritants-condition (list heap)))))
+  (let ((< (heap-ordering-predicate heap)))
+    (%make-heap (delete-min (heap-tree heap) <) <)))
+
+(define (heap-pop heap)
+  (when (heap-empty? heap)
+    (raise (condition
+            (make-heap-empty-condition)
+            (make-who-condition 'heap-pop)
+            (make-message-condition "There is no minimum element.")
+            (make-irritants-condition (list heap)))))
+  (let* ((tree (heap-tree heap))
+         (top  (node-value tree))
+         (<    (heap-ordering-predicate heap))
+         (rest (delete-min tree <)))
+    (values top
+            (%make-heap rest <))))
+
+(define (heap-insert heap value)
+  (assert (heap? heap))
+  (let ((< (heap-ordering-predicate heap)))
+    (%make-heap (insert (heap-tree heap) value <) <)))
+
+(define (heap->list heap)
+  (assert (heap? heap))
+  (let ((< (heap-ordering-predicate heap)))
+    (let loop ((tree (heap-tree heap)) (list '()))
+      (if (leaf? tree)
+          (reverse list)
+          (loop (delete-min tree <)
+                (cons (node-value tree) list))))))
+
+(define (list->heap list <)
+  (%make-heap
+   (fold-left (lambda (h item)
+                (insert h item <))
+              (make-leaf)
+              list)
+   <))
+
+(define (heap-merge heap1 heap2)
+  (define < (heap-ordering-predicate heap1))
+  (%make-heap
+   (merge-trees (heap-tree heap1)
+                (heap-tree heap2)
+                <)
+   <))
+
+(define (heap-sort < list)
+  (heap->list (list->heap list <)))
+
+(define-condition-type &heap-empty
+  &assertion
+  make-heap-empty-condition
+  heap-empty-condition?)
+)
+(package (pfds (0 3))
+  (depends (wak-trc-testing))
+  (synopsis "Purely Functional Data Structures")
+  (description
+   "A library of data structures for functional programmers."
+   "It contains implementations of:"
+   "- queues"
+   "- deques"
+   "- bbtrees"
+   "- sets"
+   "- dlists"
+   "- priority search queues"
+   "- heaps"
+   "- hamts"
+   "- finger trees"
+   "- sequences")
+  (homepage "http://github.com/ijp/pfds")
+  (documentation
+   "README.org"
+   "LICENSE")
+  (libraries
+   (sls -> "pfds")
+   ("queues" -> ("pdfs" "queues"))
+   ("deques" -> ("pdfs" "deques"))
+   ("private" -> ("pfds" "private"))))
+
+;;; psqs.sls --- Priority Search Queues
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;;; Documentation
+;;
+;; Priority search queues are a combination of two common abstract
+;; data types: finite maps, and priority queues. As such, it provides
+;; for access, insertion, removal and update on arbitrary keys, as
+;; well as for easy removal of the element with the lowest priority.
+;;
+;; Note: where a procedure takes a key or priority these are expected
+;; to be compatible with the relevant ordering procedures on the psq.
+;;
+;;;; Basic operations
+;;
+;; make-psq : < < -> psq
+;; takes a two ordering procedures, one for keys, and another for
+;; priorities, and returns an empty priority search queue
+;;
+;; psq? : obj -> boolean
+;; returns #t if the object is a priority search queue, #f otherwise.
+;;
+;; psq-empty? : psq -> boolean
+;; returns #t if the priority search queue contains no elements, #f
+;; otherwise.
+;;
+;; psq-size : psq -> non-negative integer
+;; returns the number of associations in the priority search queue
+;;
+;;;; Finite map operations
+;;
+;; psq-ref : psq key -> priority
+;; returns the priority of a key if it is in the priority search
+;; queue. If the key is not in the priority queue an
+;; assertion-violation is raised.
+;;
+;; psq-set : psq key priority -> psq
+;; returns the priority search queue obtained from inserting a key
+;; with a given priority. If the key is already in the priority search
+;; queue, it updates the priority to the new value.
+;;
+;; psq-update : psq key (priority -> priority) priority -> psq
+;; returns the priority search queue obtained by modifying the
+;; priority of key, by the given function. If the key is not in the
+;; priority search queue, it is inserted with the priority obtained by
+;; calling the function on the default value.
+;;
+;; psq-delete : psq key -> psq
+;; returns the priority search queue obtained by removing the
+;; key-priority association from the priority search queue. If the key
+;; is not in the queue, then the returned search queue will be the
+;; same as the original.
+;;
+;; psq-contains? : psq key -> boolean
+;; returns #t if there is an association for the given key in the
+;; priority search queue, #f otherwise.
+;;
+;;;; Priority queue operations
+;;
+;; psq-min : psq -> key
+;;
+;; returns the key of the minimum association in the priority search
+;; queue. If the queue is empty, an assertion violation is raised.
+;;
+;; psq-delete-min : psq -> psq
+;; returns the priority search queue obtained by removing the minimum
+;; association in the priority search queue. If the queue is empty, an
+;; assertion violation is raised.
+;;
+;; psq-pop : psq -> key + psq
+;; returns two values: the minimum key and the priority search queue
+;; obtained by removing the minimum association from the original
+;; queue. If the queue is empty, an assertion violation is raised.
+;;
+;;;; Ranged query functions
+;;
+;; psq-at-most : psq priority -> ListOf(key . priority)
+;; returns an alist containing all the associations in the priority
+;; search queue with priority less than or equal to a given value. The
+;; alist returned is ordered by key according to the predicate for the
+;; psq.
+;;
+;; psq-at-most-range : psq priority key key -> ListOf(key . priority)
+;; Similar to psq-at-most, but it also takes an upper and lower bound,
+;; for the keys it will return. These bounds are inclusive.
+;;
+(library (pfds psqs)
+(export make-psq
+        psq?
+        psq-empty?
+        psq-size
+        ;; map operations
+        psq-ref
+        psq-set
+        psq-update
+        psq-delete
+        psq-contains?
+        ;; priority queue operations
+        psq-min
+        psq-delete-min
+        psq-pop
+        ;; ranged query operations
+        psq-at-most
+        psq-at-most-range
+        )
+(import (except (rnrs) min))
+
+;;; record types
+
+(define-record-type void)
+
+(define-record-type winner
+  (fields key priority loser-tree maximum-key))
+
+(define-record-type start)
+
+(define-record-type (loser %make-loser loser?)
+  (fields size key priority left split-key right))
+
+(define (make-loser key priority left split-key right)
+  (%make-loser (+ (size left) (size right) 1)
+               key
+               priority
+               left
+               split-key
+               right))
+
+;;; functions
+(define (maximum-key psq)
+  (winner-maximum-key psq))
+
+(define max-key maximum-key)
+
+(define empty (make-void))
+
+(define (singleton key priority)
+  (make-winner key priority (make-start) key))
+
+(define (play-match psq1 psq2 key<? prio<?)
+  (cond ((void? psq1) psq2)
+        ((void? psq2) psq1)
+        ((not (prio<? (winner-priority psq2)
+                      (winner-priority psq1)))
+         (let ((k1 (winner-key psq1))
+               (p1 (winner-priority psq1))
+               (t1 (winner-loser-tree psq1))
+               (m1 (winner-maximum-key psq1))
+               (k2 (winner-key psq2))
+               (p2 (winner-priority psq2))
+               (t2 (winner-loser-tree psq2))
+               (m2 (winner-maximum-key psq2)))
+           (make-winner k1
+                        p1
+                        (balance k2 p2 t1 m1 t2 key<? prio<?)
+                        m2)))
+        (else
+         (let ((k1 (winner-key psq1))
+               (p1 (winner-priority psq1))
+               (t1 (winner-loser-tree psq1))
+               (m1 (winner-maximum-key psq1))
+               (k2 (winner-key psq2))
+               (p2 (winner-priority psq2))
+               (t2 (winner-loser-tree psq2))
+               (m2 (winner-maximum-key psq2)))
+           (make-winner k2
+                        p2
+                        (balance k1 p1 t1 m1 t2 key<? prio<?)
+                        m2)))))
+
+(define (second-best ltree key key<? prio<?)
+  (if (start? ltree)
+      (make-void)
+      (let ((k (loser-key ltree))
+            (p (loser-priority ltree))
+            (l (loser-left ltree))
+            (m (loser-split-key ltree))
+            (r (loser-right ltree)))
+        (if (not (key<? m k))
+            (play-match (make-winner k p l m)
+                        (second-best r key key<? prio<?)
+                        key<?
+                        prio<?)
+            (play-match (second-best l m key<? prio<?)
+                        (make-winner k p r key)
+                        key<?
+                        prio<?)))))
+
+(define (delete-min psq key<? prio<?)
+  ;; maybe void psqs should return void?
+  (second-best (winner-loser-tree psq) (winner-maximum-key psq) key<? prio<?))
+
+(define (psq-case psq empty-k singleton-k match-k key<?)
+  (if (void? psq)
+      (empty-k)
+      (let ((k1 (winner-key psq))
+            (p1 (winner-priority psq))
+            (t  (winner-loser-tree psq))
+            (m  (winner-maximum-key psq)))
+        (if (start? t)
+            (singleton-k k1 p1)
+            (let ((k2 (loser-key t))
+                  (p2 (loser-priority t))
+                  (l  (loser-left t))
+                  (s  (loser-split-key t))
+                  (r  (loser-right t)))
+              (if (not (key<? s k2))
+                  (match-k (make-winner k2 p2 l s)
+                           (make-winner k1 p1 r m))
+                  (match-k (make-winner k1 p1 l s)
+                           (make-winner k2 p2 r m))))))))
+
+(define (lookup psq key default key<?)
+  (psq-case psq
+            (lambda () default)
+            (lambda (k p)
+              (if (or (key<? k key) (key<? key k))
+                  default
+                  p))
+            (lambda (w1 w2)
+              (if (not (key<? (max-key w1) key))
+                  (lookup w1 key default key<?)
+                  (lookup w2 key default key<?)))
+            key<?))
+
+(define (update psq key f default key<? prio<?)
+  (psq-case psq
+            (lambda () (singleton key (f default)))
+            (lambda (k p)
+              (cond ((key<? key k)
+                     (play-match (singleton key (f default))
+                                 (singleton k p)
+                                 key<?
+                                 prio<?))
+                    ((key<? k key)
+                     (play-match (singleton k p)
+                                 (singleton key (f default))
+                                 key<?
+                                 prio<?))
+                    (else
+                     (singleton key (f p)))))
+            (lambda (w1 w2)
+              (if (not (key<? (max-key w1) key))
+                  (play-match (update w1 key f default key<? prio<?)
+                              w2
+                              key<?
+                              prio<?)
+                  (play-match w1
+                              (update w2 key f default key<? prio<?)
+                              key<?
+                              prio<?)))
+            key<?))
+
+(define (insert psq key val key<? prio<?)
+  (psq-case psq
+            (lambda () (singleton key val))
+            (lambda (k p)
+              (cond ((key<? key k)
+                     (play-match (singleton key val)
+                                 (singleton k p)
+                                 key<?
+                                 prio<?))
+                    ((key<? k key)
+                     (play-match (singleton k p)
+                                 (singleton key val)
+                                 key<?
+                                 prio<?))
+                    (else
+                     (singleton key val))))
+            (lambda (w1 w2)
+              (if (not (key<? (max-key w1) key))
+                  (play-match (insert w1 key val key<? prio<?) w2 key<? prio<?)
+                  (play-match w1 (insert w2 key val key<? prio<?) key<? prio<?)))
+            key<?))
+
+(define (delete psq key key<? prio<?)
+  (psq-case psq
+            (lambda () empty)
+            (lambda (k p)
+              (if (or (key<? k key)
+                      (key<? key k))
+                  (singleton k p)
+                  empty))
+            (lambda (w1 w2)
+              (if (not (key<? (max-key w1) key))
+                  (play-match (delete w1 key key<? prio<?) w2 key<? prio<?)
+                  (play-match w1 (delete w2 key key<? prio<?) key<? prio<?)))
+            key<?))
+
+(define (min tree)
+  (when (void? tree)
+    (assertion-violation 'psq-min
+                         "Can't take the minimum of an empty priority search queue"))
+  (winner-key tree))
+
+(define (pop tree key<? prio<?)
+  (when (void? tree)
+    (assertion-violation 'psq-pop
+                         "Can't pop from an empty priority search queue"))
+  (values (winner-key tree)
+          (delete-min tree key<? prio<?)))
+
+;; at-most and at-most-range are perfect examples of when to use
+;; dlists, but we do not do that here
+(define (at-most psq p key<? prio<?)
+  (define (at-most psq accum)
+    (if (and (winner? psq)
+             (prio<? p (winner-priority psq)))
+        accum
+        (psq-case psq
+                  (lambda () accum)
+                  (lambda (k p) (cons (cons k p) accum))
+                  (lambda (m1 m2)
+                    (at-most m1 (at-most m2 accum)))
+                  key<?)))
+  (at-most psq '()))
+
+(define (at-most-range psq p lower upper key<? prio<?)
+  (define (within-range? key)
+    ;; lower <= k <= upper
+    (not (or (key<? key lower) (key<? upper key))))
+  (define (at-most psq accum)
+    (if (and (winner? psq)
+             (prio<? p (winner-priority psq)))
+        accum
+        (psq-case psq
+                  (lambda () accum)
+                  (lambda (k p)
+                    (if (within-range? k)
+                        (cons (cons k p) accum)
+                        accum))
+                  (lambda (m1 m2)
+                    (let ((accum* (if (key<? upper (max-key m1))
+                                      accum
+                                      (at-most m2 accum))))
+                      (if (key<? (max-key m1) lower)
+                          accum*
+                          (at-most m1 accum*))))
+                  key<?)))
+  (at-most psq '()))
+
+;;; Maintaining balance
+(define weight 4) ; balancing constant
+
+(define (size ltree)
+  (if (start? ltree)
+      0
+      (loser-size ltree)))
+
+(define (balance key priority left split-key right key<? prio<?)
+  (let ((l-size (size left))
+        (r-size (size right)))
+    (cond ((< (+ l-size r-size) 2)
+           (make-loser key priority left split-key right))
+          ((> r-size (* weight l-size))
+           (balance-left key priority left split-key right key<? prio<?))
+          ((> l-size (* weight r-size))
+           (balance-right key priority left split-key right key<? prio<?))
+          (else
+           (make-loser key priority left split-key right)))))
+
+(define (balance-left key priority left split-key right key<? prio<?)
+  (if (< (size (loser-left right))
+         (size (loser-right right)))
+      (single-left key priority left split-key right key<? prio<?)
+      (double-left key priority left split-key right key<? prio<?)))
+
+(define (balance-right key priority left split-key right key<? prio<?)
+  (if (< (size (loser-right left))
+         (size (loser-left left)))
+      (single-right key priority left split-key right key<? prio<?)
+      (double-right key priority left split-key right key<? prio<?)))
+
+(define (single-left key priority left split-key right key<? prio<?)
+  (let ((right-key (loser-key right))
+        (right-priority (loser-priority right))
+        (right-left (loser-left right))
+        (right-split-key (loser-split-key right))
+        (right-right (loser-right right)))
+    ;; test
+    (if (and (not (key<? right-split-key right-key))
+             (not (prio<? right-priority priority)))
+        (make-loser key
+                    priority
+                    (make-loser right-key right-priority left split-key right-left)
+                    right-split-key
+                    right-right
+                    )
+        (make-loser right-key
+                    right-priority
+                    (make-loser key priority left split-key right-left)
+                    right-split-key
+                    right-right))))
+
+(define (double-left key priority left split-key right key<? prio<?)
+  (let ((right-key (loser-key right))
+        (right-priority (loser-priority right))
+        (right-left (loser-left right))
+        (right-split-key (loser-split-key right))
+        (right-right (loser-right right)))
+    (single-left key
+                 priority
+                 left
+                 split-key
+                 (single-right right-key
+                               right-priority
+                               right-left
+                               right-split-key
+                               right-right
+                               key<?
+                               prio<?)
+                 key<?
+                 prio<?)))
+
+(define (single-right key priority left split-key right key<? prio<?)
+  (let ((left-key (loser-key left))
+        (left-priority (loser-priority left))
+        (left-left (loser-left left))
+        (left-split-key (loser-split-key left))
+        (left-right (loser-right left)))
+    (if (and (key<? left-split-key left-key)
+             (not (prio<? left-priority priority)))
+        (make-loser key
+                    priority
+                    left-left
+                    left-split-key
+                    (make-loser left-key left-priority left-right split-key right))
+        (make-loser left-key
+                    left-priority
+                    left-left
+                    left-split-key
+                    (make-loser key priority left-right split-key right)))))
+
+(define (double-right key priority left split-key right key<? prio<?)
+  (let ((left-key (loser-key left))
+        (left-priority (loser-priority left))
+        (left-left (loser-left left))
+        (left-split-key (loser-split-key left))
+        (left-right (loser-right left)))
+    (single-right key
+                  priority
+                  (single-left left-key
+                               left-priority
+                               left-left
+                               left-split-key
+                               left-right
+                               key<?
+                               prio<?)
+                  split-key
+                  right
+                  key<?
+                  prio<?)))
+
+;;; Exported Type
+
+(define-record-type (psq %make-psq psq?)
+  (fields key<? priority<? tree))
+
+(define (%update-psq psq new-tree)
+  (%make-psq (psq-key<? psq)
+             (psq-priority<? psq)
+             new-tree))
+
+;;; Exported Procedures
+
+(define (make-psq key<? priority<?)
+  (%make-psq key<? priority<? (make-void)))
+
+(define (psq-empty? psq)
+  (assert (psq? psq))
+  (void? (psq-tree psq)))
+
+(define (psq-ref psq key)
+  (define cookie (cons #f #f))
+  (assert (psq? psq))
+  (let ((val (lookup (psq-tree psq) key cookie (psq-key<? psq))))
+    (if (eq? val cookie)
+        (assertion-violation 'psq-ref "not in tree")
+        val)))
+
+(define (psq-set psq key priority)
+  (assert (psq? psq))
+  (%update-psq psq
+               (insert (psq-tree psq) key priority (psq-key<? psq) (psq-priority<? psq))))
+
+(define (psq-update psq key f default)
+  (assert (psq? psq))
+  (%update-psq psq (update (psq-tree psq) key f default (psq-key<? psq) (psq-priority<? psq))))
+
+(define (psq-delete psq key)
+  (assert (psq? psq))
+  (%update-psq psq (delete (psq-tree psq) key (psq-key<? psq) (psq-priority<? psq))))
+
+(define (psq-contains? psq key)
+  (define cookie (cons #f #f))
+  (assert (psq? psq))
+  (let ((val (lookup (psq-tree psq) key cookie (psq-key<? psq))))
+    (not (eq? val cookie))))
+
+(define (psq-min psq)
+  (assert (psq? psq))
+  (min (psq-tree psq)))
+
+(define (psq-delete-min psq)
+  (assert (and (psq? psq)
+               (not (psq-empty? psq))))
+  (%update-psq psq (delete-min (psq-tree psq) (psq-key<? psq) (psq-priority<? psq))))
+
+(define (psq-pop psq)
+  (assert (psq? psq))
+  (let-values (((min rest) (pop (psq-tree psq) (psq-key<? psq) (psq-priority<? psq))))
+    (values min (%update-psq psq rest))))
+
+(define (psq-at-most psq max-priority)
+  (assert (psq? psq))
+  (let ((tree   (psq-tree psq))
+        (key<?  (psq-key<? psq))
+        (prio<? (psq-priority<? psq)))
+    (at-most tree max-priority key<? prio<?)))
+
+(define (psq-at-most-range psq max-priority min-key max-key)
+  (assert (psq? psq))
+  (let ((tree   (psq-tree psq))
+        (key<?  (psq-key<? psq))
+        (prio<? (psq-priority<? psq)))
+    (at-most-range tree max-priority min-key max-key key<? prio<?)))
+
+(define (psq-size psq)
+  (assert (psq? psq))
+  (let ((tree (psq-tree psq)))
+    (if (winner? tree)
+        (+ 1 (size (winner-loser-tree tree)))
+        0)))
+
+)
+
+;;; queues.sls --- Purely functional queues
+
+;; Copyright (C) 2011,2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;; Commentary:
+;;
+;; A scheme translation of "Simple and Efficient Purely Functional
+;; Queues and Deques" by Chris Okazaki
+;;
+;;
+;;; Documentation:
+;;
+;; make-queue : () -> queue
+;; returns a queue containing no items
+;;
+;; queue? : any -> boolean
+;; tests if an object is a queue
+;;
+;; queue-length : queue -> non-negative integer
+;; returns the number of items in the queue
+;;
+;; queue-empty? : queue -> boolean
+;; returns true if there are no items in the queue, false otherwise
+;;
+;; enqueue : queue any -> queue
+;; returns a new queue with the enqueued item at the end
+;;
+;; dequeue : queue -> value queue
+;; returns two values, the item at the front of the queue, and a new
+;; queue containing the all the other items
+;; raises a &queue-empty condition if the queue is empty
+;;
+;; queue-empty-condition? : object -> boolean
+;; tests if an object is a &queue-empty condition
+;;
+;; queue->list : queue -> listof(any)
+;; returns a queue containing all the items in the list. The order of
+;; the elements in the queue is the same as the order of the elements
+;; in the list.
+;;
+;; list->queue : listof(any) -> queue
+;; returns a list containing all the items in the queue. The order of
+;; the items in the list is the same as the order in the queue.
+;; For any list l, (equal? (queue->list (list->queue l)) l) is #t.
+;;
+(library (pfds queues)
+(export make-queue
+        queue?
+        queue-length
+        queue-empty?
+        enqueue
+        dequeue
+        queue-empty-condition?
+        list->queue
+        queue->list
+        )
+(import (except (rnrs) cons*)
+        (pfds private lazy-lists)
+        (pfds queues private condition)
+        (rnrs r5rs))
+
+(define (rotate l r a)
+  (if (empty? l)
+      (cons* (head r) a)
+      (cons* (head l)
+             (rotate (tail l)
+                     (tail r)
+                     (cons* (head r) a)))))
+
+
+;;; Implementation
+
+(define-record-type (queue %make-queue queue?)
+  (fields
+   (immutable length)
+   (immutable l)
+   (immutable r)
+   (immutable l^)))
+
+
+(define (make-queue)
+  (%make-queue 0 '() '() '()))
+
+(define (enqueue queue item)
+  (let ((len (queue-length queue))
+        (l (queue-l queue))
+        (r (queue-r queue))
+        (l^ (queue-l^ queue)))
+    (makeq (+ len 1) l (cons* item r) l^)))
+
+(define (dequeue queue)
+  (when (queue-empty? queue)
+    ;; (error 'dequeue  "Can't dequeue empty queue")
+    (raise (condition
+            (make-queue-empty-condition)
+            (make-who-condition 'dequeue)
+            (make-message-condition "There are no elements to dequeue")
+            (make-irritants-condition (list queue)))))
+  (let ((len (queue-length queue))
+        (l (queue-l queue))
+        (r (queue-r queue))
+        (l^ (queue-l^ queue)))
+    (values (head l)
+            (makeq (- len 1) (tail l) r l^))))
+
+(define (makeq length l r l^)
+  (if (empty? l^)
+      (let ((l* (rotate l r '())))
+        (%make-queue length l* '() l*))
+      (%make-queue length l r (tail l^))))
+
+(define (queue-empty? queue)
+  (zero? (queue-length queue)))
+
+(define (list->queue list)
+  (fold-left enqueue (make-queue) list))
+
+(define (queue->list queue)
+  (let loop ((rev-list '()) (queue queue))
+    (if (queue-empty? queue)
+        (reverse rev-list)
+        (let-values (((val queue) (dequeue queue)))
+          (loop (cons val rev-list)
+                 queue)))))
+
+)
+
+;;; sequences.sls --- Purely Functional Sequences
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;; Commentary:
+
+;; Sequences are a general-purpose, variable-length collection,
+;; similar to lists, however they support efficient addition and
+;; removal from both ends, and random-access. Like other Scheme
+;; collections, sequences are zero-indexed.
+;;        
+;; make-sequence : () -> sequence
+;; returns a new empty sequence
+;;
+;; sequence any ... -> sequence
+;; returns a new sequence containing all of the argument elements, in the
+;; same order.
+;;
+;; sequence? : any -> bool
+;; returns #t if the argument is a sequence, #f otherwise.
+;;
+;; sequence-empty? : sequence -> bool
+;; returns #t if the argument sequence contains no elements, #f otherwise.
+;;
+;; sequence-size : sequence -> non-negative integer
+;; returns the number of elements in the sequence
+;;
+;; sequence-cons : any sequence -> sequence
+;; return the new sequence created by adding the element to the front of
+;; the sequence.
+;;
+;; sequence-uncons : sequence -> any sequence
+;; returns two values: the first element of the sequence, and a new
+;; sequence containing all but the first element. If the sequence is
+;; empty, a &sequence-empty condition is raised.
+;;
+;; sequence-snoc : sequence any -> sequence
+;; return the new sequence created by adding the element to the end of
+;; the sequence.
+;;
+;; sequence-unsnoc : sequence -> sequence any
+;; returns two values: a new sequence containing all but the last
+;; element of the sequence, and the last element itself. If the
+;; sequence is empty, a &sequence-empty condition is raised.
+;;
+;; sequence-append : sequence sequence -> sequence
+;; returns a new sequence containing all the elements of the first
+;; sequence, followed by all the elements of the second sequence.
+;;
+;; list->sequence : Listof(Any) -> sequence
+;; returns a new sequence containing all the elements of the argument
+;; list, in the same order.
+;;
+;; sequence->list : sequence -> Listof(Any)
+;; returns a new list containing all the elements of the sequence, in the
+;; same order.
+;;
+;; sequence-split-at sequence integer -> sequence + sequence
+;; returns two new sequences, the first containing the first N elements
+;; of the sequence, the second containing the remaining elements. If N is
+;; negative, it returns the empty sequence as the first argument, and the
+;; original sequence as the second argument. Similarly, if N is greater
+;; than the length of the list, it returns the original sequence as the
+;; first argument, and the empty sequence as the second argument.
+;;
+;; Consequently, (let-values (((a b) (sequence-split-at s i)))
+;; (sequence-append a b)) is equivalent to s for all sequences s, and
+;; integers i.
+;;
+;; sequence-take sequence integer -> sequence
+;; returns a new sequence containing the first N elements of the
+;; argument sequence. If N is negative, the empty sequence is
+;; returned. If N is larger than the length of the sequence, the whole
+;; sequence is returned.
+;;
+;; sequence-drop sequence integer -> sequence
+;; returns a new sequence containing all but the first N elements of the
+;; argument sequence. If N is negative, the whole sequence is
+;; returned. If N is larger than the length of the sequence, the empty
+;; sequence is returned.
+;;
+;; sequence-ref : sequence non-negative-integer -> any
+;; returns the element at the specified index in the sequence. If the
+;; index is outside the range 0 <= i < (sequence-size sequence), an
+;; assertion violation is raised.
+;;
+;; sequence-set : sequence non-negative-integer any -> sequence
+;; returns the new sequence obtained by replacing the element at the
+;; specified index in the sequence with the given value. If the index
+;; is outside the range 0 <= i < (sequence-size sequence), an
+;; assertion violation is raised.
+;;
+;; sequence-fold (any -> any -> any) any sequence
+;; returns the value obtained by iterating the combiner procedure over
+;; the sequence in left-to-right order. The combiner procedure takes two
+;; arguments, the value of the position in the sequence, and an
+;; accumulator, and its return value is used as the value of the
+;; accumulator for the next call. The initial accumulator value is given
+;; by the base argument.
+;;
+;; sequence-fold-right (any -> any -> any) any sequence
+;; Like sequence-fold, but the sequence is traversed in right-to-left
+;; order, rather than left-to-right.
+;;
+;; sequence-reverse : sequence -> sequence
+;; returns a new sequence containing all the arguments of the argument
+;; list, in reverse order.
+;;
+;; sequence-map : (any -> any) sequence -> sequence
+;; returns a new sequence obtained by applying the procedure to each
+;; element of the argument sequence in turn.
+;;
+;; sequence-filter : (any -> bool) sequence -> sequence
+;; returns a new sequence containing all the elements of the argument
+;; sequence for which the predicate is true.
+;;
+;; sequence-empty-condition? : any -> bool
+;; returns #t if an object is a &sequence-empty condition, #f otherwise.
+;;
+(library (pfds sequences)
+(export make-sequence
+        sequence?
+        sequence-empty?
+        sequence-size
+        sequence-cons
+        sequence-uncons
+        sequence-snoc
+        sequence-unsnoc
+        sequence-append
+        list->sequence
+        sequence->list
+        (rename (%sequence sequence))
+        sequence-split-at
+        sequence-take
+        sequence-drop
+        sequence-ref
+        sequence-set
+        sequence-fold
+        sequence-fold-right
+        sequence-reverse
+        sequence-map
+        sequence-filter
+        sequence-empty-condition?
+        )
+
+(import (rnrs)
+        (pfds fingertrees))
+
+;; Note: as sequences are not a subtype of fingertrees, but rather a
+;; particular instantiation of them, &sequence-empty is not a subtype
+;; of &fingertree-empty
+(define-condition-type &sequence-empty
+  &assertion
+  make-sequence-empty-condition
+  sequence-empty-condition?)
+
+(define-record-type (sequence %make-sequence sequence?)
+  (fields fingertree))
+
+(define (make-sequence)
+ (%make-sequence (make-fingertree 0 + (lambda (x) 1))))
+
+(define (sequence-empty? seq)
+  (fingertree-empty? (sequence-fingertree seq)))
+
+(define (sequence-size seq)
+  (fingertree-measure (sequence-fingertree seq)))
+
+(define (sequence-cons value seq)
+  (%make-sequence
+   (fingertree-cons value (sequence-fingertree seq))))
+
+(define (sequence-snoc seq value)
+  (%make-sequence
+   (fingertree-snoc (sequence-fingertree seq) value)))
+
+(define (sequence-uncons seq)
+  (call-with-values
+      (lambda ()
+        (define ft (sequence-fingertree seq))
+        (when (fingertree-empty? ft)
+          (raise
+           (condition
+            (make-sequence-empty-condition)
+            (make-who-condition 'sequence-uncons)
+            (make-message-condition "There are no elements to uncons")
+            (make-irritants-condition (list seq)))))
+        (fingertree-uncons ft))
+    (lambda (head tree)
+      (values head (%make-sequence tree)))))
+
+(define (sequence-unsnoc seq)
+  (call-with-values
+      (lambda ()
+        (define ft (sequence-fingertree seq))
+        (when (fingertree-empty? ft)
+          (raise
+           (condition
+            (make-sequence-empty-condition)
+            (make-who-condition 'sequence-unsnoc)
+            (make-message-condition "There are no elements to unsnoc")
+            (make-irritants-condition (list seq)))))
+        (fingertree-unsnoc ft))
+    (lambda (tree last)
+      (values (%make-sequence tree) last))))
+
+(define (sequence-append seq1 seq2)
+  (%make-sequence
+   (fingertree-append (sequence-fingertree seq1)
+                      (sequence-fingertree seq2))))
+
+(define (list->sequence list)
+  (fold-left sequence-snoc
+             (make-sequence)
+             list))
+
+(define (sequence->list seq)
+  (fingertree->list (sequence-fingertree seq)))
+
+(define (%sequence . args)
+  (list->sequence args))
+
+(define (sequence-split-at seq i)
+  (let-values (((l r)
+                (fingertree-split (lambda (x) (< i x))
+                                  (sequence-fingertree seq))))
+    (values (%make-sequence l)
+            (%make-sequence r))))
+
+(define (sequence-take seq i)
+  (let-values (((head tail)
+                (sequence-split-at seq i)))
+    head))
+
+(define (sequence-drop seq i)
+  (let-values (((head tail)
+                (sequence-split-at seq i)))
+    tail))
+
+(define (sequence-ref seq i)
+  (define size (sequence-size seq))
+  (unless (and (<= 0 i) (< i size))
+    (assertion-violation 'sequence-ref "Index out of range" i))
+  (let-values (((_l x _r)
+                (fingertree-split3 (lambda (x) (< i x))
+                                   (sequence-fingertree seq))))
+    x))
+
+(define (sequence-set seq i val)
+  (define size (sequence-size seq))
+  (unless (and (<= 0 i) (< i size))
+    (assertion-violation 'sequence-set "Index out of range" i))
+  (let-values (((l x r)
+                (fingertree-split3 (lambda (x) (< i x))
+                                   (sequence-fingertree seq))))
+    (%make-sequence
+     (fingertree-append l (fingertree-cons val r)))))
+
+(define (sequence-fold proc base seq)
+  (fingertree-fold proc base (sequence-fingertree seq)))
+
+(define (sequence-fold-right proc base seq)
+  (fingertree-fold-right proc base (sequence-fingertree seq)))
+
+(define (sequence-reverse seq)
+  (%make-sequence (fingertree-reverse (sequence-fingertree seq))))
+
+(define (sequence-map proc seq)
+  (define (combine element seq)
+    (sequence-cons (proc element) seq))
+  (sequence-fold-right combine (make-sequence) seq))
+
+(define (sequence-filter pred? seq)
+  (define (combine element seq)
+    (if (pred? element)
+        (sequence-cons element seq)
+        seq))
+  (sequence-fold-right combine (make-sequence) seq))
+
+)
+
+;;; sets.sls --- Purely Functional Sets
+
+;; Copyright (C) 2012 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;; Documentation:
+;;
+;; set? : any -> boolean
+;; returns #t if the object is a set, #f otherwise
+;;
+;; make-set : (any any -> boolean) -> set
+;; returns a new empty set ordered by the < procedure
+;;
+;; set-member? : set any -> boolean
+;; returns true if element is in the set
+;;
+;; set-insert : set any -> set
+;; returns a new set created by inserting element into the set argument
+;;
+;; set-remove : set element -> set
+;; returns a new set created by removing element from the set
+;;
+;; set-size : set -> non-negative integer
+;; returns the number of elements in the set
+;;
+;; set<? : set set -> boolean
+;; returns #t if set1 is a proper subset of set2, #f otherwise. That
+;; is, if all elements of set1 are in set2, and there is at least one
+;; element of set2 not in set1.
+;;
+;; set<=? : set set -> boolean
+;; returns #t if set1 is a subset of set2, #f otherwise, i.e. if all
+;; elements of set1 are in set2.
+;;
+;; set=? : set set -> boolean
+;; returns #t if every element of set1 is in set2, and vice versa, #f
+;; otherwise.
+;;
+;; set>=? : set set -> boolean
+;; returns #t if set2 is a subset of set1, #f otherwise.
+;;
+;; set>? : set set -> boolean
+;; returns #t if set2 is a proper subset of set1, #f otherwise.
+;;
+;; subset? : set set -> boolean
+;; same as set<=?
+;;
+;; proper-subset? : set set -> boolean
+;; same as set<?
+;;
+;; set-map : (any -> any) set -> set
+;; returns the new set created by applying proc to each element of the set
+;;
+;; set-fold : (any any -> any) any set -> any
+;; returns the value obtained by iterating the procedure over each
+;; element of the set and an accumulator value. The value of the
+;; accumulator is initially base, and the return value of proc is used
+;; as the accumulator for the next iteration.
+;;
+;; list->set : Listof(any) (any any -> any) -> set
+;; returns the set containing all the elements of the list, ordered by <.
+;;
+;; set->list : set -> Listof(any)
+;; returns all the elements of the set as a list
+;;
+;; set-union : set set -> set
+;; returns the union of set1 and set2, i.e. contains all elements of
+;; set1 and set2.
+;;
+;; set-intersection : set set -> set
+;; returns the intersection of set1 and set2, i.e. the set of all
+;; items that are in both set1 and set2.
+;;
+;; set-difference : set set -> set
+;; returns the difference of set1 and set2, i.e. the set of all items
+;; in set1 that are not in set2.
+;;
+;; set-ordering-procedure : set -> (any any -> boolean)
+;; returns the ordering procedure used internall by the set.
+(library (pfds sets)
+(export set?
+        make-set
+        set-member?
+        set-insert
+        set-remove
+        set-size
+        set<?
+        set<=?
+        set=?
+        set>=?
+        set>?
+        subset?
+        proper-subset?
+        set-map
+        set-fold
+        list->set
+        set->list
+        set-union
+        set-intersection
+        set-difference
+        set-ordering-procedure
+        )
+(import (rnrs)
+        (pfds bbtrees))
+
+(define dummy #f)
+
+;;; basic sets
+(define-record-type (set %make-set set?)
+  (fields tree))
+
+(define (set-ordering-procedure set)
+  (bbtree-ordering-procedure (set-tree set)))
+
+(define (make-set <)
+  (%make-set (make-bbtree <)))
+
+;; provide a (make-equal-set) function?
+
+(define (set-member? set element)
+  (bbtree-contains? (set-tree set) element))
+
+(define (set-insert set element)
+  (%make-set (bbtree-set (set-tree set) element dummy)))
+
+(define (set-remove set element)
+  (%make-set (bbtree-delete (set-tree set) element)))
+
+(define (set-size set)
+  (bbtree-size (set-tree set)))
+
+;;; set equality
+(define (set<=? set1 set2)
+  (let ((t (set-tree set2)))
+    (bbtree-traverse (lambda (k _ l r b)
+                       (and (bbtree-contains? t k)
+                            (l #t)
+                            (r #t)))
+                     #t
+                     (set-tree set1))))
+
+(define (set<? set1 set2)
+  (and (< (set-size set1)
+          (set-size set2))
+       (set<=? set1 set2)))
+
+(define (set>=? set1 set2)
+  (set<=? set2 set1))
+
+(define (set>? set1 set2)
+  (set<? set2 set1))
+
+(define (set=? set1 set2)
+  (and (set<=? set1 set2)
+       (set>=? set1 set2)))
+
+(define subset? set<=?)
+
+(define proper-subset? set<?)
+
+;;; iterators
+(define (set-map proc set)
+  ;; currently restricted to returning a set with the same ordering, I
+  ;; could weaken this to, say, comparing with < on the object-hash,
+  ;; or I make it take a < argument for the result set.
+  (let ((tree (set-tree set)))
+    (%make-set
+     (bbtree-fold (lambda (key _ tree)
+                    (bbtree-set tree (proc key) dummy))
+                  (make-bbtree (bbtree-ordering-procedure tree))
+                  tree))))
+
+(define (set-fold proc base set)
+  (bbtree-fold (lambda (key value base)
+                 (proc key base))
+               base
+               (set-tree set)))
+
+;;; conversion
+(define (list->set list <)
+  (fold-left (lambda (tree element)
+               (set-insert tree element))
+             (make-set <)
+             list))
+
+(define (set->list set)
+  (set-fold cons '() set))
+
+;;; set operations
+(define (set-union set1 set2)
+  (%make-set (bbtree-union (set-tree set1) (set-tree set2))))
+
+(define (set-intersection set1 set2)
+  (%make-set (bbtree-intersection (set-tree set1) (set-tree set2))))
+
+(define (set-difference set1 set2)
+  (%make-set (bbtree-difference (set-tree set1) (set-tree set2))))
+
+)
+
+;; Copyright (C) 2011-2014 Ian Price <ianprice90@googlemail.com>
+
+;; Author: Ian Price <ianprice90@googlemail.com>
+
+;; This program is free software, you can redistribute it and/or
+;; modify it under the terms of the new-style BSD license.
+
+;; You should have received a copy of the BSD license along with this
+;; program. If not, see <http://www.debian.org/misc/bsd.license>.
+
+;;; Code:
+(import (rnrs)
+        (pfds tests queues)
+        (pfds tests deques)
+        (pfds tests bbtrees)
+        (pfds tests sets)
+        (pfds tests psqs)
+        (pfds tests heaps)
+        (pfds tests fingertrees)
+        (pfds tests sequences)
+        (pfds tests hamts)
+        (pfds tests utils)
+        (wak trc-testing))
+
+;; Some schemes use lazy loading of modules, and so I can't just use
+;; (run-test pfds) and rely on the side effects in the other modules
+;; to add them to the pfds parent suite.
+(define-syntax add-tests!
+  (syntax-rules ()
+    ((add-tests! suite ...)
+     (begin (add-test! pfds 'suite suite) ...))))
+
+(add-tests! queues deques bbtrees sets psqs
+            heaps fingertrees sequences hamts)
+
+(run-test pfds)
+(define-library (r7rs-extras all)
+  (import (r7rs-extras higher-order))
+  (include-library-declarations "higher-order.exports.sld")
+  (import (r7rs-extras io))
+  (include-library-declarations "io.exports.sld")
+  (import (r7rs-extras partition))
+  (include-library-declarations "partition.exports.sld")
+  (import (r7rs-extras arithmetic))
+  (include-library-declarations "arithmetic.exports.sld")
+  (import (r7rs-extras pushpop))
+  (include-library-declarations "pushpop.exports.sld")
+  )
+;;; arithmetic.body.scm --- Extra arithmetic operations
+
+;; Copyright © 2014  Taylan Ulrich Bayırlı/Kammer
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: extensions arithmetic number
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; If you're desperate for performance, you might benefit from implementing the
+;; euclidean variants in terms of the floor and ceiling variants for positive
+;; and negative values of `y' respectively.  The floor variants are in the
+;; (scheme base) library and might be more efficient in your implementation.
+
+;; These might also otherwise have significantly more efficient implementations.
+;; Let me know.
+
+;;; Code:
+
+(define-syntax define-divisions
+  (syntax-rules ()
+    ((_ div div-doc quotient quotient-doc remainder remainder-doc x y
+        quotient-expr)
+     (begin
+       (define (div x y)
+         div-doc
+         (let* ((q quotient-expr)
+                (r (- x (* y quotient-expr))))
+           (values q r)))
+       (define (quotient x y)
+         quotient-doc
+         quotient-expr)
+       (define (remainder x y)
+         remainder-doc
+         (- x (* y quotient-expr)))))))
+
+(define-divisions
+  euclidean/
+  "Return Q and R in X = Q*Y + R where 0 <= R < |Y|."
+  euclidean-quotient
+  "Return Q in X = Q*Y + R where 0 <= R < |Y|."
+  euclidean-remainder
+  "Return R in X = Q*Y + R where 0 <= R < |Y|."
+  x y
+  (cond ((positive? y)
+         (floor (/ x y)))
+        ((negative? y)
+         (ceiling (/ x y)))
+        ((zero? y)
+         (error "division by zero"))
+        (else +nan.0)))
+
+(define-divisions
+  ceiling/
+  "Return Q and R in X = Q*Y + R where Q = ceiling(X/Y)."
+  ceiling-quotient
+  "Return Q in X = Q*Y + R where Q = ceiling(X/Y)."
+  ceiling-remainder
+  "Return R in X = Q*Y + R where Q = ceiling(X/Y)."
+  x y
+  (ceiling (/ x y)))
+
+(define-divisions
+  centered/
+  "Return Q and R in X = Q*Y + R where -|Y/2| <= R < |Y/2|."
+  centered-quotient
+  "Return Q in X = Q*Y + R where -|Y/2| <= R < |Y/2|."
+  centered-remainder
+  "Return R in X = Q*Y + R where -|Y/2| <= R < |Y/2|."
+  x y
+  (cond ((positive? y)
+         (floor (+ 1/2 (/ x y))))
+        ((negative? y)
+         (ceiling (+ -1/2 (/ x y))))
+        ((zero? y)
+         (error "division by zero"))
+        (else +nan.0)))
+
+(define-divisions
+  round/
+  "Return Q and R in X = Q*Y + R where Q = round(X/Y)."
+  round-quotient
+  "Return Q in X = Q*Y + R where Q = round(X/Y)."
+  round-remainder
+  "Return R in X = Q*Y + R where Q = round(X/Y)."
+  x y
+  (round (/ x y)))
+
+;;; arithmetic.body.scm ends here
+(export
+ euclidean/
+ euclidean-quotient
+ euclidean-remainder
+ ceiling/
+ ceiling-quotient
+ ceiling-remainder
+ centered/
+ centered-quotient
+ centered-remainder
+ round/
+ round-quotient
+ round-remainder
+ )
+(define-library (r7rs-extras arithmetic)
+  (import (scheme base))
+  (include-library-declarations "arithmetic.exports.sld")
+  (include "arithmetic.body.scm"))
+;;; higher-order.body.scm --- Auxiliary higher-oder procedures
+
+;; Copyright © 2014  Taylan Ulrich Bayırlı/Kammer
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: extensions higher-order
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Miscellaneous higher-oder procedures for creating constant functions,
+;; negating functions, etc.
+
+;;; Code:
+
+(define (const value)
+  "Make a nullary procedure always returning VALUE."
+  (lambda () value))
+
+(define (negate proc)
+  "Make a procedure negating the application of PROC to its arguments."
+  (lambda x (not (apply proc x))))
+
+(define (compose proc . rest)
+  "Functional composition; e.g. ((compose x y) a) = (x (y a))."
+  (if (null? rest)
+      proc
+      (let ((rest-proc (apply compose rest)))
+        (lambda x
+          (let-values ((x (apply rest-proc x)))
+            (apply proc x))))))
+
+(define (pipeline proc . rest)
+  "Reverse functional composition; e.g. ((pipeline x y) a) = (y (x a))."
+  (if (null? rest)
+      proc
+      (let ((rest-proc (apply pipeline rest)))
+        (lambda x
+          (let-values ((x (apply proc x)))
+            (apply rest-proc x))))))
+
+(define (identity . x)
+  "Returns values given to it as-is."
+  (apply values x))
+
+(define (and=> value proc)
+  "If VALUE is true, call PROC on it, else return false."
+  (if value (proc value) value))
+
+;;; higher-order.body.scm ends here
+(export
+ const
+ negate
+ compose
+ pipeline
+ identity
+ and=>
+ )
+(define-library (r7rs-extras higher-order)
+  (import (scheme base))
+  (include-library-declarations "higher-order.exports.sld")
+  (include "higher-order.body.scm"))
+;;; io.body.scm --- Input/Output extensions for R7RS
+
+;; Copyright © 2014  Taylan Ulrich Bayırlı/Kammer
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: extensions io i/o input output input/output
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; R7RS leaves out some conceivable combinations of:
+;; 
+;; [call-]with-(input|output|error)[-(from|to)]-port
+;; 
+;; Some of these are nontrivial and annoying to redefine every time one needs
+;; them.  Others are actually so trivial that their body could be inlined at any
+;; place of usage, but it's nevertheless distracting having to remember which
+;; ones are or aren't in the base library, so we just define them all.
+
+;;; Code:
+
+(define (call-with-input-string string proc)
+  "Applies PROC to an input port fed with STRING."
+  (call-with-port (open-input-string string) proc))
+
+(define (call-with-output-string proc)
+  "Applies PROC to a port feeding a string which is then returned."
+  (let ((port (open-output-string)))
+    (call-with-port port proc)
+    (get-output-string port)))
+
+(define-syntax with-port
+  (syntax-rules ()
+    ((with-port port-param port thunk closer)
+     (parameterize ((port-param port))
+       (call-with-values thunk
+         (lambda vals
+           (closer port)
+           (apply values vals)))))))
+
+(define (with-input-port port thunk)
+  "Closes PORT after calling THUNK with it as the `current-input-port'."
+  (with-port current-input-port port thunk close-input-port))
+
+(define (with-output-port port thunk)
+  "Closes PORT after calling THUNK with it as the `current-output-port'."
+  (with-port current-output-port port thunk close-output-port))
+
+(define (with-error-port port thunk)
+  "Closes PORT after calling THUNK with it as the `current-error-port'."
+  (with-port current-error-port port thunk close-output-port))
+
+(define (with-input-from-port port thunk)
+  "Calls THUNK with PORT as the `current-input-port'.  Doesn't close PORT."
+  (parameterize ((current-input-port port))
+    (thunk)))
+
+(define (with-output-to-port port thunk)
+  "Calls THUNK with PORT as the `current-output-port'.  Doesn't close PORT."
+  (parameterize ((current-output-port port))
+    (thunk)))
+
+(define (with-error-to-port port thunk)
+  "Calls THUNK with PORT as the `current-error-port'.  Doesn't close PORT."
+  (parameterize ((current-error-port port))
+    (thunk)))
+
+(define (with-error-to-file file thunk)
+  "Calls THUNK with `current-error-port' bound to FILE."
+  (with-error-port (open-output-file file) thunk))
+
+(define (with-input-from-string string thunk)
+  "Calls THUNK with `current-input-port' bound to a port fed with STRING."
+  (with-input-port (open-input-string string) thunk))
+
+(define (with-output-to-string thunk)
+  "Calls THUNK with `current-output-port' bound to a port feeding a string which
+is then returned."
+  (let ((port (open-output-string)))
+    (with-output-port port thunk)
+    (get-output-string port)))
+
+(define (with-error-to-string thunk)
+  "Calls THUNK with `current-error-port' bound to a port feeding a string which
+is then returned."
+  (let ((port (open-output-string)))
+    (with-error-port port thunk)
+    (get-output-string port)))
+
+;;; io.body.scm ends here
+(export
+ call-with-input-string
+ call-with-output-string
+ with-input-port
+ with-output-port
+ with-error-port
+ with-input-from-port
+ with-output-to-port
+ with-error-to-port
+ with-error-to-file
+ with-input-from-string
+ with-output-to-string
+ with-error-to-string
+ )
+(define-library (r7rs-extras io)
+  (import (scheme base)
+          (scheme file))
+  (include-library-declarations "io.exports.sld")
+  (include "io.body.scm"))
+;;; partition.body.scm --- Variable-arity partition procedures
+
+;; Copyright © 2014  Taylan Ulrich Bayırlı/Kammer
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: extensions lists partition partitioning
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; `partition' proper is in SRFI-1; we define alternative versions only.
+
+;;; Code:
+
+(define (%partition exclusive? list . procs)
+  (if (null? procs)
+      list
+      (let ((lists (make-list (+ 1 (length procs)) '())))
+        (for-each
+         (lambda (elt)
+           (let loop ((procs procs)
+                      (lists lists)
+                      (match? #f))
+             (if (null? procs)
+                 (when (not match?)
+                   (set-car! lists (cons elt (car lists))))
+                 (if ((car procs) elt)
+                     (begin (set-car! lists (cons elt (car lists)))
+                            (when (not exclusive?)
+                              (loop (cdr procs) (cdr lists) #t)))
+                     (loop (cdr procs) (cdr lists) match?)))))
+         list)
+        (apply values (map reverse lists)))))
+
+(define (partition* list . procs)
+  "Partitions LIST via PROCS, returning PROCS + 1 many lists; the last list
+containing elements that didn't match any procedure.  The ordering of each list
+obeys that of LIST.  If there are elements matching multiple PROCS, it's
+unspecified in which one of the matching lists they appear."
+  (apply %partition #t list procs))
+
+(define (partition+ list . procs)
+  "This is like the `partition*' procedure, but elements matching multiple
+procedures appear in every corresponding list."
+  (apply %partition #f list procs))
+
+;;; partition.body.scm ends here
+(export
+ partition*
+ partition+
+ )
+(define-library (r7rs-extras partition)
+  (import (scheme base))
+  (include-library-declarations "partition.exports.sld")
+  (include "partition.body.scm"))
+;;; pushpop.body.scm --- push! and pop!
+
+;; Copyright © 2014  Taylan Ulrich Bayırlı/Kammer
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; Keywords: extensions push pop
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Dead simple push! and pop!.
+
+;;; Code:
+
+(define-syntax push!
+  (syntax-rules ()
+    ((push! pair value)
+     (set! pair (cons value pair)))))
+
+(define-syntax pop!
+  (syntax-rules ()
+    ((pop! pair)
+     (let ((value (car pair)))
+       (set! pair (cdr pair))
+       value))))
+
+;;; pushpop.body.scm ends here
+(export
+ push!
+ pop!
+ )
+(define-library (r7rs-extras pushpop)
+  (import (scheme base))
+  (include-library-declarations "pushpop.exports.sld")
+  (include "pushpop.body.scm"))
+;;; generic-ref-set --- Generic accessor and modifier operators.
+
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; 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.
+
+;;; Helpers
+
+(define-syntax push!
+  (syntax-rules ()
+    ((_ <list-var> <x>)
+     (set! <list-var> (cons <x> <list-var>)))))
+
+(define (alist->hashtable alist)
+  (let ((table (make-eqv-hashtable 100)))
+    (for-each (lambda (entry)
+                (hashtable-set! table (car entry) (cdr entry)))
+              alist)
+    table))
+
+(define (pair-ref pair key)
+  (cond
+   ((eqv? 'car key)
+    (car pair))
+   ((eqv? 'cdr key)
+    (cdr pair))
+   (else
+    (list-ref pair key))))
+
+(define (pair-set! pair key value)
+  (cond
+   ((eqv? 'car key)
+    (set-car! pair value))
+   ((eqv? 'cdr key)
+    (set-cdr! pair value))
+   (else
+    (list-set! pair key value))))
+
+;;; Record inspection support
+
+(cond-expand
+ ((or (library (srfi 99))
+      (library (rnrs records inspection))
+      (library (r6rs records inspection)))
+  (cond-expand
+   ((not (library (srfi 99)))
+    (define rtd-accessor record-accessor)
+    (define rtd-mutator record-mutator))
+   (else))
+  (define (record-ref record field)
+    (let* ((rtd (record-rtd record))
+           (accessor (rtd-accessor rtd field)))
+      (accessor record)))
+  (define (record-set! record field value)
+    (let* ((rtd (record-rtd record))
+           (mutator (rtd-mutator rtd field)))
+      (mutator record value)))
+  (define record-getter
+    (list (cons record? record-ref)))
+  (define record-setter
+    (list (cons record? record-set!)))
+  (define record-type
+    (list record?)))
+ (else
+  (define record-getter '())
+  (define record-setter '())
+  (define record-type '())))
+
+;;; SRFI-4 support
+
+;;; In some implementations, SRFI-4 vectors are also bytevectors.  We accomodate
+;;; for those implementations by using generic bytevector-ref/set! procedures
+;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also
+;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables.
+
+(cond-expand
+ ((library (srfi 4))
+  (define srfi-4-getters
+    (list (cons s8vector? s8vector-ref)
+          (cons u8vector? u8vector-ref)
+          (cons s16vector? s16vector-ref)
+          (cons u16vector? u16vector-ref)
+          (cons s32vector? s32vector-ref)
+          (cons u32vector? u32vector-ref)
+          (cons s64vector? s64vector-ref)
+          (cons u64vector? u64vector-ref)))
+  (define srfi-4-setters
+    (list (cons s8vector? s8vector-set!)
+          (cons u8vector? u8vector-set!)
+          (cons s16vector? s16vector-set!)
+          (cons u16vector? u16vector-set!)
+          (cons s32vector? s32vector-set!)
+          (cons u32vector? u32vector-set!)
+          (cons s64vector? s64vector-set!)
+          (cons u64vector? u64vector-set!)))
+  (define srfi-4-types
+    (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
+          s64vector? u64vector?))
+  (define srfi-4-getters-table (alist->hashtable srfi-4-getters))
+  (define srfi-4-setters-table (alist->hashtable srfi-4-setters))
+  (define (bytevector-ref bytevector index)
+    (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
+           (getter (if type
+                       (ref srfi-4-getters-table type)
+                       bytevector-u8-ref)))
+      (getter bytevector index)))
+  (define (bytevector-set! bytevector index value)
+    (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
+           (setter (if type
+                       (ref srfi-4-setters-table type)
+                       bytevector-u8-set!)))
+      (setter bytevector index value))))
+ (else
+  (define srfi-4-getters '())
+  (define srfi-4-setters '())
+  (define srfi-4-types '())
+  (define bytevector-ref bytevector-u8-ref)
+  (define bytevector-set! bytevector-u8-set!)))
+
+;;; SRFI-111 boxes support
+
+(cond-expand
+ ((library (srfi 111))
+  (define (box-ref box _field)
+    (unbox box))
+  (define (box-set! box _field value)
+    (set-box! box value))
+  (define box-getter (list (cons box? box-ref)))
+  (define box-setter (list (cons box? box-set!)))
+  (define box-type (list box?)))
+ (else
+  (define box-getter '())
+  (define box-setter '())
+  (define box-type '())))
+
+;;; Main
+
+(define %ref
+  (case-lambda
+    ((object field)
+     (let ((getter (lookup-getter object))
+           (sparse? (sparse-type? object)))
+       (if sparse?
+           (let* ((not-found (cons #f #f))
+                  (result (getter object field not-found)))
+             (if (eqv? result not-found)
+                 (error "Object has no entry for field." object field)
+                 result))
+           (getter object field))))
+    ((object field default)
+     (let ((getter (lookup-getter object)))
+       (getter object field default)))))
+
+(define (%ref* object field . fields)
+  (if (null? fields)
+      (%ref object field)
+      (apply %ref* (%ref object field) fields)))
+
+(define (%set! object field value)
+  (let ((setter (lookup-setter object)))
+    (setter object field value)))
+
+(define ref
+  (getter-with-setter
+   %ref
+   (lambda (object field value)
+     (%set! object field value))))
+
+(define ref*
+  (getter-with-setter
+   %ref*
+   (rec (set!* object field rest0 . rest)
+     (if (null? rest)
+         (%set! object field rest0)
+         (apply set!* (ref object field) rest0 rest)))))
+
+(define ~ ref*)
+
+(define $bracket-apply$ ref*)
+
+(define (lookup-getter object)
+  (or (hashtable-ref getter-table (type-of object) #f)
+      (error "No generic getter for object's type." object)))
+
+(define (lookup-setter object)
+  (or (hashtable-ref setter-table (type-of object) #f)
+      (error "No generic setter for object's type." object)))
+
+(define (sparse-type? object)
+  (memv (type-of object) sparse-types))
+
+(define (type-of object)
+  (find (lambda (pred) (pred object)) type-list))
+
+(define getter-table
+  (alist->hashtable
+   (append
+    (list (cons bytevector? bytevector-ref)
+          (cons hashtable? hashtable-ref)
+          (cons pair? pair-ref)
+          (cons string? string-ref)
+          (cons vector? vector-ref))
+    record-getter
+    srfi-4-getters
+    box-getter)))
+
+(define setter-table
+  (alist->hashtable
+   (append
+    (list (cons bytevector? bytevector-set!)
+          (cons hashtable? hashtable-set!)
+          (cons pair? pair-set!)
+          (cons string? string-set!)
+          (cons vector? vector-set!))
+    record-setter
+    srfi-4-setters
+    box-setter)))
+
+(define sparse-types
+  (list hashtable?))
+
+(define type-list
+  ;; Although the whole SRFI intrinsically neglects performance, we still use
+  ;; the micro-optimization of ordering this list roughly according to most
+  ;; likely match.
+  (append
+   (list hashtable? vector? pair? bytevector? string?)
+   srfi-4-types
+   box-type
+   ;; The record type must be placed last so specific record types (e.g. box)
+   ;; take precedence.
+   record-type
+   ;; Place those types we don't support really last.
+   (list boolean? char? eof-object? null? number? port? procedure? symbol?)))
+
+(define (register-getter-with-setter! type getter sparse?)
+  (push! type-list type)
+  (set! (~ getter-table type) getter)
+  (set! (~ setter-table type) (setter getter))
+  (when sparse?
+    (push! sparse-types type)))
+
+(cond-expand
+ ((not (or (library (srfi 99))
+           (library (rnrs records inspection))
+           (library (r6rs records inspection))))
+  (define-syntax define-record-type
+    (syntax-rules ()
+      ((_ <name> <constructor> <pred> <field> ...)
+       (begin
+         (%define-record-type <name> <constructor> <pred> <field> ...)
+         ;; Throw-away definition to not disturb an internal definitions
+         ;; sequence.
+         (define __throwaway
+           (begin
+             (register-getter-with-setter!
+              <pred>
+              (getter-with-setter (record-getter <field> ...)
+                                  (record-setter <field> ...))
+              #f)
+             ;; Return the implementation's preferred "unspecified" value.
+             (if #f #f)))))))
+
+  (define-syntax record-getter
+    (syntax-rules ()
+      ((_ (<field> <getter> . <rest>) ...)
+       (let ((getters (alist->hashtable (list (cons '<field> <getter>) ...))))
+         (lambda (record field)
+           (let ((getter (or (ref getters field #f)
+                             (error "No such field of record." record field))))
+             (getter record)))))))
+
+  (define-syntax record-setter
+    (syntax-rules ()
+      ((_ . <rest>)
+       (%record-setter () . <rest>))))
+
+  (define-syntax %record-setter
+    (syntax-rules ()
+      ((_ <setters> (<field> <getter>) . <rest>)
+       (%record-setter <setters> . <rest>))
+      ((_ <setters> (<field> <getter> <setter>) . <rest>)
+       (%record-setter ((<field> <setter>) . <setters>) . <rest>))
+      ((_ ((<field> <setter>) ...))
+       (let ((setters (alist->hashtable (list (cons '<field> <setter>) ...))))
+         (lambda (record field value)
+           (let ((setter (or (ref setters field #f)
+                             (error "No such assignable field of record."
+                                    record field))))
+             (setter record value)))))))))
+
+;;; generic-ref-set.body.scm ends here
+(define-library (srfi 123)
+  (export
+   ref ref* ~ register-getter-with-setter!
+   $bracket-apply$
+   set! setter getter-with-setter)
+  (import
+   (except (scheme base) set! define-record-type)
+   (scheme case-lambda)
+   (r6rs hashtables)
+   (srfi 1)
+   (srfi 17)
+   (srfi 31))
+  (cond-expand
+   ;; Favor SRFI-99.
+   ((library (srfi 99))
+    (import (srfi 99)))
+   ;; We assume that if there's the inspection library, there's also the
+   ;; syntactic and procedural libraries.
+   ((library (rnrs records inspection))
+    (import (rnrs records syntactic))
+    (import (rnrs records procedural))
+    (import (rnrs records inspection)))
+   ((library (r6rs records inspection))
+    (import (r6rs records syntactic))
+    (import (r6rs records procedural))
+    (import (r6rs records inspection)))
+   (else
+    (import (rename (only (scheme base) define-record-type)
+                    (define-record-type %define-record-type)))
+    (export define-record-type)))
+  (cond-expand
+   ((library (srfi 4))
+    (import (srfi 4)))
+   (else))
+  (cond-expand
+   ((library (srfi 111))
+    (import (srfi 111)))
+   (else))
+  (include "123.body.scm"))
+;;; generic-ref-set --- Generic accessor and modifier operators.
+
+;; Copyright © 2015  Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; 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-library (tests srfi-123)
+  (export run-tests)
+  (import (except (scheme base) define-record-type set!)
+          (r6rs hashtables)
+          (srfi 64)
+          (srfi 123))
+  (cond-expand
+   ((library (srfi 99))
+    (import (srfi 99)))
+   ((library (rnrs records inspection))
+    (import (rnrs records syntactic))
+    (import (rnrs records procedural)))
+    (import (rnrs records inspection))
+   ((library (r6rs records inspection))
+    (import (r6rs records syntactic))
+    (import (r6rs records procedural)))
+    (import (r6rs records inspection))
+   (else))
+  (cond-expand
+   ((library (srfi 4))
+    (import (srfi 4)))
+   (else
+    (begin
+      ;; Stub to silence compilers.
+      (define s16vector #f))))
+  (cond-expand
+   ((library (srfi 111))
+    (import (srfi 111)))
+   (else
+    (begin
+      ;; Stub to silence compilers.
+      (define box #f))))
+  (begin
+
+    (define-record-type <foo> (make-foo a b) foo?
+      (a foo-a set-foo-a!)
+      (b foo-b))
+
+    ;; The SRFI-99 sample implementation contains a bug where immutable fields
+    ;; are nevertheless mutable through the procedural API.  Test whether we are
+    ;; on that implementation.
+    (cond-expand
+     ((library (srfi 99))
+      (define using-broken-srfi99
+        (guard (err (else #f))
+          (rtd-mutator <foo> 'b))))
+     (else
+      (define using-broken-srfi99 #f)))
+
+    (define (run-tests)
+      (let ((runner (test-runner-create)))
+        (parameterize ((test-runner-current runner))
+          (test-begin "SRFI-123")
+
+          (test-begin "ref")
+          (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1)))
+          (test-assert "hashtable" (let ((table (make-eqv-hashtable)))
+                                     (hashtable-set! table 'foo 0)
+                                     (= 0 (ref table 'foo))))
+          (test-assert "hashtable default" (let ((table (make-eqv-hashtable)))
+                                             (= 1 (ref table 0 1))))
+          (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr)))
+          (test-assert "list" (= 1 (ref (list 0 1 2) 1)))
+          (test-assert "string" (char=? #\b (ref "abc" 1)))
+          (test-assert "vector" (= 1 (ref (vector 0 1 2) 1)))
+          (test-assert "record" (= 1 (ref (make-foo 0 1) 'b)))
+          (cond-expand
+           ((library (srfi 4)) (values))
+           (else               (test-skip 1)))
+          (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1)))
+          (cond-expand
+           ((library (srfi 111)) (values))
+           (else                 (test-skip 1)))
+          (test-assert "srfi-111" (= 1 (ref (box 1) '*)))
+          (test-end "ref")
+
+          (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr)))
+
+          (test-begin "ref setter")
+          (test-assert "bytevector" (let ((bv (bytevector 0 1 2)))
+                                      (set! (ref bv 1) 3)
+                                      (= 3 (ref bv 1))))
+          (test-assert "hashtable" (let ((ht (make-eqv-hashtable)))
+                                     (set! (ref ht 'foo) 0)
+                                     (= 0 (ref ht 'foo))))
+          (test-assert "pair" (let ((p (cons 0 1)))
+                                (set! (ref p 'cdr) 2)
+                                (= 2 (ref p 'cdr))))
+          (test-assert "list" (let ((l (list 0 1 2)))
+                                (set! (ref l 1) 3)
+                                (= 3 (ref l 1))))
+          (test-assert "string" (let ((s (string #\a #\b #\c)))
+                                  (set! (ref s 1) #\d)
+                                  (char=? #\d (ref s 1))))
+          (test-assert "vector" (let ((v (vector 0 1 2)))
+                                  (set! (ref v 1) 3)
+                                  (= 3 (ref v 1))))
+          (test-assert "record" (let ((r (make-foo 0 1)))
+                                  (set! (ref r 'a) 2)
+                                  (= 2 (ref r 'a))))
+          (when using-broken-srfi99
+            (test-expect-fail 1))
+          (test-assert "bad record assignment"
+            (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t)))
+          (cond-expand
+           ((library (srfi 4)) (values))
+           (else               (test-skip 1)))
+          (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2)))
+                                  (set! (ref s16v 1) 3)
+                                  (= 3 (ref s16v 1))))
+          (cond-expand
+           ((library (srfi 111)) (values))
+           (else                 (test-skip 1)))
+          (test-assert "srfi-111" (let ((b (box 0)))
+                                    (set! (ref b '*) 1)
+                                    (= 1 (ref b '*))))
+          (test-end "ref setter")
+
+          (test-assert "ref* setter"
+            (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_)))
+              (set! (ref* obj 1 1 'cdr) 2)
+              (= 2 (ref* obj 1 1 'cdr))))
+
+          (test-end "SRFI-123")
+          (and (= 0 (test-runner-xpass-count runner))
+               (= 0 (test-runner-fail-count runner))))))
+
+    ))
+(import (scheme base)
+        (scheme eval)
+        (scheme process-context))
+
+(if (eval '(run-tests) (environment '(tests srfi-123)))
+    (exit 0)
+    (exit 1))
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; This R7RS code implements (rnrs hashtables) on top of SRFI 69.
+
+;;; Private stuff.
+
+;;; Although SRFI 69 is mostly written as though hash functions take
+;;; just one argument, its reference implementation routinely passes
+;;; a second argument to hash functions, and that arguably incorrect
+;;; behavior has undoubtedly found its way into many implementations
+;;; of SRFI 69.
+;;;
+;;; A unary hash function passed to R6RS make-hashtable is therefore
+;;; unlikely to work when passed to SRFI 69 make-hash-table.  We need
+;;; to convert the unary hash function so it will accept a second
+;;; optional argument, and we also need to arrange for the original
+;;; unary hash function to be returned by hashtable-hash-function.
+;;;
+;;; We'd like to accomplish this while preserving interoperability
+;;; between R6RS hashtables and SRFI 69 hash tables.  That argues
+;;; against implementing R6RS hashtables by records that encapsulate
+;;; a SRFI 69 hash table, which would otherwise be the easy way to
+;;; go about this.
+;;;
+;;; This association list implements a bidirectional mapping between
+;;; one-argument hash functions of R6RS and their representations as
+;;; two-argument hash functions that will work with SRFI 69.
+
+(define table-of-hash-functions '())
+
+;;; Given a unary hash function, returns a hash function that will
+;;; be acceptable to SRFI 69.
+
+(define (make-srfi-69-hash-function hash-function)
+  (lambda (x . rest)
+    (if (null? rest)
+        (hash-function x)
+        (modulo (hash-function x) (car rest)))))
+
+(define (r6rs->srfi69 hash-function)
+  (let ((probe (assoc hash-function table-of-hash-functions)))
+    (if probe
+        (cdr probe)
+        (let ((hasher (make-srfi-69-hash-function hash-function)))
+          (set! table-of-hash-functions
+                (cons (cons hash-function hasher)
+                      table-of-hash-functions))
+          hasher))))
+
+(define (srfi69->r6rs hasher)
+  (define (loop table)
+    (cond ((null? table)
+           hasher)
+          ((equal? hasher (cdr (car table)))
+           (car (car table)))
+          (else
+           (loop (cdr table)))))
+  (loop table-of-hash-functions))  
+
+;;; SRFI 69 doesn't define a hash function that's suitable for use
+;;; with the eqv? predicate, and we need one for make-eqv-hashtable.
+;;;
+;;; The R7RS eqv? predicate behaves the same as eq? for these types:
+;;;
+;;;     symbols
+;;;     booleans
+;;;     empty list
+;;;     pairs
+;;;     records
+;;;     non-empty strings
+;;;     non-empty vectors
+;;;     non-empty bytevectors
+;;;
+;;; eqv? might behave differently when its arguments are:
+;;; 
+;;;     procedures that behave the same but have equal location tags
+;;;     numbers
+;;;     characters
+;;;     empty strings
+;;;     empty vectors
+;;;     empty bytevectors
+;;; 
+;;; If eqv? and eq? behave differently on two arguments x and y,
+;;; eqv? returns true and eq? returns false.
+;;; 
+;;; FIXME: There is no portable way to define a good hash function
+;;; that's compatible with eqv? on procedures and also runs in
+;;; constant time.  This one is compatible with eqv? and runs in
+;;; constant time (on procedures), but isn't any good.
+
+;;; The main thing these numerical constants have in common is that
+;;; they're positive and fit in 24 bits.
+
+(define hash:procedure         9445898)
+(define hash:character        13048478)
+(define hash:empty-string     14079236)
+(define hash:empty-vector      1288342)
+(define hash:empty-bytevector 11753202)
+(define hash:inexact           1134643)
+(define hash:infinity+         2725891)
+(define hash:infinity-         5984233)
+(define hash:nan               7537847)
+(define hash:complex           9999245)
+
+(define (hash-for-eqv x)
+  (cond ((procedure? x)
+         hash:procedure)
+        ((number? x)
+         (cond ((exact-integer? x)
+                x)
+               ((not (real? x))
+                (+ hash:complex (complex-hash x)))
+               ((exact? x)
+                (+ (numerator x) (denominator x)))
+               (else
+                (+ hash:inexact (inexact-hash x)))))
+        ((char? x)
+         (+ hash:character (char->integer x)))
+        ((eqv? x "")
+         hash:empty-string)
+        ((eqv? x '#())
+         hash:empty-vector)
+        ((eqv? x '#u8())
+         hash:empty-bytevector)
+        (else
+         (hash-by-identity x))))
+
+;;; The R6RS distinguishes mutable from immutable hashtables,
+;;; so we have to keep track of that somehow.  Here we remember
+;;; all of the immutable hashtables within a SRFI 69 hash-table.
+;;;
+;;; FIXME: That means the storage occupied by an immutable
+;;; hashtable won't be reclaimed if it becomes otherwise
+;;; inaccessible.
+
+(define immutable-hashtables
+  (make-hash-table eqv? (r6rs->srfi69 hash-table-size)))
+
+(define (complain-if-immutable ht complainant)
+  (if (hash-table-ref/default immutable-hashtables ht #f)
+      (error (string-append (symbol->string complainant)
+                            ": hashtable is immutable")
+             ht)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Exported procedures.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; The R6RS make-eq-hashtable procedure is normally called with
+;;; no arguments, but an optional argument specifies the initial
+;;; capacity of the table.  That optional argument, if present,
+;;; will be ignored by this implementation because it has no
+;;; counterpart in SRFI 69.
+
+(define (make-eq-hashtable . rest)
+  (make-hash-table eq? hash-by-identity))
+
+(define (make-eqv-hashtable . rest)
+  (make-hash-table eqv? (r6rs->srfi69 hash-for-eqv)))
+
+;;; As with make-eq-hashtable and make-eqv-hashtable, the optional
+;;; initial capacity will be ignored.
+
+(define (make-hashtable hash-function equiv . rest)
+  (make-hash-table equiv (r6rs->srfi69 hash-function)))
+
+(define (hashtable? x)
+  (hash-table? x))
+
+(define (hashtable-size ht)
+  (hash-table-size ht))
+
+(define (hashtable-ref ht key default)
+  (hash-table-ref/default ht key default))
+
+(define (hashtable-set! ht key obj)
+  (complain-if-immutable ht 'hashtable-set!)
+  (hash-table-set! ht key obj))
+
+(define (hashtable-delete! ht key)
+  (complain-if-immutable ht 'hashtable-delete!)
+  (hash-table-delete! ht key))
+
+(define (hashtable-contains? ht key)
+  (hash-table-exists? ht key))
+
+(define (hashtable-update! ht key proc default)
+  (complain-if-immutable ht 'hashtable-update!)
+  (hash-table-set! ht
+                   key
+                   (proc (hash-table-ref/default ht key default))))
+
+;;; By default, hashtable-copy returns an immutable hashtable.
+;;; The copy is mutable only if a second argument is passed and
+;;; that second argument is true.
+
+(define (hashtable-copy ht . rest)
+  (let ((mutable? (and (pair? rest) (car rest)))
+        (the-copy (hash-table-copy ht)))
+    (if (not mutable?)
+        (hash-table-set! immutable-hashtables the-copy #t))
+    the-copy))
+
+;;; As usual, the optional "initial" capacity is ignored.
+
+(define (hashtable-clear! ht . rest)
+  (complain-if-immutable ht 'hashtable-update!)
+  (hash-table-walk ht
+                   (lambda (key value)
+                     (hash-table-delete! ht key))))
+
+(define (hashtable-keys ht)
+  (list->vector (hash-table-keys ht)))
+
+(define (hashtable-entries ht)
+  (let* ((keys (hashtable-keys ht))
+         (vals (vector-map (lambda (key)
+                             (hash-table-ref ht key))
+                           keys)))
+    (values keys vals)))
+
+(define (hashtable-equivalence-function ht)
+  (hash-table-equivalence-function ht))
+
+(define (hashtable-hash-function ht)
+  (srfi69->r6rs (hash-table-hash-function ht)))
+
+(define (hashtable-mutable? ht)
+  (not (hash-table-ref/default immutable-hashtables ht #f)))
+
+(define (equal-hash obj)
+  (hash obj))
+
+;;; string-hash is exported by SRFI 69.
+;;; string-ci-hash is exported by SRFI 69.
+
+(define (r6rs:symbol-hash sym)
+  (hash-by-identity sym))
+
+;;; Reference implementation of SRFI 69, from
+;;; http://srfi.schemers.org/srfi-69/srfi-69.html
+
+;;; Copyright © Panu Kalliokoski (2005). All Rights Reserved.
+;;; 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. 
+
+;;; Modification history:
+;;;
+;;; In May 2015, William D Clinger modified this code for use in
+;;; R7RS systems, mainly so it could be used as a last resort in
+;;; the (r6rs hashtables) approximation to (rnrs hashtables).
+;;;
+;;;     string-ci-hash was changed to use R7RS string-foldcase
+;;;
+;;;     string-hash, symbol-hash, and %string-hash were changed
+;;;     to eliminate a now-useless procedure call for each character
+;;;
+;;;     whitespace was adjusted because it got messed up during
+;;;     conversion from HTML to Scheme code
+
+(define *default-bound* (- (expt 2 29) 3))
+
+(define (%string-hash s bound)
+  (let ((hash 31)
+        (len (string-length s)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hash bound))
+      (set! hash (modulo (+ (* 37 hash)
+                            (char->integer (string-ref s index)))
+                         *default-bound*)))))
+
+(define (string-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash s bound)))
+
+(define (string-ci-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash (string-foldcase s) bound)))
+
+(define (symbol-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash (symbol->string s) bound)))
+
+(define (hash obj . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (cond ((integer? obj) (modulo obj bound))
+          ((string? obj) (string-hash obj bound))
+          ((symbol? obj) (symbol-hash obj bound))
+          ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
+          ((number? obj)
+           (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
+                   bound))
+          ((char? obj) (modulo (char->integer obj) bound))
+          ((vector? obj) (vector-hash obj bound))
+          ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
+                               bound))
+          ((null? obj) 0)
+          ((not obj) 0)
+          ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
+          (else 1))))
+
+(define hash-by-identity hash)
+
+(define (vector-hash v bound)
+  (let ((hashvalue 571)
+        (len (vector-length v)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hashvalue bound))
+      (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
+                              *default-bound*)))))
+
+(define %make-hash-node cons)
+(define %hash-node-set-value! set-cdr!)
+(define %hash-node-key car)
+(define %hash-node-value cdr)
+
+(define-record-type <srfi-hash-table>
+  (%make-hash-table size hash compare associate entries)
+  hash-table?
+  (size hash-table-size hash-table-set-size!)
+  (hash hash-table-hash-function)
+  (compare hash-table-equivalence-function)
+  (associate hash-table-association-function)
+  (entries hash-table-entries hash-table-set-entries!))
+
+(define *default-table-size* 64)
+
+(define (appropriate-hash-function-for comparison)
+  (or (and (eq? comparison eq?) hash-by-identity)
+      (and (eq? comparison string=?) string-hash)
+      (and (eq? comparison string-ci=?) string-ci-hash)
+      hash))
+
+(define (make-hash-table . args)
+  (let* ((comparison (if (null? args) equal? (car args)))
+         (hash
+          (if (or (null? args) (null? (cdr args)))
+                  (appropriate-hash-function-for comparison) (cadr args)))
+         (size
+          (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+              *default-table-size* (caddr args)))
+         (association
+          (or (and (eq? comparison eq?) assq)
+              (and (eq? comparison eqv?) assv)
+              (and (eq? comparison equal?) assoc)
+              (letrec
+               ((associate
+                 (lambda (val alist)
+                   (cond ((null? alist) #f)
+                         ((comparison val (caar alist)) (car alist))
+                         (else (associate val (cdr alist)))))))
+               associate))))
+    (%make-hash-table 0 hash comparison association (make-vector size '()))))
+
+(define (make-hash-table-maker comp hash)
+  (lambda args (apply make-hash-table (cons comp (cons hash args)))))
+(define make-symbol-hash-table
+  (make-hash-table-maker eq? symbol-hash))
+(define make-string-hash-table
+  (make-hash-table-maker string=? string-hash))
+(define make-string-ci-hash-table
+  (make-hash-table-maker string-ci=? string-ci-hash))
+(define make-integer-hash-table
+  (make-hash-table-maker = modulo))
+
+(define (%hash-table-hash hash-table key)
+  ((hash-table-hash-function hash-table)
+   key (vector-length (hash-table-entries hash-table))))
+
+(define (%hash-table-find entries associate hash key)
+  (associate key (vector-ref entries hash)))
+
+(define (%hash-table-add! entries hash key value)
+  (vector-set! entries hash
+                       (cons (%make-hash-node key value)
+                             (vector-ref entries hash))))
+
+(define (%hash-table-delete! entries compare hash key)
+  (let ((entrylist (vector-ref entries hash)))
+    (cond ((null? entrylist) #f)
+          ((compare key (caar entrylist))
+           (vector-set! entries hash (cdr entrylist)) #t)
+          (else
+           (let loop ((current (cdr entrylist)) (previous entrylist))
+             (cond ((null? current) #f)
+                   ((compare key (caar current))
+                    (set-cdr! previous (cdr current)) #t)
+                   (else (loop (cdr current) current))))))))
+
+(define (%hash-table-walk proc entries)
+  (do ((index (- (vector-length entries) 1) (- index 1)))
+    ((< index 0)) (for-each proc (vector-ref entries index))))
+
+(define (%hash-table-maybe-resize! hash-table)
+  (let* ((old-entries (hash-table-entries hash-table))
+         (hash-length (vector-length old-entries)))
+    (if (> (hash-table-size hash-table) hash-length)
+        (let* ((new-length (* 2 hash-length))
+               (new-entries (make-vector new-length '()))
+               (hash (hash-table-hash-function hash-table)))
+          (%hash-table-walk
+           (lambda (node)
+             (%hash-table-add! new-entries
+                               (hash (%hash-node-key node) new-length)
+                               (%hash-node-key node) (%hash-node-value node)))
+           old-entries)
+          (hash-table-set-entries! hash-table new-entries)))))
+
+(define (hash-table-ref hash-table key . maybe-default)
+  (cond ((%hash-table-find (hash-table-entries hash-table)
+                           (hash-table-association-function hash-table)
+                           (%hash-table-hash hash-table key) key)
+         => %hash-node-value)
+        ((null? maybe-default)
+         (error "hash-table-ref: no value associated with" key))
+        (else ((car maybe-default)))))
+
+(define (hash-table-ref/default hash-table key default)
+  (hash-table-ref hash-table key (lambda () default)))
+
+(define (hash-table-set! hash-table key value)
+  (let ((hash (%hash-table-hash hash-table key))
+        (entries (hash-table-entries hash-table)))
+    (cond ((%hash-table-find entries
+                             (hash-table-association-function hash-table)
+                             hash key)
+           => (lambda (node) (%hash-node-set-value! node value)))
+          (else (%hash-table-add! entries hash key value)
+                (hash-table-set-size! hash-table
+                                      (+ 1 (hash-table-size hash-table)))
+                (%hash-table-maybe-resize! hash-table)))))
+
+(define (hash-table-update! hash-table key function . maybe-default)
+  (let ((hash (%hash-table-hash hash-table key))
+        (entries (hash-table-entries hash-table)))
+    (cond ((%hash-table-find entries
+                             (hash-table-association-function hash-table)
+                             hash key)
+           => (lambda (node)
+                (%hash-node-set-value!
+                 node (function (%hash-node-value node)))))
+          ((null? maybe-default)
+           (error "hash-table-update!: no value exists for key" key))
+          (else (%hash-table-add! entries hash key
+                                  (function ((car maybe-default))))
+                (hash-table-set-size! hash-table
+                                      (+ 1 (hash-table-size hash-table)))
+                (%hash-table-maybe-resize! hash-table)))))
+
+(define (hash-table-update!/default hash-table key function default)
+  (hash-table-update! hash-table key function (lambda () default)))
+
+(define (hash-table-delete! hash-table key)
+  (if (%hash-table-delete! (hash-table-entries hash-table)
+                           (hash-table-equivalence-function hash-table)
+                           (%hash-table-hash hash-table key) key)
+      (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1))))
+
+(define (hash-table-exists? hash-table key)
+  (and (%hash-table-find (hash-table-entries hash-table)
+                         (hash-table-association-function hash-table)
+                         (%hash-table-hash hash-table key) key) #t))
+
+(define (hash-table-walk hash-table proc)
+  (%hash-table-walk
+   (lambda (node) (proc (%hash-node-key node) (%hash-node-value node)))
+   (hash-table-entries hash-table)))
+
+(define (hash-table-fold hash-table f acc)
+  (hash-table-walk hash-table 
+                   (lambda (key value) (set! acc (f key value acc))))
+  acc)
+
+(define (alist->hash-table alist . args)
+  (let* ((comparison (if (null? args) equal? (car args)))
+         (hash
+          (if (or (null? args) (null? (cdr args)))
+              (appropriate-hash-function-for comparison) (cadr args)))
+         (size
+          (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+              (max *default-table-size* (* 2 (length alist))) (caddr args)))
+         (hash-table (make-hash-table comparison hash size)))
+    (for-each
+      (lambda (elem)
+        (hash-table-update!/default
+           hash-table (car elem) (lambda (x) x) (cdr elem)))
+      alist)
+    hash-table))
+
+(define (hash-table->alist hash-table)
+  (hash-table-fold hash-table
+                   (lambda (key val acc) (cons (cons key val) acc)) '()))
+
+(define (hash-table-copy hash-table)
+  (let ((new (make-hash-table (hash-table-equivalence-function hash-table)
+                              (hash-table-hash-function hash-table)
+                              (max *default-table-size*
+                                   (* 2 (hash-table-size hash-table))))))
+    (hash-table-walk hash-table
+                     (lambda (key value) (hash-table-set! new key value)))
+    new))
+
+(define (hash-table-merge! hash-table1 hash-table2)
+  (hash-table-walk
+    hash-table2
+    (lambda (key value) (hash-table-set! hash-table1 key value)))
+  hash-table1)
+
+(define (hash-table-keys hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
+
+(define (hash-table-values hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
+
+; eof
+;; Copyright 1991, 1994, 1998 William D Clinger
+;; Copyright 1998             Lars T Hansen
+;; Copyright 1984 - 1993      Lightship Software, Incorporated
+
+;; Permission to copy this software, in whole or in part, to use this
+;; software for any lawful purpose, and to redistribute this software
+;; is granted subject to the following restriction:  Any publication
+;; or redistribution of this software, whether on its own or
+;; incorporated into other software, must bear the above copyright
+;; notices and the following legend:
+
+;;     The Twobit compiler and the Larceny runtime system were
+;;     developed by William Clinger and Lars Hansen with the
+;;     assistance of Lightship Software and the College of Computer
+;;     Science of Northeastern University.  This acknowledges that
+;;     Clinger et al remain the sole copyright holders to Twobit
+;;     and Larceny and that no rights pursuant to that status are
+;;     waived or conveyed.
+
+;; Twobit and Larceny are provided as is.  The user specifically
+;; acknowledges that Northeastern University, William Clinger, Lars
+;; Hansen, and Lightship Software have not made any representations
+;; or warranty with regard to performance of Twobit and Larceny,
+;; their merchantability, or fitness for a particular purpose.  Users
+;; further acknowledge that they have had the opportunity to inspect
+;; Twobit and Larceny and will hold harmless Northeastern University,
+;; William Clinger, Lars Hansen, and Lightship Software from any cost,
+;; liability, or expense arising from, or in any way related to the
+;; use of this software.
+
+(define-library (r6rs hashtables)
+
+  (export
+
+   make-eq-hashtable
+   make-eqv-hashtable
+   make-hashtable
+   hashtable?
+   hashtable-size
+   hashtable-ref
+   hashtable-set!
+   hashtable-delete!
+   hashtable-contains?
+   hashtable-update!
+   hashtable-copy
+   hashtable-clear!
+   hashtable-keys
+   hashtable-entries
+   hashtable-equivalence-function
+   hashtable-hash-function
+   hashtable-mutable?
+   equal-hash
+   string-hash
+   string-ci-hash
+   (rename r6rs:symbol-hash symbol-hash)    ; see explanation below
+   )
+
+  (import (scheme base)
+          (scheme cxr))
+
+  ;; Hashing on inexact and complex numbers depends on whether the
+  ;; (scheme inexact) and (scheme complex) libraries are available.
+
+  (cond-expand
+
+   ((library (rnrs hashtables)))    ; nothing to do
+
+   ((library (scheme inexact))
+    (import (scheme inexact))
+    (begin
+     (define (inexact-hash x)
+       (cond ((finite? x)
+              (hash-for-eqv (exact x)))
+             ((infinite? x)
+              (if (> x 0.0)
+                  hash:infinity+
+                  hash:infinity-))
+             (else
+              hash:nan)))))
+
+   (else
+    (begin
+     (define (inexact-hash x) 0))))
+
+  (cond-expand
+
+   ((and (library (rnrs hashtables))
+         (not (library (r6rs no-rnrs))))
+    ;; nothing to do
+    )
+
+   ((library (scheme complex))
+    (import (scheme complex))
+    (begin
+     (define (complex-hash z)
+       (+ (hash-for-eqv (real-part z))
+          (hash-for-eqv (imag-part z))))))
+
+   (else
+    (begin
+     (define (complex-hash z) 0))))
+
+  ;; If the (rnrs hashtables) library is available, import it.
+  ;; Otherwise use SRFI 69 if it's available.
+  ;; If SRFI 69 isn't available, use its reference implementation.
+  ;;
+  ;; The (r6rs hashtables) library must export symbol-hash, which
+  ;; has no equivalent among the procedures specified by SRFI 69.
+  ;; The SRFI 69 reference implementation does define symbol-hash,
+  ;; however, which has led to the current situation in which some
+  ;; implementations of (srfi 69) export symbol-hash but others
+  ;; don't.  The R7RS says it's an error to import symbol-hash
+  ;; more than once with different bindings, or to redefine it
+  ;; if it's been imported, so this (r6rs hashtables) library
+  ;; defines r6rs:symbol-hash and renames it to symbol-hash only
+  ;; when it's exported.
+
+  (cond-expand
+
+   ((and (library (rnrs hashtables))
+         (not (library (r6rs no-rnrs))))
+    (import (rnrs hashtables))
+    (begin (define r6rs:symbol-hash symbol-hash)))
+
+   ((library (srfi 69 basic-hash-tables))
+    (import (srfi 69 basic-hash-tables))
+    (include "hashtables.atop69.scm"))
+
+   ((library (srfi 69))
+    (import (srfi 69))
+    (include "hashtables.atop69.scm"))
+
+   ((library (srfi 69 basic-hash-tables))
+    (import (srfi 69 basic-hash-tables))
+    (include "hashtables.atop69.scm"))
+
+   ((library (srfi 69))
+    (import (srfi 69))
+    (include "hashtables.atop69.scm"))
+
+   ((library (scheme char))
+    (import (scheme char))
+    (include "hashtables.body69.scm")
+    (include "hashtables.atop69.scm"))
+
+   (else
+    (begin (define (string-foldcase s) s)
+           (define (string-ci=? s1 s2)
+             (string=? s1 s2)))
+    (include "hashtables.body69.scm")
+    (include "hashtables.atop69.scm")))
+
+  )
+(define make-eq-hashtable
+  (case-lambda
+    (() (make-eq-hashtable #f #f))
+    ((capacity) (make-eq-hashtable capacity #f))
+    ((capacity weakness)
+     (when weakness
+       (error "No weak or ephemeral hashtables supported."))
+     (if capacity
+         (rnrs-make-eq-hashtable capacity)
+         (rnrs-make-eq-hashtable)))))
+
+(define make-eqv-hashtable
+  (case-lambda
+    (() (make-eqv-hashtable #f #f))
+    ((capacity) (make-eqv-hashtable capacity #f))
+    ((capacity weakness)
+     (when weakness
+       (error "No weak or ephemeral hashtables supported."))
+     (if capacity
+         (rnrs-make-eqv-hashtable capacity)
+         (rnrs-make-eqv-hashtable)))))
+
+(define make-hashtable
+  (case-lambda
+    ((hash equiv) (make-hashtable hash equiv #f #f))
+    ((hash equiv capacity) (make-hashtable hash equiv capacity #f))
+    ((hash equiv capacity weakness)
+     (cond
+      ((and (not hash) (eq? equiv eq?))
+       (make-eq-hashtable capacity weakness))
+      ((and (not hash) (eq? equiv eqv?))
+       (make-eqv-hashtable capacity weakness))
+      (else
+       (when weakness
+         (error "No weak or ephemeral hashtables supported."))
+       (let ((hash (if (pair? hash)
+                       (car hash)
+                       hash)))
+         (if capacity
+             (rnrs-make-hashtable hash equiv capacity)
+             (rnrs-make-hashtable hash equiv))))))))
+
+(define (alist->eq-hashtable . args)
+  (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+  (apply alist->hashtable #f eqv? args))
+
+(define alist->hashtable
+  (case-lambda
+    ((hash equiv alist)
+     (alist->hashtable hash equiv #f #f alist))
+    ((hash equiv capacity alist)
+     (alist->hashtable hash equiv capacity #f alist))
+    ((hash equiv capacity weakness alist)
+     (let ((hashtable (make-hashtable hash equiv capacity weakness)))
+       (for-each (lambda (entry)
+                   (hashtable-set! hashtable (car entry) (cdr entry)))
+                 (reverse alist))
+       hashtable))))
+
+(define-enumeration weakness
+  (weak-key
+   weak-value
+   weak-key-and-value
+   ephemeral-key
+   ephemeral-value
+   ephemeral-key-and-value)
+  weakness-set)
+
+(define hashtable? rnrs-hashtable?)
+
+(define hashtable-size rnrs-hashtable-size)
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define hashtable-ref
+  (case-lambda
+    ((hashtable key)
+     (let ((value (rnrs-hashtable-ref hashtable key nil)))
+       (if (nil? value)
+           (error "No such key in hashtable." hashtable key)
+           value)))
+    ((hashtable key default)
+     (rnrs-hashtable-ref hashtable key default))))
+
+(define hashtable-set! rnrs-hashtable-set!)
+
+(define hashtable-delete! rnrs-hashtable-delete!)
+
+(define hashtable-contains? rnrs-hashtable-contains?)
+
+(define (hashtable-lookup hashtable key)
+  (let ((value (rnrs-hashtable-ref hashtable key nil)))
+    (if (nil? value)
+        (values #f #f)
+        (values value #t))))
+
+(define hashtable-update!
+  (case-lambda
+    ((hashtable key proc) (hashtable-update! hashtable key proc nil))
+    ((hashtable key proc default)
+     (rnrs-hashtable-update!
+      hashtable key
+      (lambda (value)
+        (if (nil? value)
+            (error "No such key in hashtable." hashtable key)
+            (proc value)))
+      default))))
+
+;;; XXX This could be implemented at the platform level to eliminate the second
+;;; lookup for the key.
+(define (hashtable-intern! hashtable key default-proc)
+  (let ((value (rnrs-hashtable-ref hashtable key nil)))
+    (if (nil? value)
+        (let ((value (default-proc)))
+          (hashtable-set! hashtable key value)
+          value)
+        value)))
+
+(define hashtable-copy
+  (case-lambda
+    ((hashtable) (hashtable-copy hashtable #f #f))
+    ((hashtable mutable) (hashtable-copy hashtable mutable #f))
+    ((hashtable mutable weakness)
+     (when weakness
+       (error "No weak or ephemeral tables supported."))
+     (rnrs-hashtable-copy hashtable mutable))))
+
+(define hashtable-clear!
+  (case-lambda
+    ((hashtable) (rnrs-hashtable-clear! hashtable))
+    ((hashtable capacity)
+     (if capacity
+         (rnrs-hashtable-clear! hashtable capacity)
+         (rnrs-hashtable-clear! hashtable)))))
+
+(define hashtable-empty-copy
+  (case-lambda
+    ((hashtable) (hashtable-empty-copy hashtable #f))
+    ((hashtable capacity)
+     (make-hashtable (hashtable-hash-function hashtable)
+                     (hashtable-equivalence-function hashtable)
+                     (if (eq? #t capacity)
+                         (hashtable-size hashtable)
+                         capacity)
+                     (hashtable-weakness hashtable)))))
+
+(define hashtable-keys rnrs-hashtable-keys)
+
+(define (hashtable-values hashtable)
+  (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+    values))
+
+(define hashtable-entries rnrs-hashtable-entries)
+
+(define (hashtable-key-list hashtable)
+  (hashtable-map->lset hashtable (lambda (key value) key)))
+
+(define (hashtable-value-list hashtable)
+  (hashtable-map->lset hashtable (lambda (key value) value)))
+
+(define (hashtable-entry-lists hashtable)
+  (let ((keys '())
+        (vals '()))
+    (hashtable-walk hashtable
+      (lambda (key val)
+        (set! keys (cons key keys))
+        (set! vals (cons val vals))))
+    (values keys vals)))
+
+;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!,
+;;; and hashtable-sum should be implemented more efficiently at the platform
+;;; level.  In particular, they should not allocate intermediate vectors or
+;;; lists to hold the keys or values that are being operated on.
+
+(define (hashtable-walk hashtable proc)
+  (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+    (vector-for-each proc keys values)))
+
+(define (hashtable-update-all! hashtable proc)
+  (let-values (((keys values) (hashtable-entries hashtable)))
+    (vector-for-each (lambda (key value)
+                       (hashtable-set! hashtable key (proc key value)))
+                     keys values)))
+
+(define (hashtable-prune! hashtable proc)
+  (let-values (((keys values) (hashtable-entries hashtable)))
+    (vector-for-each (lambda (key value)
+                       (when (proc key value)
+                         (hashtable-delete! hashtable key)))
+                     keys values)))
+
+(define (hashtable-merge! hashtable-dest hashtable-source)
+  (hashtable-walk hashtable-source
+    (lambda (key value)
+      (hashtable-set! hashtable-dest key value)))
+  hashtable-dest)
+
+(define (hashtable-sum hashtable init proc)
+  (let-values (((keys vals) (hashtable-entry-lists hashtable)))
+    (fold proc init keys vals)))
+
+(define (hashtable-map->lset hashtable proc)
+  (hashtable-sum hashtable '()
+    (lambda (key value accumulator)
+      (cons (proc key value) accumulator))))
+
+;;; XXX If available, let-escape-continuation might be more efficient than
+;;; call/cc here.
+(define (hashtable-find hashtable proc)
+  (call/cc
+   (lambda (return)
+     (hashtable-walk hashtable
+       (lambda (key value)
+         (when (proc key value)
+           (return key value #t))))
+     (return #f #f #f))))
+
+(define (hashtable-empty? hashtable)
+  (zero? (hashtable-size hashtable)))
+
+;;; XXX A platform-level implementation could avoid allocating the constant true
+;;; function and the lookup for the key in the delete operation.
+(define (hashtable-pop! hashtable)
+  (if (hashtable-empty? hashtable)
+      (error "Cannot pop from empty hashtable." hashtable)
+      (let-values (((key value found?)
+                    (hashtable-find hashtable (lambda (k v) #t))))
+        (hashtable-delete! hashtable key)
+        (values key value))))
+
+(define hashtable-inc!
+  (case-lambda
+    ((hashtable key) (hashtable-inc! hashtable key 1))
+    ((hashtable key number)
+     (hashtable-update! hashtable key (lambda (v) (+ v number)) 0))))
+
+(define hashtable-dec!
+  (case-lambda
+    ((hashtable key) (hashtable-dec! hashtable key 1))
+    ((hashtable key number)
+     (hashtable-update! hashtable key (lambda (v) (- v number)) 0))))
+
+(define hashtable-equivalence-function rnrs-hashtable-equivalence-function)
+
+(define hashtable-hash-function rnrs-hashtable-hash-function)
+
+(define (hashtable-weakness hashtable) #f)
+
+(define hashtable-mutable? rnrs-hashtable-mutable?)
+
+(define *hash-salt*
+  (let ((seed (get-environment-variable "SRFI_126_HASH_SEED")))
+    (if (or (not seed) (string=? seed ""))
+        (random-integer (greatest-fixnum))
+        (modulo
+         (fold (lambda (char result)
+                 (+ (char->integer char) result))
+               0
+               (string->list seed))
+         (greatest-fixnum)))))
+
+(define (hash-salt) *hash-salt*)
+
+(define equal-hash rnrs-equal-hash)
+
+(define string-hash rnrs-string-hash)
+
+(define string-ci-hash rnrs-string-ci-hash)
+
+(define symbol-hash rnrs-symbol-hash)
+
+;; Local Variables:
+;; eval: (put 'hashtable-walk 'scheme-indent-function 1)
+;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-prune! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-sum 'scheme-indent-function 2)
+;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1)
+;; eval: (put 'hashtable-find 'scheme-indent-function 1)
+;; End:
+(define-library (srfi 126)
+  (export
+   make-eq-hashtable make-eqv-hashtable make-hashtable
+   alist->eq-hashtable alist->eqv-hashtable alist->hashtable
+   weakness
+   hashtable?
+   hashtable-size
+   hashtable-ref hashtable-set! hashtable-delete!
+   hashtable-contains?
+   hashtable-lookup hashtable-update! hashtable-intern!
+   hashtable-copy hashtable-clear! hashtable-empty-copy
+   hashtable-keys hashtable-values hashtable-entries
+   hashtable-key-list hashtable-value-list hashtable-entry-lists
+   hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge!
+   hashtable-sum hashtable-map->lset hashtable-find
+   hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec!
+   hashtable-equivalence-function hashtable-hash-function hashtable-weakness
+   hashtable-mutable?
+   hash-salt equal-hash string-hash string-ci-hash symbol-hash)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (scheme process-context)
+   (r6rs enums)
+   (prefix (r6rs hashtables) rnrs-)
+   (srfi 1)
+   (srfi 27))
+  (begin
+
+    ;; Smallest allowed in R6RS.
+    (define (greatest-fixnum) (expt 23 2))
+
+    ;; INCLUDE 126.body.scm
+(define make-eq-hashtable
+  (case-lambda
+    (() (make-eq-hashtable #f #f))
+    ((capacity) (make-eq-hashtable capacity #f))
+    ((capacity weakness)
+     (when weakness
+       (error "No weak or ephemeral hashtables supported."))
+     (if capacity
+         (rnrs-make-eq-hashtable capacity)
+         (rnrs-make-eq-hashtable)))))
+
+(define make-eqv-hashtable
+  (case-lambda
+    (() (make-eqv-hashtable #f #f))
+    ((capacity) (make-eqv-hashtable capacity #f))
+    ((capacity weakness)
+     (when weakness
+       (error "No weak or ephemeral hashtables supported."))
+     (if capacity
+         (rnrs-make-eqv-hashtable capacity)
+         (rnrs-make-eqv-hashtable)))))
+
+(define make-hashtable
+  (case-lambda
+    ((hash equiv) (make-hashtable hash equiv #f #f))
+    ((hash equiv capacity) (make-hashtable hash equiv capacity #f))
+    ((hash equiv capacity weakness)
+     (cond
+      ((and (not hash) (eq? equiv eq?))
+       (make-eq-hashtable capacity weakness))
+      ((and (not hash) (eq? equiv eqv?))
+       (make-eqv-hashtable capacity weakness))
+      (else
+       (when weakness
+         (error "No weak or ephemeral hashtables supported."))
+       (let ((hash (if (pair? hash)
+                       (car hash)
+                       hash)))
+         (if capacity
+             (rnrs-make-hashtable hash equiv capacity)
+             (rnrs-make-hashtable hash equiv))))))))
+
+(define (alist->eq-hashtable . args)
+  (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+  (apply alist->hashtable #f eqv? args))
+
+(define alist->hashtable
+  (case-lambda
+    ((hash equiv alist)
+     (alist->hashtable hash equiv #f #f alist))
+    ((hash equiv capacity alist)
+     (alist->hashtable hash equiv capacity #f alist))
+    ((hash equiv capacity weakness alist)
+     (let ((hashtable (make-hashtable hash equiv capacity weakness)))
+       (for-each (lambda (entry)
+                   (hashtable-set! hashtable (car entry) (cdr entry)))
+                 (reverse alist))
+       hashtable))))
+
+(define-enumeration weakness
+  (weak-key
+   weak-value
+   weak-key-and-value
+   ephemeral-key
+   ephemeral-value
+   ephemeral-key-and-value)
+  weakness-set)
+
+(define hashtable? rnrs-hashtable?)
+
+(define hashtable-size rnrs-hashtable-size)
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define hashtable-ref
+  (case-lambda
+    ((hashtable key)
+     (let ((value (rnrs-hashtable-ref hashtable key nil)))
+       (if (nil? value)
+           (error "No such key in hashtable." hashtable key)
+           value)))
+    ((hashtable key default)
+     (rnrs-hashtable-ref hashtable key default))))
+
+(define hashtable-set! rnrs-hashtable-set!)
+
+(define hashtable-delete! rnrs-hashtable-delete!)
+
+(define hashtable-contains? rnrs-hashtable-contains?)
+
+(define (hashtable-lookup hashtable key)
+  (let ((value (rnrs-hashtable-ref hashtable key nil)))
+    (if (nil? value)
+        (values #f #f)
+        (values value #t))))
+
+(define hashtable-update!
+  (case-lambda
+    ((hashtable key proc) (hashtable-update! hashtable key proc nil))
+    ((hashtable key proc default)
+     (rnrs-hashtable-update!
+      hashtable key
+      (lambda (value)
+        (if (nil? value)
+            (error "No such key in hashtable." hashtable key)
+            (proc value)))
+      default))))
+
+;;; XXX This could be implemented at the platform level to eliminate the second
+;;; lookup for the key.
+(define (hashtable-intern! hashtable key default-proc)
+  (let ((value (rnrs-hashtable-ref hashtable key nil)))
+    (if (nil? value)
+        (let ((value (default-proc)))
+          (hashtable-set! hashtable key value)
+          value)
+        value)))
+
+(define hashtable-copy
+  (case-lambda
+    ((hashtable) (hashtable-copy hashtable #f #f))
+    ((hashtable mutable) (hashtable-copy hashtable mutable #f))
+    ((hashtable mutable weakness)
+     (when weakness
+       (error "No weak or ephemeral tables supported."))
+     (rnrs-hashtable-copy hashtable mutable))))
+
+(define hashtable-clear!
+  (case-lambda
+    ((hashtable) (rnrs-hashtable-clear! hashtable))
+    ((hashtable capacity)
+     (if capacity
+         (rnrs-hashtable-clear! hashtable capacity)
+         (rnrs-hashtable-clear! hashtable)))))
+
+(define hashtable-empty-copy
+  (case-lambda
+    ((hashtable) (hashtable-empty-copy hashtable #f))
+    ((hashtable capacity)
+     (make-hashtable (hashtable-hash-function hashtable)
+                     (hashtable-equivalence-function hashtable)
+                     (if (eq? #t capacity)
+                         (hashtable-size hashtable)
+                         capacity)
+                     (hashtable-weakness hashtable)))))
+
+(define hashtable-keys rnrs-hashtable-keys)
+
+(define (hashtable-values hashtable)
+  (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+    values))
+
+(define hashtable-entries rnrs-hashtable-entries)
+
+(define (hashtable-key-list hashtable)
+  (hashtable-map->lset hashtable (lambda (key value) key)))
+
+(define (hashtable-value-list hashtable)
+  (hashtable-map->lset hashtable (lambda (key value) value)))
+
+(define (hashtable-entry-lists hashtable)
+  (let ((keys '())
+        (vals '()))
+    (hashtable-walk hashtable
+      (lambda (key val)
+        (set! keys (cons key keys))
+        (set! vals (cons val vals))))
+    (values keys vals)))
+
+;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!,
+;;; and hashtable-sum should be implemented more efficiently at the platform
+;;; level.  In particular, they should not allocate intermediate vectors or
+;;; lists to hold the keys or values that are being operated on.
+
+(define (hashtable-walk hashtable proc)
+  (let-values (((keys values) (rnrs-hashtable-entries hashtable)))
+    (vector-for-each proc keys values)))
+
+(define (hashtable-update-all! hashtable proc)
+  (let-values (((keys values) (hashtable-entries hashtable)))
+    (vector-for-each (lambda (key value)
+                       (hashtable-set! hashtable key (proc key value)))
+                     keys values)))
+
+(define (hashtable-prune! hashtable proc)
+  (let-values (((keys values) (hashtable-entries hashtable)))
+    (vector-for-each (lambda (key value)
+                       (when (proc key value)
+                         (hashtable-delete! hashtable key)))
+                     keys values)))
+
+(define (hashtable-merge! hashtable-dest hashtable-source)
+  (hashtable-walk hashtable-source
+    (lambda (key value)
+      (hashtable-set! hashtable-dest key value)))
+  hashtable-dest)
+
+(define (hashtable-sum hashtable init proc)
+  (let-values (((keys vals) (hashtable-entry-lists hashtable)))
+    (fold proc init keys vals)))
+
+(define (hashtable-map->lset hashtable proc)
+  (hashtable-sum hashtable '()
+    (lambda (key value accumulator)
+      (cons (proc key value) accumulator))))
+
+;;; XXX If available, let-escape-continuation might be more efficient than
+;;; call/cc here.
+(define (hashtable-find hashtable proc)
+  (call/cc
+   (lambda (return)
+     (hashtable-walk hashtable
+       (lambda (key value)
+         (when (proc key value)
+           (return key value #t))))
+     (return #f #f #f))))
+
+(define (hashtable-empty? hashtable)
+  (zero? (hashtable-size hashtable)))
+
+;;; XXX A platform-level implementation could avoid allocating the constant true
+;;; function and the lookup for the key in the delete operation.
+(define (hashtable-pop! hashtable)
+  (if (hashtable-empty? hashtable)
+      (error "Cannot pop from empty hashtable." hashtable)
+      (let-values (((key value found?)
+                    (hashtable-find hashtable (lambda (k v) #t))))
+        (hashtable-delete! hashtable key)
+        (values key value))))
+
+(define hashtable-inc!
+  (case-lambda
+    ((hashtable key) (hashtable-inc! hashtable key 1))
+    ((hashtable key number)
+     (hashtable-update! hashtable key (lambda (v) (+ v number)) 0))))
+
+(define hashtable-dec!
+  (case-lambda
+    ((hashtable key) (hashtable-dec! hashtable key 1))
+    ((hashtable key number)
+     (hashtable-update! hashtable key (lambda (v) (- v number)) 0))))
+
+(define hashtable-equivalence-function rnrs-hashtable-equivalence-function)
+
+(define hashtable-hash-function rnrs-hashtable-hash-function)
+
+(define (hashtable-weakness hashtable) #f)
+
+(define hashtable-mutable? rnrs-hashtable-mutable?)
+
+(define *hash-salt*
+  (let ((seed (get-environment-variable "SRFI_126_HASH_SEED")))
+    (if (or (not seed) (string=? seed ""))
+        (random-integer (greatest-fixnum))
+        (modulo
+         (fold (lambda (char result)
+                 (+ (char->integer char) result))
+               0
+               (string->list seed))
+         (greatest-fixnum)))))
+
+(define (hash-salt) *hash-salt*)
+
+(define equal-hash rnrs-equal-hash)
+
+(define string-hash rnrs-string-hash)
+
+(define string-ci-hash rnrs-string-ci-hash)
+
+(define symbol-hash rnrs-symbol-hash)
+
+;; Local Variables:
+;; eval: (put 'hashtable-walk 'scheme-indent-function 1)
+;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-prune! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-sum 'scheme-indent-function 2)
+;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1)
+;; eval: (put 'hashtable-find 'scheme-indent-function 1)
+;; End:
+
+    ))
+;;; Guile implementation.
+
+(define-module (srfi srfi-126))
+
+(use-modules
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-9 gnu)
+ (srfi srfi-11)
+ (ice-9 hash-table)
+ (ice-9 control)
+ ((rnrs hashtables) #\select
+  (equal-hash string-hash string-ci-hash symbol-hash)))
+
+(export
+ make-eq-hashtable make-eqv-hashtable make-hashtable
+ alist->eq-hashtable alist->eqv-hashtable alist->hashtable
+ weakness
+ hashtable? hashtable-size
+ hashtable-ref hashtable-set! hashtable-delete! hashtable-contains?
+ hashtable-lookup hashtable-update! hashtable-intern!
+ hashtable-copy hashtable-clear! hashtable-empty-copy
+ hashtable-keys hashtable-values hashtable-entries
+ hashtable-key-list hashtable-value-list hashtable-entry-lists
+ hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge!
+ hashtable-sum hashtable-map->lset hashtable-find
+ hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec!
+ hashtable-equivalence-function hashtable-hash-function
+ hashtable-weakness hashtable-mutable?
+ hash-salt
+ )
+
+(re-export equal-hash string-hash string-ci-hash symbol-hash)
+
+(define-record-type <hashtable>
+  (%make-hashtable %table %hash %assoc hash equiv weakness mutable)
+  hashtable?
+  (%table %hashtable-table)
+  (%hash %hashtable-hash)
+  (%assoc %hashtable-assoc)
+  (hash hashtable-hash-function)
+  (equiv hashtable-equivalence-function)
+  (weakness hashtable-weakness)
+  (mutable hashtable-mutable? %hashtable-set-mutable!))
+
+(define nil (cons #f #f))
+(define (nil? obj) (eq? obj nil))
+
+(define (make-table capacity weakness)
+  (let ((capacity (or capacity 32)))
+    (case weakness
+      ((#f) (make-hash-table capacity))
+      ((weak-key) (make-weak-key-hash-table capacity))
+      ((weak-value) (make-weak-value-hash-table capacity))
+      ((weak-key-and-value) (make-doubly-weak-hash-table capacity))
+      (else (error "Hashtable weakness not supported." weakness)))))
+
+(define* (make-eq-hashtable #\optional capacity weakness)
+  (let ((table (make-table capacity weakness)))
+    (%make-hashtable table hashq assq #f eq? weakness #t)))
+
+(define* (make-eqv-hashtable #\optional capacity weakness)
+  (let ((table (make-table capacity weakness)))
+    (%make-hashtable table hashv assv #f eqv? weakness #t)))
+
+(define* (make-hashtable hash equiv #\optional capacity weakness)
+  (cond
+   ((and (not hash) (eq? equiv eq?))
+    (make-eq-hashtable capacity weakness))
+   ((and (not hash) (eq? equiv eqv?))
+    (make-eqv-hashtable capacity weakness))
+   (else
+    (let* ((table (make-table capacity weakness))
+           (hash (if (pair? hash)
+                     (car hash)
+                     hash))
+           (%hash (lambda (obj bound)
+                           (modulo (hash obj) bound)))
+           (assoc (lambda (key alist)
+                    (find (lambda (entry)
+                            (equiv (car entry) key))
+                          alist))))
+      (%make-hashtable table %hash assoc hash equiv weakness #t)))))
+
+(define (alist->eq-hashtable . args)
+  (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+  (apply alist->hashtable #f eqv? args))
+
+(define alist->hashtable
+  (case-lambda
+    ((hash equiv alist)
+     (alist->hashtable hash equiv #f #f alist))
+    ((hash equiv capacity alist)
+     (alist->hashtable hash equiv capacity #f alist))
+    ((hash equiv capacity weakness alist)
+     (let ((ht (make-hashtable hash equiv capacity weakness)))
+       (for-each (lambda (entry)
+                   (hashtable-set! ht (car entry) (cdr entry)))
+                 (reverse alist))
+       ht))))
+
+(define-syntax weakness
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <sym>)
+       (let ((sym (syntax->datum #'<sym>)))
+         (case sym
+           ((weak-key weak-value weak-key-and-value ephemeral-key
+                      ephemeral-value ephemeral-key-and-value)
+            #''sym)
+           (else
+            (error "Bad weakness symbol." sym))))))))
+
+(define (hashtable-size ht)
+  (hash-count (const #t) (%hashtable-table ht)))
+
+(define* (%hashtable-ref ht key default)
+  (hashx-ref (%hashtable-hash ht) (%hashtable-assoc ht)
+             (%hashtable-table ht) key default))
+
+(define* (hashtable-ref ht key #\optional (default nil))
+  (let ((val (%hashtable-ref ht key default)))
+    (if (nil? val)
+        (error "No association for key in hashtable." key ht)
+        val)))
+
+(define (assert-mutable ht)
+  (when (not (hashtable-mutable? ht))
+    (error "Hashtable is immutable." ht)))
+
+(define (hashtable-set! ht key value)
+  (assert-mutable ht)
+  (hashx-set! (%hashtable-hash ht) (%hashtable-assoc ht)
+              (%hashtable-table ht) key value)
+  *unspecified*)
+
+(define (hashtable-delete! ht key)
+  (assert-mutable ht)
+  (hashx-remove! (%hashtable-hash ht) (%hashtable-assoc ht)
+                 (%hashtable-table ht) key)
+  *unspecified*)
+
+(define (hashtable-contains? ht key)
+  (not (nil? (%hashtable-ref ht key nil))))
+
+(define (hashtable-lookup ht key)
+  (let ((val (%hashtable-ref ht key nil)))
+    (if (nil? val)
+        (values #f #f)
+        (values val #t))))
+
+(define* (hashtable-update! ht key updater #\optional (default nil))
+  (assert-mutable ht)
+  (let ((handle (hashx-create-handle!
+                 (%hashtable-hash ht) (%hashtable-assoc ht)
+                 (%hashtable-table ht) key nil)))
+    (if (eq? nil (cdr handle))
+        (if (nil? default)
+            (error "No association for key in hashtable." key ht)
+            (set-cdr! handle (updater default)))
+        (set-cdr! handle (updater (cdr handle))))
+    (cdr handle)))
+
+(define (hashtable-intern! ht key default-proc)
+  (assert-mutable ht)
+  (let ((handle (hashx-create-handle!
+                 (%hashtable-hash ht) (%hashtable-assoc ht)
+                 (%hashtable-table ht) key nil)))
+    (when (nil? (cdr handle))
+      (set-cdr! handle (default-proc)))
+    (cdr handle)))
+
+(define* (hashtable-copy ht #\optional mutable weakness)
+  (let ((copy (hashtable-empty-copy ht (hashtable-size ht) weakness)))
+    (hashtable-walk ht
+      (lambda (k v)
+        (hashtable-set! copy k v)))
+    (%hashtable-set-mutable! copy mutable)
+    copy))
+
+(define* (hashtable-clear! ht #\optional _capacity)
+  (assert-mutable ht)
+  (hash-clear! (%hashtable-table ht))
+  *unspecified*)
+
+(define* (hashtable-empty-copy ht #\optional capacity weakness)
+  (make-hashtable (hashtable-hash-function ht)
+                  (hashtable-equivalence-function ht)
+                  (case capacity
+                    ((#f) #f)
+                    ((#t) (hashtable-size ht))
+                    (else capacity))
+                  (or weakness (hashtable-weakness ht))))
+
+(define (hashtable-keys ht)
+  (let ((keys (make-vector (hashtable-size ht))))
+    (hashtable-sum ht 0
+      (lambda (k v i)
+        (vector-set! keys i k)
+        (+ i 1)))
+    keys))
+
+(define (hashtable-values ht)
+  (let ((vals (make-vector (hashtable-size ht))))
+    (hashtable-sum ht 0
+      (lambda (k v i)
+        (vector-set! vals i v)
+        (+ i 1)))
+    vals))
+
+(define (hashtable-entries ht)
+  (let ((keys (make-vector (hashtable-size ht)))
+        (vals (make-vector (hashtable-size ht))))
+    (hashtable-sum ht 0
+      (lambda (k v i)
+        (vector-set! keys i k)
+        (vector-set! vals i v)
+        (+ i 1)))
+    (values keys vals)))
+
+(define (hashtable-key-list ht)
+  (hashtable-map->lset ht (lambda (k v) k)))
+
+(define (hashtable-value-list ht)
+  (hashtable-map->lset ht (lambda (k v) v)))
+
+(define (hashtable-entry-lists ht)
+  (let ((keys&vals (cons '() '())))
+    (hashtable-walk ht
+      (lambda (k v)
+        (set-car! keys&vals (cons k (car keys&vals)))
+        (set-cdr! keys&vals (cons v (cdr keys&vals)))))
+    (car+cdr keys&vals)))
+
+(define (hashtable-walk ht proc)
+  (hash-for-each proc (%hashtable-table ht)))
+
+(define (hashtable-update-all! ht proc)
+  (assert-mutable ht)
+  (hash-for-each-handle
+   (lambda (handle)
+     (set-cdr! handle (proc (car handle) (cdr handle))))
+   (%hashtable-table ht)))
+
+(define (hashtable-prune! ht pred)
+  (assert-mutable ht)
+  (let ((keys (hashtable-sum ht '()
+                (lambda (k v keys-to-delete)
+                  (if (pred k v)
+                      (cons k keys-to-delete)
+                      keys-to-delete)))))
+    (for-each (lambda (k)
+                (hashtable-delete! ht k))
+              keys)))
+
+(define (hashtable-merge! ht-dest ht-src)
+  (assert-mutable ht-dest)
+  (hashtable-walk ht-src
+    (lambda (k v)
+      (hashtable-set! ht-dest k v)))
+  ht-dest)
+
+(define (hashtable-sum ht init proc)
+  (hash-fold proc init (%hashtable-table ht)))
+
+(define (hashtable-map->lset ht proc)
+  (hash-map->list proc (%hashtable-table ht)))
+
+(define (hashtable-find ht pred)
+  (let/ec return
+    (hashtable-walk ht
+      (lambda (k v)
+        (when (pred k v)
+          (return k v #t))))
+    (return #f #f #f)))
+
+(define (hashtable-empty? ht)
+  (zero? (hashtable-size ht)))
+
+(define (hashtable-pop! ht)
+  (assert-mutable ht)
+  (when (hashtable-empty? ht)
+    (error "Cannot pop from empty hashtable." ht))
+  (let-values (((k v found?) (hashtable-find ht (const #t))))
+    (hashtable-delete! ht k)
+    (values k v)))
+
+(define* (hashtable-inc! ht k #\optional (x 1))
+  (assert-mutable ht)
+  (hashtable-update! ht k (lambda (v) (+ v x)) 0))
+
+(define* (hashtable-dec! ht k #\optional (x 1))
+  (assert-mutable ht)
+  (hashtable-update! ht k (lambda (v) (- v x)) 0))
+
+(define (hash-salt) 0)
+
+(set-record-type-printer!
+ <hashtable>
+ (lambda (ht port)
+   (with-output-to-port port
+     (lambda ()
+       (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+             (string-hash (@ (rnrs hashtables) string-hash))
+             (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+             (symbol-hash (@ (rnrs hashtables) symbol-hash))
+             (hash (hashtable-hash-function ht))
+             (equiv (hashtable-equivalence-function ht))
+             (alist (hashtable-map->lset ht cons)))
+         (cond
+          ((and (not hash) (eq? equiv eq?))
+           (display "#hasheq")
+           (display alist))
+          ((and (not hash) (eq? equiv eqv?))
+           (display "#hasheqv")
+           (display alist))
+          (else
+           (display "#hash")
+           (cond
+            ((and (eq? hash (@ (rnrs hashtables) equal-hash)) (eq? equiv equal?))
+             (display alist))
+            ((and (eq? hash (@ (rnrs hashtables) string-hash)) (eq? equiv string=?))
+             (display (cons 'string alist)))
+            ((and (eq? hash string-ci-hash) (eq? equiv string-ci=?))
+             (display (cons 'string-ci alist)))
+            ((and (eq? hash symbol-hash) (eq? equiv eq?))
+             (display (cons 'symbol alist)))
+            (else
+             (display (cons 'custom alist)))))))))))
+
+(read-hash-extend
+ #\h
+ (lambda (char port)
+   (with-input-from-port port
+     (lambda ()
+       (let ((equal-hash (@ (rnrs hashtables) equal-hash))
+             (string-hash (@ (rnrs hashtables) string-hash))
+             (string-ci-hash (@ (rnrs hashtables) string-ci-hash))
+             (symbol-hash (@ (rnrs hashtables) symbol-hash))
+             (type (string-append "h" (symbol->string (read))))
+             (alist (read)))
+         (cond
+          ((string=? type "hasheq")
+           (alist->eq-hashtable alist))
+          ((string=? type "hasheqv")
+           (alist->eqv-hashtable alist))
+          (else
+           (when (not (string=? type "hash"))
+             (error "Unrecognized hash type." type))
+           (let* ((has-tag? (symbol? (car alist)))
+                  (subtype (if has-tag?
+                               (car alist)
+                               "equal"))
+                  (alist (if has-tag?
+                             (cdr alist)
+                             alist)))
+             (cond
+              ((string=? subtype "equal")
+               (alist->hashtable equal-hash equal? alist))
+              ((string=? subtype "string")
+               (alist->hashtable string-hash string=? alist))
+              ((string=? subtype "string-ci")
+               (alist->hashtable string-ci-hash string-ci=? alist))
+              ((string=? subtype "symbol")
+               (alist->hashtable symbol-hash eq? alist))
+              (else
+               (error "Unrecognized hash subtype." subtype)))))))))))
+
+;; Local Variables:
+;; eval: (put 'hashtable-walk 'scheme-indent-function 1)
+;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-prune! 'scheme-indent-function 1)
+;; eval: (put 'hashtable-sum 'scheme-indent-function 2)
+;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1)
+;; eval: (put 'hashtable-find 'scheme-indent-function 1)
+;; End:
+;;; This doesn't test weakness, external representation, and quasiquote.
+
+(test-begin "SRFI-126")
+
+(test-group "constructors & inspection"
+  (test-group "eq"
+    (let ((tables (list (make-eq-hashtable)
+                        (make-eq-hashtable 10)
+                        (make-eq-hashtable #f #f)
+                        (make-hashtable #f eq?)
+                        (alist->eq-hashtable '((a . b) (c . d)))
+                        (alist->eq-hashtable 10 '((a . b) (c . d)))
+                        (alist->eq-hashtable #f #f '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label #f (hashtable-hash-function table))
+          (test-eq label eq? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))))
+  (test-group "eqv"
+    (let ((tables (list (make-eqv-hashtable)
+                        (make-eqv-hashtable 10)
+                        (make-eqv-hashtable #f #f)
+                        (make-hashtable #f eqv?)
+                        (alist->eqv-hashtable '((a . b) (c . d)))
+                        (alist->eqv-hashtable 10 '((a . b) (c . d)))
+                        (alist->eqv-hashtable #f #f '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label #f (hashtable-hash-function table))
+          (test-eq label eqv? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))))
+  (test-group "equal"
+    (let ((tables (list (make-hashtable equal-hash equal?)
+                        (make-hashtable equal-hash equal? 10)
+                        (make-hashtable equal-hash equal? #f #f)
+                        (alist->hashtable equal-hash equal?
+                                          '((a . b) (c . d)))
+                        (alist->hashtable equal-hash equal? 10
+                                          '((a . b) (c . d)))
+                        (alist->hashtable equal-hash equal? #f #f
+                                          '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label equal-hash (hashtable-hash-function table))
+          (test-eq label equal? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))
+      (let ((table (make-hashtable (cons equal-hash equal-hash) equal?)))
+        (let ((hash (hashtable-hash-function table)))
+          (test-assert (or (eq? equal-hash hash)
+                           (and (eq? equal-hash (car hash))
+                                (eq? equal-hash (cdr hash)))))))))
+  (test-group "alist"
+    (let ((tables (list (alist->eq-hashtable '((a . b) (a . c)))
+                        (alist->eqv-hashtable '((a . b) (a . c)))
+                        (alist->hashtable equal-hash equal?
+                                          '((a . b) (a . c))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-eq label 'b (hashtable-ref table 'a)))))))
+
+(test-group "procedures"
+  (test-group "basics"
+    (let ((table (make-eq-hashtable)))
+      (test-group "ref"
+        (test-error (hashtable-ref table 'a))
+        (test-eq 'b (hashtable-ref table 'a 'b))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-eqv 0 (hashtable-size table)))
+      (test-group "set"
+        (hashtable-set! table 'a 'c)
+        (test-eq 'c (hashtable-ref table 'a))
+        (test-eq 'c (hashtable-ref table 'a 'b))
+        (test-assert (hashtable-contains? table 'a))
+        (test-eqv 1 (hashtable-size table)))
+      (test-group "delete"
+        (hashtable-delete! table 'a)
+        (test-error (hashtable-ref table 'a))
+        (test-eq 'b (hashtable-ref table 'a 'b))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-eqv 0 (hashtable-size table)))))
+  (test-group "advanced"
+    (let ((table (make-eq-hashtable)))
+      (test-group "lookup"
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-assert (not found?))))
+      (test-group "update"
+        (test-error (hashtable-update! table 'a (lambda (x) (+ x 1))))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv 1 x)
+          (test-assert found?))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)))
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv x 2)
+          (test-assert found?))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv x 3)
+          (test-assert found?)))
+      (test-group "intern"
+        (test-eqv 0 (hashtable-intern! table 'b (lambda () 0)))
+        (test-eqv 0 (hashtable-intern! table 'b (lambda () 1))))))
+  (test-group "copy/clear"
+    (let ((table (alist->hashtable equal-hash equal? '((a . b)))))
+      (test-group "copy"
+        (let ((table2 (hashtable-copy table)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (test-error (hashtable-set! table2 'a 'c)))
+        (let ((table2 (hashtable-copy table #f)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (test-error (hashtable-set! table2 'a 'c)))
+        (let ((table2 (hashtable-copy table #t)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (hashtable-set! table2 'a 'c)
+          (test-eq 'c (hashtable-ref table2 'a)))
+        (let ((table2 (hashtable-copy table #f #f)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq #f (hashtable-weakness table2))))
+      (test-group "clear"
+        (let ((table2 (hashtable-copy table #t)))
+          (hashtable-clear! table2)
+          (test-eqv 0 (hashtable-size table2)))
+        (let ((table2 (hashtable-copy table #t)))
+          (hashtable-clear! table2 10)
+          (test-eqv 0 (hashtable-size table2))))
+      (test-group "empty-copy"
+        (let ((table2 (hashtable-empty-copy table)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eqv 0 (hashtable-size table2)))
+        (let ((table2 (hashtable-empty-copy table 10)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eqv 0 (hashtable-size table2))))))
+  (test-group "keys/values"
+    (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+      (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table))))
+      (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table))))
+      (let-values (((keys values) (hashtable-entries table)))
+        (test-assert (lset= eq? '(a c) (vector->list keys)))
+        (test-assert (lset= eq? '(b d) (vector->list values))))
+      (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+      (test-assert (lset= eq? '(b d) (hashtable-value-list table)))
+      (let-values (((keys values) (hashtable-entry-lists table)))
+        (test-assert (lset= eq? '(a c) keys))
+        (test-assert (lset= eq? '(b d) values)))))
+  (test-group "iteration"
+    (test-group "walk"
+      (let ((keys '())
+            (values '()))
+        (hashtable-walk (alist->eq-hashtable '((a . b) (c . d)))
+          (lambda (k v)
+            (set! keys (cons k keys))
+            (set! values (cons v values))))
+        (test-assert (lset= eq? '(a c) keys))
+        (test-assert (lset= eq? '(b d) values))))
+    (test-group "update-all"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (hashtable-update-all! table
+          (lambda (k v)
+            (string->symbol (string-append (symbol->string v) "x"))))
+        (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+        (test-assert (lset= eq? '(bx dx) (hashtable-value-list table)))))
+    (test-group "prune"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (hashtable-prune! table (lambda (k v) (eq? k 'a)))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-assert (hashtable-contains? table 'c))))
+    (test-group "merge"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d))))
+            (table2 (alist->eq-hashtable '((a . x) (e . f)))))
+        (hashtable-merge! table table2)
+        (test-assert (lset= eq? '(a c e) (hashtable-key-list table)))
+        (test-assert (lset= eq? '(x d f) (hashtable-value-list table)))))
+    (test-group "sum"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (test-assert (lset= eq? '(a b c d)
+                            (hashtable-sum table '()
+                              (lambda (k v acc)
+                                (lset-adjoin eq? acc k v)))))))
+    (test-group "map->lset"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (test-assert (lset= equal? '((a . b) (c . d))
+                            (hashtable-map->lset table cons)))))
+    (test-group "find"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (let-values (((k v f?) (hashtable-find table
+                                 (lambda (k v)
+                                   (eq? k 'a)))))
+          (test-assert (and f? (eq? k 'a) (eq? v 'b))))
+        (let-values (((k v f?) (hashtable-find table (lambda (k v) #f))))
+          (test-assert (not f?)))))
+    (test-group "misc"
+      (test-group "empty?"
+        (test-assert (hashtable-empty? (alist->eq-hashtable '())))
+        (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b)))))))
+      (test-group "pop!"
+        (test-error (hashtable-pop! (make-eq-hashtable)))
+        (let ((table (alist->eq-hashtable '((a . b)))))
+          (let-values (((k v) (hashtable-pop! table)))
+            (test-eq 'a k)
+            (test-eq 'b v)
+            (test-assert (hashtable-empty? table)))))
+      (test-group "inc!"
+        (let ((table (alist->eq-hashtable '((a . 0)))))
+          (hashtable-inc! table 'a)
+          (test-eqv 1 (hashtable-ref table 'a))
+          (hashtable-inc! table 'a 2)
+          (test-eqv 3 (hashtable-ref table 'a))))
+      (test-group "dec!"
+        (let ((table (alist->eq-hashtable '((a . 0)))))
+          (hashtable-dec! table 'a)
+          (test-eqv -1 (hashtable-ref table 'a))
+          (hashtable-dec! table 'a 2)
+          (test-eqv -3 (hashtable-ref table 'a)))))))
+
+(test-group "hashing"
+  (test-assert (and (exact-integer? (hash-salt))))
+  (test-assert (not (negative? (hash-salt))))
+  (test-assert (= (equal-hash (list "foo" 'bar 42))
+                  (equal-hash (list "foo" 'bar 42))))
+  (test-assert (= (string-hash (string-copy "foo"))
+                  (string-hash (string-copy "foo"))))
+  (test-assert (= (string-ci-hash (string-copy "foo"))
+                  (string-ci-hash (string-copy "FOO"))))
+  (test-assert (= (symbol-hash (string->symbol "foo"))
+                  (symbol-hash (string->symbol "foo")))))
+
+(test-end "SRFI-126")
+
+(display
+ (string-append
+  "\n"
+  "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n"
+  "      14 tests are expected to fail in relation to make-eq-hashtable and\n"
+  "      make-eqv-hashtable returning hashtables whose hash functions are\n"
+  "      exposed instead of being #f.  We have no obvious way to detect this\n"
+  "      within this portable test suite, hence no XFAIL results.\n"))
+
+;; Local Variables:
+;; eval: (put (quote test-group) (quote scheme-indent-function) 1)
+;; End:
+(import
+ (scheme base)
+ (scheme write)
+ (srfi 1)
+ (srfi 64)
+ (srfi 126))
+
+;; INCLUDE test-suite.body.scm
+;;; This doesn't test weakness, external representation, and quasiquote.
+
+(test-begin "SRFI-126")
+
+(test-group "constructors & inspection"
+  (test-group "eq"
+    (let ((tables (list (make-eq-hashtable)
+                        (make-eq-hashtable 10)
+                        (make-eq-hashtable #f #f)
+                        (make-hashtable #f eq?)
+                        (alist->eq-hashtable '((a . b) (c . d)))
+                        (alist->eq-hashtable 10 '((a . b) (c . d)))
+                        (alist->eq-hashtable #f #f '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label #f (hashtable-hash-function table))
+          (test-eq label eq? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))))
+  (test-group "eqv"
+    (let ((tables (list (make-eqv-hashtable)
+                        (make-eqv-hashtable 10)
+                        (make-eqv-hashtable #f #f)
+                        (make-hashtable #f eqv?)
+                        (alist->eqv-hashtable '((a . b) (c . d)))
+                        (alist->eqv-hashtable 10 '((a . b) (c . d)))
+                        (alist->eqv-hashtable #f #f '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label #f (hashtable-hash-function table))
+          (test-eq label eqv? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))))
+  (test-group "equal"
+    (let ((tables (list (make-hashtable equal-hash equal?)
+                        (make-hashtable equal-hash equal? 10)
+                        (make-hashtable equal-hash equal? #f #f)
+                        (alist->hashtable equal-hash equal?
+                                          '((a . b) (c . d)))
+                        (alist->hashtable equal-hash equal? 10
+                                          '((a . b) (c . d)))
+                        (alist->hashtable equal-hash equal? #f #f
+                                          '((a . b) (c . d))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-assert label (hashtable? table))
+          (test-eq label equal-hash (hashtable-hash-function table))
+          (test-eq label equal? (hashtable-equivalence-function table))
+          (test-eq label #f (hashtable-weakness table))
+          (test-assert label (hashtable-mutable? table))))
+      (let ((table (make-hashtable (cons equal-hash equal-hash) equal?)))
+        (let ((hash (hashtable-hash-function table)))
+          (test-assert (or (eq? equal-hash hash)
+                           (and (eq? equal-hash (car hash))
+                                (eq? equal-hash (cdr hash)))))))))
+  (test-group "alist"
+    (let ((tables (list (alist->eq-hashtable '((a . b) (a . c)))
+                        (alist->eqv-hashtable '((a . b) (a . c)))
+                        (alist->hashtable equal-hash equal?
+                                          '((a . b) (a . c))))))
+      (do ((tables tables (cdr tables))
+           (i 0 (+ i 1)))
+          ((null? tables))
+        (let ((table (car tables))
+              (label (number->string i)))
+          (test-eq label 'b (hashtable-ref table 'a)))))))
+
+(test-group "procedures"
+  (test-group "basics"
+    (let ((table (make-eq-hashtable)))
+      (test-group "ref"
+        (test-error (hashtable-ref table 'a))
+        (test-eq 'b (hashtable-ref table 'a 'b))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-eqv 0 (hashtable-size table)))
+      (test-group "set"
+        (hashtable-set! table 'a 'c)
+        (test-eq 'c (hashtable-ref table 'a))
+        (test-eq 'c (hashtable-ref table 'a 'b))
+        (test-assert (hashtable-contains? table 'a))
+        (test-eqv 1 (hashtable-size table)))
+      (test-group "delete"
+        (hashtable-delete! table 'a)
+        (test-error (hashtable-ref table 'a))
+        (test-eq 'b (hashtable-ref table 'a 'b))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-eqv 0 (hashtable-size table)))))
+  (test-group "advanced"
+    (let ((table (make-eq-hashtable)))
+      (test-group "lookup"
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-assert (not found?))))
+      (test-group "update"
+        (test-error (hashtable-update! table 'a (lambda (x) (+ x 1))))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv 1 x)
+          (test-assert found?))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)))
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv x 2)
+          (test-assert found?))
+        (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+        (let-values (((x found?) (hashtable-lookup table 'a)))
+          (test-eqv x 3)
+          (test-assert found?)))
+      (test-group "intern"
+        (test-eqv 0 (hashtable-intern! table 'b (lambda () 0)))
+        (test-eqv 0 (hashtable-intern! table 'b (lambda () 1))))))
+  (test-group "copy/clear"
+    (let ((table (alist->hashtable equal-hash equal? '((a . b)))))
+      (test-group "copy"
+        (let ((table2 (hashtable-copy table)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (test-error (hashtable-set! table2 'a 'c)))
+        (let ((table2 (hashtable-copy table #f)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (test-error (hashtable-set! table2 'a 'c)))
+        (let ((table2 (hashtable-copy table #t)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq 'b (hashtable-ref table2 'a))
+          (hashtable-set! table2 'a 'c)
+          (test-eq 'c (hashtable-ref table2 'a)))
+        (let ((table2 (hashtable-copy table #f #f)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eq #f (hashtable-weakness table2))))
+      (test-group "clear"
+        (let ((table2 (hashtable-copy table #t)))
+          (hashtable-clear! table2)
+          (test-eqv 0 (hashtable-size table2)))
+        (let ((table2 (hashtable-copy table #t)))
+          (hashtable-clear! table2 10)
+          (test-eqv 0 (hashtable-size table2))))
+      (test-group "empty-copy"
+        (let ((table2 (hashtable-empty-copy table)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eqv 0 (hashtable-size table2)))
+        (let ((table2 (hashtable-empty-copy table 10)))
+          (test-eq equal-hash (hashtable-hash-function table2))
+          (test-eq equal? (hashtable-equivalence-function table2))
+          (test-eqv 0 (hashtable-size table2))))))
+  (test-group "keys/values"
+    (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+      (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table))))
+      (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table))))
+      (let-values (((keys values) (hashtable-entries table)))
+        (test-assert (lset= eq? '(a c) (vector->list keys)))
+        (test-assert (lset= eq? '(b d) (vector->list values))))
+      (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+      (test-assert (lset= eq? '(b d) (hashtable-value-list table)))
+      (let-values (((keys values) (hashtable-entry-lists table)))
+        (test-assert (lset= eq? '(a c) keys))
+        (test-assert (lset= eq? '(b d) values)))))
+  (test-group "iteration"
+    (test-group "walk"
+      (let ((keys '())
+            (values '()))
+        (hashtable-walk (alist->eq-hashtable '((a . b) (c . d)))
+          (lambda (k v)
+            (set! keys (cons k keys))
+            (set! values (cons v values))))
+        (test-assert (lset= eq? '(a c) keys))
+        (test-assert (lset= eq? '(b d) values))))
+    (test-group "update-all"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (hashtable-update-all! table
+          (lambda (k v)
+            (string->symbol (string-append (symbol->string v) "x"))))
+        (test-assert (lset= eq? '(a c) (hashtable-key-list table)))
+        (test-assert (lset= eq? '(bx dx) (hashtable-value-list table)))))
+    (test-group "prune"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (hashtable-prune! table (lambda (k v) (eq? k 'a)))
+        (test-assert (not (hashtable-contains? table 'a)))
+        (test-assert (hashtable-contains? table 'c))))
+    (test-group "merge"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d))))
+            (table2 (alist->eq-hashtable '((a . x) (e . f)))))
+        (hashtable-merge! table table2)
+        (test-assert (lset= eq? '(a c e) (hashtable-key-list table)))
+        (test-assert (lset= eq? '(x d f) (hashtable-value-list table)))))
+    (test-group "sum"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (test-assert (lset= eq? '(a b c d)
+                            (hashtable-sum table '()
+                              (lambda (k v acc)
+                                (lset-adjoin eq? acc k v)))))))
+    (test-group "map->lset"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (test-assert (lset= equal? '((a . b) (c . d))
+                            (hashtable-map->lset table cons)))))
+    (test-group "find"
+      (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+        (let-values (((k v f?) (hashtable-find table
+                                 (lambda (k v)
+                                   (eq? k 'a)))))
+          (test-assert (and f? (eq? k 'a) (eq? v 'b))))
+        (let-values (((k v f?) (hashtable-find table (lambda (k v) #f))))
+          (test-assert (not f?)))))
+    (test-group "misc"
+      (test-group "empty?"
+        (test-assert (hashtable-empty? (alist->eq-hashtable '())))
+        (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b)))))))
+      (test-group "pop!"
+        (test-error (hashtable-pop! (make-eq-hashtable)))
+        (let ((table (alist->eq-hashtable '((a . b)))))
+          (let-values (((k v) (hashtable-pop! table)))
+            (test-eq 'a k)
+            (test-eq 'b v)
+            (test-assert (hashtable-empty? table)))))
+      (test-group "inc!"
+        (let ((table (alist->eq-hashtable '((a . 0)))))
+          (hashtable-inc! table 'a)
+          (test-eqv 1 (hashtable-ref table 'a))
+          (hashtable-inc! table 'a 2)
+          (test-eqv 3 (hashtable-ref table 'a))))
+      (test-group "dec!"
+        (let ((table (alist->eq-hashtable '((a . 0)))))
+          (hashtable-dec! table 'a)
+          (test-eqv -1 (hashtable-ref table 'a))
+          (hashtable-dec! table 'a 2)
+          (test-eqv -3 (hashtable-ref table 'a)))))))
+
+(test-group "hashing"
+  (test-assert (and (exact-integer? (hash-salt))))
+  (test-assert (not (negative? (hash-salt))))
+  (test-assert (= (equal-hash (list "foo" 'bar 42))
+                  (equal-hash (list "foo" 'bar 42))))
+  (test-assert (= (string-hash (string-copy "foo"))
+                  (string-hash (string-copy "foo"))))
+  (test-assert (= (string-ci-hash (string-copy "foo"))
+                  (string-ci-hash (string-copy "FOO"))))
+  (test-assert (= (symbol-hash (string->symbol "foo"))
+                  (symbol-hash (string->symbol "foo")))))
+
+(test-end "SRFI-126")
+
+(display
+ (string-append
+  "\n"
+  "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n"
+  "      14 tests are expected to fail in relation to make-eq-hashtable and\n"
+  "      make-eqv-hashtable returning hashtables whose hash functions are\n"
+  "      exposed instead of being #f.  We have no obvious way to detect this\n"
+  "      within this portable test suite, hence no XFAIL results.\n"))
+
+;; Local Variables:
+;; eval: (put (quote test-group) (quote scheme-indent-function) 1)
+;; End:
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+  (when (not (test-runner-current))
+    (let* ((log-file (string-append suite-name ".srfi64.log"))
+           (runner (test-runner-simple log-file)))
+      (%test-runner-auto-installed! runner #t)
+      (test-runner-current runner))))
+
+(define (maybe-uninstall-default-runner)
+  (when (%test-runner-auto-installed? (test-runner-current))
+    (test-runner-current #f)))
+
+(define test-begin
+  (case-lambda
+    ((name)
+     (test-begin name #f))
+    ((name count)
+     (maybe-install-default-runner name)
+     (let ((r (test-runner-current)))
+       (let ((skip-list (%test-runner-skip-list r))
+             (skip-save (%test-runner-skip-save r))
+             (fail-list (%test-runner-fail-list r))
+             (fail-save (%test-runner-fail-save r))
+             (total-count (%test-runner-total-count r))
+             (count-list (%test-runner-count-list r))
+             (group-stack (test-runner-group-stack r)))
+         ((test-runner-on-group-begin r) r name count)
+         (%test-runner-skip-save! r (cons skip-list skip-save))
+         (%test-runner-fail-save! r (cons fail-list fail-save))
+         (%test-runner-count-list! r (cons (cons total-count count)
+                                           count-list))
+         (test-runner-group-stack! r (cons name group-stack)))))))
+
+(define test-end
+  (case-lambda
+    (()
+     (test-end #f))
+    ((name)
+     (let* ((r (test-runner-get))
+            (groups (test-runner-group-stack r)))
+       (test-result-clear r)
+       (when (null? groups)
+         (error "test-end not in a group"))
+       (when (and name (not (equal? name (car groups))))
+         ((test-runner-on-bad-end-name r) r name (car groups)))
+       (let* ((count-list (%test-runner-count-list r))
+              (expected-count (cdar count-list))
+              (saved-count (caar count-list))
+              (group-count (- (%test-runner-total-count r) saved-count)))
+         (when (and expected-count
+                    (not (= expected-count group-count)))
+           ((test-runner-on-bad-count r) r group-count expected-count))
+         ((test-runner-on-group-end r) r)
+         (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+         (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+         (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+         (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+         (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+         (%test-runner-count-list! r (cdr count-list))
+         (when (null? (test-runner-group-stack r))
+           ((test-runner-on-final r) r)
+           (maybe-uninstall-default-runner)))))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ <name> <body> . <body>*)
+     (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+  (begin
+    (maybe-install-default-runner name)
+    (let ((runner (test-runner-get)))
+      (test-result-clear runner)
+      (test-result-set! runner 'name name)
+      (unless (test-skip? runner)
+        (dynamic-wind
+          (lambda () (test-begin name))
+          thunk
+          (lambda () (test-end name)))))))
+
+(define-syntax test-group-with-cleanup
+  (syntax-rules ()
+    ((_ <name> <body> <body>* ... <cleanup>)
+     (test-group <name>
+       (dynamic-wind (lambda () #f)
+                     (lambda () <body> <body>* ...)
+                     (lambda () <cleanup>))))))
+
+
+;;; Skipping, expected-failing, matching
+
+(define (test-skip . specs)
+  (let ((runner (test-runner-get)))
+    (%test-runner-skip-list!
+     runner (cons (apply test-match-all specs)
+                  (%test-runner-skip-list runner)))))
+
+(define (test-skip? runner)
+  (let ((run-list (%test-runner-run-list runner))
+        (skip-list (%test-runner-skip-list runner)))
+    (or (and run-list (not (any-pred run-list runner)))
+        (any-pred skip-list runner))))
+
+(define (test-expect-fail . specs)
+  (let ((runner (test-runner-get)))
+    (%test-runner-fail-list!
+     runner (cons (apply test-match-all specs)
+                  (%test-runner-fail-list runner)))))
+
+(define (test-match-any . specs)
+  (let ((preds (map make-pred specs)))
+    (lambda (runner)
+      (any-pred preds runner))))
+
+(define (test-match-all . specs)
+  (let ((preds (map make-pred specs)))
+    (lambda (runner)
+      (every-pred preds runner))))
+
+(define (make-pred spec)
+  (cond
+   ((procedure? spec)
+    spec)
+   ((integer? spec)
+    (test-match-nth 1 spec))
+   ((string? spec)
+    (test-match-name spec))
+   (else
+    (error "not a valid test specifier" spec))))
+
+(define test-match-nth
+  (case-lambda
+    ((n) (test-match-nth n 1))
+    ((n count)
+     (let ((i 0))
+       (lambda (runner)
+         (set! i (+ i 1))
+         (and (>= i n) (< i (+ n count))))))))
+
+(define (test-match-name name)
+  (lambda (runner)
+    (equal? name (test-runner-test-name runner))))
+
+;;; Beware: all predicates must be called because they might have side-effects;
+;;; no early returning or and/or short-circuiting of procedure calls allowed.
+
+(define (any-pred preds object)
+  (let loop ((matched? #f)
+             (preds preds))
+    (if (null? preds)
+        matched?
+        (let ((result ((car preds) object)))
+          (loop (or matched? result)
+                (cdr preds))))))
+
+(define (every-pred preds object)
+  (let loop ((failed? #f)
+             (preds preds))
+    (if (null? preds)
+        (not failed?)
+        (let ((result ((car preds) object)))
+          (loop (or failed? (not result))
+                (cdr preds))))))
+
+;;; Actual testing
+
+(define-syntax false-if-error
+  (syntax-rules ()
+    ((_ <expression> <runner>)
+     (guard (error
+             (else
+              (test-result-set! <runner> 'actual-error error)
+              #f))
+       <expression>))))
+
+(define (test-prelude source-info runner name form)
+  (test-result-clear runner)
+  (set-source-info! runner source-info)
+  (when name
+    (test-result-set! runner 'name name))
+  (test-result-set! runner 'source-form form)
+  (let ((skip? (test-skip? runner)))
+    (if skip?
+        (test-result-set! runner 'result-kind 'skip)
+        (let ((fail-list (%test-runner-fail-list runner)))
+          (when (any-pred fail-list runner)
+            ;; For later inspection only.
+            (test-result-set! runner 'result-kind 'xfail))))
+    ((test-runner-on-test-begin runner) runner)
+    (not skip?)))
+
+(define (test-postlude runner)
+  (let ((result-kind (test-result-kind runner)))
+    (case result-kind
+      ((pass)
+       (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner))))
+      ((fail)
+       (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner))))
+      ((xpass)
+       (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner))))
+      ((xfail)
+       (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner))))
+      ((skip)
+       (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner)))))
+    (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner)))
+    ((test-runner-on-test-end runner) runner)))
+
+(define (set-result-kind! runner pass?)
+  (test-result-set! runner 'result-kind
+                    (if (eq? (test-result-kind runner) 'xfail)
+                        (if pass? 'xpass 'xfail)
+                        (if pass? 'pass 'fail))))
+
+;;; We need to use some trickery to get the source info right.  The important
+;;; thing is to pass a syntax object that is a pair to `source-info', and make
+;;; sure this syntax object comes from user code and not from ourselves.
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-assert/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-assert/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expr>)
+     (test-assert/source-info <source-info> #f <expr>))
+    ((_ <source-info> <name> <expr>)
+     (%test-assert <source-info> <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (let ((val (false-if-error (thunk) runner)))
+        (test-result-set! runner 'actual-value val)
+        (set-result-kind! runner val)))
+    (test-postlude runner)))
+
+(define-syntax test-compare
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-compare/source-info
+  (syntax-rules ()
+    ((_ <source-info> <compare> <expected> <expr>)
+     (test-compare/source-info <source-info> <compare> #f <expected> <expr>))
+    ((_ <source-info> <compare> <name> <expected> <expr>)
+     (%test-compare <source-info> <compare> <name> <expected> '<expr>
+                    (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (test-result-set! runner 'expected-value expected)
+      (let ((pass? (false-if-error
+                    (let ((val (thunk)))
+                      (test-result-set! runner 'actual-value val)
+                      (compare expected val))
+                    runner)))
+        (set-result-kind! runner pass?)))
+    (test-postlude runner)))
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) equal? . <rest>))))
+
+(define-syntax test-eqv
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) eqv? . <rest>))))
+
+(define-syntax test-eq
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) eq? . <rest>))))
+
+(define (approx= margin)
+  (lambda (value expected)
+    (let ((rval (real-part value))
+          (ival (imag-part value))
+          (rexp (real-part expected))
+          (iexp (imag-part expected)))
+      (and (>= rval (- rexp margin))
+           (>= ival (- iexp margin))
+           (<= rval (+ rexp margin))
+           (<= ival (+ iexp margin))))))
+
+(define-syntax test-approximate
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-approximate/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-approximate/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expected> <expr> <error-margin>)
+     (test-approximate/source-info
+      <source-info> #f <expected> <expr> <error-margin>))
+    ((_ <source-info> <name> <expected> <expr> <error-margin>)
+     (test-compare/source-info
+      <source-info> (approx= <error-margin>) <name> <expected> <expr>))))
+
+(define (error-matches? error type)
+  (cond
+   ((eq? type #t)
+    #t)
+   ((condition-type? type)
+    (and (condition? error) (condition-has-type? error type)))
+   ((procedure? type)
+    (type error))
+   (else
+    (let ((runner (test-runner-get)))
+      ((%test-runner-on-bad-error-type runner) runner type error))
+    #f)))
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-error/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-error/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expr>)
+     (test-error/source-info <source-info> #f #t <expr>))
+    ((_ <source-info> <error-type> <expr>)
+     (test-error/source-info <source-info> #f <error-type> <expr>))
+    ((_ <source-info> <name> <error-type> <expr>)
+     (%test-error <source-info> <name> <error-type> '<expr>
+                  (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (test-result-set! runner 'expected-error error-type)
+      (let ((pass? (guard (error (else (test-result-set!
+                                        runner 'actual-error error)
+                                       (error-matches? error error-type)))
+                     (let ((val (thunk)))
+                       (test-result-set! runner 'actual-value val))
+                     #f)))
+        (set-result-kind! runner pass?)))
+    (test-postlude runner)))
+
+(define (default-module)
+  (cond-expand
+   (guile (current-module))
+   (else #f)))
+
+(define test-read-eval-string
+  (case-lambda
+    ((string)
+     (test-read-eval-string string (default-module)))
+    ((string env)
+     (let* ((port (open-input-string string))
+            (form (read port)))
+       (if (eof-object? (read-char port))
+           (if env
+               (eval form env)
+               (eval form))
+           (error "(not at eof)"))))))
+
+
+;;; Test runner control flow
+
+(define-syntax test-with-runner
+  (syntax-rules ()
+    ((_ <runner> <body> . <body>*)
+     (let ((saved-runner (test-runner-current)))
+       (dynamic-wind
+         (lambda () (test-runner-current <runner>))
+         (lambda () <body> . <body>*)
+         (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+  (let ((runner (if (test-runner? first)
+                    first
+                    (or (test-runner-current) (test-runner-create))))
+        (run-list (if (test-runner? first)
+                      (drop-right rest 1)
+                      (cons first (drop-right rest 1))))
+        (proc (last rest)))
+    (test-with-runner runner
+      (let ((saved-run-list (%test-runner-run-list runner)))
+        (%test-runner-run-list! runner run-list)
+        (proc)
+        (%test-runner-run-list! runner saved-run-list)))))
+
+
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+  (let ((runner (test-runner-current)))
+    (when (not runner)
+      (error "No test runner installed.  Might have been auto-removed
+by test-end if you had not installed one explicitly."))
+    (if (and (zero? (test-runner-xpass-count runner))
+             (zero? (test-runner-fail-count runner)))
+        (exit 0)
+        (exit 1))))
+
+;;; execution.scm ends here
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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.
+
+;;; In some systems, a macro use like (source-info ...), that resides in a
+;;; syntax-rules macro body, first gets inserted into the place where the
+;;; syntax-rules macro was used, and then the transformer of 'source-info' is
+;;; called with a syntax object that has the source location information of that
+;;; position.  That works fine when the user calls e.g. (test-assert ...), whose
+;;; body contains (source-info ...); the user gets the source location of the
+;;; (test-assert ...) call as intended, and not the source location of the real
+;;; (source-info ...) call.
+
+;;; In other systems, *first* the (source-info ...) is processed to get its real
+;;; position, which is within the body of a syntax-rules macro like test-assert,
+;;; so no matter where the user calls (test-assert ...), they get source
+;;; location information of where we defined test-assert with the call to
+;;; (source-info ...) in its body.  That's arguably more correct behavior,
+;;; although in this case it makes our job a bit harder; we need to get the
+;;; source location from an argument to 'source-info' instead.
+
+(define (canonical-syntax form arg)
+  (cond-expand
+   (kawa arg)
+   (guile-2 form)
+   (else #f)))
+
+(cond-expand
+ ((or kawa guile-2)
+  (define-syntax source-info
+    (lambda (stx)
+      (syntax-case stx ()
+        ((_ <x>)
+         (let* ((stx (canonical-syntax stx (syntax <x>)))
+                (file (syntax-source-file stx))
+                (line (syntax-source-line stx)))
+           (quasisyntax
+            (cons (unsyntax file) (unsyntax line)))))))))
+ (else
+  (define-syntax source-info
+    (syntax-rules ()
+      ((_ <x>)
+       #f)))))
+
+(define (syntax-source-file stx)
+  (cond-expand
+   (kawa
+    (syntax-source stx))
+   (guile-2
+    (let ((source (syntax-source stx)))
+      (and source (assq-ref source 'filename))))
+   (else
+    #f)))
+
+(define (syntax-source-line stx)
+  (cond-expand
+   (kawa
+    (syntax-line stx))
+   (guile-2
+    (let ((source (syntax-source stx)))
+      (and source (assq-ref source 'line))))
+   (else
+    #f)))
+
+(define (set-source-info! runner source-info)
+  (when source-info
+    (test-result-set! runner 'source-file (car source-info))
+    (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; source-info.body.scm ends here
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Helpers
+
+(define (string-join strings delimiter)
+  (if (null? strings)
+      ""
+      (let loop ((result (car strings))
+                 (rest (cdr strings)))
+        (if (null? rest)
+            result
+            (loop (string-append result delimiter (car rest))
+                  (cdr rest))))))
+
+(define (truncate-string string length)
+  (define (newline->space c) (if (char=? #\newline c) #\space c))
+  (let* ((string (string-map newline->space string))
+         (fill "...")
+         (fill-len (string-length fill))
+         (string-len (string-length string)))
+    (if (<= string-len (+ length fill-len))
+        string
+        (let-values (((q r) (floor/ length 4)))
+          ;; Left part gets 3/4 plus the remainder.
+          (let ((left-end (+ (* q 3) r))
+                (right-start (- string-len q)))
+            (string-append (substring string 0 left-end)
+                           fill
+                           (substring string right-start string-len)))))))
+
+(define (print runner format-string . args)
+  (apply format #t format-string args)
+  (let ((port (%test-runner-log-port runner)))
+    (when port
+      (apply format port format-string args))))
+
+;;; Main
+
+(define test-runner-simple
+  (case-lambda
+   (()
+    (test-runner-simple #f))
+   ((log-file)
+    (let ((runner (test-runner-null)))
+      (test-runner-reset runner)
+      (test-runner-on-group-begin!     runner test-on-group-begin-simple)
+      (test-runner-on-group-end!       runner test-on-group-end-simple)
+      (test-runner-on-final!           runner test-on-final-simple)
+      (test-runner-on-test-begin!      runner test-on-test-begin-simple)
+      (test-runner-on-test-end!        runner test-on-test-end-simple)
+      (test-runner-on-bad-count!       runner test-on-bad-count-simple)
+      (test-runner-on-bad-end-name!    runner test-on-bad-end-name-simple)
+      (%test-runner-on-bad-error-type! runner on-bad-error-type)
+      (%test-runner-log-file!          runner log-file)
+      runner))))
+
+(when (not (test-runner-factory))
+  (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+  (when (null? (test-runner-group-stack runner))
+    (maybe-start-logging runner)
+    (print runner "Test suite begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+  (let ((name (car (test-runner-group-stack runner))))
+    (when (= 1 (length (test-runner-group-stack runner)))
+      (print runner "Test suite end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+  (print runner "Passes:            ~a\n" (test-runner-pass-count runner))
+  (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+  (print runner "Failures:          ~a\n" (test-runner-fail-count runner))
+  (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+  (print runner "Skipped tests:     ~a~%" (test-runner-skip-count runner))
+  (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+  (let ((log-file (%test-runner-log-file runner)))
+    (when log-file
+      ;; The possible race-condition here doesn't bother us.
+      (when (file-exists? log-file)
+        (delete-file log-file))
+      (%test-runner-log-port! runner (open-output-file log-file))
+      (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+  (let ((log-file (%test-runner-log-file runner)))
+    (when log-file
+      (print runner "Wrote log file: ~a~%" log-file)
+      (close-output-port (%test-runner-log-port runner)))))
+
+(define (test-on-test-begin-simple runner)
+  (values))
+
+(define (test-on-test-end-simple runner)
+  (let* ((result-kind (test-result-kind runner))
+         (result-kind-name (case result-kind
+                             ((pass) "PASS") ((fail) "FAIL")
+                             ((xpass) "XPASS") ((xfail) "XFAIL")
+                             ((skip) "SKIP")))
+         (name (let ((name (test-runner-test-name runner)))
+                 (if (string=? "" name)
+                     (truncate-string
+                      (format #f "~a" (test-result-ref runner 'source-form))
+                      30)
+                     name)))
+         (label (string-join (append (test-runner-group-path runner)
+                                     (list name))
+                             ": ")))
+    (print runner "[~a] ~a~%" result-kind-name label)
+    (when (memq result-kind '(fail xpass))
+      (let ((nil (cons #f #f)))
+        (define (found? value)
+          (not (eq? nil value)))
+        (define (maybe-print value message)
+          (when (found? value)
+            (print runner message value)))
+        (let ((file (test-result-ref runner 'source-file "(unknown file)"))
+              (line (test-result-ref runner 'source-line "(unknown line)"))
+              (expression (test-result-ref runner 'source-form))
+              (expected-value (test-result-ref runner 'expected-value nil))
+              (actual-value (test-result-ref runner 'actual-value nil))
+              (expected-error (test-result-ref runner 'expected-error nil))
+              (actual-error (test-result-ref runner 'actual-error nil)))
+          (print runner "~a:~a: ~s~%" file line expression)
+          (maybe-print expected-value "Expected value: ~s~%")
+          (maybe-print expected-error "Expected error: ~a~%")
+          (when (or (found? expected-value) (found? expected-error))
+            (maybe-print actual-value "Returned value: ~s~%"))
+          (maybe-print actual-error "Raised error: ~a~%")
+          (newline))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+  (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+          count expected-count)
+  (print runner
+         "*** Discrepancy indicates testsuite error or exceptions. ***~%"))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+  (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"."
+                 end-name begin-name)))
+
+(define (on-bad-error-type runner type error)
+  (print runner "WARNING: unknown error type predicate: ~a~%" type)
+  (print runner "         error was: ~a~%" error))
+
+;;; test-runner-simple.scm ends here
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+
+;;; The data type
+
+(define-record-type <test-runner>
+  (make-test-runner) test-runner?
+
+  (result-alist test-result-alist test-result-alist!)
+
+  (pass-count test-runner-pass-count test-runner-pass-count!)
+  (fail-count test-runner-fail-count test-runner-fail-count!)
+  (xpass-count test-runner-xpass-count test-runner-xpass-count!)
+  (xfail-count test-runner-xfail-count test-runner-xfail-count!)
+  (skip-count test-runner-skip-count test-runner-skip-count!)
+  (total-count %test-runner-total-count %test-runner-total-count!)
+
+  ;; Stack (list) of (count-at-start . expected-count):
+  (count-list %test-runner-count-list %test-runner-count-list!)
+
+  ;; Normally #f, except when in a test-apply.
+  (run-list %test-runner-run-list %test-runner-run-list!)
+
+  (skip-list %test-runner-skip-list %test-runner-skip-list!)
+  (fail-list %test-runner-fail-list %test-runner-fail-list!)
+
+  (skip-save %test-runner-skip-save %test-runner-skip-save!)
+  (fail-save %test-runner-fail-save %test-runner-fail-save!)
+
+  (group-stack test-runner-group-stack test-runner-group-stack!)
+
+  ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and
+  ;; test-end forms in the execution library.  They're called at the
+  ;; beginning/end of each individual test, whereas the test-begin and test-end
+  ;; forms demarcate test groups.
+
+  (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+  (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!)
+  (on-test-end test-runner-on-test-end test-runner-on-test-end!)
+  (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+  (on-final test-runner-on-final test-runner-on-final!)
+  (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!)
+  (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+
+  (on-bad-error-type %test-runner-on-bad-error-type
+                     %test-runner-on-bad-error-type!)
+
+  (aux-value test-runner-aux-value test-runner-aux-value!)
+
+  (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!)
+
+  (log-file %test-runner-log-file %test-runner-log-file!)
+  (log-port %test-runner-log-port %test-runner-log-port!))
+
+(define (test-runner-group-path runner)
+  (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-reset runner)
+  (test-result-alist! runner '())
+  (test-runner-pass-count! runner 0)
+  (test-runner-fail-count! runner 0)
+  (test-runner-xpass-count! runner 0)
+  (test-runner-xfail-count! runner 0)
+  (test-runner-skip-count! runner 0)
+  (%test-runner-total-count! runner 0)
+  (%test-runner-count-list! runner '())
+  (%test-runner-run-list! runner #f)
+  (%test-runner-skip-list! runner '())
+  (%test-runner-fail-list! runner '())
+  (%test-runner-skip-save! runner '())
+  (%test-runner-fail-save! runner '())
+  (test-runner-group-stack! runner '()))
+
+(define (test-runner-null)
+  (define (test-null-callback . args) #f)
+  (let ((runner (make-test-runner)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner test-null-callback)
+    (test-runner-on-group-end! runner test-null-callback)
+    (test-runner-on-final! runner test-null-callback)
+    (test-runner-on-test-begin! runner test-null-callback)
+    (test-runner-on-test-end! runner test-null-callback)
+    (test-runner-on-bad-count! runner test-null-callback)
+    (test-runner-on-bad-end-name! runner test-null-callback)
+    (%test-runner-on-bad-error-type! runner test-null-callback)
+    (%test-runner-auto-installed! runner #f)
+    (%test-runner-log-file! runner #f)
+    (%test-runner-log-port! runner #f)
+    runner))
+
+
+;;; State
+
+(define test-result-ref
+  (case-lambda
+    ((runner key)
+     (test-result-ref runner key #f))
+    ((runner key default)
+     (let ((entry (assq key (test-result-alist runner))))
+       (if entry (cdr entry) default)))))
+
+(define (test-result-set! runner key value)
+  (let* ((alist (test-result-alist runner))
+         (entry (assq key alist)))
+    (if entry
+        (set-cdr! entry value)
+        (test-result-alist! runner (cons (cons key value) alist)))))
+
+(define (test-result-remove runner key)
+  (test-result-alist! runner (remove (lambda (entry)
+                                       (eq? key (car entry)))
+                                     (test-result-alist runner))))
+
+(define (test-result-clear runner)
+  (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+  (or (test-result-ref runner 'name) ""))
+
+(define test-result-kind
+  (case-lambda
+    (() (test-result-kind (test-runner-get)))
+    ((runner) (test-result-ref runner 'result-kind))))
+
+(define test-passed?
+  (case-lambda
+    (() (test-passed? (test-runner-get)))
+    ((runner) (memq (test-result-kind runner) '(pass xpass)))))
+
+
+;;; Factory and current instance
+
+(define test-runner-factory (make-parameter #f))
+
+(define (test-runner-create) ((test-runner-factory)))
+
+(define test-runner-current (make-parameter #f))
+
+(define (test-runner-get)
+  (or (test-runner-current)
+      (error "test-runner not initialized - test-begin missing?")))
+
+;;; test-runner.scm ends here
+(define-module (srfi srfi-64)
+  #\export
+  (test-begin
+   test-end test-assert test-eqv test-eq test-equal
+   test-approximate test-assert test-error test-apply test-with-runner
+   test-match-nth test-match-all test-match-any test-match-name
+   test-skip test-expect-fail test-read-eval-string
+   test-runner-group-path test-group test-group-with-cleanup
+   test-exit
+   test-result-ref test-result-set! test-result-clear test-result-remove
+   test-result-kind test-passed?
+   test-runner? test-runner-reset test-runner-null
+   test-runner-simple test-runner-current test-runner-factory test-runner-get
+   test-runner-create test-runner-test-name
+   test-runner-pass-count test-runner-pass-count!
+   test-runner-fail-count test-runner-fail-count!
+   test-runner-xpass-count test-runner-xpass-count!
+   test-runner-xfail-count test-runner-xfail-count!
+   test-runner-skip-count test-runner-skip-count!
+   test-runner-group-stack test-runner-group-stack!
+   test-runner-on-test-begin test-runner-on-test-begin!
+   test-runner-on-test-end test-runner-on-test-end!
+   test-runner-on-group-begin test-runner-on-group-begin!
+   test-runner-on-group-end test-runner-on-group-end!
+   test-runner-on-final test-runner-on-final!
+   test-runner-on-bad-count test-runner-on-bad-count!
+   test-runner-on-bad-end-name test-runner-on-bad-end-name!
+   test-result-alist test-result-alist!
+   test-runner-aux-value test-runner-aux-value!
+   test-on-group-begin-simple test-on-group-end-simple
+   test-on-bad-count-simple test-on-bad-end-name-simple
+   test-on-final-simple test-on-test-end-simple
+   test-on-final-simple))
+
+(cond-expand-provide (current-module) '(srfi-64))
+
+(import
+ (only (rnrs exceptions) guard)
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-11)
+ (srfi srfi-35))
+(include-from-path "srfi/srfi-64/source-info.body.scm")
+(include-from-path "srfi/srfi-64/test-runner.body.scm")
+(include-from-path "srfi/srfi-64/test-runner-simple.body.scm")
+(include-from-path "srfi/srfi-64/execution.body.scm")
+(define-library (srfi-tests aux)
+  (export define-tests)
+  (import
+   (scheme base)
+   (scheme write)
+   (scheme case-lambda)
+   (srfi 64))
+  (begin
+    (define-syntax define-tests
+      (syntax-rules ()
+        ((_ proc-name suite-name form ...)
+         (define proc-name
+           (case-lambda
+             (() (proc-name (test-runner-create)))
+             ((runner)
+              (parameterize ((test-runner-current runner))
+                (test-begin suite-name)
+                form ...
+                (test-end suite-name)
+                (and (= 0 (test-runner-xpass-count runner))
+                     (= 0 (test-runner-fail-count runner))))))))))
+    ))
+;; Copyright (C) Oleg Kiselyov (1998). All Rights Reserved.
+
+;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;; 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-library (srfi-tests srfi-2)
+  (export run-tests)
+  (import
+   (scheme base)
+   (scheme eval)
+   (srfi 2)
+   (srfi 64)
+   (srfi-tests aux))
+  (begin
+
+    (define (test-eval form)
+      (eval form (environment '(scheme base) '(srfi 2))))
+
+    ;; We want to check whether 'form' has indeed wrong syntax.  We eval it and
+    ;; check for any exception, which is our best approximation.
+    (define-syntax test-syntax-error
+      (syntax-rules ()
+        ((_ form)
+         (test-error (test-eval 'form)))))
+
+    (define-tests run-tests "SRFI-2"
+      (test-equal 1 (and-let* () 1))
+      (test-equal 2 (and-let* () 1 2))
+      (test-equal #t (and-let* ()))
+
+      (test-equal #f (let ((x #f)) (and-let* (x))))
+      (test-equal 1 (let ((x 1)) (and-let* (x))))
+      (test-equal #f (and-let* ((x #f))))
+      (test-equal 1 (and-let* ((x 1))))
+      (test-equal #f (and-let* ((#f) (x 1))))
+      (test-equal 1 (and-let* ((2) (x 1))))
+      ;; Gauche allows let-binding a constant, thus fails to signal an error on
+      ;; the following two tests.
+      (cond-expand
+       (gauche (test-expect-fail 2))
+       (else))
+      (test-syntax-error (and-let* (#f (x 1))))
+      (test-syntax-error (and-let* (2 (x 1))))
+      (test-equal 2 (and-let* ((x 1) (2))))
+      (test-equal #f (let ((x #f)) (and-let* (x) x)))
+      (test-equal "" (let ((x "")) (and-let* (x) x)))
+      (test-equal "" (let ((x "")) (and-let* (x))))
+      (test-equal 2 (let ((x 1)) (and-let* (x) (+ x 1))))
+      (test-equal #f (let ((x #f)) (and-let* (x) (+ x 1))))
+      (test-equal 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1))))
+      (test-equal #t (let ((x 1)) (and-let* (((positive? x))))))
+      (test-equal #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1))))
+      (test-equal 3
+        (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))))
+      ;; This is marked as must-be-error in the original test suite; see
+      ;; comments in the implementation for our rationale for intentionally
+      ;; breaking off from the specification.
+      (test-equal 4
+        (let ((x 1))
+          (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
+
+      (test-equal 2
+        (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test-equal 2
+        (let ((x 1)) (and-let* (((begin x)) ((positive? x))) (+ x 1))))
+      (test-equal #f
+        (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test-equal #f
+        (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))))
+      (test-equal #f
+        (let ((x #f)) (and-let* (((begin x)) ((positive? x))) (+ x 1))))
+
+      (test-equal #f
+        (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test-equal #f
+        (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test-equal #f
+        (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+      (test-equal 3/2
+        (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))))
+
+    ))
+(define-library (srfi-tests srfi-26)
+  (export run-tests)
+  (import
+   (scheme base)
+   (srfi 26)
+   (srfi 64)
+   (srfi-tests aux))
+  (begin
+    (define-tests run-tests "SRFI-26"
+      ;; cut
+      (test-equal '() ((cut list)))
+      (test-equal '() ((cut list <___>)))
+      (test-equal '(1) ((cut list 1)))
+      (test-equal '(1) ((cut list <>) 1))
+      (test-equal '(1) ((cut list <___>) 1))
+      (test-equal '(1 2) ((cut list 1 2)))
+      (test-equal '(1 2) ((cut list 1 <>) 2))
+      (test-equal '(1 2) ((cut list 1 <___>) 2))
+      (test-equal '(1 2 3 4) ((cut list 1 <___>) 2 3 4))
+      (test-equal '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4))
+      (test-equal '(1 2 3 4 5 6) ((cut list 1 <> 3 <___>) 2 4 5 6))
+      (test-equal '(ok) (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)))
+      (test-equal 2 (let ((a 0))
+                       (map (cut + (begin (set! a (+ a 1)) a) <>)
+                            '(1 2))
+                       a))
+      ;; cute
+      (test-equal '() ((cute list)))
+      (test-equal '() ((cute list <___>)))
+      (test-equal '(1) ((cute list 1)))
+      (test-equal '(1) ((cute list <>) 1))
+      (test-equal '(1) ((cute list <___>) 1))
+      (test-equal '(1 2) ((cute list 1 2)))
+      (test-equal '(1 2) ((cute list 1 <>) 2))
+      (test-equal '(1 2) ((cute list 1 <___>) 2))
+      (test-equal '(1 2 3 4) ((cute list 1 <___>) 2 3 4))
+      (test-equal '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4))
+      (test-equal '(1 2 3 4 5 6) ((cute list 1 <> 3 <___>) 2 4 5 6))
+      (test-equal 1 (let ((a 0))
+                       (map (cute + (begin (set! a (+ a 1)) a) <>)
+                            '(1 2))
+                       a)))))
+(define-library (srfi-tests srfi-31)
+  (export run-tests)
+  (import
+   (scheme base)
+   (scheme lazy)
+   (srfi 31)
+   (srfi 64)
+   (srfi-tests aux))
+  (begin
+    (define-tests run-tests "SRFI-31"
+      (test-eqv "factorial" 3628800
+        ((rec (! n)
+           (if (zero? n)
+               1
+               (* n (! (- n 1)))))
+         10))
+      (test-eqv "lazy stream" 'x
+        (car (force (cdr (force (cdr (rec xs (cons 'x (delay xs))))))))))))
+
+
+(define-library (srfi-tests srfi-54)
+  (export run-tests)
+  (import
+   (scheme base)
+   (scheme char)
+   (scheme write)
+   (srfi 54)
+   (srfi 64)
+   (srfi-tests aux))
+  (begin
+
+    (define-syntax value-and-output
+      (syntax-rules ()
+        ((_ expr)
+         (let ((port (open-output-string)))
+           (parameterize ((current-output-port port))
+             (let ((value expr))
+               (list value (get-output-string port))))))))
+
+    (define (string-reverse string)
+      (list->string (reverse (string->list string))))
+
+    (define-tests run-tests "SRFI-54"
+      (test-equal "130.00    " (cat 129.995 -10 2.))
+      (test-equal "    130.00" (cat 129.995 10 2.))
+      (test-equal "    129.98" (cat 129.985 10 2.))
+      (test-equal "    129.99" (cat 129.985001 10 2.))
+      (test-equal "#e130.00" (cat 129.995 2. 'exact))
+      (test-equal "129.00" (cat 129 -2.))
+      (test-equal "#e129.00" (cat 129 2.))
+      (test-equal "#e+0129.00" (cat 129 10 2. #\0 'sign))
+      (test-equal "*#e+129.00" (cat 129 10 2. #\* 'sign))
+      (test-equal "1/3" (cat 1/3))
+      (test-equal "    #e0.33" (cat 1/3 10 2.))
+      (test-equal "      0.33" (cat 1/3 10 -2.))
+      (test-equal " 1,29.99,5" (cat 129.995 10 '(#\, 2)))
+      (test-equal "  +129,995" (cat 129995 10 '(#\,) 'sign))
+      (test-equal "130" (cat (cat 129.995 0.) '(0 -1)))
+      ;; These produce different results on Chibi, but I don't know if that's a
+      ;; bug or whether the result is implementation-dependent.
+      ;; (test-equal "#i#o+307/2" (cat 99.5 10 'sign 'octal))
+      ;; (test-equal "  #o+307/2" (cat 99.5 10 'sign 'octal 'exact))
+      (test-equal "#o+443" (cat #x123 'octal 'sign))
+      (test-equal "#e+291.00*" (cat #x123 -10 2. 'sign #\*))
+      ;; These produce different results on Larceny, but I don't know if that's
+      ;; a bug or whether the result is implementation-dependent.
+      ;; (test-equal "-1.234e+15+1.236e-15i" (cat -1.2345e+15+1.2355e-15i 3.))
+      ;; (test-equal "+1.234e+15" (cat 1.2345e+15 10 3. 'sign))
+      (test-equal "string    " (cat "string" -10))
+      (test-equal "    STRING" (cat "string" 10 (list string-upcase)))
+      (test-equal "      RING" (cat "string" 10 (list string-upcase) '(-2)))
+      (test-equal "     STING" (cat "string" 10 `(,string-upcase) '(2 3)))
+      (test-equal "GNIRTS" (cat "string" `(,string-reverse ,string-upcase)))
+      (test-equal "         a" (cat #\a 10))
+      (test-equal "    symbol" (cat 'symbol 10))
+      (test-equal "#(#\\a \"str\" s)" (cat '#(#\a "str" s)))
+      (test-equal "(#\\a \"str\" s)" (cat '(#\a "str" s)))
+      (test-equal '("(#\\a \"str\" s)" "(#\\a \"str\" s)")
+          (value-and-output (cat '(#\a "str" s) #t)))
+      (test-equal '("(#\\a \"str\" s)" "(#\\a \"str\" s)")
+          (value-and-output (cat '(#\a "str" s) (current-output-port))))
+      (test-equal "3s \"str\"" (cat 3 (cat 's) " " (cat "str" write)))
+      (test-equal '("3s \"str\"" "3s \"str\"")
+          (value-and-output (cat 3 #t (cat 's) " " (cat "str" write))))
+      (test-equal '("3s \"str\"" "s3s \"str\"")
+          (value-and-output (cat 3 #t (cat 's #t) " " (cat "str" write)))))
+
+    ))
+(import
+ (scheme base)
+ (scheme process-context)
+ (srfi 64))
+
+;;;
+;;;  This is a test suite written in the notation of 
+;;;  SRFI-64, A Scheme API for test suites
+;;;
+
+(test-begin "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;;  Ironically, in order to set up the meta-test environment,
+;;;  we have to invoke one of the most sophisticated features:
+;;;  custom test runners
+;;;
+
+;;;  The `prop-runner' invokes `thunk' in the context of a new
+;;;  test runner, and returns the indicated properties of the 
+;;;  last-executed test result.
+
+(define (prop-runner props thunk)
+  (let ((r (test-runner-null))
+        (plist '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! plist (test-result-alist runner))))
+    ;;
+    (test-with-runner r (thunk))
+    ;; reorder the properties so they are in the order
+    ;; given by `props'.  Note that any property listed in `props'
+    ;; that is not in the property alist will occur as #f
+    (map (lambda (k)
+           (assq k plist))
+         props)))
+
+;;;  `on-test-runner' creates a null test runner and then
+;;;  arranged for `visit' to be called with the runner
+;;;  whenever a test is run.  The results of the calls to
+;;;  `visit' are returned in a list
+
+(define (on-test-runner thunk visit)
+  (let ((r (test-runner-null))
+        (results '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! results (cons (visit r) results))))
+    ;;
+    (test-with-runner r (thunk))
+    (reverse results)))
+
+;;;
+;;;  The `triv-runner' invokes `thunk'
+;;;  and returns a list of 6 lists, the first 5 of which
+;;;  are a list of the names of the tests that, respectively,
+;;;  PASS, FAIL, XFAIL, XPASS, and SKIP.
+;;;  The last item is a list of counts.
+;;;
+
+(define (triv-runner thunk)
+  (let ((r (test-runner-null))
+        (accum-pass '())
+        (accum-fail '())
+        (accum-xfail '())
+        (accum-xpass '())
+        (accum-skip '()))
+    ;;
+    (test-runner-on-bad-count!
+     r
+     (lambda (runner count expected-count)
+       (error (string-append "bad count " (number->string count)
+			     " but expected "
+			     (number->string expected-count)))))
+    (test-runner-on-bad-end-name!
+     r
+     (lambda (runner begin end)
+       (error (string-append "bad end group name " end
+			     " but expected " begin))))
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (let ((n (test-runner-test-name runner)))
+         (case (test-result-kind runner)
+           ((pass) (set! accum-pass (cons n accum-pass)))
+           ((fail) (set! accum-fail (cons n accum-fail)))
+           ((xpass) (set! accum-xpass (cons n accum-xpass)))
+           ((xfail) (set! accum-xfail (cons n accum-xfail)))
+           ((skip) (set! accum-skip (cons n accum-skip)))))))
+    ;;
+    (test-with-runner r (thunk))
+    (list (reverse accum-pass)    ; passed as expected
+          (reverse accum-fail)    ; failed, but was expected to pass
+          (reverse accum-xfail)   ; failed as expected
+          (reverse accum-xpass)   ; passed, but was expected to fail
+          (reverse accum-skip)    ; was not executed
+          (list (test-runner-pass-count r)
+                (test-runner-fail-count r)
+                (test-runner-xfail-count r)
+                (test-runner-xpass-count r)
+                (test-runner-skip-count r)))))
+
+(define (path-revealing-runner thunk)
+  (let ((r (test-runner-null))
+        (seq '()))
+    ;;
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (set! seq (cons (list (test-runner-group-path runner)
+                             (test-runner-test-name runner))
+                       seq))))
+    (test-with-runner r (thunk))
+    (reverse seq)))
+
+;;;
+;;;  Now we can start testing compliance with SRFI-64
+;;;
+
+(test-begin "1. Simple test-cases")
+
+(test-begin "1.1. test-assert")
+
+(define (t)
+  (triv-runner
+   (lambda ()
+     (test-assert "a" #t)
+     (test-assert "b" #f))))
+
+(test-equal
+ "1.1.1. Very simple"
+ '(("a") ("b") () () () (1 1 0 0 0))
+ (t))
+
+(test-equal
+ "1.1.2. A test with no name"
+ '(("a") ("") () () () (1 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
+
+(test-equal
+ "1.1.3. Tests can have the same name"
+ '(("a" "a") () () () () (2 0 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
+
+(define (choke)
+  (vector-ref '#(1 2) 3))
+
+(test-equal
+ "1.1.4. One way to FAIL is to throw an error"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" (choke)))))
+
+(test-end);1.1
+
+(test-begin "1.2. test-eqv")
+
+(define (mean x y)
+  (/ (+ x y) 2.0))
+
+(test-equal
+ "1.2.1.  Simple numerical equivalence"
+ '(("c") ("a" "b") () () () (1 2 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-eqv "a" (mean 3 5) 4)
+    (test-eqv "b" (mean 3 5) 4.5)
+    (test-eqv "c" (mean 3 5) 4.0))))
+
+(test-end);1.2
+
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-approximate "a" (mean 3 5) 4   0.001)
+    (test-approximate "b" (mean 3 5) 4.5 0.001)
+    (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
+(test-end "1. Simple test-cases")
+
+;;;
+;;;
+;;;
+
+(test-begin "2. Tests for catching errors")
+
+(test-begin "2.1. test-error")
+
+(test-equal
+ "2.1.1. Baseline test; PASS with no optional args"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.2. Baseline test; FAIL with no optional args"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL: the expr does not raise an error and `test-error' is
+    ;;       claiming that it will, so this test should FAIL
+    (test-error (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.3. PASS with a test name and error type"
+ '(("a") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error "a" #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error #t (vector-ref '#(1 2) 0)))))
+
+(test-end "2.1. test-error")
+
+(test-end "2. Tests for catching errors")
+
+;;;
+;;;
+;;;
+
+(test-begin "3. Test groups and paths")
+
+(test-equal
+ "3.1. test-begin with unspecific test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end))))
+
+(test-equal
+ "3.2. test-begin with name-matching test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+;;; since the error raised by `test-end' on a mismatch is not a test
+;;; error, we actually expect the triv-runner itself to fail
+
+(test-error
+ "3.3. test-begin with mismatched test-end"
+#t
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "x"))))
+
+(test-equal
+ "3.4. test-begin with name and count"
+ '(("b" "c") () () () () (2 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 2)
+    (test-assert "b" #t)
+    (test-assert "c" #t)
+    (test-end "a"))))
+
+;; similarly here, a mismatched count is a lexical error
+;; and not a test failure...
+
+(test-error
+ "3.5. test-begin with mismatched count"
+ #t
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 99)
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+(test-equal
+ "3.6. introspecting on the group path"
+ '((() "w")
+   (("a" "b") "x")
+   (("a" "b") "y")
+   (("a") "z"))
+ ;;
+ ;;  `path-revealing-runner' is designed to return a list
+ ;;  of the tests executed, in order.  Each entry is a list
+ ;;  (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
+ ;;  of test groups starting from the topmost
+ ;;
+ (path-revealing-runner
+  (lambda ()
+    (test-assert "w" #t)
+    (test-begin "a")
+    (test-begin "b")
+    (test-assert "x" #t)
+    (test-assert "y" #t)
+    (test-end)
+    (test-assert "z" #t))))
+
+
+(test-end "3. Test groups and paths")
+
+;;;
+;;;
+;;;
+
+(test-begin "4. Handling set-up and cleanup")
+
+(test-equal "4.1. Normal exit path"
+             '(in 1 2 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-group-with-cleanup
+                   "foo"
+                   (do 'in)
+                   (do 1)
+                   (do 2)
+                   (do 'out))))
+               (reverse ex)))
+               
+(test-equal "4.2. Exception exit path"
+             '(in 1 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               ;; the outer runner is to run the `test-error' in, to
+               ;; catch the exception raised in the inner runner,
+               ;; since we don't want to depend on any other
+               ;; exception-catching support
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-error
+                   (triv-runner
+                    (lambda ()
+                      (test-group-with-cleanup
+                       "foo"
+                       (do 'in) (test-assert #t)
+                       (do 1)   (test-assert #t)
+                       (choke)  (test-assert #t)
+                       (do 2)   (test-assert #t)
+                       (do 'out)))))))
+               (reverse ex)))
+
+(test-end "4. Handling set-up and cleanup")
+
+;;;
+;;;
+;;;
+
+(test-begin "5. Test specifiers")
+
+(test-begin "5.1. test-match-named")
+
+(test-equal "5.1.1. match test names"
+            '(("y") () () () ("x") (1 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-assert "x" #t)
+               (test-assert "y" #t))))
+
+(test-equal "5.1.2. but not group names"
+            '(("z") () () () () (1 0 0 0 0))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-begin "x")
+               (test-assert "z" #t)
+               (test-end))))
+
+(test-end)
+
+(test-begin "5.2. test-match-nth")
+;; See also: [6.4. Short-circuit evaluation]
+
+(test-equal "5.2.1. skip the nth one after"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.2.2. skip m, starting at n"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3 SKIP
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.3. test-match-any")
+(test-equal "5.3.1. basic disjunction"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-nth 3)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.3.2. disjunction is commutative"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-name "x")
+                                          (test-match-nth 3)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.4. test-match-all")
+(test-equal "5.4.1. basic conjunction"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-nth 2 2)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.4.2. conjunction is commutative"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-name "x")
+                                          (test-match-nth 2 2)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-end "5. Test specifiers")
+
+;;;
+;;;
+;;;
+
+(test-begin "6. Skipping selected tests")
+
+(test-equal
+ "6.1. Skip by specifier - match-name"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-name "y"))
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-equal
+ "6.2. Shorthand specifiers"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-begin "6.3. Specifier Stack")
+
+(test-equal
+ "6.3.1. Clearing the Specifier Stack"
+ '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; FAIL
+    (test-end))))
+
+(test-equal
+ "6.3.2. Inheriting the Specifier Stack"
+ '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-skip "y")
+    (test-begin "a")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-end);6.3
+
+(test-begin "6.4. Short-circuit evaluation")
+
+(test-equal
+ "6.4.1. In test-match-all"
+ '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-all "y" (test-match-nth 2)))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  FAIL
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-equal
+ "6.4.2. In separate skip-list entries"
+ '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-skip (test-match-nth 2))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  SKIP
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-begin "6.4.3. Skipping test suites")
+
+(test-equal
+ "6.4.3.1. Introduced using 'test-begin'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-begin "b")            ; not skipped
+    (test-assert "x" #t)
+    (test-end "b")
+    (test-end "a"))))
+
+(test-expect-fail 1) ;; ???
+(test-equal
+ "6.4.3.2. Introduced using 'test-group'"
+ '(() () () () () (0 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-group 
+     "b"            ; skipped
+     (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-equal
+ "6.4.3.3. Non-skipped 'test-group'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "c")
+    (test-group "b" (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-end) ; 6.4.3
+ 
+(test-end);6.4
+
+(test-end "6. Skipping selected tests")
+
+;;;
+;;;
+;;;
+
+(test-begin "7. Expected failures")
+
+(test-equal "7.1. Simple example"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" #f))))
+
+(test-equal "7.2. Expected exception"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" (choke)))))
+
+(test-equal "7.3. Unexpectedly PASS"
+            '(() () ("y") ("x") () (0 0 1 1 0))
+            (triv-runner
+             (lambda ()
+               (test-expect-fail "x")
+               (test-expect-fail "y")
+               (test-assert "x" #t)
+               (test-assert "y" #f))))
+               
+
+
+(test-end "7. Expected failures")
+
+;;;
+;;;
+;;;
+
+(test-begin "8. Test-runner")
+
+;;;
+;;;  Because we want this test suite to be accurate even
+;;;  when the underlying implementation chooses to use, e.g.,
+;;;  a global variable to implement what could be thread variables
+;;;  or SRFI-39 parameter objects, we really need to save and restore
+;;;  their state ourselves
+;;;
+(define (with-factory-saved thunk)
+  (let* ((saved (test-runner-factory))
+         (result (thunk)))
+    (test-runner-factory saved)
+    result))
+
+(test-begin "8.1. test-runner-current")
+(test-assert "8.1.1. automatically restored"
+             (let ((a 0)
+                   (b 1)
+                   (c 2))
+               ;
+               (triv-runner
+                (lambda ()
+                  (set! a (test-runner-current))
+                  ;;
+                  (triv-runner
+                   (lambda ()
+                     (set! b (test-runner-current))))
+                  ;;
+                  (set! c (test-runner-current))))
+               ;;
+               (and (eq? a c)
+                    (not (eq? a b)))))
+              
+(test-end)
+
+(test-begin "8.2. test-runner-simple")
+(test-assert "8.2.1. default on-test hook"
+             (eq? (test-runner-on-test-end (test-runner-simple))
+                  test-on-test-end-simple))
+(test-assert "8.2.2. default on-final hook"
+             (eq? (test-runner-on-final (test-runner-simple))
+                  test-on-final-simple))
+(test-end)
+
+(test-begin "8.3. test-runner-factory")
+
+(test-assert "8.3.1. default factory"
+             (eq? (test-runner-factory) test-runner-simple))
+
+(test-assert "8.3.2. settable factory"
+             (with-factory-saved
+              (lambda ()
+                (test-runner-factory test-runner-null)
+                ;; we have no way, without bringing in other SRFIs,
+                ;; to make sure the following doesn't print anything,
+                ;; but it shouldn't:
+                (test-with-runner
+                 (test-runner-create)
+                 (lambda ()
+                   (test-begin "a")
+                   (test-assert #t)             ; pass
+                   (test-assert #f)             ; fail
+                   (test-assert (vector-ref '#(3) 10))  ; fail with error
+                   (test-end "a")))
+                (eq? (test-runner-factory) test-runner-null))))
+                
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.4. test-runner-create")
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2 
+
+(test-begin "8.5. test-runner-factory")
+(test-end)
+
+(test-begin "8.6. test-apply")
+(test-equal "8.6.1. Simple (form 1) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-equal "8.6.2. Simple (form 2) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-expect-fail 1) ;; depends on all test-match-nth being called.
+(test-equal "8.6.3. test-apply with skips"
+            '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-skip (test-match-nth 2))
+               (test-skip (test-match-nth 4))
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (test-match-name "q")
+                (lambda ()
+                                        ; only execute if SKIP=no and APPLY=yes
+                  (test-assert "x" #t)  ; # 1 SKIP=no  APPLY=no
+                  (test-assert "p" #t)  ; # 2 SKIP=yes APPLY=yes
+                  (test-assert "q" #t)  ; # 3 SKIP=no  APPLY=yes
+                  (test-assert "x" #f)  ; # 4 SKIP=yes APPLY=no
+                  0))
+               (test-assert "v" #t))))
+
+;;;  Unfortunately, since there is no way to UNBIND the current test runner,
+;;;  there is no way to test the behavior of `test-apply' in the absence
+;;;  of a current runner within our little meta-test framework.
+;;;
+;;;  To test the behavior manually, you should be able to invoke:
+;;;
+;;;     (test-apply "a" (lambda () (test-assert "a" #t)))
+;;;
+;;;  from the top level (with SRFI 64 available) and it should create a
+;;;  new, default (simple) test runner.
+
+(test-end)
+
+;;;  This entire suite depends heavily on 'test-with-runner'.  If it didn't
+;;;  work, this suite would probably go down in flames
+(test-begin "8.7. test-with-runner")
+(test-end)
+
+;;;  Again, this suite depends heavily on many of the test-runner
+;;;  components.  We'll just test those that aren't being exercised
+;;;  by the meta-test framework
+(test-begin "8.8. test-runner components")
+
+(define (auxtrack-runner thunk)
+  (let ((r (test-runner-null)))
+    (test-runner-aux-value! r '())
+    (test-runner-on-test-end! r (lambda (r)
+                              (test-runner-aux-value!
+                               r
+                               (cons (test-runner-test-name r)
+                                     (test-runner-aux-value r)))))
+    (test-with-runner r (thunk))
+    (reverse (test-runner-aux-value r))))
+
+(test-equal "8.8.1. test-runner-aux-value"
+            '("x" "" "y")
+            (auxtrack-runner
+             (lambda ()
+               (test-assert "x" #t)
+               (test-begin "a")
+               (test-assert #t)
+               (test-end)
+               (test-assert "y" #f))))
+
+(test-end) ; 8.8
+
+(test-end "8. Test-runner")
+
+(test-begin "9. Test Result Properties")
+
+(test-begin "9.1. test-result-alist")
+
+(define (symbol-alist? l)
+  (if (null? l)
+      #t
+      (and (pair? l)
+           (pair? (car l))
+           (symbol? (caar l))
+           (symbol-alist? (cdr l)))))
+
+;;; check the various syntactic forms
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+;;; check to make sure the required properties are returned
+
+(test-equal '((result-kind . pass))
+	    (prop-runner
+             '(result-kind)
+             (lambda ()
+               (test-assert #t)))
+	    )
+
+(test-equal 
+            '((result-kind . fail)
+              (expected-value . 2)
+              (actual-value . 3))
+	    (prop-runner
+             '(result-kind expected-value actual-value)
+             (lambda ()
+               (test-equal 2 (+ 1 2)))))
+
+(test-end "9.1. test-result-alist")
+
+(test-begin "9.2. test-result-ref")
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(fail pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-end "9.2. test-result-ref")
+
+(test-begin "9.3. test-result-set!")
+
+(test-equal '(100 100)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-set! r 'foo 100)
+               (test-result-ref r 'foo))))
+
+(test-end "9.3. test-result-set!")
+
+(test-end "9. Test Result Properties")
+
+;;;
+;;;
+;;;
+
+;#|  Time to stop having fun...
+;
+;(test-begin "9. For fun, some meta-test errors")
+;
+;(test-equal
+; "9.1. Really PASSes, but test like it should FAIL"
+; '(() ("b") () () ())
+; (triv-runner
+;  (lambda ()
+;    (test-assert "b" #t))))
+;
+;(test-expect-fail "9.2. Expect to FAIL and do so")
+;(test-expect-fail "9.3. Expect to FAIL but PASS")
+;(test-skip "9.4. SKIP this one")
+;
+;(test-assert "9.2. Expect to FAIL and do so" #f)
+;(test-assert "9.3. Expect to FAIL but PASS" #t)
+;(test-assert "9.4. SKIP this one" #t)
+;
+;(test-end)
+; |#
+
+(test-end "SRFI 64 - Meta-Test Suite")
+
+(let ((runner (test-runner-current)))
+  (unless (and (= 0 (test-runner-xpass-count runner))
+               (= 0 (test-runner-fail-count runner)))
+    (exit 1)))
+
+;;;
+;;;
+;;;  This is a test suite written in the notation of 
+;;;  SRFI-64, A Scheme API for test suites
+;;;
+
+(test-begin "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;;  Ironically, in order to set up the meta-test environment,
+;;;  we have to invoke one of the most sophisticated features:
+;;;  custom test runners
+;;;
+
+;;;  The `prop-runner' invokes `thunk' in the context of a new
+;;;  test runner, and returns the indicated properties of the 
+;;;  last-executed test result.
+
+(define (prop-runner props thunk)
+  (let ((r (test-runner-null))
+        (plist '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! plist (test-result-alist runner))))
+    ;;
+    (test-with-runner r (thunk))
+    ;; reorder the properties so they are in the order
+    ;; given by `props'.  Note that any property listed in `props'
+    ;; that is not in the property alist will occur as #f
+    (map (lambda (k)
+           (assq k plist))
+         props)))
+
+;;;  `on-test-runner' creates a null test runner and then
+;;;  arranged for `visit' to be called with the runner
+;;;  whenever a test is run.  The results of the calls to
+;;;  `visit' are returned in a list
+
+(define (on-test-runner thunk visit)
+  (let ((r (test-runner-null))
+        (results '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! results (cons (visit r) results))))
+    ;;
+    (test-with-runner r (thunk))
+    (reverse results)))
+
+;;;
+;;;  The `triv-runner' invokes `thunk'
+;;;  and returns a list of 6 lists, the first 5 of which
+;;;  are a list of the names of the tests that, respectively,
+;;;  PASS, FAIL, XFAIL, XPASS, and SKIP.
+;;;  The last item is a list of counts.
+;;;
+
+(define (triv-runner thunk)
+  (let ((r (test-runner-null))
+        (accum-pass '())
+        (accum-fail '())
+        (accum-xfail '())
+        (accum-xpass '())
+        (accum-skip '()))
+    ;;
+    (test-runner-on-bad-count!
+     r
+     (lambda (runner count expected-count)
+       (error (string-append "bad count " (number->string count)
+			     " but expected "
+			     (number->string expected-count)))))
+    (test-runner-on-bad-end-name!
+     r
+     (lambda (runner begin end)
+       (error (string-append "bad end group name " end
+			     " but expected " begin))))
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (let ((n (test-runner-test-name runner)))
+         (case (test-result-kind runner)
+           ((pass) (set! accum-pass (cons n accum-pass)))
+           ((fail) (set! accum-fail (cons n accum-fail)))
+           ((xpass) (set! accum-xpass (cons n accum-xpass)))
+           ((xfail) (set! accum-xfail (cons n accum-xfail)))
+           ((skip) (set! accum-skip (cons n accum-skip)))))))
+    ;;
+    (test-with-runner r (thunk))
+    (list (reverse accum-pass)    ; passed as expected
+          (reverse accum-fail)    ; failed, but was expected to pass
+          (reverse accum-xfail)   ; failed as expected
+          (reverse accum-xpass)   ; passed, but was expected to fail
+          (reverse accum-skip)    ; was not executed
+          (list (test-runner-pass-count r)
+                (test-runner-fail-count r)
+                (test-runner-xfail-count r)
+                (test-runner-xpass-count r)
+                (test-runner-skip-count r)))))
+
+(define (path-revealing-runner thunk)
+  (let ((r (test-runner-null))
+        (seq '()))
+    ;;
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (set! seq (cons (list (test-runner-group-path runner)
+                             (test-runner-test-name runner))
+                       seq))))
+    (test-with-runner r (thunk))
+    (reverse seq)))
+
+;;;
+;;;  Now we can start testing compliance with SRFI-64
+;;;
+
+(test-begin "1. Simple test-cases")
+
+(test-begin "1.1. test-assert")
+
+(define (t)
+  (triv-runner
+   (lambda ()
+     (test-assert "a" #t)
+     (test-assert "b" #f))))
+
+(test-equal
+ "1.1.1. Very simple"
+ '(("a") ("b") () () () (1 1 0 0 0))
+ (t))
+
+(test-equal
+ "1.1.2. A test with no name"
+ '(("a") ("") () () () (1 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
+
+(test-equal
+ "1.1.3. Tests can have the same name"
+ '(("a" "a") () () () () (2 0 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
+
+(define (choke)
+  (vector-ref '#(1 2) 3))
+
+(test-equal
+ "1.1.4. One way to FAIL is to throw an error"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" (choke)))))
+
+(test-end);1.1
+
+(test-begin "1.2. test-eqv")
+
+(define (mean x y)
+  (/ (+ x y) 2.0))
+
+(test-equal
+ "1.2.1.  Simple numerical equivalence"
+ '(("c") ("a" "b") () () () (1 2 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-eqv "a" (mean 3 5) 4)
+    (test-eqv "b" (mean 3 5) 4.5)
+    (test-eqv "c" (mean 3 5) 4.0))))
+
+(test-end);1.2
+
+(test-end "1. Simple test-cases")
+
+;;;
+;;;
+;;;
+
+(test-begin "2. Tests for catching errors")
+
+(test-begin "2.1. test-error")
+
+(test-equal
+ "2.1.1. Baseline test; PASS with no optional args"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.2. Baseline test; FAIL with no optional args"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL: the expr does not raise an error and `test-error' is
+    ;;       claiming that it will, so this test should FAIL
+    (test-error (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.3. PASS with a test name and error type"
+ '(("a") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error "a" #t (vector-ref '#(1 2) 9)))))
+
+(test-end "2.1. test-error")
+
+(test-end "2. Tests for catching errors")
+
+;;;
+;;;
+;;;
+
+(test-begin "3. Test groups and paths")
+
+(test-equal
+ "3.1. test-begin with unspecific test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end))))
+
+(test-equal
+ "3.2. test-begin with name-matching test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+;;; since the error raised by `test-end' on a mismatch is not a test
+;;; error, we actually expect the triv-runner itself to fail
+
+(test-error
+ "3.3. test-begin with mismatched test-end"
+#t
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "x"))))
+
+(test-equal
+ "3.4. test-begin with name and count"
+ '(("b" "c") () () () () (2 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 2)
+    (test-assert "b" #t)
+    (test-assert "c" #t)
+    (test-end "a"))))
+
+;; similarly here, a mismatched count is a lexical error
+;; and not a test failure...
+
+(test-error
+ "3.5. test-begin with mismatched count"
+ #t
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 99)
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+(test-equal
+ "3.6. introspecting on the group path"
+ '((() "w")
+   (("a" "b") "x")
+   (("a" "b") "y")
+   (("a") "z"))
+ ;;
+ ;;  `path-revealing-runner' is designed to return a list
+ ;;  of the tests executed, in order.  Each entry is a list
+ ;;  (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
+ ;;  of test groups starting from the topmost
+ ;;
+ (path-revealing-runner
+  (lambda ()
+    (test-assert "w" #t)
+    (test-begin "a")
+    (test-begin "b")
+    (test-assert "x" #t)
+    (test-assert "y" #t)
+    (test-end)
+    (test-assert "z" #t))))
+
+
+(test-end "3. Test groups and paths")
+
+;;;
+;;;
+;;;
+
+(test-begin "4. Handling set-up and cleanup")
+
+(test-equal "4.1. Normal exit path"
+             '(in 1 2 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-group-with-cleanup
+                   "foo"
+                   (do 'in)
+                   (do 1)
+                   (do 2)
+                   (do 'out))))
+               (reverse ex)))
+               
+(test-equal "4.2. Exception exit path"
+             '(in 1 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               ;; the outer runner is to run the `test-error' in, to
+               ;; catch the exception raised in the inner runner,
+               ;; since we don't want to depend on any other
+               ;; exception-catching support
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-error
+                   (triv-runner
+                    (lambda ()
+                      (test-group-with-cleanup
+                       "foo"
+                       (do 'in) (test-assert #t)
+                       (do 1)   (test-assert #t)
+                       (choke)  (test-assert #t)
+                       (do 2)   (test-assert #t)
+                       (do 'out)))))))
+               (reverse ex)))
+
+(test-end "4. Handling set-up and cleanup")
+
+;;;
+;;;
+;;;
+
+(test-begin "5. Test specifiers")
+
+(test-begin "5.1. test-match-named")
+
+(test-equal "5.1.1. match test names"
+            '(("y") () () () ("x") (1 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-assert "x" #t)
+               (test-assert "y" #t))))
+
+(test-equal "5.1.2. but not group names"
+            '(("z") () () () () (1 0 0 0 0))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-begin "x")
+               (test-assert "z" #t)
+               (test-end))))
+
+(test-end)
+
+(test-begin "5.2. test-match-nth")
+;; See also: [6.4. Short-circuit evaluation]
+
+(test-equal "5.2.1. skip the nth one after"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.2.2. skip m, starting at n"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3 SKIP
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.3. test-match-any")
+(test-equal "5.3.1. basic disjunction"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-nth 3)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.3.2. disjunction is commutative"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-name "x")
+                                          (test-match-nth 3)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.4. test-match-all")
+(test-equal "5.4.1. basic conjunction"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-nth 2 2)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.4.2. conjunction is commutative"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-name "x")
+                                          (test-match-nth 2 2)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-end "5. Test specifiers")
+
+;;;
+;;;
+;;;
+
+(test-begin "6. Skipping selected tests")
+
+(test-equal
+ "6.1. Skip by specifier - match-name"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-name "y"))
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-equal
+ "6.2. Shorthand specifiers"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-begin "6.3. Specifier Stack")
+
+(test-equal
+ "6.3.1. Clearing the Specifier Stack"
+ '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; FAIL
+    (test-end))))
+
+(test-equal
+ "6.3.2. Inheriting the Specifier Stack"
+ '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-skip "y")
+    (test-begin "a")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-end);6.3
+
+(test-begin "6.4. Short-circuit evaluation")
+
+(test-equal
+ "6.4.1. In test-match-all"
+ '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-all "y" (test-match-nth 2)))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  FAIL
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-equal
+ "6.4.2. In separate skip-list entries"
+ '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-skip (test-match-nth 2))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  SKIP
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-begin "6.4.3. Skipping test suites")
+
+(test-equal
+ "6.4.3.1. Introduced using 'test-begin'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-begin "b")            ; not skipped
+    (test-assert "x" #t)
+    (test-end "b")
+    (test-end "a"))))
+
+(test-expect-fail 1) ;; ???
+(test-equal
+ "6.4.3.2. Introduced using 'test-group'"
+ '(() () () () () (0 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-group 
+     "b"            ; skipped
+     (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-equal
+ "6.4.3.3. Non-skipped 'test-group'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "c")
+    (test-group "b" (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-end) ; 6.4.3
+ 
+(test-end);6.4
+
+(test-end "6. Skipping selected tests")
+
+;;;
+;;;
+;;;
+
+(test-begin "7. Expected failures")
+
+(test-equal "7.1. Simple example"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" #f))))
+
+(test-equal "7.2. Expected exception"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" (choke)))))
+
+(test-equal "7.3. Unexpectedly PASS"
+            '(() () ("y") ("x") () (0 0 1 1 0))
+            (triv-runner
+             (lambda ()
+               (test-expect-fail "x")
+               (test-expect-fail "y")
+               (test-assert "x" #t)
+               (test-assert "y" #f))))
+               
+
+
+(test-end "7. Expected failures")
+
+;;;
+;;;
+;;;
+
+(test-begin "8. Test-runner")
+
+;;;
+;;;  Because we want this test suite to be accurate even
+;;;  when the underlying implementation chooses to use, e.g.,
+;;;  a global variable to implement what could be thread variables
+;;;  or SRFI-39 parameter objects, we really need to save and restore
+;;;  their state ourselves
+;;;
+(define (with-factory-saved thunk)
+  (let* ((saved (test-runner-factory))
+         (result (thunk)))
+    (test-runner-factory saved)
+    result))
+
+(test-begin "8.1. test-runner-current")
+(test-assert "8.1.1. automatically restored"
+             (let ((a 0)
+                   (b 1)
+                   (c 2))
+               ;
+               (triv-runner
+                (lambda ()
+                  (set! a (test-runner-current))
+                  ;;
+                  (triv-runner
+                   (lambda ()
+                     (set! b (test-runner-current))))
+                  ;;
+                  (set! c (test-runner-current))))
+               ;;
+               (and (eq? a c)
+                    (not (eq? a b)))))
+              
+(test-end)
+
+(test-begin "8.2. test-runner-simple")
+(test-assert "8.2.1. default on-test hook"
+             (eq? (test-runner-on-test-end (test-runner-simple))
+                  test-on-test-end-simple))
+(test-assert "8.2.2. default on-final hook"
+             (eq? (test-runner-on-final (test-runner-simple))
+                  test-on-final-simple))
+(test-end)
+
+(test-begin "8.3. test-runner-factory")
+
+(test-assert "8.3.1. default factory"
+             (eq? (test-runner-factory) test-runner-simple))
+
+(test-assert "8.3.2. settable factory"
+             (with-factory-saved
+              (lambda ()
+                (test-runner-factory test-runner-null)
+                ;; we have no way, without bringing in other SRFIs,
+                ;; to make sure the following doesn't print anything,
+                ;; but it shouldn't:
+                (test-with-runner
+                 (test-runner-create)
+                 (lambda ()
+                   (test-begin "a")
+                   (test-assert #t)             ; pass
+                   (test-assert #f)             ; fail
+                   (test-assert (vector-ref '#(3) 10))  ; fail with error
+                   (test-end "a")))
+                (eq? (test-runner-factory) test-runner-null))))
+                
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.4. test-runner-create")
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2 
+
+(test-begin "8.5. test-runner-factory")
+(test-end)
+
+(test-begin "8.6. test-apply")
+(test-equal "8.6.1. Simple (form 1) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-equal "8.6.2. Simple (form 2) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-expect-fail 1) ;; depends on all test-match-nth being called.
+(test-equal "8.6.3. test-apply with skips"
+            '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-skip (test-match-nth 2))
+               (test-skip (test-match-nth 4))
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (test-match-name "q")
+                (lambda ()
+                                        ; only execute if SKIP=no and APPLY=yes
+                  (test-assert "x" #t)  ; # 1 SKIP=no  APPLY=no
+                  (test-assert "p" #t)  ; # 2 SKIP=yes APPLY=yes
+                  (test-assert "q" #t)  ; # 3 SKIP=no  APPLY=yes
+                  (test-assert "x" #f)  ; # 4 SKIP=yes APPLY=no
+                  0))
+               (test-assert "v" #t))))
+
+;;;  Unfortunately, since there is no way to UNBIND the current test runner,
+;;;  there is no way to test the behavior of `test-apply' in the absence
+;;;  of a current runner within our little meta-test framework.
+;;;
+;;;  To test the behavior manually, you should be able to invoke:
+;;;
+;;;     (test-apply "a" (lambda () (test-assert "a" #t)))
+;;;
+;;;  from the top level (with SRFI 64 available) and it should create a
+;;;  new, default (simple) test runner.
+
+(test-end)
+
+;;;  This entire suite depends heavily on 'test-with-runner'.  If it didn't
+;;;  work, this suite would probably go down in flames
+(test-begin "8.7. test-with-runner")
+(test-end)
+
+;;;  Again, this suite depends heavily on many of the test-runner
+;;;  components.  We'll just test those that aren't being exercised
+;;;  by the meta-test framework
+(test-begin "8.8. test-runner components")
+
+(define (auxtrack-runner thunk)
+  (let ((r (test-runner-null)))
+    (test-runner-aux-value! r '())
+    (test-runner-on-test-end! r (lambda (r)
+                              (test-runner-aux-value!
+                               r
+                               (cons (test-runner-test-name r)
+                                     (test-runner-aux-value r)))))
+    (test-with-runner r (thunk))
+    (reverse (test-runner-aux-value r))))
+
+(test-equal "8.8.1. test-runner-aux-value"
+            '("x" "" "y")
+            (auxtrack-runner
+             (lambda ()
+               (test-assert "x" #t)
+               (test-begin "a")
+               (test-assert #t)
+               (test-end)
+               (test-assert "y" #f))))
+
+(test-end) ; 8.8
+
+(test-end "8. Test-runner")
+
+(test-begin "9. Test Result Properties")
+
+(test-begin "9.1. test-result-alist")
+
+(define (symbol-alist? l)
+  (if (null? l)
+      #t
+      (and (pair? l)
+           (pair? (car l))
+           (symbol? (caar l))
+           (symbol-alist? (cdr l)))))
+
+;;; check the various syntactic forms
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+;;; check to make sure the required properties are returned
+
+(test-equal '((result-kind . pass))
+	    (prop-runner
+             '(result-kind)
+             (lambda ()
+               (test-assert #t)))
+	    )
+
+(test-equal 
+            '((result-kind . fail)
+              (expected-value . 2)
+              (actual-value . 3))
+	    (prop-runner
+             '(result-kind expected-value actual-value)
+             (lambda ()
+               (test-equal 2 (+ 1 2)))))
+
+(test-end "9.1. test-result-alist")
+
+(test-begin "9.2. test-result-ref")
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(fail pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-end "9.2. test-result-ref")
+
+(test-begin "9.3. test-result-set!")
+
+(test-equal '(100 100)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-set! r 'foo 100)
+               (test-result-ref r 'foo))))
+
+(test-end "9.3. test-result-set!")
+
+(test-end "9. Test Result Properties")
+
+;;;
+;;;
+;;;
+
+;#|  Time to stop having fun...
+;
+;(test-begin "9. For fun, some meta-test errors")
+;
+;(test-equal
+; "9.1. Really PASSes, but test like it should FAIL"
+; '(() ("b") () () ())
+; (triv-runner
+;  (lambda ()
+;    (test-assert "b" #t))))
+;
+;(test-expect-fail "9.2. Expect to FAIL and do so")
+;(test-expect-fail "9.3. Expect to FAIL but PASS")
+;(test-skip "9.4. SKIP this one")
+;
+;(test-assert "9.2. Expect to FAIL and do so" #f)
+;(test-assert "9.3. Expect to FAIL but PASS" #t)
+;(test-assert "9.4. SKIP this one" #t)
+;
+;(test-end)
+; |#
+
+(test-end "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; 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.
+
+;;; Eval these in Emacs:
+;; (put 'stream-lambda 'scheme-indent-function 1)
+;; (put 'stream-let 'scheme-indent-function 2)
+
+(define-syntax define-stream
+  (syntax-rules ()
+    ((define-stream (name . formal) body0 body1 ...)
+     (define name (stream-lambda formal body0 body1 ...)))))
+
+(define (list->stream objs)
+  (define list->stream
+    (stream-lambda (objs)
+      (if (null? objs)
+          stream-null
+          (stream-cons (car objs) (list->stream (cdr objs))))))
+  (if (not (list? objs))
+      (error "non-list argument" objs)
+      (list->stream objs)))
+
+(define (port->stream . port)
+  (define port->stream
+    (stream-lambda (p)
+      (let ((c (read-char p)))
+        (if (eof-object? c)
+            stream-null
+            (stream-cons c (port->stream p))))))
+  (let ((p (if (null? port) (current-input-port) (car port))))
+    (if (not (input-port? p))
+        (error "non-input-port argument" p)
+        (port->stream p))))
+
+(define-syntax stream
+  (syntax-rules ()
+    ((stream) stream-null)
+    ((stream x y ...) (stream-cons x (stream y ...)))))
+
+(define (stream->list . args)
+  (let ((n (if (= 1 (length args)) #f (car args)))
+        (strm (if (= 1 (length args)) (car args) (cadr args))))
+    (cond
+     ((not (stream? strm)) (error "non-stream argument" strm))
+     ((and n (not (integer? n))) (error "non-integer count" n))
+     ((and n (negative? n)) (error "negative count" n))
+     (else (let loop ((n (if n n -1)) (strm strm))
+             (if (or (zero? n) (stream-null? strm))
+                 '()
+                 (cons (stream-car strm)
+                       (loop (- n 1) (stream-cdr strm)))))))))
+
+(define (stream-append . strms)
+  (define stream-append
+    (stream-lambda (strms)
+      (cond
+       ((null? (cdr strms)) (car strms))
+       ((stream-null? (car strms)) (stream-append (cdr strms)))
+       (else (stream-cons (stream-car (car strms))
+                          (stream-append (cons (stream-cdr (car strms))
+                                               (cdr strms))))))))
+  (cond
+   ((null? strms) stream-null)
+   ((find (lambda (x) (not (stream? x))) strms)
+    => (lambda (strm)
+         (error "non-stream argument" strm)))
+   (else (stream-append strms))))
+
+(define (stream-concat strms)
+  (define stream-concat
+    (stream-lambda (strms)
+      (cond
+       ((stream-null? strms) stream-null)
+       ((not (stream? (stream-car strms)))
+        (error "non-stream object in input stream" strms))
+       ((stream-null? (stream-car strms))
+        (stream-concat (stream-cdr strms)))
+       (else (stream-cons
+              (stream-car (stream-car strms))
+              (stream-concat
+               (stream-cons (stream-cdr (stream-car strms))
+                            (stream-cdr strms))))))))
+  (if (not (stream? strms))
+      (error "non-stream argument" strms)
+      (stream-concat strms)))
+
+(define stream-constant
+  (stream-lambda objs
+    (cond
+     ((null? objs) stream-null)
+     ((null? (cdr objs)) (stream-cons (car objs)
+                                      (stream-constant (car objs))))
+     (else (stream-cons (car objs)
+                        (apply stream-constant
+                               (append (cdr objs) (list (car objs)))))))))
+
+(define (stream-drop n strm)
+  (define stream-drop
+    (stream-lambda (n strm)
+      (if (or (zero? n) (stream-null? strm))
+          strm
+          (stream-drop (- n 1) (stream-cdr strm)))))
+  (cond
+   ((not (integer? n)) (error "non-integer argument" n))
+   ((negative? n) (error "negative argument" n))
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   (else (stream-drop n strm))))
+
+(define (stream-drop-while pred? strm)
+  (define stream-drop-while
+    (stream-lambda (strm)
+      (if (and (stream-pair? strm) (pred? (stream-car strm)))
+          (stream-drop-while (stream-cdr strm))
+          strm)))
+  (cond
+   ((not (procedure? pred?)) (error "non-procedural argument" pred?))
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   (else (stream-drop-while strm))))
+
+(define (stream-filter pred? strm)
+  (define stream-filter
+    (stream-lambda (strm)
+      (cond
+       ((stream-null? strm) stream-null)
+       ((pred? (stream-car strm))
+        (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
+       (else (stream-filter (stream-cdr strm))))))
+  (cond
+   ((not (procedure? pred?)) (error "non-procedural argument" pred?))
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   (else (stream-filter strm))))
+
+(define (stream-fold proc base strm)
+  (cond
+   ((not (procedure? proc)) (error "non-procedural argument" proc))
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   (else (let loop ((base base) (strm strm))
+           (if (stream-null? strm)
+               base
+               (loop (proc base (stream-car strm)) (stream-cdr strm)))))))
+
+(define (stream-for-each proc . strms)
+  (define (stream-for-each strms)
+    (if (not (find stream-null? strms))
+        (begin (apply proc (map stream-car strms))
+               (stream-for-each (map stream-cdr strms)))))
+  (cond
+   ((not (procedure? proc)) (error "non-procedural argument" proc))
+   ((null? strms) (error "no stream arguments"))
+   ((find (lambda (x) (not (stream? x))) strms)
+    => (lambda (strm)
+         (error "non-stream argument" strm)))
+   (else (stream-for-each strms))))
+
+(define (stream-from first . step)
+  (define stream-from
+    (stream-lambda (first delta)
+      (stream-cons first (stream-from (+ first delta) delta))))
+  (let ((delta (if (null? step) 1 (car step))))
+    (cond
+     ((not (number? first)) (error "non-numeric starting number" first))
+     ((not (number? delta)) (error "non-numeric step size" delta))
+     (else (stream-from first delta)))))
+
+(define (stream-iterate proc base)
+  (define stream-iterate
+    (stream-lambda (base)
+      (stream-cons base (stream-iterate (proc base)))))
+  (if (not (procedure? proc))
+      (error "non-procedural argument" proc)
+      (stream-iterate base)))
+
+(define (stream-length strm)
+  (if (not (stream? strm))
+      (error "non-stream argument" strm)
+      (let loop ((len 0) (strm strm))
+        (if (stream-null? strm)
+            len
+            (loop (+ len 1) (stream-cdr strm))))))
+
+(define-syntax stream-let
+  (syntax-rules ()
+    ((stream-let tag ((name val) ...) body1 body2 ...)
+     ((letrec ((tag (stream-lambda (name ...) body1 body2 ...)))
+        tag)
+      val ...))))
+
+(define (stream-map proc . strms)
+  (define stream-map
+    (stream-lambda (strms)
+      (if (find stream-null? strms)
+          stream-null
+          (stream-cons (apply proc (map stream-car strms))
+                       (stream-map (map stream-cdr strms))))))
+  (cond
+   ((not (procedure? proc)) (error "non-procedural argument" proc))
+   ((null? strms) (error "no stream arguments"))
+   ((find (lambda (x) (not (stream? x))) strms)
+    => (lambda (strm)
+         (error "non-stream argument" strm)))
+   (else (stream-map strms))))
+
+(define-syntax stream-match
+  (syntax-rules ()
+    ((stream-match strm-expr clause ...)
+     (let ((strm strm-expr))
+       (cond
+        ((not (stream? strm)) (error "non-stream argument" strm))
+        ((stream-match-test strm clause) => car) ...
+        (else (error "pattern failure")))))))
+
+(define-syntax stream-match-test
+  (syntax-rules ()
+    ((stream-match-test strm (pattern fender expr))
+     (stream-match-pattern strm pattern () (and fender (list expr))))
+    ((stream-match-test strm (pattern expr))
+     (stream-match-pattern strm pattern () (list expr)))))
+
+(define-syntax stream-match-pattern
+  (syntax-rules (_)
+    ((stream-match-pattern strm () (binding ...) body)
+     (and (stream-null? strm) (let (binding ...) body)))
+    ((stream-match-pattern strm (_ . rest) (binding ...) body)
+     (and (stream-pair? strm)
+          (let ((strm (stream-cdr strm)))
+            (stream-match-pattern strm rest (binding ...) body))))
+    ((stream-match-pattern strm (var . rest) (binding ...) body)
+     (and (stream-pair? strm)
+          (let ((temp (stream-car strm)) (strm (stream-cdr strm))) 
+            (stream-match-pattern strm rest ((var temp) binding ...) body))))
+    ((stream-match-pattern strm _ (binding ...) body)
+     (let (binding ...) body))
+    ((stream-match-pattern strm var (binding ...) body) 
+     (let ((var strm) binding ...) body))))
+
+(define-syntax stream-of
+  (syntax-rules ()
+    ((_ expr rest ...)
+     (stream-of-aux expr stream-null rest ...))))
+
+(define-syntax stream-of-aux
+  (syntax-rules (in is)
+    ((stream-of-aux expr base)
+     (stream-cons expr base))
+    ((stream-of-aux expr base (var in stream) rest ...)
+     (stream-let loop ((strm stream))
+       (if (stream-null? strm)
+           base
+           (let ((var (stream-car strm)))
+             (stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
+    ((stream-of-aux expr base (var is exp) rest ...)
+     (let ((var exp)) (stream-of-aux expr base rest ...)))
+    ((stream-of-aux expr base pred? rest ...)
+     (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define (stream-range first past . step)
+  (define stream-range
+    (stream-lambda (first past delta lt?)
+      (if (lt? first past)
+          (stream-cons first (stream-range (+ first delta) past delta lt?))
+          stream-null)))
+  (cond
+   ((not (number? first)) (error "non-numeric starting number" first))
+   ((not (number? past)) (error "non-numeric ending number" past))
+   (else (let ((delta (cond ((pair? step) (car step))
+                            ((< first past) 1)
+                            (else -1))))
+           (if (not (number? delta))
+               (error "non-numeric step size" delta)
+               (let ((lt? (if (< 0 delta) < >)))
+                 (stream-range first past delta lt?)))))))
+
+(define (stream-ref strm n)
+  (cond
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   ((not (integer? n)) (error "non-integer argument" n))
+   ((negative? n) (error "negative argument" n))
+   (else (let loop ((strm strm) (n n))
+           (cond
+            ((stream-null? strm) (error "beyond end of stream" strm))
+            ((zero? n) (stream-car strm))
+            (else (loop (stream-cdr strm) (- n 1))))))))
+
+(define (stream-reverse strm)
+  (define stream-reverse
+    (stream-lambda (strm rev)
+      (if (stream-null? strm)
+          rev
+          (stream-reverse (stream-cdr strm)
+                          (stream-cons (stream-car strm) rev)))))
+  (if (not (stream? strm))
+      (error "non-stream argument" strm)
+      (stream-reverse strm stream-null)))
+
+(define (stream-scan proc base strm)
+  (define stream-scan
+    (stream-lambda (base strm)
+      (if (stream-null? strm)
+          (stream base)
+          (stream-cons base (stream-scan (proc base (stream-car strm))
+                                         (stream-cdr strm))))))
+  (cond
+   ((not (procedure? proc)) (error "non-procedural argument" proc))
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   (else (stream-scan base strm))))
+
+(define (stream-take n strm)
+  (define stream-take
+    (stream-lambda (n strm)
+      (if (or (stream-null? strm) (zero? n))
+          stream-null
+          (stream-cons (stream-car strm)
+                       (stream-take (- n 1) (stream-cdr strm))))))
+  (cond
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   ((not (integer? n)) (error "non-integer argument" n))
+   ((negative? n) (error "negative argument" n))
+   (else (stream-take n strm))))
+
+(define (stream-take-while pred? strm)
+  (define stream-take-while
+    (stream-lambda (strm)
+      (cond
+       ((stream-null? strm) stream-null)
+       ((pred? (stream-car strm))
+        (stream-cons (stream-car strm)
+                     (stream-take-while (stream-cdr strm))))
+       (else stream-null))))
+  (cond
+   ((not (stream? strm)) (error "non-stream argument" strm))
+   ((not (procedure? pred?)) (error "non-procedural argument" pred?))
+   (else (stream-take-while strm))))
+
+(define (stream-unfold mapper pred? generator base)
+  (define stream-unfold
+    (stream-lambda (base)
+      (if (pred? base)
+          (stream-cons (mapper base) (stream-unfold (generator base)))
+          stream-null)))
+  (cond
+   ((not (procedure? mapper)) (error "non-procedural mapper" mapper))
+   ((not (procedure? pred?)) (error "non-procedural pred?" pred?))
+   ((not (procedure? generator)) (error "non-procedural generator" generator))
+   (else (stream-unfold base))))
+
+(define (stream-unfolds gen seed)
+  (define (len-values gen seed)
+    (call-with-values
+        (lambda () (gen seed))
+      (lambda vs (- (length vs) 1))))
+  (define unfold-result-stream
+    (stream-lambda (gen seed)
+      (call-with-values
+          (lambda () (gen seed))
+        (lambda (next . results)
+          (stream-cons results (unfold-result-stream gen next))))))
+  (define result-stream->output-stream
+    (stream-lambda (result-stream i)
+      (let ((result (list-ref (stream-car result-stream) (- i 1))))
+        (cond
+         ((pair? result)
+          (stream-cons
+           (car result)
+           (result-stream->output-stream (stream-cdr result-stream) i)))
+         ((not result)
+          (result-stream->output-stream (stream-cdr result-stream) i))
+         ((null? result) stream-null)
+         (else (error "can't happen"))))))
+  (define (result-stream->output-streams result-stream)
+    (let loop ((i (len-values gen seed)) (outputs '()))
+      (if (zero? i)
+          (apply values outputs)
+          (loop (- i 1) (cons (result-stream->output-stream result-stream i)
+                              outputs)))))
+  (if (not (procedure? gen))
+      (error "non-procedural argument" gen)
+      (result-stream->output-streams (unfold-result-stream gen seed))))
+
+(define (stream-zip . strms)
+  (define stream-zip
+    (stream-lambda (strms)
+      (if (find stream-null? strms)
+          stream-null
+          (stream-cons (map stream-car strms)
+                       (stream-zip (map stream-cdr strms))))))
+  (cond
+   ((null? strms) (error "no stream arguments"))
+   ((find (lambda (x) (not (stream? x))) strms)
+    => (lambda (strm)
+         (error "non-stream argument" strm)))
+   (else (stream-zip strms))))
+(define-library (srfi 41 derived)
+  (export
+   stream-null stream-cons stream? stream-null? stream-pair? stream-car
+   stream-cdr stream-lambda define-stream list->stream port->stream stream
+   stream->list stream-append stream-concat stream-constant stream-drop
+   stream-drop-while stream-filter stream-fold stream-for-each stream-from
+   stream-iterate stream-length stream-let stream-map stream-match _
+   stream-of stream-range stream-ref stream-reverse stream-scan stream-take
+   stream-take-while stream-unfold stream-unfolds stream-zip
+   )
+  (import
+   (scheme base)
+   (srfi 1)
+   (srfi 41 primitive))
+  (include "derived.body.scm"))
+;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
+;;; 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.
+
+(library (streams derived)
+
+  (export stream-null stream-cons stream? stream-null? stream-pair? stream-car
+          stream-cdr stream-lambda define-stream list->stream port->stream stream
+          stream->list stream-append stream-concat stream-constant stream-drop
+          stream-drop-while stream-filter stream-fold stream-for-each stream-from
+          stream-iterate stream-length stream-let stream-map stream-match _
+          stream-of stream-range stream-ref stream-reverse stream-scan stream-take
+          stream-take-while stream-unfold stream-unfolds stream-zip)
+
+  (import (rnrs) (streams primitive))
+
+  (define-syntax define-stream
+    (syntax-rules ()
+      ((define-stream (name . formal) body0 body1 ...)
+        (define name (stream-lambda formal body0 body1 ...)))))
+
+  (define (list->stream objs)
+    (define list->stream
+      (stream-lambda (objs)
+        (if (null? objs)
+            stream-null
+            (stream-cons (car objs) (list->stream (cdr objs))))))
+    (if (not (list? objs))
+        (error 'list->stream "non-list argument")
+        (list->stream objs)))
+
+  (define (port->stream . port)
+    (define port->stream
+      (stream-lambda (p)
+        (let ((c (read-char p)))
+          (if (eof-object? c)
+              stream-null
+              (stream-cons c (port->stream p))))))
+    (let ((p (if (null? port) (current-input-port) (car port))))
+      (if (not (input-port? p))
+          (error 'port->stream "non-input-port argument")
+          (port->stream p))))
+
+  (define-syntax stream
+    (syntax-rules ()
+      ((stream) stream-null)
+      ((stream x y ...) (stream-cons x (stream y ...)))))
+
+  (define (stream->list . args)
+    (let ((n (if (= 1 (length args)) #f (car args)))
+          (strm (if (= 1 (length args)) (car args) (cadr args))))
+      (cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
+            ((and n (not (integer? n))) (error 'stream->list "non-integer count"))
+            ((and n (negative? n)) (error 'stream->list "negative count"))
+            (else (let loop ((n (if n n -1)) (strm strm))
+                    (if (or (zero? n) (stream-null? strm))
+                        '()
+                        (cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
+
+  (define (stream-append . strms)
+    (define stream-append
+      (stream-lambda (strms)
+        (cond ((null? (cdr strms)) (car strms))
+              ((stream-null? (car strms)) (stream-append (cdr strms)))
+              (else (stream-cons (stream-car (car strms))
+                                 (stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
+    (cond ((null? strms) stream-null)
+          ((exists (lambda (x) (not (stream? x))) strms)
+            (error 'stream-append "non-stream argument"))
+          (else (stream-append strms))))
+
+  (define (stream-concat strms)
+    (define stream-concat
+      (stream-lambda (strms)
+        (cond ((stream-null? strms) stream-null)
+              ((not (stream? (stream-car strms)))
+                (error 'stream-concat "non-stream object in input stream"))
+              ((stream-null? (stream-car strms))
+                (stream-concat (stream-cdr strms)))
+              (else (stream-cons
+                      (stream-car (stream-car strms))
+                      (stream-concat
+                        (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
+    (if (not (stream? strms))
+        (error 'stream-concat "non-stream argument")
+        (stream-concat strms)))
+
+  (define stream-constant
+    (stream-lambda objs
+      (cond ((null? objs) stream-null)
+            ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
+            (else (stream-cons (car objs)
+                               (apply stream-constant (append (cdr objs) (list (car objs)))))))))
+
+  (define (stream-drop n strm)
+    (define stream-drop
+      (stream-lambda (n strm)
+        (if (or (zero? n) (stream-null? strm))
+            strm
+            (stream-drop (- n 1) (stream-cdr strm)))))
+    (cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
+          ((negative? n) (error 'stream-drop "negative argument"))
+          ((not (stream? strm)) (error 'stream-drop "non-stream argument"))
+          (else (stream-drop n strm))))
+
+  (define (stream-drop-while pred? strm)
+    (define stream-drop-while
+      (stream-lambda (strm)
+        (if (and (stream-pair? strm) (pred? (stream-car strm)))
+            (stream-drop-while (stream-cdr strm))
+            strm)))
+    (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
+          ((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
+          (else (stream-drop-while strm))))
+
+  (define (stream-filter pred? strm)
+    (define stream-filter
+      (stream-lambda (strm)
+        (cond ((stream-null? strm) stream-null)
+              ((pred? (stream-car strm))
+                (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
+              (else (stream-filter (stream-cdr strm))))))
+    (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
+          ((not (stream? strm)) (error 'stream-filter "non-stream argument"))
+          (else (stream-filter strm))))
+
+  (define (stream-fold proc base strm)
+    (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
+          ((not (stream? strm)) (error 'stream-fold "non-stream argument"))
+          (else (let loop ((base base) (strm strm))
+                  (if (stream-null? strm)
+                      base
+                      (loop (proc base (stream-car strm)) (stream-cdr strm)))))))
+
+  (define (stream-for-each proc . strms)
+    (define (stream-for-each strms)
+      (if (not (exists stream-null? strms))
+          (begin (apply proc (map stream-car strms))
+                 (stream-for-each (map stream-cdr strms)))))
+    (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
+          ((null? strms) (error 'stream-for-each "no stream arguments"))
+          ((exists (lambda (x) (not (stream? x))) strms)
+            (error 'stream-for-each "non-stream argument"))
+          (else (stream-for-each strms))))
+
+  (define (stream-from first . step)
+    (define stream-from
+      (stream-lambda (first delta)
+        (stream-cons first (stream-from (+ first delta) delta))))
+    (let ((delta (if (null? step) 1 (car step))))
+      (cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
+            ((not (number? delta)) (error 'stream-from "non-numeric step size"))
+            (else (stream-from first delta)))))
+
+  (define (stream-iterate proc base)
+    (define stream-iterate
+      (stream-lambda (base)
+        (stream-cons base (stream-iterate (proc base)))))
+    (if (not (procedure? proc))
+        (error 'stream-iterate "non-procedural argument")
+        (stream-iterate base)))
+
+  (define (stream-length strm)
+    (if (not (stream? strm))
+        (error 'stream-length "non-stream argument")
+        (let loop ((len 0) (strm strm))
+          (if (stream-null? strm)
+              len
+              (loop (+ len 1) (stream-cdr strm))))))
+
+  (define-syntax stream-let
+    (syntax-rules ()
+      ((stream-let tag ((name val) ...) body1 body2 ...)
+       ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
+
+  (define (stream-map proc . strms)
+    (define stream-map
+      (stream-lambda (strms)
+        (if (exists stream-null? strms)
+            stream-null
+            (stream-cons (apply proc (map stream-car strms))
+                         (stream-map (map stream-cdr strms))))))
+    (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
+          ((null? strms) (error 'stream-map "no stream arguments"))
+          ((exists (lambda (x) (not (stream? x))) strms)
+            (error 'stream-map "non-stream argument"))
+          (else (stream-map strms))))
+
+  (define-syntax stream-match
+    (syntax-rules ()
+      ((stream-match strm-expr clause ...)
+        (let ((strm strm-expr))
+          (cond
+            ((not (stream? strm)) (error 'stream-match "non-stream argument"))
+            ((stream-match-test strm clause) => car) ...
+            (else (error 'stream-match "pattern failure")))))))
+
+  (define-syntax stream-match-test
+    (syntax-rules ()
+      ((stream-match-test strm (pattern fender expr))
+        (stream-match-pattern strm pattern () (and fender (list expr))))
+      ((stream-match-test strm (pattern expr))
+        (stream-match-pattern strm pattern () (list expr)))))
+
+  (define-syntax stream-match-pattern 
+    (lambda (x)
+      (define (wildcard? x)
+        (and (identifier? x)
+             (free-identifier=? x (syntax _))))
+      (syntax-case x () 
+        ((stream-match-pattern strm () (binding ...) body)
+          (syntax (and (stream-null? strm) (let (binding ...) body))))
+        ((stream-match-pattern strm (w? . rest) (binding ...) body)
+          (wildcard? #'w?) 
+          (syntax (and (stream-pair? strm)
+                       (let ((strm (stream-cdr strm)))
+                         (stream-match-pattern strm rest (binding ...) body)))))
+        ((stream-match-pattern strm (var . rest) (binding ...) body)
+          (syntax (and (stream-pair? strm)
+                       (let ((temp (stream-car strm)) (strm (stream-cdr strm))) 
+                         (stream-match-pattern strm rest ((var temp) binding ...) body)))))
+        ((stream-match-pattern strm w? (binding ...) body)
+          (wildcard? #'w?)
+          (syntax (let (binding ...) body)))
+        ((stream-match-pattern strm var (binding ...) body) 
+          (syntax (let ((var strm) binding ...) body))))))
+
+  (define-syntax stream-of
+    (syntax-rules ()
+      ((_ expr rest ...)
+        (stream-of-aux expr stream-null rest ...))))
+
+  (define-syntax stream-of-aux
+    (syntax-rules (in is)
+      ((stream-of-aux expr base)
+        (stream-cons expr base))
+      ((stream-of-aux expr base (var in stream) rest ...)
+        (stream-let loop ((strm stream))
+          (if (stream-null? strm)
+              base
+              (let ((var (stream-car strm)))
+                (stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
+      ((stream-of-aux expr base (var is exp) rest ...)
+        (let ((var exp)) (stream-of-aux expr base rest ...)))
+      ((stream-of-aux expr base pred? rest ...)
+        (if pred? (stream-of-aux expr base rest ...) base))))
+
+  (define (stream-range first past . step)
+    (define stream-range
+      (stream-lambda (first past delta lt?)
+        (if (lt? first past)
+            (stream-cons first (stream-range (+ first delta) past delta lt?))
+            stream-null)))
+    (cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
+          ((not (number? past)) (error 'stream-range "non-numeric ending number"))
+          (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
+                  (if (not (number? delta))
+                      (error 'stream-range "non-numeric step size")
+                      (let ((lt? (if (< 0 delta) < >)))
+                        (stream-range first past delta lt?)))))))
+
+  (define (stream-ref strm n)
+    (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
+          ((not (integer? n)) (error 'stream-ref "non-integer argument"))
+          ((negative? n) (error 'stream-ref "negative argument"))
+          (else (let loop ((strm strm) (n n))
+                  (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
+                        ((zero? n) (stream-car strm))
+                        (else (loop (stream-cdr strm) (- n 1))))))))
+
+  (define (stream-reverse strm)
+    (define stream-reverse
+      (stream-lambda (strm rev)
+        (if (stream-null? strm)
+            rev
+            (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
+    (if (not (stream? strm))
+        (error 'stream-reverse "non-stream argument")
+        (stream-reverse strm stream-null)))
+
+  (define (stream-scan proc base strm)
+    (define stream-scan
+      (stream-lambda (base strm)
+        (if (stream-null? strm)
+            (stream base)
+            (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
+    (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
+          ((not (stream? strm)) (error 'stream-scan "non-stream argument"))
+          (else (stream-scan base strm))))
+
+  (define (stream-take n strm)
+    (define stream-take
+      (stream-lambda (n strm)
+        (if (or (stream-null? strm) (zero? n))
+            stream-null
+            (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
+    (cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
+          ((not (integer? n)) (error 'stream-take "non-integer argument"))
+          ((negative? n) (error 'stream-take "negative argument"))
+          (else (stream-take n strm))))
+
+  (define (stream-take-while pred? strm)
+    (define stream-take-while
+      (stream-lambda (strm)
+        (cond ((stream-null? strm) stream-null)
+              ((pred? (stream-car strm))
+                (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
+              (else stream-null))))
+    (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
+          ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
+          (else (stream-take-while strm))))
+
+  (define (stream-unfold mapper pred? generator base)
+    (define stream-unfold
+      (stream-lambda (base)
+        (if (pred? base)
+            (stream-cons (mapper base) (stream-unfold (generator base)))
+            stream-null)))
+    (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
+          ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
+          ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
+          (else (stream-unfold base))))
+
+  (define (stream-unfolds gen seed)
+    (define (len-values gen seed)
+      (call-with-values
+        (lambda () (gen seed))
+        (lambda vs (- (length vs) 1))))
+    (define unfold-result-stream
+      (stream-lambda (gen seed)
+        (call-with-values
+          (lambda () (gen seed))
+          (lambda (next . results)
+            (stream-cons results (unfold-result-stream gen next))))))
+    (define result-stream->output-stream
+      (stream-lambda (result-stream i)
+        (let ((result (list-ref (stream-car result-stream) (- i 1))))
+          (cond ((pair? result)
+                  (stream-cons
+                    (car result)
+                    (result-stream->output-stream (stream-cdr result-stream) i)))
+                ((not result)
+                  (result-stream->output-stream (stream-cdr result-stream) i))
+                ((null? result) stream-null)
+                (else (error 'stream-unfolds "can't happen"))))))
+    (define (result-stream->output-streams result-stream)
+      (let loop ((i (len-values gen seed)) (outputs '()))
+        (if (zero? i)
+            (apply values outputs)
+            (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
+    (if (not (procedure? gen))
+        (error 'stream-unfolds "non-procedural argument")
+        (result-stream->output-streams (unfold-result-stream gen seed))))
+
+  (define (stream-zip . strms)
+    (define stream-zip
+      (stream-lambda (strms)
+        (if (exists stream-null? strms)
+            stream-null
+            (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
+    (cond ((null? strms) (error 'stream-zip "no stream arguments"))
+          ((exists (lambda (x) (not (stream? x))) strms)
+            (error 'stream-zip "non-stream argument"))
+          (else (stream-zip strms)))))
+;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; 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-record-type <stream>
+  (make-stream promise)
+  stream?
+  (promise stream-promise stream-promise!))
+
+(define-syntax stream-lazy
+  (syntax-rules ()
+    ((stream-lazy expr)
+     (make-stream
+      (cons 'lazy (lambda () expr))))))
+
+(define (stream-eager expr)
+  (make-stream
+   (cons 'eager expr)))
+
+(define-syntax stream-delay
+  (syntax-rules ()
+    ((stream-delay expr)
+     (stream-lazy (stream-eager expr)))))
+
+(define (stream-force promise)
+  (let ((content (stream-promise promise)))
+    (case (car content)
+      ((eager) (cdr content))
+      ((lazy)  (let* ((promise* ((cdr content)))
+                      (content  (stream-promise promise)))
+                 (if (not (eqv? (car content) 'eager))
+                     (begin (set-car! content (car (stream-promise promise*)))
+                            (set-cdr! content (cdr (stream-promise promise*)))
+                            (stream-promise! promise* content)))
+                 (stream-force promise))))))
+
+(define stream-null (stream-delay (cons 'stream 'null)))
+
+(define-record-type <stream-pare>
+  (make-stream-pare kar kdr)
+  stream-pare?
+  (kar stream-kar)
+  (kdr stream-kdr))
+
+(define (stream-pair? obj)
+  (and (stream? obj) (stream-pare? (stream-force obj))))
+
+(define (stream-null? obj)
+  (and (stream? obj)
+       (eqv? (stream-force obj)
+             (stream-force stream-null))))
+
+(define-syntax stream-cons
+  (syntax-rules ()
+    ((stream-cons obj strm)
+     (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
+
+(define (stream-car strm)
+  (cond ((not (stream? strm)) (error "non-stream" strm))
+        ((stream-null? strm) (error "null stream" strm))
+        (else (stream-force (stream-kar (stream-force strm))))))
+
+(define (stream-cdr strm)
+  (cond ((not (stream? strm)) (error "non-stream" strm))
+        ((stream-null? strm) (error "null stream" strm))
+        (else (stream-kdr (stream-force strm)))))
+
+(define-syntax stream-lambda
+  (syntax-rules ()
+    ((stream-lambda formals body0 body1 ...)
+     (lambda formals (stream-lazy (let () body0 body1 ...))))))
+(define-library (srfi 41 primitive)
+  (export
+   stream-null stream-cons stream? stream-null? stream-pair?
+   stream-car stream-cdr stream-lambda
+   )
+  (import (scheme base))
+  (include "primitive.body.scm"))
+;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
+
+;;; 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.
+
+(library (streams primitive)
+
+  (export stream-null stream-cons stream? stream-null? stream-pair?
+          stream-car stream-cdr stream-lambda)
+
+  (import (rnrs) (rnrs mutable-pairs))
+
+  (define-record-type (stream-type make-stream stream?)
+    (fields (mutable box stream-promise stream-promise!)))
+
+  (define-syntax stream-lazy
+    (syntax-rules ()
+      ((stream-lazy expr)
+        (make-stream
+          (cons 'lazy (lambda () expr))))))
+
+  (define (stream-eager expr)
+    (make-stream
+      (cons 'eager expr)))
+
+  (define-syntax stream-delay
+    (syntax-rules ()
+      ((stream-delay expr)
+        (stream-lazy (stream-eager expr)))))
+
+  (define (stream-force promise)
+    (let ((content (stream-promise promise)))
+      (case (car content)
+        ((eager) (cdr content))
+        ((lazy)  (let* ((promise* ((cdr content)))
+                        (content  (stream-promise promise)))
+                   (if (not (eqv? (car content) 'eager))
+                       (begin (set-car! content (car (stream-promise promise*)))
+                              (set-cdr! content (cdr (stream-promise promise*)))
+                              (stream-promise! promise* content)))
+                   (stream-force promise))))))
+
+  (define stream-null (stream-delay (cons 'stream 'null)))
+
+  (define-record-type (stream-pare-type make-stream-pare stream-pare?)
+    (fields (immutable kar stream-kar) (immutable kdr stream-kdr)))
+
+  (define (stream-pair? obj)
+    (and (stream? obj) (stream-pare? (stream-force obj))))
+
+  (define (stream-null? obj)
+    (and (stream? obj)
+         (eqv? (stream-force obj)
+               (stream-force stream-null))))
+
+  (define-syntax stream-cons
+    (syntax-rules ()
+      ((stream-cons obj strm)
+        (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
+
+  (define (stream-car strm)
+    (cond ((not (stream? strm)) (error 'stream-car "non-stream"))
+          ((stream-null? strm) (error 'stream-car "null stream"))
+          (else (stream-force (stream-kar (stream-force strm))))))
+
+  (define (stream-cdr strm)
+    (cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
+          ((stream-null? strm) (error 'stream-cdr "null stream"))
+          (else (stream-kdr (stream-force strm)))))
+
+  (define-syntax stream-lambda
+    (syntax-rules ()
+      ((stream-lambda formals body0 body1 ...)
+        (lambda formals (stream-lazy (let () body0 body1 ...)))))))
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+  (when (not (test-runner-current))
+    (let* ((log-file (string-append suite-name ".srfi64.log"))
+           (runner (test-runner-simple log-file)))
+      (%test-runner-auto-installed! runner #t)
+      (test-runner-current runner))))
+
+(define (maybe-uninstall-default-runner)
+  (when (%test-runner-auto-installed? (test-runner-current))
+    (test-runner-current #f)))
+
+(define test-begin
+  (case-lambda
+    ((name)
+     (test-begin name #f))
+    ((name count)
+     (maybe-install-default-runner name)
+     (let ((r (test-runner-current)))
+       (let ((skip-list (%test-runner-skip-list r))
+             (skip-save (%test-runner-skip-save r))
+             (fail-list (%test-runner-fail-list r))
+             (fail-save (%test-runner-fail-save r))
+             (total-count (%test-runner-total-count r))
+             (count-list (%test-runner-count-list r))
+             (group-stack (test-runner-group-stack r)))
+         ((test-runner-on-group-begin r) r name count)
+         (%test-runner-skip-save! r (cons skip-list skip-save))
+         (%test-runner-fail-save! r (cons fail-list fail-save))
+         (%test-runner-count-list! r (cons (cons total-count count)
+                                           count-list))
+         (test-runner-group-stack! r (cons name group-stack)))))))
+
+(define test-end
+  (case-lambda
+    (()
+     (test-end #f))
+    ((name)
+     (let* ((r (test-runner-get))
+            (groups (test-runner-group-stack r)))
+       (test-result-clear r)
+       (when (null? groups)
+         (error "test-end not in a group"))
+       (when (and name (not (equal? name (car groups))))
+         ((test-runner-on-bad-end-name r) r name (car groups)))
+       (let* ((count-list (%test-runner-count-list r))
+              (expected-count (cdar count-list))
+              (saved-count (caar count-list))
+              (group-count (- (%test-runner-total-count r) saved-count)))
+         (when (and expected-count
+                    (not (= expected-count group-count)))
+           ((test-runner-on-bad-count r) r group-count expected-count))
+         ((test-runner-on-group-end r) r)
+         (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+         (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+         (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+         (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+         (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+         (%test-runner-count-list! r (cdr count-list))
+         (when (null? (test-runner-group-stack r))
+           ((test-runner-on-final r) r)
+           (maybe-uninstall-default-runner)))))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ <name> <body> . <body>*)
+     (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+  (begin
+    (maybe-install-default-runner name)
+    (let ((runner (test-runner-get)))
+      (test-result-clear runner)
+      (test-result-set! runner 'name name)
+      (unless (test-skip? runner)
+        (dynamic-wind
+          (lambda () (test-begin name))
+          thunk
+          (lambda () (test-end name)))))))
+
+(define-syntax test-group-with-cleanup
+  (syntax-rules ()
+    ((_ <name> <body> <body>* ... <cleanup>)
+     (test-group <name>
+       (dynamic-wind (lambda () #f)
+                     (lambda () <body> <body>* ...)
+                     (lambda () <cleanup>))))))
+
+
+;;; Skipping, expected-failing, matching
+
+(define (test-skip . specs)
+  (let ((runner (test-runner-get)))
+    (%test-runner-skip-list!
+     runner (cons (apply test-match-all specs)
+                  (%test-runner-skip-list runner)))))
+
+(define (test-skip? runner)
+  (let ((run-list (%test-runner-run-list runner))
+        (skip-list (%test-runner-skip-list runner)))
+    (or (and run-list (not (any-pred run-list runner)))
+        (any-pred skip-list runner))))
+
+(define (test-expect-fail . specs)
+  (let ((runner (test-runner-get)))
+    (%test-runner-fail-list!
+     runner (cons (apply test-match-all specs)
+                  (%test-runner-fail-list runner)))))
+
+(define (test-match-any . specs)
+  (let ((preds (map make-pred specs)))
+    (lambda (runner)
+      (any-pred preds runner))))
+
+(define (test-match-all . specs)
+  (let ((preds (map make-pred specs)))
+    (lambda (runner)
+      (every-pred preds runner))))
+
+(define (make-pred spec)
+  (cond
+   ((procedure? spec)
+    spec)
+   ((integer? spec)
+    (test-match-nth 1 spec))
+   ((string? spec)
+    (test-match-name spec))
+   (else
+    (error "not a valid test specifier" spec))))
+
+(define test-match-nth
+  (case-lambda
+    ((n) (test-match-nth n 1))
+    ((n count)
+     (let ((i 0))
+       (lambda (runner)
+         (set! i (+ i 1))
+         (and (>= i n) (< i (+ n count))))))))
+
+(define (test-match-name name)
+  (lambda (runner)
+    (equal? name (test-runner-test-name runner))))
+
+;;; Beware: all predicates must be called because they might have side-effects;
+;;; no early returning or and/or short-circuiting of procedure calls allowed.
+
+(define (any-pred preds object)
+  (let loop ((matched? #f)
+             (preds preds))
+    (if (null? preds)
+        matched?
+        (let ((result ((car preds) object)))
+          (loop (or matched? result)
+                (cdr preds))))))
+
+(define (every-pred preds object)
+  (let loop ((failed? #f)
+             (preds preds))
+    (if (null? preds)
+        (not failed?)
+        (let ((result ((car preds) object)))
+          (loop (or failed? (not result))
+                (cdr preds))))))
+
+;;; Actual testing
+
+(define-syntax false-if-error
+  (syntax-rules ()
+    ((_ <expression> <runner>)
+     (guard (error
+             (else
+              (test-result-set! <runner> 'actual-error error)
+              #f))
+       <expression>))))
+
+(define (test-prelude source-info runner name form)
+  (test-result-clear runner)
+  (set-source-info! runner source-info)
+  (when name
+    (test-result-set! runner 'name name))
+  (test-result-set! runner 'source-form form)
+  (let ((skip? (test-skip? runner)))
+    (if skip?
+        (test-result-set! runner 'result-kind 'skip)
+        (let ((fail-list (%test-runner-fail-list runner)))
+          (when (any-pred fail-list runner)
+            ;; For later inspection only.
+            (test-result-set! runner 'result-kind 'xfail))))
+    ((test-runner-on-test-begin runner) runner)
+    (not skip?)))
+
+(define (test-postlude runner)
+  (let ((result-kind (test-result-kind runner)))
+    (case result-kind
+      ((pass)
+       (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner))))
+      ((fail)
+       (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner))))
+      ((xpass)
+       (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner))))
+      ((xfail)
+       (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner))))
+      ((skip)
+       (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner)))))
+    (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner)))
+    ((test-runner-on-test-end runner) runner)))
+
+(define (set-result-kind! runner pass?)
+  (test-result-set! runner 'result-kind
+                    (if (eq? (test-result-kind runner) 'xfail)
+                        (if pass? 'xpass 'xfail)
+                        (if pass? 'pass 'fail))))
+
+;;; We need to use some trickery to get the source info right.  The important
+;;; thing is to pass a syntax object that is a pair to `source-info', and make
+;;; sure this syntax object comes from user code and not from ourselves.
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-assert/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-assert/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expr>)
+     (test-assert/source-info <source-info> #f <expr>))
+    ((_ <source-info> <name> <expr>)
+     (%test-assert <source-info> <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (let ((val (false-if-error (thunk) runner)))
+        (test-result-set! runner 'actual-value val)
+        (set-result-kind! runner val)))
+    (test-postlude runner)))
+
+(define-syntax test-compare
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-compare/source-info
+  (syntax-rules ()
+    ((_ <source-info> <compare> <expected> <expr>)
+     (test-compare/source-info <source-info> <compare> #f <expected> <expr>))
+    ((_ <source-info> <compare> <name> <expected> <expr>)
+     (%test-compare <source-info> <compare> <name> <expected> '<expr>
+                    (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (test-result-set! runner 'expected-value expected)
+      (let ((pass? (false-if-error
+                    (let ((val (thunk)))
+                      (test-result-set! runner 'actual-value val)
+                      (compare expected val))
+                    runner)))
+        (set-result-kind! runner pass?)))
+    (test-postlude runner)))
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) equal? . <rest>))))
+
+(define-syntax test-eqv
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) eqv? . <rest>))))
+
+(define-syntax test-eq
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-compare/source-info (source-info <rest>) eq? . <rest>))))
+
+(define (approx= margin)
+  (lambda (value expected)
+    (let ((rval (real-part value))
+          (ival (imag-part value))
+          (rexp (real-part expected))
+          (iexp (imag-part expected)))
+      (and (>= rval (- rexp margin))
+           (>= ival (- iexp margin))
+           (<= rval (+ rexp margin))
+           (<= ival (+ iexp margin))))))
+
+(define-syntax test-approximate
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-approximate/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-approximate/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expected> <expr> <error-margin>)
+     (test-approximate/source-info
+      <source-info> #f <expected> <expr> <error-margin>))
+    ((_ <source-info> <name> <expected> <expr> <error-margin>)
+     (test-compare/source-info
+      <source-info> (approx= <error-margin>) <name> <expected> <expr>))))
+
+(define (error-matches? error type)
+  (cond
+   ((eq? type #t)
+    #t)
+   ((condition-type? type)
+    (and (condition? error) (condition-has-type? error type)))
+   ((procedure? type)
+    (type error))
+   (else
+    (let ((runner (test-runner-get)))
+      ((%test-runner-on-bad-error-type runner) runner type error))
+    #f)))
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ . <rest>)
+     (test-error/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-error/source-info
+  (syntax-rules ()
+    ((_ <source-info> <expr>)
+     (test-error/source-info <source-info> #f #t <expr>))
+    ((_ <source-info> <error-type> <expr>)
+     (test-error/source-info <source-info> #f <error-type> <expr>))
+    ((_ <source-info> <name> <error-type> <expr>)
+     (%test-error <source-info> <name> <error-type> '<expr>
+                  (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+  (let ((runner (test-runner-get)))
+    (when (test-prelude source-info runner name form)
+      (test-result-set! runner 'expected-error error-type)
+      (let ((pass? (guard (error (else (test-result-set!
+                                        runner 'actual-error error)
+                                       (error-matches? error error-type)))
+                     (let ((val (thunk)))
+                       (test-result-set! runner 'actual-value val))
+                     #f)))
+        (set-result-kind! runner pass?)))
+    (test-postlude runner)))
+
+(define (default-module)
+  (cond-expand
+   (guile (current-module))
+   (else #f)))
+
+(define test-read-eval-string
+  (case-lambda
+    ((string)
+     (test-read-eval-string string (default-module)))
+    ((string env)
+     (let* ((port (open-input-string string))
+            (form (read port)))
+       (if (eof-object? (read-char port))
+           (if env
+               (eval form env)
+               (eval form))
+           (error "(not at eof)"))))))
+
+
+;;; Test runner control flow
+
+(define-syntax test-with-runner
+  (syntax-rules ()
+    ((_ <runner> <body> . <body>*)
+     (let ((saved-runner (test-runner-current)))
+       (dynamic-wind
+         (lambda () (test-runner-current <runner>))
+         (lambda () <body> . <body>*)
+         (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+  (let ((runner (if (test-runner? first)
+                    first
+                    (or (test-runner-current) (test-runner-create))))
+        (run-list (if (test-runner? first)
+                      (drop-right rest 1)
+                      (cons first (drop-right rest 1))))
+        (proc (last rest)))
+    (test-with-runner runner
+      (let ((saved-run-list (%test-runner-run-list runner)))
+        (%test-runner-run-list! runner run-list)
+        (proc)
+        (%test-runner-run-list! runner saved-run-list)))))
+
+
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+  (let ((runner (test-runner-current)))
+    (when (not runner)
+      (error "No test runner installed.  Might have been auto-removed
+by test-end if you had not installed one explicitly."))
+    (if (and (zero? (test-runner-xpass-count runner))
+             (zero? (test-runner-fail-count runner)))
+        (exit 0)
+        (exit 1))))
+
+;;; execution.scm ends here
+(export
+ test-begin test-end test-group test-group-with-cleanup
+
+ test-skip test-expect-fail
+ test-match-name test-match-nth
+ test-match-all test-match-any
+
+ test-assert test-eqv test-eq test-equal test-approximate
+ test-error test-read-eval-string
+
+ test-apply test-with-runner
+
+ test-exit
+ )
+(define-library (srfi 64 execution)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (scheme complex)
+   (scheme eval)
+   (scheme process-context)
+   (scheme read)
+   (srfi 1)
+   (srfi 35)
+   (srfi 48)
+   (srfi 64 source-info)
+   (srfi 64 test-runner)
+   (srfi 64 test-runner-simple))
+  (include-library-declarations "execution.exports.sld")
+  (include "execution.body.scm"))
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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.
+
+;;; In some systems, a macro use like (source-info ...), that resides in a
+;;; syntax-rules macro body, first gets inserted into the place where the
+;;; syntax-rules macro was used, and then the transformer of 'source-info' is
+;;; called with a syntax object that has the source location information of that
+;;; position.  That works fine when the user calls e.g. (test-assert ...), whose
+;;; body contains (source-info ...); the user gets the source location of the
+;;; (test-assert ...) call as intended, and not the source location of the real
+;;; (source-info ...) call.
+
+;;; In other systems, *first* the (source-info ...) is processed to get its real
+;;; position, which is within the body of a syntax-rules macro like test-assert,
+;;; so no matter where the user calls (test-assert ...), they get source
+;;; location information of where we defined test-assert with the call to
+;;; (source-info ...) in its body.  That's arguably more correct behavior,
+;;; although in this case it makes our job a bit harder; we need to get the
+;;; source location from an argument to 'source-info' instead.
+
+(define (canonical-syntax form arg)
+  (cond-expand
+   (kawa arg)
+   (guile-2 form)
+   (else #f)))
+
+(cond-expand
+ ((or kawa guile-2)
+  (define-syntax source-info
+    (lambda (stx)
+      (syntax-case stx ()
+        ((_ <x>)
+         (let* ((stx (canonical-syntax stx (syntax <x>)))
+                (file (syntax-source-file stx))
+                (line (syntax-source-line stx)))
+           (quasisyntax
+            (cons (unsyntax file) (unsyntax line)))))))))
+ (else
+  (define-syntax source-info
+    (syntax-rules ()
+      ((_ <x>)
+       #f)))))
+
+(define (syntax-source-file stx)
+  (cond-expand
+   (kawa
+    (syntax-source stx))
+   (guile-2
+    (let ((source (syntax-source stx)))
+      (and source (assq-ref source 'filename))))
+   (else
+    #f)))
+
+(define (syntax-source-line stx)
+  (cond-expand
+   (kawa
+    (syntax-line stx))
+   (guile-2
+    (let ((source (syntax-source stx)))
+      (and source (assq-ref source 'line))))
+   (else
+    #f)))
+
+(define (set-source-info! runner source-info)
+  (when source-info
+    (test-result-set! runner 'source-file (car source-info))
+    (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; source-info.body.scm ends here
+(define-library (srfi 64 source-info)
+  (import
+   (scheme base)
+   (srfi 64 test-runner))
+  (export source-info set-source-info!)
+  (include "source-info.body.scm"))
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Helpers
+
+(define (string-join strings delimiter)
+  (if (null? strings)
+      ""
+      (let loop ((result (car strings))
+                 (rest (cdr strings)))
+        (if (null? rest)
+            result
+            (loop (string-append result delimiter (car rest))
+                  (cdr rest))))))
+
+(define (truncate-string string length)
+  (define (newline->space c) (if (char=? #\newline c) #\space c))
+  (let* ((string (string-map newline->space string))
+         (fill "...")
+         (fill-len (string-length fill))
+         (string-len (string-length string)))
+    (if (<= string-len (+ length fill-len))
+        string
+        (let-values (((q r) (floor/ length 4)))
+          ;; Left part gets 3/4 plus the remainder.
+          (let ((left-end (+ (* q 3) r))
+                (right-start (- string-len q)))
+            (string-append (substring string 0 left-end)
+                           fill
+                           (substring string right-start string-len)))))))
+
+(define (print runner format-string . args)
+  (apply format #t format-string args)
+  (let ((port (%test-runner-log-port runner)))
+    (when port
+      (apply format port format-string args))))
+
+;;; Main
+
+(define test-runner-simple
+  (case-lambda
+   (()
+    (test-runner-simple #f))
+   ((log-file)
+    (let ((runner (test-runner-null)))
+      (test-runner-reset runner)
+      (test-runner-on-group-begin!     runner test-on-group-begin-simple)
+      (test-runner-on-group-end!       runner test-on-group-end-simple)
+      (test-runner-on-final!           runner test-on-final-simple)
+      (test-runner-on-test-begin!      runner test-on-test-begin-simple)
+      (test-runner-on-test-end!        runner test-on-test-end-simple)
+      (test-runner-on-bad-count!       runner test-on-bad-count-simple)
+      (test-runner-on-bad-end-name!    runner test-on-bad-end-name-simple)
+      (%test-runner-on-bad-error-type! runner on-bad-error-type)
+      (%test-runner-log-file!          runner log-file)
+      runner))))
+
+(when (not (test-runner-factory))
+  (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+  (when (null? (test-runner-group-stack runner))
+    (maybe-start-logging runner)
+    (print runner "Test suite begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+  (let ((name (car (test-runner-group-stack runner))))
+    (when (= 1 (length (test-runner-group-stack runner)))
+      (print runner "Test suite end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+  (print runner "Passes:            ~a\n" (test-runner-pass-count runner))
+  (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+  (print runner "Failures:          ~a\n" (test-runner-fail-count runner))
+  (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+  (print runner "Skipped tests:     ~a~%" (test-runner-skip-count runner))
+  (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+  (let ((log-file (%test-runner-log-file runner)))
+    (when log-file
+      ;; The possible race-condition here doesn't bother us.
+      (when (file-exists? log-file)
+        (delete-file log-file))
+      (%test-runner-log-port! runner (open-output-file log-file))
+      (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+  (let ((log-file (%test-runner-log-file runner)))
+    (when log-file
+      (print runner "Wrote log file: ~a~%" log-file)
+      (close-output-port (%test-runner-log-port runner)))))
+
+(define (test-on-test-begin-simple runner)
+  (values))
+
+(define (test-on-test-end-simple runner)
+  (let* ((result-kind (test-result-kind runner))
+         (result-kind-name (case result-kind
+                             ((pass) "PASS") ((fail) "FAIL")
+                             ((xpass) "XPASS") ((xfail) "XFAIL")
+                             ((skip) "SKIP")))
+         (name (let ((name (test-runner-test-name runner)))
+                 (if (string=? "" name)
+                     (truncate-string
+                      (format #f "~a" (test-result-ref runner 'source-form))
+                      30)
+                     name)))
+         (label (string-join (append (test-runner-group-path runner)
+                                     (list name))
+                             ": ")))
+    (print runner "[~a] ~a~%" result-kind-name label)
+    (when (memq result-kind '(fail xpass))
+      (let ((nil (cons #f #f)))
+        (define (found? value)
+          (not (eq? nil value)))
+        (define (maybe-print value message)
+          (when (found? value)
+            (print runner message value)))
+        (let ((file (test-result-ref runner 'source-file "(unknown file)"))
+              (line (test-result-ref runner 'source-line "(unknown line)"))
+              (expression (test-result-ref runner 'source-form))
+              (expected-value (test-result-ref runner 'expected-value nil))
+              (actual-value (test-result-ref runner 'actual-value nil))
+              (expected-error (test-result-ref runner 'expected-error nil))
+              (actual-error (test-result-ref runner 'actual-error nil)))
+          (print runner "~a:~a: ~s~%" file line expression)
+          (maybe-print expected-value "Expected value: ~s~%")
+          (maybe-print expected-error "Expected error: ~a~%")
+          (when (or (found? expected-value) (found? expected-error))
+            (maybe-print actual-value "Returned value: ~s~%"))
+          (maybe-print actual-error "Raised error: ~a~%")
+          (newline))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+  (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+          count expected-count)
+  (print runner
+         "*** Discrepancy indicates testsuite error or exceptions. ***~%"))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+  (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"."
+                 end-name begin-name)))
+
+(define (on-bad-error-type runner type error)
+  (print runner "WARNING: unknown error type predicate: ~a~%" type)
+  (print runner "         error was: ~a~%" error))
+
+;;; test-runner-simple.scm ends here
+(export
+ test-runner-simple
+ ;; The following are exported so you can leverage their existing functionality
+ ;; when making more complex test runners.
+ test-on-group-begin-simple test-on-group-end-simple test-on-final-simple
+ test-on-test-begin-simple test-on-test-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ )
+(define-library (srfi 64 test-runner-simple)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (scheme file)
+   (scheme write)
+   (srfi 48)
+   (srfi 64 test-runner))
+  (include-library-declarations "test-runner-simple.exports.sld")
+  (include "test-runner-simple.body.scm"))
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+
+;;; The data type
+
+(define-record-type <test-runner>
+  (make-test-runner) test-runner?
+
+  (result-alist test-result-alist test-result-alist!)
+
+  (pass-count test-runner-pass-count test-runner-pass-count!)
+  (fail-count test-runner-fail-count test-runner-fail-count!)
+  (xpass-count test-runner-xpass-count test-runner-xpass-count!)
+  (xfail-count test-runner-xfail-count test-runner-xfail-count!)
+  (skip-count test-runner-skip-count test-runner-skip-count!)
+  (total-count %test-runner-total-count %test-runner-total-count!)
+
+  ;; Stack (list) of (count-at-start . expected-count):
+  (count-list %test-runner-count-list %test-runner-count-list!)
+
+  ;; Normally #f, except when in a test-apply.
+  (run-list %test-runner-run-list %test-runner-run-list!)
+
+  (skip-list %test-runner-skip-list %test-runner-skip-list!)
+  (fail-list %test-runner-fail-list %test-runner-fail-list!)
+
+  (skip-save %test-runner-skip-save %test-runner-skip-save!)
+  (fail-save %test-runner-fail-save %test-runner-fail-save!)
+
+  (group-stack test-runner-group-stack test-runner-group-stack!)
+
+  ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and
+  ;; test-end forms in the execution library.  They're called at the
+  ;; beginning/end of each individual test, whereas the test-begin and test-end
+  ;; forms demarcate test groups.
+
+  (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+  (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!)
+  (on-test-end test-runner-on-test-end test-runner-on-test-end!)
+  (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+  (on-final test-runner-on-final test-runner-on-final!)
+  (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!)
+  (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+
+  (on-bad-error-type %test-runner-on-bad-error-type
+                     %test-runner-on-bad-error-type!)
+
+  (aux-value test-runner-aux-value test-runner-aux-value!)
+
+  (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!)
+
+  (log-file %test-runner-log-file %test-runner-log-file!)
+  (log-port %test-runner-log-port %test-runner-log-port!))
+
+(define (test-runner-group-path runner)
+  (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-reset runner)
+  (test-result-alist! runner '())
+  (test-runner-pass-count! runner 0)
+  (test-runner-fail-count! runner 0)
+  (test-runner-xpass-count! runner 0)
+  (test-runner-xfail-count! runner 0)
+  (test-runner-skip-count! runner 0)
+  (%test-runner-total-count! runner 0)
+  (%test-runner-count-list! runner '())
+  (%test-runner-run-list! runner #f)
+  (%test-runner-skip-list! runner '())
+  (%test-runner-fail-list! runner '())
+  (%test-runner-skip-save! runner '())
+  (%test-runner-fail-save! runner '())
+  (test-runner-group-stack! runner '()))
+
+(define (test-runner-null)
+  (define (test-null-callback . args) #f)
+  (let ((runner (make-test-runner)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner test-null-callback)
+    (test-runner-on-group-end! runner test-null-callback)
+    (test-runner-on-final! runner test-null-callback)
+    (test-runner-on-test-begin! runner test-null-callback)
+    (test-runner-on-test-end! runner test-null-callback)
+    (test-runner-on-bad-count! runner test-null-callback)
+    (test-runner-on-bad-end-name! runner test-null-callback)
+    (%test-runner-on-bad-error-type! runner test-null-callback)
+    (%test-runner-auto-installed! runner #f)
+    (%test-runner-log-file! runner #f)
+    (%test-runner-log-port! runner #f)
+    runner))
+
+
+;;; State
+
+(define test-result-ref
+  (case-lambda
+    ((runner key)
+     (test-result-ref runner key #f))
+    ((runner key default)
+     (let ((entry (assq key (test-result-alist runner))))
+       (if entry (cdr entry) default)))))
+
+(define (test-result-set! runner key value)
+  (let* ((alist (test-result-alist runner))
+         (entry (assq key alist)))
+    (if entry
+        (set-cdr! entry value)
+        (test-result-alist! runner (cons (cons key value) alist)))))
+
+(define (test-result-remove runner key)
+  (test-result-alist! runner (remove (lambda (entry)
+                                       (eq? key (car entry)))
+                                     (test-result-alist runner))))
+
+(define (test-result-clear runner)
+  (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+  (or (test-result-ref runner 'name) ""))
+
+(define test-result-kind
+  (case-lambda
+    (() (test-result-kind (test-runner-get)))
+    ((runner) (test-result-ref runner 'result-kind))))
+
+(define test-passed?
+  (case-lambda
+    (() (test-passed? (test-runner-get)))
+    ((runner) (memq (test-result-kind runner) '(pass xpass)))))
+
+
+;;; Factory and current instance
+
+(define test-runner-factory (make-parameter #f))
+
+(define (test-runner-create) ((test-runner-factory)))
+
+(define test-runner-current (make-parameter #f))
+
+(define (test-runner-get)
+  (or (test-runner-current)
+      (error "test-runner not initialized - test-begin missing?")))
+
+;;; test-runner.scm ends here
+(export
+ ;; The data type
+ test-runner-null test-runner? test-runner-reset
+
+ test-result-alist test-result-alist!
+
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ %test-runner-total-count %test-runner-total-count!
+
+ %test-runner-count-list %test-runner-count-list!
+
+ %test-runner-run-list %test-runner-run-list!
+
+ %test-runner-skip-list %test-runner-skip-list!
+ %test-runner-fail-list %test-runner-fail-list!
+
+ %test-runner-skip-save %test-runner-skip-save!
+ %test-runner-fail-save %test-runner-fail-save!
+
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-group-path
+
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+
+ %test-runner-on-bad-error-type %test-runner-on-bad-error-type!
+
+ test-runner-aux-value test-runner-aux-value!
+
+ %test-runner-log-file %test-runner-log-file!
+ %test-runner-log-port %test-runner-log-port!
+
+ ;; State
+ test-result-ref test-result-set!
+ test-result-remove test-result-clear
+ test-runner-test-name test-result-kind test-passed?
+
+ ;; Factory and current instance
+ test-runner-factory test-runner-create
+ test-runner-current test-runner-get
+ )
+(define-library (srfi 64 test-runner)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (srfi 1))
+  (include-library-declarations "test-runner.exports.sld")
+  (include "test-runner.body.scm"))
+;;; SRFI-1 list-processing library 			-*- Scheme -*-
+;;; Reference implementation
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;;     -Olin
+;;;
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014.
+
+;;; See 1.upstream.scm in the same repository for a bunch of comments which I
+;;; removed here because what they document does not necessarily correspond with
+;;; the code anymore.  Diff with the same file to see changes in the code.
+
+;;; Constructors
+;;;;;;;;;;;;;;;;
+
+;;; Occasionally useful as a value to be passed to a fold or other
+;;; higher-order procedure.
+(define (xcons d a) (cons a d))
+
+;;;; Recursively copy every cons.
+;(define (tree-copy x)
+;  (let recur ((x x))
+;    (if (not (pair? x)) x
+;	(cons (recur (car x)) (recur (cdr x))))))
+
+
+;(define (list . ans) ans)	; R4RS
+
+
+;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+
+(define (list-tabulate len proc)
+  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
+  (check-arg procedure? proc list-tabulate)
+  (do ((i (- len 1) (- i 1))
+       (ans '() (cons (proc i) ans)))
+      ((< i 0) ans)))
+
+;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+;;; (cons* a1) = a1	(cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+;;;
+;;; (cons first (unfold not-pair? car cdr rest values))
+
+(define (cons* first . rest)
+  (let recur ((x first) (rest rest))
+    (if (pair? rest)
+	(cons x (recur (car rest) (cdr rest)))
+	x)))
+
+;;; IOTA count [start step]	(start start+step ... start+(count-1)*step)
+
+(define (nonnegative? x)
+  (not (negative? x)))
+
+(define/opt (iota count (start 0) (step 1))
+  (check-arg integer? count iota)
+  (check-arg nonnegative? count iota)
+  (check-arg number? start iota)
+  (check-arg number? step iota)
+  (let loop ((n 0) (r '()))
+    (if (= n count)
+        (reverse r)
+        (loop (+ 1 n)
+              (cons (+ start (* n step)) r)))))
+
+;;; I thought these were lovely, but the public at large did not share my
+;;; enthusiasm...
+;;; :IOTA to		(0 ... to-1)
+;;; :IOTA from to	(from ... to-1)
+;;; :IOTA from to step  (from from+step ...)
+
+;;; IOTA: to		(1 ... to)
+;;; IOTA: from to	(from+1 ... to)
+;;; IOTA: from to step	(from+step from+2step ...)
+
+;(define (%parse-iota-args arg1 rest-args proc)
+;  (let ((check (lambda (n) (check-arg integer? n proc))))
+;    (check arg1)
+;    (if (pair? rest-args)
+;	(let ((arg2 (check (car rest-args)))
+;	      (rest (cdr rest-args)))
+;	  (if (pair? rest)
+;	      (let ((arg3 (check (car rest)))
+;		    (rest (cdr rest)))
+;		(if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
+;		    (values arg1 arg2 arg3)))
+;	      (values arg1 arg2 1)))
+;	(values 0 arg1 1))))
+;
+;(define (iota: arg1 . rest-args)
+;  (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
+;    (let* ((numsteps (floor (/ (- to from) step)))
+;	   (last-val (+ from (* step numsteps))))
+;      (if (< numsteps 0) (error "Negative step count" iota: from to step))
+;      (do ((steps-left numsteps (- steps-left 1))
+;	   (val last-val (- val step))
+;	   (ans '() (cons val ans)))
+;	  ((<= steps-left 0) ans)))))
+;
+;
+;(define (\:iota arg1 . rest-args)
+;  (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
+;    (let* ((numsteps (ceiling (/ (- to from) step)))
+;	   (last-val (+ from (* step (- numsteps 1)))))
+;      (if (< numsteps 0) (error "Negative step count" :iota from to step))
+;      (do ((steps-left numsteps (- steps-left 1))
+;	   (val last-val (- val step))
+;	   (ans '() (cons val ans)))
+;	  ((<= steps-left 0) ans)))))
+
+
+
+(define (circular-list val1 . vals)
+  (let ((ans (cons val1 vals)))
+    (set-cdr! (last-pair ans) ans)
+    ans))
+
+;;; <proper-list> ::= ()			; Empty proper list
+;;;		  |   (cons <x> <proper-list>)	; Proper-list pair
+;;; Note that this definition rules out circular lists -- and this
+;;; function is required to detect this case and return false.
+
+(define (proper-list? x)
+  (let lp ((x x) (lag x))
+    (if (pair? x)
+	(let ((x (cdr x)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag)))
+		(and (not (eq? x lag)) (lp x lag)))
+	      (null? x)))
+	(null? x))))
+
+
+;;; A dotted list is a finite list (possibly of length 0) terminated
+;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+;;; is a dotted list of length 0.
+;;;
+;;; <dotted-list> ::= <non-nil,non-pair>	; Empty dotted list
+;;;               |   (cons <x> <dotted-list>)	; Proper-list pair
+
+(define (dotted-list? x)
+  (let lp ((x x) (lag x))
+    (if (pair? x)
+	(let ((x (cdr x)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag)))
+		(and (not (eq? x lag)) (lp x lag)))
+	      (not (null? x))))
+	(not (null? x)))))
+
+(define (circular-list? x)
+  (let lp ((x x) (lag x))
+    (and (pair? x)
+	 (let ((x (cdr x)))
+	   (and (pair? x)
+		(let ((x   (cdr x))
+		      (lag (cdr lag)))
+		  (or (eq? x lag) (lp x lag))))))))
+
+(define (not-pair? x) (not (pair? x)))	; Inline me.
+
+;;; This is a legal definition which is fast and sloppy:
+;;;     (define null-list? not-pair?)
+;;; but we'll provide a more careful one:
+(define (null-list? l)
+  (cond ((pair? l) #f)
+	((null? l) #t)
+	(else (error "null-list?: argument out of domain" l))))
+           
+
+(define (list= = . lists)
+  (or (null? lists) ; special case
+
+      (let lp1 ((list-a (car lists)) (others (cdr lists)))
+	(or (null? others)
+	    (let ((list-b (car others))
+		  (others (cdr others)))
+	      (if (eq? list-a list-b)	; EQ? => LIST=
+		  (lp1 list-b others)
+		  (let lp2 ((list-a list-a) (list-b list-b))
+		    (if (null-list? list-a)
+			(and (null-list? list-b)
+			     (lp1 list-b others))
+			(and (not (null-list? list-b))
+			     (= (car list-a) (car list-b))
+			     (lp2 (cdr list-a) (cdr list-b)))))))))))
+			
+
+
+;;; R4RS, so commented out.
+;(define (length x)			; LENGTH may diverge or
+;  (let lp ((x x) (len 0))		; raise an error if X is
+;    (if (pair? x)			; a circular list. This version
+;        (lp (cdr x) (+ len 1))		; diverges.
+;        len)))
+
+(define (length+ x)			; Returns #f if X is circular.
+  (let lp ((x x) (lag x) (len 0))
+    (if (pair? x)
+	(let ((x (cdr x))
+	      (len (+ len 1)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag))
+		    (len (+ len 1)))
+		(and (not (eq? x lag)) (lp x lag len)))
+	      len))
+	len)))
+
+(define (zip list1 . more-lists) (apply map list list1 more-lists))
+
+
+;;; Selectors
+;;;;;;;;;;;;;
+
+;;; R4RS non-primitives:
+;(define (caar   x) (car (car x)))
+;(define (cadr   x) (car (cdr x)))
+;(define (cdar   x) (cdr (car x)))
+;(define (cddr   x) (cdr (cdr x)))
+;
+;(define (caaar  x) (caar (car x)))
+;(define (caadr  x) (caar (cdr x)))
+;(define (cadar  x) (cadr (car x)))
+;(define (caddr  x) (cadr (cdr x)))
+;(define (cdaar  x) (cdar (car x)))
+;(define (cdadr  x) (cdar (cdr x)))
+;(define (cddar  x) (cddr (car x)))
+;(define (cdddr  x) (cddr (cdr x)))
+;
+;(define (caaaar x) (caaar (car x)))
+;(define (caaadr x) (caaar (cdr x)))
+;(define (caadar x) (caadr (car x)))
+;(define (caaddr x) (caadr (cdr x)))
+;(define (cadaar x) (cadar (car x)))
+;(define (cadadr x) (cadar (cdr x)))
+;(define (caddar x) (caddr (car x)))
+;(define (cadddr x) (caddr (cdr x)))
+;(define (cdaaar x) (cdaar (car x)))
+;(define (cdaadr x) (cdaar (cdr x)))
+;(define (cdadar x) (cdadr (car x)))
+;(define (cdaddr x) (cdadr (cdr x)))
+;(define (cddaar x) (cddar (car x)))
+;(define (cddadr x) (cddar (cdr x)))
+;(define (cdddar x) (cdddr (car x)))
+;(define (cddddr x) (cdddr (cdr x)))
+
+
+(define first  car)
+(define second cadr)
+(define third  caddr)
+(define fourth cadddr)
+(define (fifth   x) (car    (cddddr x)))
+(define (sixth   x) (cadr   (cddddr x)))
+(define (seventh x) (caddr  (cddddr x)))
+(define (eighth  x) (cadddr (cddddr x)))
+(define (ninth   x) (car  (cddddr (cddddr x))))
+(define (tenth   x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr pair) (values (car pair) (cdr pair)))
+
+;;; take & drop
+
+(define (take lis k)
+  (check-arg integer? k take)
+  (let recur ((lis lis) (k k))
+    (if (zero? k) '()
+	(cons (car lis)
+	      (recur (cdr lis) (- k 1))))))
+
+(define (drop lis k)
+  (check-arg integer? k drop)
+  (let iter ((lis lis) (k k))
+    (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+
+(define (take! lis k)
+  (check-arg integer? k take!)
+  (if (zero? k) '()
+      (begin (set-cdr! (drop lis (- k 1)) '())
+	     lis)))
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.
+
+(define (take-right lis k)
+  (check-arg integer? k take-right)
+  (let lp ((lag lis)  (lead (drop lis k)))
+    (if (pair? lead)
+	(lp (cdr lag) (cdr lead))
+	lag)))
+
+(define (drop-right lis k)
+  (check-arg integer? k drop-right)
+  (let recur ((lag lis) (lead (drop lis k)))
+    (if (pair? lead)
+	(cons (car lag) (recur (cdr lag) (cdr lead)))
+	'())))
+
+;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+;;; us stop LAG one step early, in time to smash its cdr to ().
+(define (drop-right! lis k)
+  (check-arg integer? k drop-right!)
+  (let ((lead (drop lis k)))
+    (if (pair? lead)
+
+	(let lp ((lag lis)  (lead (cdr lead)))	; Standard case
+	  (if (pair? lead)
+	      (lp (cdr lag) (cdr lead))
+	      (begin (set-cdr! lag '())
+		     lis)))
+
+	'())))	; Special case dropping everything -- no cons to side-effect.
+
+;(define (list-ref lis i) (car (drop lis i)))	; R4RS
+
+;;; These use the APL convention, whereby negative indices mean 
+;;; "from the right." I liked them, but they didn't win over the
+;;; SRFI reviewers.
+;;; K >= 0: Take and drop  K elts from the front of the list.
+;;; K <= 0: Take and drop -K elts from the end   of the list.
+
+;(define (take lis k)
+;  (check-arg integer? k take)
+;  (if (negative? k)
+;      (list-tail lis (+ k (length lis)))
+;      (let recur ((lis lis) (k k))
+;	(if (zero? k) '()
+;	    (cons (car lis)
+;		  (recur (cdr lis) (- k 1)))))))
+;
+;(define (drop lis k)
+;  (check-arg integer? k drop)
+;  (if (negative? k)
+;      (let recur ((lis lis) (nelts (+ k (length lis))))
+;	(if (zero? nelts) '()
+;	    (cons (car lis)
+;		  (recur (cdr lis) (- nelts 1)))))
+;      (list-tail lis k)))
+;
+;
+;(define (take! lis k)
+;  (check-arg integer? k take!)
+;  (cond ((zero? k) '())
+;	((positive? k)
+;	 (set-cdr! (list-tail lis (- k 1)) '())
+;	 lis)
+;	(else (list-tail lis (+ k (length lis))))))
+;
+;(define (drop! lis k)
+;  (check-arg integer? k drop!)
+;  (if (negative? k)
+;      (let ((nelts (+ k (length lis))))
+;	(if (zero? nelts) '()
+;	    (begin (set-cdr! (list-tail lis (- nelts 1)) '())
+;		   lis)))
+;      (list-tail lis k)))
+
+(define (split-at x k)
+  (check-arg integer? k split-at)
+  (let recur ((lis x) (k k))
+    (if (zero? k) (values '() lis)
+	(receive (prefix suffix) (recur (cdr lis) (- k 1))
+	  (values (cons (car lis) prefix) suffix)))))
+
+(define (split-at! x k)
+  (check-arg integer? k split-at!)
+  (if (zero? k) (values '() x)
+      (let* ((prev (drop x (- k 1)))
+	     (suffix (cdr prev)))
+	(set-cdr! prev '())
+	(values x suffix))))
+
+
+(define (last lis) (car (last-pair lis)))
+
+(define (last-pair lis)
+  (check-arg pair? lis last-pair)
+  (let lp ((lis lis))
+    (let ((tail (cdr lis)))
+      (if (pair? tail) (lp tail) lis))))
+
+
+;;; Unzippers -- 1 through 5
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (unzip1 lis) (map car lis))
+
+(define (unzip2 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle
+	(let ((elt (car lis)))			; dotted lists.
+	  (receive (a b) (recur (cdr lis))
+	    (values (cons (car  elt) a)
+		    (cons (cadr elt) b)))))))
+
+(define (unzip3 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c) (recur (cdr lis))
+	    (values (cons (car   elt) a)
+		    (cons (cadr  elt) b)
+		    (cons (caddr elt) c)))))))
+
+(define (unzip4 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c d) (recur (cdr lis))
+	    (values (cons (car    elt) a)
+		    (cons (cadr   elt) b)
+		    (cons (caddr  elt) c)
+		    (cons (cadddr elt) d)))))))
+
+(define (unzip5 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c d e) (recur (cdr lis))
+	    (values (cons (car     elt) a)
+		    (cons (cadr    elt) b)
+		    (cons (caddr   elt) c)
+		    (cons (cadddr  elt) d)
+		    (cons (car (cddddr  elt)) e)))))))
+
+
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append! . lists)
+  ;; First, scan through lists looking for a non-empty one.
+  (let lp ((lists lists) (prev '()))
+    (if (not (pair? lists)) prev
+	(let ((first (car lists))
+	      (rest (cdr lists)))
+	  (if (not (pair? first)) (lp rest first)
+
+	      ;; Now, do the splicing.
+	      (let lp2 ((tail-cons (last-pair first))
+			(rest rest))
+		(if (pair? rest)
+		    (let ((next (car rest))
+			  (rest (cdr rest)))
+		      (set-cdr! tail-cons next)
+		      (lp2 (if (pair? next) (last-pair next) tail-cons)
+			   rest))
+		    first)))))))
+
+;;; APPEND is R4RS.
+;(define (append . lists)
+;  (if (pair? lists)
+;      (let recur ((list1 (car lists)) (lists (cdr lists)))
+;        (if (pair? lists)
+;            (let ((tail (recur (car lists) (cdr lists))))
+;              (fold-right cons tail list1)) ; Append LIST1 & TAIL.
+;            list1))
+;      '()))
+
+;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+
+;(define (append-reverse! rev-head tail)
+;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+;             tail
+;             rev-head))
+
+;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+
+(define (append-reverse rev-head tail)
+  (let lp ((rev-head rev-head) (tail tail))
+    (if (null-list? rev-head) tail
+	(lp (cdr rev-head) (cons (car rev-head) tail)))))
+
+(define (append-reverse! rev-head tail)
+  (let lp ((rev-head rev-head) (tail tail))
+    (if (null-list? rev-head) tail
+	(let ((next-rev (cdr rev-head)))
+	  (set-cdr! rev-head tail)
+	  (lp next-rev rev-head)))))
+
+
+(define (concatenate  lists) (reduce-right append  '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;; Fold/map internal utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These little internal utilities are used by the general
+;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+;;; One the other hand, the n-ary cases are painfully inefficient as it is.
+;;; An aggressive implementation should simply re-write these functions 
+;;; for raw efficiency; I have written them for as much clarity, portability,
+;;; and simplicity as can be achieved.
+;;;
+;;; I use the dreaded call/cc to do local aborts. A good compiler could
+;;; handle this with extreme efficiency. An implementation that provides
+;;; a one-shot, non-persistent continuation grabber could help the compiler
+;;; out by using that in place of the call/cc's in these routines.
+;;;
+;;; These functions have funky definitions that are precisely tuned to
+;;; the needs of the fold/map procs -- for example, to minimize the number
+;;; of times the argument lists need to be examined.
+
+;;; Return (map cdr lists). 
+;;; However, if any element of LISTS is empty, just abort and return '().
+(define (%cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+	(if (pair? lists)
+	    (let ((lis (car lists)))
+	      (if (null-list? lis) (abort '())
+		  (cons (cdr lis) (recur (cdr lists)))))
+	    '())))))
+
+(define (%cars+ lists last-elt)	; (append! (map car lists) (list last-elt))
+  (let recur ((lists lists))
+    (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+        (if (pair? lists)
+	    (receive (list other-lists) (car+cdr lists)
+	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+		  (receive (a d) (car+cdr list)
+		    (receive (cars cdrs) (recur other-lists)
+		      (values (cons a cars) (cons d cdrs))))))
+	    (values '() '()))))))
+
+;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
+;;; cars list. What a hack.
+(define (%cars+cdrs+ lists cars-final)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+        (if (pair? lists)
+	    (receive (list other-lists) (car+cdr lists)
+	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+		  (receive (a d) (car+cdr list)
+		    (receive (cars cdrs) (recur other-lists)
+		      (values (cons a cars) (cons d cdrs))))))
+	    (values (list cars-final) '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+  (let recur ((lists lists))
+    (if (pair? lists)
+	(receive (list other-lists) (car+cdr lists)
+	  (receive (a d) (car+cdr list)
+	    (receive (cars cdrs) (recur other-lists)
+	      (values (cons a cars) (cons d cdrs)))))
+	(values '() '()))))
+
+
+;;; count
+;;;;;;;;;
+(define (count pred list1 . lists)
+  (check-arg procedure? pred count)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (let lp ((list1 list1) (lists lists) (i 0))
+	(if (null-list? list1) i
+	    (receive (as ds) (%cars+cdrs lists)
+	      (if (null? as) i
+		  (lp (cdr list1) ds
+		      (if (apply pred (car list1) as) (+ i 1) i))))))
+
+      ;; Fast path
+      (let lp ((lis list1) (i 0))
+	(if (null-list? lis) i
+	    (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
+
+
+;;; fold/unfold
+;;;;;;;;;;;;;;;
+
+(define/opt (unfold-right p f g seed (tail '()))
+  (check-arg procedure? p unfold-right)
+  (check-arg procedure? f unfold-right)
+  (check-arg procedure? g unfold-right)
+  (let lp ((seed seed) (ans tail))
+    (if (p seed) ans
+        (lp (g seed)
+            (cons (f seed) ans)))))
+
+
+(define/opt (unfold p f g seed (tail-gen #f))
+  (check-arg procedure? p unfold)
+  (check-arg procedure? f unfold)
+  (check-arg procedure? g unfold)
+  (check-arg procedure? tail-gen unfold)
+  (let recur ((seed seed))
+    (if (p seed)
+        (if tail-gen (tail-gen seed) '())
+        (cons (f seed) (recur (g seed))))))
+      
+
+(define (fold kons knil lis1 . lists)
+  (check-arg procedure? kons fold)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
+	(receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
+	  (if (null? cars+ans) ans ; Done.
+	      (lp cdrs (apply kons cars+ans)))))
+	    
+      (let lp ((lis lis1) (ans knil))			; Fast path
+	(if (null-list? lis) ans
+	    (lp (cdr lis) (kons (car lis) ans))))))
+
+
+(define (fold-right kons knil lis1 . lists)
+  (check-arg procedure? kons fold-right)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))		; N-ary case
+	(let ((cdrs (%cdrs lists)))
+	  (if (null? cdrs) knil
+	      (apply kons (%cars+ lists (recur cdrs))))))
+
+      (let recur ((lis lis1))				; Fast path
+	(if (null-list? lis) knil
+	    (let ((head (car lis)))
+	      (kons head (recur (cdr lis))))))))
+
+
+(define (pair-fold-right f zero lis1 . lists)
+  (check-arg procedure? f pair-fold-right)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))		; N-ary case
+	(let ((cdrs (%cdrs lists)))
+	  (if (null? cdrs) zero
+	      (apply f (append! lists (list (recur cdrs)))))))
+
+      (let recur ((lis lis1))				; Fast path
+	(if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+
+(define (pair-fold f zero lis1 . lists)
+  (check-arg procedure? f pair-fold)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans zero))	; N-ary case
+	(let ((tails (%cdrs lists)))
+	  (if (null? tails) ans
+	      (lp tails (apply f (append! lists (list ans)))))))
+
+      (let lp ((lis lis1) (ans zero))
+	(if (null-list? lis) ans
+	    (let ((tail (cdr lis)))		; Grab the cdr now,
+	      (lp tail (f lis ans)))))))	; in case F SET-CDR!s LIS.
+      
+
+;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+;;; These cannot meaningfully be n-ary.
+
+(define (reduce f ridentity lis)
+  (check-arg procedure? f reduce)
+  (if (null-list? lis) ridentity
+      (fold f (car lis) (cdr lis))))
+
+(define (reduce-right f ridentity lis)
+  (check-arg procedure? f reduce-right)
+  (if (null-list? lis) ridentity
+      (let recur ((head (car lis)) (lis (cdr lis)))
+	(if (pair? lis)
+	    (f head (recur (car lis) (cdr lis)))
+	    head))))
+
+
+
+;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append-map f lis1 . lists)
+  (really-append-map append-map  append  f lis1 lists))
+(define (append-map! f lis1 . lists) 
+  (really-append-map append-map! append! f lis1 lists))
+
+(define (really-append-map who appender f lis1 lists)
+  (check-arg procedure? f who)
+  (if (pair? lists)
+      (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
+	(if (null? cars) '()
+	    (let recur ((cars cars) (cdrs cdrs))
+	      (let ((vals (apply f cars)))
+		(receive (cars2 cdrs2) (%cars+cdrs cdrs)
+		  (if (null? cars2) vals
+		      (appender vals (recur cars2 cdrs2))))))))
+
+      ;; Fast path
+      (if (null-list? lis1) '()
+	  (let recur ((elt (car lis1)) (rest (cdr lis1)))
+	    (let ((vals (f elt)))
+	      (if (null-list? rest) vals
+		  (appender vals (recur (car rest) (cdr rest)))))))))
+
+
+(define (pair-for-each proc lis1 . lists)
+  (check-arg procedure? proc pair-for-each)
+  (if (pair? lists)
+
+      (let lp ((lists (cons lis1 lists)))
+	(let ((tails (%cdrs lists)))
+	  (if (pair? tails)
+	      (begin (apply proc lists)
+		     (lp tails)))))
+
+      ;; Fast path.
+      (let lp ((lis lis1))
+	(if (not (null-list? lis))
+	    (let ((tail (cdr lis)))	; Grab the cdr now,
+	      (proc lis)		; in case PROC SET-CDR!s LIS.
+	      (lp tail))))))
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+(define (map! f lis1 . lists)
+  (check-arg procedure? f map!)
+  (if (pair? lists)
+      (let lp ((lis1 lis1) (lists lists))
+	(if (not (null-list? lis1))
+	    (receive (heads tails) (%cars+cdrs/no-test lists)
+	      (set-car! lis1 (apply f (car lis1) heads))
+	      (lp (cdr lis1) tails))))
+
+      ;; Fast path.
+      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+  lis1)
+
+
+;;; Map F across L, and save up all the non-false results.
+(define (filter-map f lis1 . lists)
+  (check-arg procedure? f filter-map)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))
+	(receive (cars cdrs) (%cars+cdrs lists)
+	  (if (pair? cars)
+	      (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+		    (else (recur cdrs))) ; Tail call in this arm.
+	      '())))
+	    
+      ;; Fast path.
+      (let recur ((lis lis1))
+	(if (null-list? lis) lis
+	    (let ((tail (recur (cdr lis))))
+	      (cond ((f (car lis)) => (lambda (x) (cons x tail)))
+		    (else tail)))))))
+
+
+;;; Map F across lists, guaranteeing to go left-to-right.
+;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+;;; in which case this procedure may simply be defined as a synonym for MAP.
+
+(define (map-in-order f lis1 . lists)
+  (check-arg procedure? f map-in-order)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))
+	(receive (cars cdrs) (%cars+cdrs lists)
+	  (if (pair? cars)
+	      (let ((x (apply f cars)))		; Do head first,
+		(cons x (recur cdrs)))		; then tail.
+	      '())))
+	    
+      ;; Fast path.
+      (let recur ((lis lis1))
+	(if (null-list? lis) lis
+	    (let ((tail (cdr lis))
+		  (x (f (car lis))))		; Do head first,
+	      (cons x (recur tail)))))))	; then tail.
+
+
+;;; We extend MAP to handle arguments of unequal length.
+(define map map-in-order)	
+
+
+;;; filter, remove, partition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+;;; disorder the elements of their argument.
+
+;; This FILTER shares the longest tail of L that has no deleted elements.
+;; If Scheme had multi-continuation calls, they could be made more efficient.
+
+(define (filter pred lis)			; Sleazing with EQ? makes this
+  (check-arg procedure? pred filter)		; one faster.
+  (let recur ((lis lis))		
+    (if (null-list? lis) lis			; Use NOT-PAIR? to handle dotted lists.
+	(let ((head (car lis))
+	      (tail (cdr lis)))
+	  (if (pred head)
+	      (let ((new-tail (recur tail)))	; Replicate the RECUR call so
+		(if (eq? tail new-tail) lis
+		    (cons head new-tail)))
+	      (recur tail))))))			; this one can be a tail call.
+
+
+;;; Another version that shares longest tail.
+;(define (filter pred lis)
+;  (receive (ans no-del?)
+;      ;; (recur l) returns L with (pred x) values filtered.
+;      ;; It also returns a flag NO-DEL? if the returned value
+;      ;; is EQ? to L, i.e. if it didn't have to delete anything.
+;      (let recur ((l l))
+;	(if (null-list? l) (values l #t)
+;	    (let ((x  (car l))
+;		  (tl (cdr l)))
+;	      (if (pred x)
+;		  (receive (ans no-del?) (recur tl)
+;		    (if no-del?
+;			(values l #t)
+;			(values (cons x ans) #f)))
+;		  (receive (ans no-del?) (recur tl) ; Delete X.
+;		    (values ans #f))))))
+;    ans))
+
+
+
+;(define (filter! pred lis)			; Things are much simpler
+;  (let recur ((lis lis))			; if you are willing to
+;    (if (pair? lis)				; push N stack frames & do N
+;        (cond ((pred (car lis))		; SET-CDR! writes, where N is
+;               (set-cdr! lis (recur (cdr lis))); the length of the answer.
+;               lis)				
+;              (else (recur (cdr lis))))
+;        lis)))
+
+
+;;; This implementation of FILTER!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 
+;;;   usually expensive on modern machines, and can be extremely expensive on 
+;;;   modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the 
+;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the 
+;;; beginning of the next.
+
+(define (filter! pred lis)
+  (check-arg procedure? pred filter!)
+  (let lp ((ans lis))
+    (cond ((null-list? ans)       ans)			; Scan looking for
+	  ((not (pred (car ans))) (lp (cdr ans)))	; first cons of result.
+
+	  ;; ANS is the eventual answer.
+	  ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+	  ;;          Scan over a contiguous segment of the list that
+	  ;;          satisfies PRED.
+	  ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+	  ;;           segment of the list that *doesn't* satisfy PRED.
+	  ;;           When the segment ends, patch in a link from PREV
+	  ;;           to the start of the next good segment, and jump to
+	  ;;           SCAN-IN.
+	  (else (letrec ((scan-in (lambda (prev lis)
+				    (if (pair? lis)
+					(if (pred (car lis))
+					    (scan-in lis (cdr lis))
+					    (scan-out prev (cdr lis))))))
+			 (scan-out (lambda (prev lis)
+				     (let lp ((lis lis))
+				       (if (pair? lis)
+					   (if (pred (car lis))
+					       (begin (set-cdr! prev lis)
+						      (scan-in lis (cdr lis)))
+					       (lp (cdr lis)))
+					   (set-cdr! prev lis))))))
+		  (scan-in ans (cdr ans))
+		  ans)))))
+
+
+
+;;; Answers share common tail with LIS where possible; 
+;;; the technique is slightly subtle.
+
+(define (partition pred lis)
+  (check-arg procedure? pred partition)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle dotted lists.
+	(let ((elt (car lis))
+	      (tail (cdr lis)))
+	  (receive (in out) (recur tail)
+	    (if (pred elt)
+		(values (if (pair? out) (cons elt in) lis) out)
+		(values in (if (pair? in) (cons elt out) lis))))))))
+
+
+
+;(define (partition! pred lis)			; Things are much simpler
+;  (let recur ((lis lis))			; if you are willing to
+;    (if (null-list? lis) (values lis lis)	; push N stack frames & do N
+;        (let ((elt (car lis)))			; SET-CDR! writes, where N is
+;          (receive (in out) (recur (cdr lis))	; the length of LIS.
+;            (cond ((pred elt)
+;                   (set-cdr! lis in)
+;                   (values lis out))
+;                  (else (set-cdr! lis out)
+;                        (values in lis))))))))
+
+
+;;; This implementation of PARTITION!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;;   usually expensive on modern machines, and can be extremely expensive on 
+;;;   modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice these runs together into the result 
+;;; lists.
+
+(define (partition! pred lis)
+  (check-arg procedure? pred partition!)
+  (if (null-list? lis) (values lis lis)
+
+      ;; This pair of loops zips down contiguous in & out runs of the
+      ;; list, splicing the runs together. The invariants are
+      ;;   SCAN-IN:  (cdr in-prev)  = LIS.
+      ;;   SCAN-OUT: (cdr out-prev) = LIS.
+      (letrec ((scan-in (lambda (in-prev out-prev lis)
+			  (let lp ((in-prev in-prev) (lis lis))
+			    (if (pair? lis)
+				(if (pred (car lis))
+				    (lp lis (cdr lis))
+				    (begin (set-cdr! out-prev lis)
+					   (scan-out in-prev lis (cdr lis))))
+				(set-cdr! out-prev lis))))) ; Done.
+
+	       (scan-out (lambda (in-prev out-prev lis)
+			   (let lp ((out-prev out-prev) (lis lis))
+			     (if (pair? lis)
+				 (if (pred (car lis))
+				     (begin (set-cdr! in-prev lis)
+					    (scan-in lis out-prev (cdr lis)))
+				     (lp lis (cdr lis)))
+				 (set-cdr! in-prev lis)))))) ; Done.
+
+	;; Crank up the scan&splice loops.
+	(if (pred (car lis))
+	    ;; LIS begins in-list. Search for out-list's first pair.
+	    (let lp ((prev-l lis) (l (cdr lis)))
+	      (cond ((not (pair? l)) (values lis l))
+		    ((pred (car l)) (lp l (cdr l)))
+		    (else (scan-out prev-l l (cdr l))
+			  (values lis l))))	; Done.
+
+	    ;; LIS begins out-list. Search for in-list's first pair.
+	    (let lp ((prev-l lis) (l (cdr lis)))
+	      (cond ((not (pair? l)) (values l lis))
+		    ((pred (car l))
+		     (scan-in l prev-l (cdr l))
+		     (values l lis))		; Done.
+		    (else (lp l (cdr l)))))))))
+
+
+;;; Inline us, please.
+(define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+
+
+;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
+;;; (I don't actually think these are the world's most important
+;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
+;;; are far more general.)
+;;;
+;;; Function			Action
+;;; ---------------------------------------------------------------------------
+;;; remove pred lis		Delete by general predicate
+;;; delete x lis [=]		Delete by element comparison
+;;;					     
+;;; find pred lis		Search by general predicate
+;;; find-tail pred lis		Search by general predicate
+;;; member x lis [=]		Search by element comparison
+;;;
+;;; assoc key lis [=]		Search alist by key comparison
+;;; alist-delete key alist [=]	Alist-delete by key comparison
+
+(define/opt (delete x lis (= equal?))
+  (filter (lambda (y) (not (= x y))) lis))
+
+(define/opt (delete! x lis (= equal?))
+  (filter! (lambda (y) (not (= x y))) lis))
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define/opt (member x lis (= equal?))
+  (find-tail (lambda (y) (= x y)) lis))
+
+;;; R4RS, hence we don't bother to define.
+;;; The MEMBER and then FIND-TAIL call should definitely
+;;; be inlined for MEMQ & MEMV.
+;(define (memq    x lis) (member x lis eq?))
+;(define (memv    x lis) (member x lis eqv?))
+
+
+;;; right-duplicate deletion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; delete-duplicates delete-duplicates!
+;;;
+;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+;;; in long lists, sort the list to bring duplicates together, then use a 
+;;; linear-time algorithm to kill the dups. Or use an algorithm based on
+;;; element-marking. The former gives you O(n lg n), the latter is linear.
+
+(define/opt (delete-duplicates lis (elt= equal?))
+  (check-arg procedure? elt= delete-duplicates)
+  (let recur ((lis lis))
+    (if (null-list? lis) lis
+        (let* ((x (car lis))
+               (tail (cdr lis))
+               (new-tail (recur (delete x tail elt=))))
+          (if (eq? tail new-tail) lis (cons x new-tail))))))
+
+(define/opt (delete-duplicates! lis (elt= equal?))
+  (check-arg procedure? elt= delete-duplicates!)
+  (let recur ((lis lis))
+    (if (null-list? lis) lis
+        (let* ((x (car lis))
+               (tail (cdr lis))
+               (new-tail (recur (delete! x tail elt=))))
+          (if (eq? tail new-tail) lis (cons x new-tail))))))
+
+
+;;; alist stuff
+;;;;;;;;;;;;;;;
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define/opt (assoc x lis (= equal?))
+  (find (lambda (entry) (= x (car entry))) lis))
+
+(define (alist-cons key datum alist) (cons (cons key datum) alist))
+
+(define (alist-copy alist)
+  (map (lambda (elt) (cons (car elt) (cdr elt)))
+       alist))
+
+(define/opt (alist-delete key alist (= equal?))
+  (filter (lambda (elt) (not (= key (car elt)))) alist))
+
+(define/opt (alist-delete! key alist (= equal?))
+  (filter! (lambda (elt) (not (= key (car elt)))) alist))
+
+
+;;; find find-tail take-while drop-while span break any every list-index
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (find pred list)
+  (cond ((find-tail pred list) => car)
+	(else #f)))
+
+(define (find-tail pred list)
+  (check-arg procedure? pred find-tail)
+  (let lp ((list list))
+    (and (not (null-list? list))
+	 (if (pred (car list)) list
+	     (lp (cdr list))))))
+
+(define (take-while pred lis)
+  (check-arg procedure? pred take-while)
+  (let recur ((lis lis))
+    (if (null-list? lis) '()
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (cons x (recur (cdr lis)))
+	      '())))))
+
+(define (drop-while pred lis)
+  (check-arg procedure? pred drop-while)
+  (let lp ((lis lis))
+    (if (null-list? lis) '()
+	(if (pred (car lis))
+	    (lp (cdr lis))
+	    lis))))
+
+(define (take-while! pred lis)
+  (check-arg procedure? pred take-while!)
+  (if (or (null-list? lis) (not (pred (car lis)))) '()
+      (begin (let lp ((prev lis) (rest (cdr lis)))
+	       (if (pair? rest)
+		   (let ((x (car rest)))
+		     (if (pred x) (lp rest (cdr rest))
+			 (set-cdr! prev '())))))
+	     lis)))
+
+(define (span pred lis)
+  (check-arg procedure? pred span)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values '() '())
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (receive (prefix suffix) (recur (cdr lis))
+		(values (cons x prefix) suffix))
+	      (values '() lis))))))
+
+(define (span! pred lis)
+  (check-arg procedure? pred span!)
+  (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+      (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+		      (if (null-list? rest) rest
+			  (let ((x (car rest)))
+			    (if (pred x) (lp rest (cdr rest))
+				(begin (set-cdr! prev '())
+				       rest)))))))
+	(values lis suffix))))
+  
+
+(define (break  pred lis) (span  (lambda (x) (not (pred x))) lis))
+(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+
+(define (any pred lis1 . lists)
+  (check-arg procedure? pred any)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+	(and (pair? heads)
+	     (let lp ((heads heads) (tails tails))
+	       (receive (next-heads next-tails) (%cars+cdrs tails)
+		 (if (pair? next-heads)
+		     (or (apply pred heads) (lp next-heads next-tails))
+		     (apply pred heads)))))) ; Last PRED app is tail call.
+
+      ;; Fast path
+      (and (not (null-list? lis1))
+	   (let lp ((head (car lis1)) (tail (cdr lis1)))
+	     (if (null-list? tail)
+		 (pred head)		; Last PRED app is tail call.
+		 (or (pred head) (lp (car tail) (cdr tail))))))))
+
+
+;(define (every pred list)              ; Simple definition.
+;  (let lp ((list list))                ; Doesn't return the last PRED value.
+;    (or (not (pair? list))
+;        (and (pred (car list))
+;             (lp (cdr list))))))
+
+(define (every pred lis1 . lists)
+  (check-arg procedure? pred every)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+	(or (not (pair? heads))
+	    (let lp ((heads heads) (tails tails))
+	      (receive (next-heads next-tails) (%cars+cdrs tails)
+		(if (pair? next-heads)
+		    (and (apply pred heads) (lp next-heads next-tails))
+		    (apply pred heads)))))) ; Last PRED app is tail call.
+
+      ;; Fast path
+      (or (null-list? lis1)
+	  (let lp ((head (car lis1))  (tail (cdr lis1)))
+	    (if (null-list? tail)
+		(pred head)	; Last PRED app is tail call.
+		(and (pred head) (lp (car tail) (cdr tail))))))))
+
+(define (list-index pred lis1 . lists)
+  (check-arg procedure? pred list-index)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (let lp ((lists (cons lis1 lists)) (n 0))
+	(receive (heads tails) (%cars+cdrs lists)
+	  (and (pair? heads)
+	       (if (apply pred heads) n
+		   (lp tails (+ n 1))))))
+
+      ;; Fast path
+      (let lp ((lis lis1) (n 0))
+	(and (not (null-list? lis))
+	     (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;; Reverse
+;;;;;;;;;;;
+
+;R4RS, so not defined here.
+;(define (reverse lis) (fold cons '() lis))
+				      
+;(define (reverse! lis)
+;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
+
+(define (reverse! lis)
+  (let lp ((lis lis) (ans '()))
+    (if (null-list? lis) ans
+        (let ((tail (cdr lis)))
+          (set-cdr! lis ans)
+          (lp tail lis)))))
+
+;;; Lists-as-sets
+;;;;;;;;;;;;;;;;;
+
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;; - It tries to avoid linear-time scans in special cases where constant-time
+;;;   computations can be performed.
+;;; - It relies on similar properties from the other list-lib procs it calls.
+;;;   For example, it uses the fact that the implementations of MEMBER and
+;;;   FILTER in this source code share longest common tails between args
+;;;   and results to get structure sharing in the lset procedures.
+
+(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
+
+(define (lset<= = . lists)
+  (check-arg procedure? = lset<=)
+  (or (not (pair? lists)) ; 0-ary case
+      (let lp ((s1 (car lists)) (rest (cdr lists)))
+	(or (not (pair? rest))
+	    (let ((s2 (car rest))  (rest (cdr rest)))
+	      (and (or (eq? s2 s1)	; Fast path
+		       (%lset2<= = s1 s2)) ; Real test
+		   (lp s2 rest)))))))
+
+(define (lset= = . lists)
+  (check-arg procedure? = lset=)
+  (or (not (pair? lists)) ; 0-ary case
+      (let lp ((s1 (car lists)) (rest (cdr lists)))
+	(or (not (pair? rest))
+	    (let ((s2   (car rest))
+		  (rest (cdr rest)))
+	      (and (or (eq? s1 s2)	; Fast path
+		       (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
+		   (lp s2 rest)))))))
+
+
+(define (lset-adjoin = lis . elts)
+  (check-arg procedure? = lset-adjoin)
+  (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
+	lis elts))
+
+
+(define (lset-union = . lists)
+  (check-arg procedure? = lset-union)
+  (reduce (lambda (lis ans)		; Compute ANS + LIS.
+	    (cond ((null? lis) ans)	; Don't copy any lists
+		  ((null? ans) lis) 	; if we don't have to.
+		  ((eq? lis ans) ans)
+		  (else
+		   (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+					       ans
+					       (cons elt ans)))
+			 ans lis))))
+	  '() lists))
+
+(define (lset-union! = . lists)
+  (check-arg procedure? = lset-union!)
+  (reduce (lambda (lis ans)		; Splice new elts of LIS onto the front of ANS.
+	    (cond ((null? lis) ans)	; Don't copy any lists
+		  ((null? ans) lis) 	; if we don't have to.
+		  ((eq? lis ans) ans)
+		  (else
+		   (pair-fold (lambda (pair ans)
+				(let ((elt (car pair)))
+				  (if (any (lambda (x) (= x elt)) ans)
+				      ans
+				      (begin (set-cdr! pair ans) pair))))
+			      ans lis))))
+	  '() lists))
+
+
+(define (lset-intersection = lis1 . lists)
+  (check-arg procedure? = lset-intersection)
+  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+    (cond ((any null-list? lists) '())		; Short cut
+	  ((null? lists)          lis1)		; Short cut
+	  (else (filter (lambda (x)
+			  (every (lambda (lis) (member x lis =)) lists))
+			lis1)))))
+
+(define (lset-intersection! = lis1 . lists)
+  (check-arg procedure? = lset-intersection!)
+  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+    (cond ((any null-list? lists) '())		; Short cut
+	  ((null? lists)          lis1)		; Short cut
+	  (else (filter! (lambda (x)
+			   (every (lambda (lis) (member x lis =)) lists))
+			 lis1)))))
+
+
+(define (lset-difference = lis1 . lists)
+  (check-arg procedure? = lset-difference)
+  (let ((lists (filter pair? lists)))	; Throw out empty lists.
+    (cond ((null? lists)     lis1)	; Short cut
+	  ((memq lis1 lists) '())	; Short cut
+	  (else (filter (lambda (x)
+			  (every (lambda (lis) (not (member x lis =)))
+				 lists))
+			lis1)))))
+
+(define (lset-difference! = lis1 . lists)
+  (check-arg procedure? = lset-difference!)
+  (let ((lists (filter pair? lists)))	; Throw out empty lists.
+    (cond ((null? lists)     lis1)	; Short cut
+	  ((memq lis1 lists) '())	; Short cut
+	  (else (filter! (lambda (x)
+			   (every (lambda (lis) (not (member x lis =)))
+				  lists))
+			 lis1)))))
+
+
+(define (lset-xor = . lists)
+  (check-arg procedure? = lset-xor)
+  (reduce (lambda (b a)			; Compute A xor B:
+	    ;; Note that this code relies on the constant-time
+	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+	    ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+	    ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+	    ;; a careful case analysis to see it, but it's carefully
+	    ;; built in.
+
+	    ;; Compute a-b and a^b, then compute b-(a^b) and
+	    ;; cons it onto the front of a-b.
+	    (receive (a-b a-int-b)   (lset-diff+intersection = a b)
+	      (cond ((null? a-b)     (lset-difference = b a))
+		    ((null? a-int-b) (append b a))
+		    (else (fold (lambda (xb ans)
+				  (if (member xb a-int-b =) ans (cons xb ans)))
+				a-b
+				b)))))
+	  '() lists))
+
+
+(define (lset-xor! = . lists)
+  (check-arg procedure? = lset-xor!)
+  (reduce (lambda (b a)			; Compute A xor B:
+	    ;; Note that this code relies on the constant-time
+	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+	    ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+	    ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+	    ;; a careful case analysis to see it, but it's carefully
+	    ;; built in.
+
+	    ;; Compute a-b and a^b, then compute b-(a^b) and
+	    ;; cons it onto the front of a-b.
+	    (receive (a-b a-int-b)   (lset-diff+intersection! = a b)
+	      (cond ((null? a-b)     (lset-difference! = b a))
+		    ((null? a-int-b) (append! b a))
+		    (else (pair-fold (lambda (b-pair ans)
+				       (if (member (car b-pair) a-int-b =) ans
+					   (begin (set-cdr! b-pair ans) b-pair)))
+				     a-b
+				     b)))))
+	  '() lists))
+
+
+(define (lset-diff+intersection = lis1 . lists)
+  (check-arg procedure? = lset-diff+intersection)
+  (cond ((every null-list? lists) (values lis1 '()))	; Short cut
+	((memq lis1 lists)        (values '() lis1))	; Short cut
+	(else (partition (lambda (elt)
+			   (not (any (lambda (lis) (member elt lis =))
+				     lists)))
+			 lis1))))
+
+(define (lset-diff+intersection! = lis1 . lists)
+  (check-arg procedure? = lset-diff+intersection!)
+  (cond ((every null-list? lists) (values lis1 '()))	; Short cut
+	((memq lis1 lists)        (values '() lis1))	; Short cut
+	(else (partition! (lambda (elt)
+			    (not (any (lambda (lis) (member elt lis =))
+				      lists)))
+			  lis1))))
+(define-library (srfi 1)
+  (export
+   xcons list-tabulate cons*
+   proper-list? circular-list? dotted-list? not-pair? null-list? list=
+   circular-list length+
+   iota
+   first second third fourth fifth sixth seventh eighth ninth tenth
+   car+cdr
+   take       drop
+   take-right drop-right
+   take!      drop-right!
+   split-at   split-at!
+   last last-pair
+   zip unzip1 unzip2 unzip3 unzip4 unzip5
+   count
+   append! append-reverse append-reverse! concatenate concatenate!
+   unfold       fold       pair-fold       reduce
+   unfold-right fold-right pair-fold-right reduce-right
+   append-map append-map! map! pair-for-each filter-map map-in-order
+   filter  partition  remove
+   filter! partition! remove!
+   find find-tail any every list-index
+   take-while drop-while take-while!
+   span break span! break!
+   delete delete!
+   alist-cons alist-copy
+   delete-duplicates delete-duplicates!
+   alist-delete alist-delete!
+   reverse!
+   lset<= lset= lset-adjoin
+   lset-union  lset-intersection  lset-difference  lset-xor  lset-diff+intersection
+   lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+   )
+  (import
+   (except (scheme base) map member assoc)
+   (scheme case-lambda)
+   (scheme cxr)
+   (srfi 8)
+   (srfi aux))
+  (begin
+    (define-check-arg check-arg))
+  (include "1.body.scm"))
+;;;;"array.scm" Arrays for Scheme
+; Copyright (C) 2001, 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@code{(require 'array)} or @code{(require 'srfi-63)}
+;;@ftindex array
+
+(define-record-type <array>
+  (array:construct dimensions scales offset store)
+  array:array?
+  (dimensions dimensions)
+  (scales scales)
+  (offset offset)
+  (store store))
+
+(define (array:dimensions array)
+  (cond ((vector? array) (list (vector-length array)))
+        ((string? array) (list (string-length array)))
+        (else (dimensions array))))
+
+(define (array:scales array)
+  (cond ((vector? array) '(1))
+        ((string? array) '(1))
+        (else (scales array))))
+
+(define (array:store array)
+  (cond ((vector? array) array)
+        ((string? array) array)
+        (else (store array))))
+
+(define (array:offset array)
+  (cond ((vector? array) 0)
+        ((string? array) 0)
+        (else (offset array))))
+
+;;@args obj
+;;Returns @code{#t} if the @1 is an array, and @code{#f} if not.
+(define (array? obj)
+  (or (vector? obj) (string? obj) (array:array? obj)))
+
+;;@noindent
+;;@emph{Note:} Arrays are not disjoint from other Scheme types.
+;;Vectors and possibly strings also satisfy @code{array?}.
+;;A disjoint array predicate can be written:
+;;
+;;@example
+;;(define (strict-array? obj)
+;;  (and (array? obj) (not (string? obj)) (not (vector? obj))))
+;;@end example
+
+;;@body
+;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the
+;;corresponding elements of @1 and @2 are @code{equal?}.
+
+;;@body
+;;@0 recursively compares the contents of pairs, vectors, strings, and
+;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers
+;;and symbols.  A rule of thumb is that objects are generally @0 if
+;;they print the same.  @0 may fail to terminate if its arguments are
+;;circular data structures.
+;;
+;;@example
+;;(equal? 'a 'a)                             @result{}  #t
+;;(equal? '(a) '(a))                         @result{}  #t
+;;(equal? '(a (b) c)
+;;        '(a (b) c))                        @result{}  #t
+;;(equal? "abc" "abc")                       @result{}  #t
+;;(equal? 2 2)                               @result{}  #t
+;;(equal? (make-vector 5 'a)
+;;        (make-vector 5 'a))                @result{}  #t
+;;(equal? (make-array (a:fixN32b 4) 5 3)
+;;        (make-array (a:fixN32b 4) 5 3))    @result{}  #t
+;;(equal? (make-array '#(foo) 3 3)
+;;        (make-array '#(foo) 3 3))          @result{}  #t
+;;(equal? (lambda (x) x)
+;;        (lambda (y) y))                    @result{}  @emph{unspecified}
+;;@end example
+(define (equal? obj1 obj2)
+  (cond ((eqv? obj1 obj2) #t)
+        ((or (pair? obj1) (pair? obj2))
+         (and (pair? obj1) (pair? obj2)
+              (equal? (car obj1) (car obj2))
+              (equal? (cdr obj1) (cdr obj2))))
+        ((or (string? obj1) (string? obj2))
+         (and (string? obj1) (string? obj2)
+              (string=? obj1 obj2)))
+        ((or (vector? obj1) (vector? obj2))
+         (and (vector? obj1) (vector? obj2)
+              (equal? (vector-length obj1) (vector-length obj2))
+              (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx)))
+                  ((or (negative? idx)
+                       (not (equal? (vector-ref obj1 idx)
+                                    (vector-ref obj2 idx))))
+                   (negative? idx)))))
+        ((or (array? obj1) (array? obj2))
+         (and (array? obj1) (array? obj2)
+              (equal? (array:dimensions obj1) (array:dimensions obj2))
+              (equal? (array:store obj1) (array:store obj2))))
+        (else #f)))
+
+;;@body
+;;Returns the number of dimensions of @1.  If @1 is not an array, 0 is
+;;returned.
+(define (array-rank obj)
+  (if (array? obj) (length (array:dimensions obj)) 0))
+
+;;@args array
+;;Returns a list of dimensions.
+;;
+;;@example
+;;(array-dimensions (make-array '#() 3 5))
+;;   @result{} (3 5)
+;;@end example
+(define array-dimensions array:dimensions)
+
+;;@args prototype k1 @dots{}
+;;
+;;Creates and returns an array of type @1 with dimensions @2, @dots{}
+;;and filled with elements from @1.  @1 must be an array, vector, or
+;;string.  The implementation-dependent type of the returned array
+;;will be the same as the type of @1; except if that would be a vector
+;;or string with rank not equal to one, in which case some variety of
+;;array will be returned.
+;;
+;;If the @1 has no elements, then the initial contents of the returned
+;;array are unspecified.  Otherwise, the returned array will be filled
+;;with the element at the origin of @1.
+(define (make-array prototype . dimensions)
+  (define tcnt (apply * dimensions))
+  (let ((store
+         (if (string? prototype)
+             (case (string-length prototype)
+               ((0) (make-string tcnt))
+               (else (make-string tcnt
+                                  (string-ref prototype 0))))
+             (let ((pdims (array:dimensions prototype)))
+               (case (apply * pdims)
+                 ((0) (make-vector tcnt))
+                 (else (make-vector tcnt
+                                    (apply array-ref prototype
+                                           (map (lambda (x) 0) pdims)))))))))
+    (define (loop dims scales)
+      (if (null? dims)
+          (array:construct dimensions (cdr scales) 0 store)
+          (loop (cdr dims) (cons (* (car dims) (car scales)) scales))))
+    (loop (reverse dimensions) '(1))))
+;;@args prototype k1 @dots{}
+;;@0 is an alias for @code{make-array}.
+(define create-array make-array)
+
+;;@args array mapper k1 @dots{}
+;;@0 can be used to create shared subarrays of other
+;;arrays.  The @var{mapper} is a function that translates coordinates in
+;;the new array into coordinates in the old array.  A @var{mapper} must be
+;;linear, and its range must stay within the bounds of the old array, but
+;;it can be otherwise arbitrary.  A simple example:
+;;
+;;@example
+;;(define fred (make-array '#(#f) 8 8))
+;;(define freds-diagonal
+;;  (make-shared-array fred (lambda (i) (list i i)) 8))
+;;(array-set! freds-diagonal 'foo 3)
+;;(array-ref fred 3 3)
+;;   @result{} FOO
+;;(define freds-center
+;;  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j)))
+;;                     2 2))
+;;(array-ref freds-center 0 0)
+;;   @result{} FOO
+;;@end example
+(define (make-shared-array array mapper . dimensions)
+  (define odl (array:scales array))
+  (define rank (length dimensions))
+  (define shape
+    (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions))
+  (do ((idx (+ -1 rank) (+ -1 idx))
+       (uvt (append (cdr (vector->list (make-vector rank 0))) '(1))
+            (append (cdr uvt) '(0)))
+       (uvts '() (cons uvt uvts)))
+      ((negative? idx)
+       (let ((ker0 (apply + (map * odl (apply mapper uvt)))))
+         (array:construct
+          (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape)
+          (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0))
+               uvts)
+          (apply +
+                 (array:offset array)
+                 (map * odl (apply mapper (map car shape))))
+          (array:store array))))))
+
+;;@args rank proto list
+;;@3 must be a rank-nested list consisting of all the elements, in
+;;row-major order, of the array to be created.
+;;
+;;@0 returns an array of rank @1 and type @2 consisting of all the
+;;elements, in row-major order, of @3.  When @1 is 0, @3 is the lone
+;;array element; not necessarily a list.
+;;
+;;@example
+;;(list->array 2 '#() '((1 2) (3 4)))
+;;                @result{} #2A((1 2) (3 4))
+;;(list->array 0 '#() 3)
+;;                @result{} #0A 3
+;;@end example
+(define (list->array rank proto lst)
+  (define dimensions
+    (do ((shp '() (cons (length row) shp))
+         (row lst (car lst))
+         (rnk (+ -1 rank) (+ -1 rnk)))
+        ((negative? rnk) (reverse shp))))
+  (let ((nra (apply make-array proto dimensions)))
+    (define (l2ra dims idxs row)
+      (cond ((null? dims)
+             (apply array-set! nra row (reverse idxs)))
+            (else
+             (if (not (eqv? (car dims) (length row)))
+                 (error "Array not rectangular:" dims dimensions))
+             (do ((idx 0 (+ 1 idx))
+                  (row row (cdr row)))
+                 ((>= idx (car dims)))
+               (l2ra (cdr dims) (cons idx idxs) (car row))))))
+    (l2ra dimensions '() lst)
+    nra))
+
+;;@args array
+;;Returns a rank-nested list consisting of all the elements, in
+;;row-major order, of @1.  In the case of a rank-0 array, @0 returns
+;;the single element.
+;;
+;;@example
+;;(array->list #2A((ho ho ho) (ho oh oh)))
+;;                @result{} ((ho ho ho) (ho oh oh))
+;;(array->list #0A ho)
+;;                @result{} ho
+;;@end example
+(define (array->list ra)
+  (define (ra2l dims idxs)
+    (if (null? dims)
+        (apply array-ref ra (reverse idxs))
+        (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst))
+             (idx (+ -1 (car dims)) (+ -1 idx)))
+            ((negative? idx) lst))))
+  (ra2l (array-dimensions ra) '()))
+
+;;@args vect proto dim1 @dots{}
+;;@1 must be a vector of length equal to the product of exact
+;;nonnegative integers @3, @dots{}.
+;;
+;;@0 returns an array of type @2 consisting of all the elements, in
+;;row-major order, of @1.  In the case of a rank-0 array, @1 has a
+;;single element.
+;;
+;;@example
+;;(vector->array #(1 2 3 4) #() 2 2)
+;;                @result{} #2A((1 2) (3 4))
+;;(vector->array '#(3) '#())
+;;                @result{} #0A 3
+;;@end example
+(define (vector->array vect prototype . dimensions)
+  (define vdx (vector-length vect))
+  (if (not (eqv? vdx (apply * dimensions)))
+      (error "Vector length does not equal product of dimensions:"
+             vdx dimensions))
+  (let ((ra (apply make-array prototype dimensions)))
+    (define (v2ra dims idxs)
+      (cond ((null? dims)
+             (set! vdx (+ -1 vdx))
+             (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
+            (else
+             (do ((idx (+ -1 (car dims)) (+ -1 idx)))
+                 ((negative? idx) vect)
+               (v2ra (cdr dims) (cons idx idxs))))))
+    (v2ra dimensions '())
+    ra))
+
+;;@args array
+;;Returns a new vector consisting of all the elements of @1 in
+;;row-major order.
+;;
+;;@example
+;;(array->vector #2A ((1 2)( 3 4)))
+;;                @result{} #(1 2 3 4)
+;;(array->vector #0A ho)
+;;                @result{} #(ho)
+;;@end example
+(define (array->vector ra)
+  (define dims (array-dimensions ra))
+  (let* ((vdx (apply * dims))
+         (vect (make-vector vdx)))
+    (define (ra2v dims idxs)
+      (if (null? dims)
+          (let ((val (apply array-ref ra (reverse idxs))))
+            (set! vdx (+ -1 vdx))
+            (vector-set! vect vdx val)
+            vect)
+          (do ((idx (+ -1 (car dims)) (+ -1 idx)))
+              ((negative? idx) vect)
+            (ra2v (cdr dims) (cons idx idxs)))))
+    (ra2v dims '())))
+
+(define (array:in-bounds? array indices)
+  (do ((bnds (array:dimensions array) (cdr bnds))
+       (idxs indices (cdr idxs)))
+      ((or (null? bnds)
+           (null? idxs)
+           (not (integer? (car idxs)))
+           (not (< -1 (car idxs) (car bnds))))
+       (and (null? bnds) (null? idxs)))))
+
+;;@args array index1 @dots{}
+;;Returns @code{#t} if its arguments would be acceptable to
+;;@code{array-ref}.
+(define (array-in-bounds? array . indices)
+  (array:in-bounds? array indices))
+
+;;@args array k1 @dots{}
+;;Returns the (@2, @dots{}) element of @1.
+(define (array-ref array . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (error "Bad indices:" indices))
+  ((if (string? store) string-ref vector-ref)
+   store (apply + (array:offset array) (map * (array:scales array) indices))))
+
+;;@args array obj k1 @dots{}
+;;Stores @2 in the (@3, @dots{}) element of @1.  The value returned
+;;by @0 is unspecified.
+(define (array-set! array obj . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (error "Bad indices:" indices))
+  ((if (string? store) string-set! vector-set!)
+   store (apply + (array:offset array) (map * (array:scales array) indices))
+   obj))
+
+;;@noindent
+;;These functions return a prototypical uniform-array enclosing the
+;;optional argument (which must be of the correct type).  If the
+;;uniform-array type is supported by the implementation, then it is
+;;returned; defaulting to the next larger precision type; resorting
+;;finally to vector.
+
+(define (make-prototype-checker name pred? creator)
+  (lambda args
+    (case (length args)
+      ((1) (if (pred? (car args))
+               (creator (car args))
+               (error "Incompatible type:" name (car args))))
+      ((0) (creator))
+      (else (error "Wrong number of arguments:" name args)))))
+
+(define (integer-bytes?? n)
+  (lambda (obj)
+    (and (integer? obj)
+         (exact? obj)
+         (or (negative? n) (not (negative? obj)))
+         (do ((num obj (quotient num 256))
+              (n (+ -1 (abs n)) (+ -1 n)))
+             ((or (zero? num) (negative? n))
+              (zero? num))))))
+
+;;@args z
+;;@args
+;;Returns an inexact 128.bit flonum complex uniform-array prototype.
+(define a:floc128b (make-prototype-checker 'a:floc128b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 64.bit flonum complex uniform-array prototype.
+(define a:floc64b (make-prototype-checker 'a:floc64b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 32.bit flonum complex uniform-array prototype.
+(define a:floc32b (make-prototype-checker 'a:floc32b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 16.bit flonum complex uniform-array prototype.
+(define a:floc16b (make-prototype-checker 'a:floc16b complex? vector))
+
+;;@args z
+;;@args
+;;Returns an inexact 128.bit flonum real uniform-array prototype.
+(define a:flor128b (make-prototype-checker 'a:flor128b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 64.bit flonum real uniform-array prototype.
+(define a:flor64b (make-prototype-checker 'a:flor64b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 32.bit flonum real uniform-array prototype.
+(define a:flor32b (make-prototype-checker 'a:flor32b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 16.bit flonum real uniform-array prototype.
+(define a:flor16b (make-prototype-checker 'a:flor16b real? vector))
+
+;;@args z
+;;@args
+;;Returns an exact 128.bit decimal flonum rational uniform-array prototype.
+(define a:flor128b (make-prototype-checker 'a:flor128b real? vector))
+;;@args z
+;;@args
+;;Returns an exact 64.bit decimal flonum rational uniform-array prototype.
+(define a:flor64b (make-prototype-checker 'a:flor64b real? vector))
+;;@args z
+;;@args
+;;Returns an exact 32.bit decimal flonum rational uniform-array prototype.
+(define a:flor32b (make-prototype-checker 'a:flor32b real? vector))
+
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;64 bits of precision.
+(define a:fixz64b (make-prototype-checker 'a:fixz64b (integer-bytes?? -8) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;32 bits of precision.
+(define a:fixz32b (make-prototype-checker 'a:fixz32b (integer-bytes?? -4) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;16 bits of precision.
+(define a:fixz16b (make-prototype-checker 'a:fixz16b (integer-bytes?? -2) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;8 bits of precision.
+(define a:fixz8b (make-prototype-checker 'a:fixz8b (integer-bytes?? -1) vector))
+
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 64 bits of precision.
+(define a:fixn64b (make-prototype-checker 'a:fixn64b (integer-bytes?? 8) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 32 bits of precision.
+(define a:fixn32b (make-prototype-checker 'a:fixn32b (integer-bytes?? 4) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 16 bits of precision.
+(define a:fixn16b (make-prototype-checker 'a:fixn16b (integer-bytes?? 2) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 8 bits of precision.
+(define a:fixn8b (make-prototype-checker 'a:fixn8b (integer-bytes?? 1) vector))
+
+;;@args bool
+;;@args
+;;Returns a boolean uniform-array prototype.
+(define a:bool (make-prototype-checker 'a:bool boolean? vector))
+;;; SRFI-1 list-processing library 			-*- Scheme -*-
+;;; Reference implementation
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;;     -Olin
+
+;;; This is a library of list- and pair-processing functions. I wrote it after
+;;; carefully considering the functions provided by the libraries found in
+;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
+;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
+;;; rich toolkit, providing a superset of the functionality found in any of
+;;; the various Schemes I considered.
+
+;;; This implementation is intended as a portable reference implementation
+;;; for SRFI-1. See the porting notes below for more information.
+
+;;; Exported:
+;;; xcons tree-copy make-list list-tabulate cons* list-copy 
+;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
+;;; circular-list length+
+;;; iota
+;;; first second third fourth fifth sixth seventh eighth ninth tenth
+;;; car+cdr
+;;; take       drop       
+;;; take-right drop-right 
+;;; take!      drop-right!
+;;; split-at   split-at!
+;;; last last-pair
+;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
+;;; count
+;;; append! append-reverse append-reverse! concatenate concatenate! 
+;;; unfold       fold       pair-fold       reduce
+;;; unfold-right fold-right pair-fold-right reduce-right
+;;; append-map append-map! map! pair-for-each filter-map map-in-order
+;;; filter  partition  remove
+;;; filter! partition! remove! 
+;;; find find-tail any every list-index
+;;; take-while drop-while take-while!
+;;; span break span! break!
+;;; delete delete!
+;;; alist-cons alist-copy
+;;; delete-duplicates delete-duplicates!
+;;; alist-delete alist-delete!
+;;; reverse! 
+;;; lset<= lset= lset-adjoin  
+;;; lset-union  lset-intersection  lset-difference  lset-xor  lset-diff+intersection
+;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+;;; 
+;;; In principle, the following R4RS list- and pair-processing procedures
+;;; are also part of this package's exports, although they are not defined
+;;; in this file:
+;;;   Primitives: cons pair? null? car cdr set-car! set-cdr!
+;;;   Non-primitives: list length append reverse cadr ... cddddr list-ref
+;;;                   memq memv assq assv
+;;;   (The non-primitives are defined in this file, but commented out.)
+;;;
+;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
+;;; in this file:
+;;;   map for-each member assoc
+;;;
+;;; The remaining two R4RS list-processing procedures are not included: 
+;;;   list-tail (use drop)
+;;;   list? (use proper-list?)
+
+
+;;; A note on recursion and iteration/reversal:
+;;; Many iterative list-processing algorithms naturally compute the elements
+;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
+;;; the order needed to cons them into the proper answer (right-to-left, or
+;;; tail-then-head). One style or idiom of programming these algorithms, then,
+;;; loops, consing up the elements in reverse order, then destructively 
+;;; reverses the list at the end of the loop. I do not do this. The natural
+;;; and efficient way to code these algorithms is recursively. This trades off
+;;; intermediate temporary list structure for intermediate temporary stack
+;;; structure. In a stack-based system, this improves cache locality and
+;;; lightens the load on the GC system. Don't stand on your head to iterate!
+;;; Recurse, where natural. Multiple-value returns make this even more
+;;; convenient, when the recursion/iteration has multiple state values.
+
+;;; Porting:
+;;; This is carefully tuned code; do not modify casually.
+;;;   - It is careful to share storage when possible;
+;;;   - Side-effecting code tries not to perform redundant writes.
+;;; 
+;;; That said, a port of this library to a specific Scheme system might wish
+;;; to tune this code to exploit particulars of the implementation. 
+;;; The single most important compiler-specific optimisation you could make
+;;; to this library would be to add rewrite rules or transforms to:
+;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
+;;;   LSET-UNION) into multiple applications of a primitive two-argument 
+;;;   variant.
+;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, 
+;;;   ANY, EVERY) into open-coded loops. The killer here is that these 
+;;;   functions are n-ary. Handling the general case is quite inefficient,
+;;;   requiring many intermediate data structures to be allocated and
+;;;   discarded.
+;;; - transform applications of procedures that take optional arguments
+;;;   into calls to variants that do not take optional arguments. This
+;;;   eliminates unnecessary consing and parsing of the rest parameter.
+;;;
+;;; These transforms would provide BIG speedups. In particular, the n-ary
+;;; mapping functions are particularly slow and cons-intensive, and are good
+;;; candidates for tuning. I have coded fast paths for the single-list cases,
+;;; but what you really want to do is exploit the fact that the compiler
+;;; usually knows how many arguments are being passed to a particular
+;;; application of these functions -- they are usually explicitly called, not
+;;; passed around as higher-order values. If you can arrange to have your
+;;; compiler produce custom code or custom linkages based on the number of
+;;; arguments in the call, you can speed these functions up a *lot*. But this
+;;; kind of compiler technology no longer exists in the Scheme world as far as
+;;; I can see.
+;;;
+;;; Note that this code is, of course, dependent upon standard bindings for
+;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
+;;; to the procedure that takes the car of a list. If your Scheme 
+;;; implementation allows user code to alter the bindings of these procedures
+;;; in a manner that would be visible to these definitions, then there might
+;;; be trouble. You could consider horrible kludgery along the lines of
+;;;    (define fact 
+;;;      (let ((= =) (- -) (* *))
+;;;        (letrec ((real-fact (lambda (n) 
+;;;                              (if (= n 0) 1 (* n (real-fact (- n 1)))))))
+;;;          real-fact)))
+;;; Or you could consider shifting to a reasonable Scheme system that, say,
+;;; has a module system protecting code from this kind of lossage.
+;;;
+;;; This code does a fair amount of run-time argument checking. If your
+;;; Scheme system has a sophisticated compiler that can eliminate redundant
+;;; error checks, this is no problem. However, if not, these checks incur
+;;; some performance overhead -- and, in a safe Scheme implementation, they
+;;; are in some sense redundant: if we don't check to see that the PROC 
+;;; parameter is a procedure, we'll find out anyway three lines later when
+;;; we try to call the value. It's pretty easy to rip all this argument 
+;;; checking code out if it's inappropriate for your implementation -- just
+;;; nuke every call to CHECK-ARG.
+;;;
+;;; On the other hand, if you *do* have a sophisticated compiler that will
+;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
+;;; being the only possible candidate of which I'm aware), leaving these checks 
+;;; in can *help*, since their presence can be elided in redundant cases,
+;;; and in cases where they are needed, performing the checks early, at
+;;; procedure entry, can "lift" a check out of a loop. 
+;;;
+;;; Finally, I have only checked the properties that can portably be checked
+;;; with R5RS Scheme -- and this is not complete. You may wish to alter
+;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
+;;; checks, such as procedure arity for higher-order values.
+;;;
+;;; The code has only these non-R4RS dependencies:
+;;;   A few calls to an ERROR procedure;
+;;;   Uses of the R5RS multiple-value procedure VALUES and the m-v binding
+;;;     RECEIVE macro (which isn't R5RS, but is a trivial macro).
+;;;   Many calls to a parameter-checking procedure check-arg:
+;;;    (define (check-arg pred val caller)
+;;;      (let lp ((val val))
+;;;        (if (pred val) val (lp (error "Bad argument" val pred caller)))))
+;;;   A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
+;;;     optional arguments.
+;;;
+;;; Most of these procedures use the NULL-LIST? test to trigger the
+;;; base case in the inner loop or recursion. The NULL-LIST? function
+;;; is defined to be a careful one -- it raises an error if passed a
+;;; non-nil, non-pair value. The spec allows an implementation to use
+;;; a less-careful implementation that simply defines NULL-LIST? to
+;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
+;;; at the expense of having them silently accept dotted lists.
+
+;;; A note on dotted lists:
+;;; I, personally, take the view that the only consistent view of lists
+;;; in Scheme is the view that *everything* is a list -- values such as
+;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
+;;; fact that Scheme actually has no true list type. It has a pair type,
+;;; and there is an *interpretation* of the trees built using this type
+;;; as lists.
+;;;
+;;; I lobbied to have these list-processing procedures hew to this
+;;; view, and accept any value as a list argument. I was overwhelmingly
+;;; overruled during the SRFI discussion phase. So I am inserting this
+;;; text in the reference lib and the SRFI spec as a sort of "minority
+;;; opinion" dissent.
+;;;
+;;; Many of the procedures in this library can be trivially redefined
+;;; to handle dotted lists, just by changing the NULL-LIST? base-case
+;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
+;;; an empty list. For most of these procedures, that's all that is
+;;; required.
+;;;
+;;; However, we have to do a little more work for some procedures that
+;;; *produce* lists from other lists.  Were we to extend these procedures to
+;;; accept dotted lists, we would have to define how they terminate the lists
+;;; produced as results when passed a dotted list. I designed a coherent set
+;;; of termination rules for these cases; this was posted to the SRFI-1
+;;; discussion list. I additionally wrote an earlier version of this library
+;;; that implemented that spec. It has been discarded during later phases of
+;;; the definition and implementation of this library.
+;;;
+;;; The argument *against* defining these procedures to work on dotted
+;;; lists is that dotted lists are the rare, odd case, and that by 
+;;; arranging for the procedures to handle them, we lose error checking
+;;; in the cases where a dotted list is passed by accident -- e.g., when
+;;; the programmer swaps a two arguments to a list-processing function,
+;;; one being a scalar and one being a list. For example,
+;;;     (member '(1 3 5 7 9) 7)
+;;; This would quietly return #f if we extended MEMBER to accept dotted
+;;; lists.
+;;;
+;;; The SRFI discussion record contains more discussion on this topic.
+
+
+;;; Constructors
+;;;;;;;;;;;;;;;;
+
+;;; Occasionally useful as a value to be passed to a fold or other
+;;; higher-order procedure.
+(define (xcons d a) (cons a d))
+
+;;;; Recursively copy every cons.
+;(define (tree-copy x)
+;  (let recur ((x x))
+;    (if (not (pair? x)) x
+;	(cons (recur (car x)) (recur (cdr x))))))
+
+;;; Make a list of length LEN.
+
+(define (make-list len . maybe-elt)
+  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
+  (let ((elt (cond ((null? maybe-elt) #f) ; Default value
+		   ((null? (cdr maybe-elt)) (car maybe-elt))
+		   (else (error "Too many arguments to MAKE-LIST"
+				(cons len maybe-elt))))))
+    (do ((i len (- i 1))
+	 (ans '() (cons elt ans)))
+	((<= i 0) ans))))
+
+
+;(define (list . ans) ans)	; R4RS
+
+
+;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+
+(define (list-tabulate len proc)
+  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
+  (check-arg procedure? proc list-tabulate)
+  (do ((i (- len 1) (- i 1))
+       (ans '() (cons (proc i) ans)))
+      ((< i 0) ans)))
+
+;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+;;; (cons* a1) = a1	(cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+;;;
+;;; (cons first (unfold not-pair? car cdr rest values))
+
+(define (cons* first . rest)
+  (let recur ((x first) (rest rest))
+    (if (pair? rest)
+	(cons x (recur (car rest) (cdr rest)))
+	x)))
+
+;;; (unfold not-pair? car cdr lis values)
+
+(define (list-copy lis)				
+  (let recur ((lis lis))			
+    (if (pair? lis)				
+	(cons (car lis) (recur (cdr lis)))	
+	lis)))					
+
+;;; IOTA count [start step]	(start start+step ... start+(count-1)*step)
+
+(define (iota count . maybe-start+step)
+  (check-arg integer? count iota)
+  (if (< count 0) (error "Negative step count" iota count))
+  (let-optionals maybe-start+step ((start 0) (step 1))
+    (check-arg number? start iota)
+    (check-arg number? step iota)
+    (let loop ((n 0) (r '()))
+      (if (= n count)
+	  (reverse r)
+	  (loop (+ 1 n)
+		(cons (+ start (* n step)) r))))))
+	  
+;;; I thought these were lovely, but the public at large did not share my
+;;; enthusiasm...
+;;; :IOTA to		(0 ... to-1)
+;;; :IOTA from to	(from ... to-1)
+;;; :IOTA from to step  (from from+step ...)
+
+;;; IOTA: to		(1 ... to)
+;;; IOTA: from to	(from+1 ... to)
+;;; IOTA: from to step	(from+step from+2step ...)
+
+;(define (%parse-iota-args arg1 rest-args proc)
+;  (let ((check (lambda (n) (check-arg integer? n proc))))
+;    (check arg1)
+;    (if (pair? rest-args)
+;	(let ((arg2 (check (car rest-args)))
+;	      (rest (cdr rest-args)))
+;	  (if (pair? rest)
+;	      (let ((arg3 (check (car rest)))
+;		    (rest (cdr rest)))
+;		(if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
+;		    (values arg1 arg2 arg3)))
+;	      (values arg1 arg2 1)))
+;	(values 0 arg1 1))))
+;
+;(define (iota: arg1 . rest-args)
+;  (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
+;    (let* ((numsteps (floor (/ (- to from) step)))
+;	   (last-val (+ from (* step numsteps))))
+;      (if (< numsteps 0) (error "Negative step count" iota: from to step))
+;      (do ((steps-left numsteps (- steps-left 1))
+;	   (val last-val (- val step))
+;	   (ans '() (cons val ans)))
+;	  ((<= steps-left 0) ans)))))
+;
+;
+;(define (\:iota arg1 . rest-args)
+;  (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
+;    (let* ((numsteps (ceiling (/ (- to from) step)))
+;	   (last-val (+ from (* step (- numsteps 1)))))
+;      (if (< numsteps 0) (error "Negative step count" :iota from to step))
+;      (do ((steps-left numsteps (- steps-left 1))
+;	   (val last-val (- val step))
+;	   (ans '() (cons val ans)))
+;	  ((<= steps-left 0) ans)))))
+
+
+
+(define (circular-list val1 . vals)
+  (let ((ans (cons val1 vals)))
+    (set-cdr! (last-pair ans) ans)
+    ans))
+
+;;; <proper-list> ::= ()			; Empty proper list
+;;;		  |   (cons <x> <proper-list>)	; Proper-list pair
+;;; Note that this definition rules out circular lists -- and this
+;;; function is required to detect this case and return false.
+
+(define (proper-list? x)
+  (let lp ((x x) (lag x))
+    (if (pair? x)
+	(let ((x (cdr x)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag)))
+		(and (not (eq? x lag)) (lp x lag)))
+	      (null? x)))
+	(null? x))))
+
+
+;;; A dotted list is a finite list (possibly of length 0) terminated
+;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+;;; is a dotted list of length 0.
+;;;
+;;; <dotted-list> ::= <non-nil,non-pair>	; Empty dotted list
+;;;               |   (cons <x> <dotted-list>)	; Proper-list pair
+
+(define (dotted-list? x)
+  (let lp ((x x) (lag x))
+    (if (pair? x)
+	(let ((x (cdr x)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag)))
+		(and (not (eq? x lag)) (lp x lag)))
+	      (not (null? x))))
+	(not (null? x)))))
+
+(define (circular-list? x)
+  (let lp ((x x) (lag x))
+    (and (pair? x)
+	 (let ((x (cdr x)))
+	   (and (pair? x)
+		(let ((x   (cdr x))
+		      (lag (cdr lag)))
+		  (or (eq? x lag) (lp x lag))))))))
+
+(define (not-pair? x) (not (pair? x)))	; Inline me.
+
+;;; This is a legal definition which is fast and sloppy:
+;;;     (define null-list? not-pair?)
+;;; but we'll provide a more careful one:
+(define (null-list? l)
+  (cond ((pair? l) #f)
+	((null? l) #t)
+	(else (error "null-list?: argument out of domain" l))))
+           
+
+(define (list= = . lists)
+  (or (null? lists) ; special case
+
+      (let lp1 ((list-a (car lists)) (others (cdr lists)))
+	(or (null? others)
+	    (let ((list-b (car others))
+		  (others (cdr others)))
+	      (if (eq? list-a list-b)	; EQ? => LIST=
+		  (lp1 list-b others)
+		  (let lp2 ((list-a list-a) (list-b list-b))
+		    (if (null-list? list-a)
+			(and (null-list? list-b)
+			     (lp1 list-b others))
+			(and (not (null-list? list-b))
+			     (= (car list-a) (car list-b))
+			     (lp2 (cdr list-a) (cdr list-b)))))))))))
+			
+
+
+;;; R4RS, so commented out.
+;(define (length x)			; LENGTH may diverge or
+;  (let lp ((x x) (len 0))		; raise an error if X is
+;    (if (pair? x)			; a circular list. This version
+;        (lp (cdr x) (+ len 1))		; diverges.
+;        len)))
+
+(define (length+ x)			; Returns #f if X is circular.
+  (let lp ((x x) (lag x) (len 0))
+    (if (pair? x)
+	(let ((x (cdr x))
+	      (len (+ len 1)))
+	  (if (pair? x)
+	      (let ((x   (cdr x))
+		    (lag (cdr lag))
+		    (len (+ len 1)))
+		(and (not (eq? x lag)) (lp x lag len)))
+	      len))
+	len)))
+
+(define (zip list1 . more-lists) (apply map list list1 more-lists))
+
+
+;;; Selectors
+;;;;;;;;;;;;;
+
+;;; R4RS non-primitives:
+;(define (caar   x) (car (car x)))
+;(define (cadr   x) (car (cdr x)))
+;(define (cdar   x) (cdr (car x)))
+;(define (cddr   x) (cdr (cdr x)))
+;
+;(define (caaar  x) (caar (car x)))
+;(define (caadr  x) (caar (cdr x)))
+;(define (cadar  x) (cadr (car x)))
+;(define (caddr  x) (cadr (cdr x)))
+;(define (cdaar  x) (cdar (car x)))
+;(define (cdadr  x) (cdar (cdr x)))
+;(define (cddar  x) (cddr (car x)))
+;(define (cdddr  x) (cddr (cdr x)))
+;
+;(define (caaaar x) (caaar (car x)))
+;(define (caaadr x) (caaar (cdr x)))
+;(define (caadar x) (caadr (car x)))
+;(define (caaddr x) (caadr (cdr x)))
+;(define (cadaar x) (cadar (car x)))
+;(define (cadadr x) (cadar (cdr x)))
+;(define (caddar x) (caddr (car x)))
+;(define (cadddr x) (caddr (cdr x)))
+;(define (cdaaar x) (cdaar (car x)))
+;(define (cdaadr x) (cdaar (cdr x)))
+;(define (cdadar x) (cdadr (car x)))
+;(define (cdaddr x) (cdadr (cdr x)))
+;(define (cddaar x) (cddar (car x)))
+;(define (cddadr x) (cddar (cdr x)))
+;(define (cdddar x) (cdddr (car x)))
+;(define (cddddr x) (cdddr (cdr x)))
+
+
+(define first  car)
+(define second cadr)
+(define third  caddr)
+(define fourth cadddr)
+(define (fifth   x) (car    (cddddr x)))
+(define (sixth   x) (cadr   (cddddr x)))
+(define (seventh x) (caddr  (cddddr x)))
+(define (eighth  x) (cadddr (cddddr x)))
+(define (ninth   x) (car  (cddddr (cddddr x))))
+(define (tenth   x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr pair) (values (car pair) (cdr pair)))
+
+;;; take & drop
+
+(define (take lis k)
+  (check-arg integer? k take)
+  (let recur ((lis lis) (k k))
+    (if (zero? k) '()
+	(cons (car lis)
+	      (recur (cdr lis) (- k 1))))))
+
+(define (drop lis k)
+  (check-arg integer? k drop)
+  (let iter ((lis lis) (k k))
+    (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+
+(define (take! lis k)
+  (check-arg integer? k take!)
+  (if (zero? k) '()
+      (begin (set-cdr! (drop lis (- k 1)) '())
+	     lis)))
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.
+
+(define (take-right lis k)
+  (check-arg integer? k take-right)
+  (let lp ((lag lis)  (lead (drop lis k)))
+    (if (pair? lead)
+	(lp (cdr lag) (cdr lead))
+	lag)))
+
+(define (drop-right lis k)
+  (check-arg integer? k drop-right)
+  (let recur ((lag lis) (lead (drop lis k)))
+    (if (pair? lead)
+	(cons (car lag) (recur (cdr lag) (cdr lead)))
+	'())))
+
+;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+;;; us stop LAG one step early, in time to smash its cdr to ().
+(define (drop-right! lis k)
+  (check-arg integer? k drop-right!)
+  (let ((lead (drop lis k)))
+    (if (pair? lead)
+
+	(let lp ((lag lis)  (lead (cdr lead)))	; Standard case
+	  (if (pair? lead)
+	      (lp (cdr lag) (cdr lead))
+	      (begin (set-cdr! lag '())
+		     lis)))
+
+	'())))	; Special case dropping everything -- no cons to side-effect.
+
+;(define (list-ref lis i) (car (drop lis i)))	; R4RS
+
+;;; These use the APL convention, whereby negative indices mean 
+;;; "from the right." I liked them, but they didn't win over the
+;;; SRFI reviewers.
+;;; K >= 0: Take and drop  K elts from the front of the list.
+;;; K <= 0: Take and drop -K elts from the end   of the list.
+
+;(define (take lis k)
+;  (check-arg integer? k take)
+;  (if (negative? k)
+;      (list-tail lis (+ k (length lis)))
+;      (let recur ((lis lis) (k k))
+;	(if (zero? k) '()
+;	    (cons (car lis)
+;		  (recur (cdr lis) (- k 1)))))))
+;
+;(define (drop lis k)
+;  (check-arg integer? k drop)
+;  (if (negative? k)
+;      (let recur ((lis lis) (nelts (+ k (length lis))))
+;	(if (zero? nelts) '()
+;	    (cons (car lis)
+;		  (recur (cdr lis) (- nelts 1)))))
+;      (list-tail lis k)))
+;
+;
+;(define (take! lis k)
+;  (check-arg integer? k take!)
+;  (cond ((zero? k) '())
+;	((positive? k)
+;	 (set-cdr! (list-tail lis (- k 1)) '())
+;	 lis)
+;	(else (list-tail lis (+ k (length lis))))))
+;
+;(define (drop! lis k)
+;  (check-arg integer? k drop!)
+;  (if (negative? k)
+;      (let ((nelts (+ k (length lis))))
+;	(if (zero? nelts) '()
+;	    (begin (set-cdr! (list-tail lis (- nelts 1)) '())
+;		   lis)))
+;      (list-tail lis k)))
+
+(define (split-at x k)
+  (check-arg integer? k split-at)
+  (let recur ((lis x) (k k))
+    (if (zero? k) (values '() lis)
+	(receive (prefix suffix) (recur (cdr lis) (- k 1))
+	  (values (cons (car lis) prefix) suffix)))))
+
+(define (split-at! x k)
+  (check-arg integer? k split-at!)
+  (if (zero? k) (values '() x)
+      (let* ((prev (drop x (- k 1)))
+	     (suffix (cdr prev)))
+	(set-cdr! prev '())
+	(values x suffix))))
+
+
+(define (last lis) (car (last-pair lis)))
+
+(define (last-pair lis)
+  (check-arg pair? lis last-pair)
+  (let lp ((lis lis))
+    (let ((tail (cdr lis)))
+      (if (pair? tail) (lp tail) lis))))
+
+
+;;; Unzippers -- 1 through 5
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (unzip1 lis) (map car lis))
+
+(define (unzip2 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle
+	(let ((elt (car lis)))			; dotted lists.
+	  (receive (a b) (recur (cdr lis))
+	    (values (cons (car  elt) a)
+		    (cons (cadr elt) b)))))))
+
+(define (unzip3 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c) (recur (cdr lis))
+	    (values (cons (car   elt) a)
+		    (cons (cadr  elt) b)
+		    (cons (caddr elt) c)))))))
+
+(define (unzip4 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c d) (recur (cdr lis))
+	    (values (cons (car    elt) a)
+		    (cons (cadr   elt) b)
+		    (cons (caddr  elt) c)
+		    (cons (cadddr elt) d)))))))
+
+(define (unzip5 lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis lis lis lis)
+	(let ((elt (car lis)))
+	  (receive (a b c d e) (recur (cdr lis))
+	    (values (cons (car     elt) a)
+		    (cons (cadr    elt) b)
+		    (cons (caddr   elt) c)
+		    (cons (cadddr  elt) d)
+		    (cons (car (cddddr  elt)) e)))))))
+
+
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append! . lists)
+  ;; First, scan through lists looking for a non-empty one.
+  (let lp ((lists lists) (prev '()))
+    (if (not (pair? lists)) prev
+	(let ((first (car lists))
+	      (rest (cdr lists)))
+	  (if (not (pair? first)) (lp rest first)
+
+	      ;; Now, do the splicing.
+	      (let lp2 ((tail-cons (last-pair first))
+			(rest rest))
+		(if (pair? rest)
+		    (let ((next (car rest))
+			  (rest (cdr rest)))
+		      (set-cdr! tail-cons next)
+		      (lp2 (if (pair? next) (last-pair next) tail-cons)
+			   rest))
+		    first)))))))
+
+;;; APPEND is R4RS.
+;(define (append . lists)
+;  (if (pair? lists)
+;      (let recur ((list1 (car lists)) (lists (cdr lists)))
+;        (if (pair? lists)
+;            (let ((tail (recur (car lists) (cdr lists))))
+;              (fold-right cons tail list1)) ; Append LIST1 & TAIL.
+;            list1))
+;      '()))
+
+;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+
+;(define (append-reverse! rev-head tail)
+;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+;             tail
+;             rev-head))
+
+;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+
+(define (append-reverse rev-head tail)
+  (let lp ((rev-head rev-head) (tail tail))
+    (if (null-list? rev-head) tail
+	(lp (cdr rev-head) (cons (car rev-head) tail)))))
+
+(define (append-reverse! rev-head tail)
+  (let lp ((rev-head rev-head) (tail tail))
+    (if (null-list? rev-head) tail
+	(let ((next-rev (cdr rev-head)))
+	  (set-cdr! rev-head tail)
+	  (lp next-rev rev-head)))))
+
+
+(define (concatenate  lists) (reduce-right append  '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;; Fold/map internal utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These little internal utilities are used by the general
+;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+;;; One the other hand, the n-ary cases are painfully inefficient as it is.
+;;; An aggressive implementation should simply re-write these functions 
+;;; for raw efficiency; I have written them for as much clarity, portability,
+;;; and simplicity as can be achieved.
+;;;
+;;; I use the dreaded call/cc to do local aborts. A good compiler could
+;;; handle this with extreme efficiency. An implementation that provides
+;;; a one-shot, non-persistent continuation grabber could help the compiler
+;;; out by using that in place of the call/cc's in these routines.
+;;;
+;;; These functions have funky definitions that are precisely tuned to
+;;; the needs of the fold/map procs -- for example, to minimize the number
+;;; of times the argument lists need to be examined.
+
+;;; Return (map cdr lists). 
+;;; However, if any element of LISTS is empty, just abort and return '().
+(define (%cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+	(if (pair? lists)
+	    (let ((lis (car lists)))
+	      (if (null-list? lis) (abort '())
+		  (cons (cdr lis) (recur (cdr lists)))))
+	    '())))))
+
+(define (%cars+ lists last-elt)	; (append! (map car lists) (list last-elt))
+  (let recur ((lists lists))
+    (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+        (if (pair? lists)
+	    (receive (list other-lists) (car+cdr lists)
+	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+		  (receive (a d) (car+cdr list)
+		    (receive (cars cdrs) (recur other-lists)
+		      (values (cons a cars) (cons d cdrs))))))
+	    (values '() '()))))))
+
+;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
+;;; cars list. What a hack.
+(define (%cars+cdrs+ lists cars-final)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+        (if (pair? lists)
+	    (receive (list other-lists) (car+cdr lists)
+	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+		  (receive (a d) (car+cdr list)
+		    (receive (cars cdrs) (recur other-lists)
+		      (values (cons a cars) (cons d cdrs))))))
+	    (values (list cars-final) '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+  (let recur ((lists lists))
+    (if (pair? lists)
+	(receive (list other-lists) (car+cdr lists)
+	  (receive (a d) (car+cdr list)
+	    (receive (cars cdrs) (recur other-lists)
+	      (values (cons a cars) (cons d cdrs)))))
+	(values '() '()))))
+
+
+;;; count
+;;;;;;;;;
+(define (count pred list1 . lists)
+  (check-arg procedure? pred count)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (let lp ((list1 list1) (lists lists) (i 0))
+	(if (null-list? list1) i
+	    (receive (as ds) (%cars+cdrs lists)
+	      (if (null? as) i
+		  (lp (cdr list1) ds
+		      (if (apply pred (car list1) as) (+ i 1) i))))))
+
+      ;; Fast path
+      (let lp ((lis list1) (i 0))
+	(if (null-list? lis) i
+	    (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
+
+
+;;; fold/unfold
+;;;;;;;;;;;;;;;
+
+(define (unfold-right p f g seed . maybe-tail)
+  (check-arg procedure? p unfold-right)
+  (check-arg procedure? f unfold-right)
+  (check-arg procedure? g unfold-right)
+  (let lp ((seed seed) (ans (#\:optional maybe-tail '())))
+    (if (p seed) ans
+	(lp (g seed)
+	    (cons (f seed) ans)))))
+
+
+(define (unfold p f g seed . maybe-tail-gen)
+  (check-arg procedure? p unfold)
+  (check-arg procedure? f unfold)
+  (check-arg procedure? g unfold)
+  (if (pair? maybe-tail-gen)
+
+      (let ((tail-gen (car maybe-tail-gen)))
+	(if (pair? (cdr maybe-tail-gen))
+	    (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
+
+	    (let recur ((seed seed))
+	      (if (p seed) (tail-gen seed)
+		  (cons (f seed) (recur (g seed)))))))
+
+      (let recur ((seed seed))
+	(if (p seed) '()
+	    (cons (f seed) (recur (g seed)))))))
+      
+
+(define (fold kons knil lis1 . lists)
+  (check-arg procedure? kons fold)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
+	(receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
+	  (if (null? cars+ans) ans ; Done.
+	      (lp cdrs (apply kons cars+ans)))))
+	    
+      (let lp ((lis lis1) (ans knil))			; Fast path
+	(if (null-list? lis) ans
+	    (lp (cdr lis) (kons (car lis) ans))))))
+
+
+(define (fold-right kons knil lis1 . lists)
+  (check-arg procedure? kons fold-right)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))		; N-ary case
+	(let ((cdrs (%cdrs lists)))
+	  (if (null? cdrs) knil
+	      (apply kons (%cars+ lists (recur cdrs))))))
+
+      (let recur ((lis lis1))				; Fast path
+	(if (null-list? lis) knil
+	    (let ((head (car lis)))
+	      (kons head (recur (cdr lis))))))))
+
+
+(define (pair-fold-right f zero lis1 . lists)
+  (check-arg procedure? f pair-fold-right)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))		; N-ary case
+	(let ((cdrs (%cdrs lists)))
+	  (if (null? cdrs) zero
+	      (apply f (append! lists (list (recur cdrs)))))))
+
+      (let recur ((lis lis1))				; Fast path
+	(if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+
+(define (pair-fold f zero lis1 . lists)
+  (check-arg procedure? f pair-fold)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)) (ans zero))	; N-ary case
+	(let ((tails (%cdrs lists)))
+	  (if (null? tails) ans
+	      (lp tails (apply f (append! lists (list ans)))))))
+
+      (let lp ((lis lis1) (ans zero))
+	(if (null-list? lis) ans
+	    (let ((tail (cdr lis)))		; Grab the cdr now,
+	      (lp tail (f lis ans)))))))	; in case F SET-CDR!s LIS.
+      
+
+;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+;;; These cannot meaningfully be n-ary.
+
+(define (reduce f ridentity lis)
+  (check-arg procedure? f reduce)
+  (if (null-list? lis) ridentity
+      (fold f (car lis) (cdr lis))))
+
+(define (reduce-right f ridentity lis)
+  (check-arg procedure? f reduce-right)
+  (if (null-list? lis) ridentity
+      (let recur ((head (car lis)) (lis (cdr lis)))
+	(if (pair? lis)
+	    (f head (recur (car lis) (cdr lis)))
+	    head))))
+
+
+
+;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append-map f lis1 . lists)
+  (really-append-map append-map  append  f lis1 lists))
+(define (append-map! f lis1 . lists) 
+  (really-append-map append-map! append! f lis1 lists))
+
+(define (really-append-map who appender f lis1 lists)
+  (check-arg procedure? f who)
+  (if (pair? lists)
+      (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
+	(if (null? cars) '()
+	    (let recur ((cars cars) (cdrs cdrs))
+	      (let ((vals (apply f cars)))
+		(receive (cars2 cdrs2) (%cars+cdrs cdrs)
+		  (if (null? cars2) vals
+		      (appender vals (recur cars2 cdrs2))))))))
+
+      ;; Fast path
+      (if (null-list? lis1) '()
+	  (let recur ((elt (car lis1)) (rest (cdr lis1)))
+	    (let ((vals (f elt)))
+	      (if (null-list? rest) vals
+		  (appender vals (recur (car rest) (cdr rest)))))))))
+
+
+(define (pair-for-each proc lis1 . lists)
+  (check-arg procedure? proc pair-for-each)
+  (if (pair? lists)
+
+      (let lp ((lists (cons lis1 lists)))
+	(let ((tails (%cdrs lists)))
+	  (if (pair? tails)
+	      (begin (apply proc lists)
+		     (lp tails)))))
+
+      ;; Fast path.
+      (let lp ((lis lis1))
+	(if (not (null-list? lis))
+	    (let ((tail (cdr lis)))	; Grab the cdr now,
+	      (proc lis)		; in case PROC SET-CDR!s LIS.
+	      (lp tail))))))
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+(define (map! f lis1 . lists)
+  (check-arg procedure? f map!)
+  (if (pair? lists)
+      (let lp ((lis1 lis1) (lists lists))
+	(if (not (null-list? lis1))
+	    (receive (heads tails) (%cars+cdrs/no-test lists)
+	      (set-car! lis1 (apply f (car lis1) heads))
+	      (lp (cdr lis1) tails))))
+
+      ;; Fast path.
+      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+  lis1)
+
+
+;;; Map F across L, and save up all the non-false results.
+(define (filter-map f lis1 . lists)
+  (check-arg procedure? f filter-map)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))
+	(receive (cars cdrs) (%cars+cdrs lists)
+	  (if (pair? cars)
+	      (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+		    (else (recur cdrs))) ; Tail call in this arm.
+	      '())))
+	    
+      ;; Fast path.
+      (let recur ((lis lis1))
+	(if (null-list? lis) lis
+	    (let ((tail (recur (cdr lis))))
+	      (cond ((f (car lis)) => (lambda (x) (cons x tail)))
+		    (else tail)))))))
+
+
+;;; Map F across lists, guaranteeing to go left-to-right.
+;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+;;; in which case this procedure may simply be defined as a synonym for MAP.
+
+(define (map-in-order f lis1 . lists)
+  (check-arg procedure? f map-in-order)
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))
+	(receive (cars cdrs) (%cars+cdrs lists)
+	  (if (pair? cars)
+	      (let ((x (apply f cars)))		; Do head first,
+		(cons x (recur cdrs)))		; then tail.
+	      '())))
+	    
+      ;; Fast path.
+      (let recur ((lis lis1))
+	(if (null-list? lis) lis
+	    (let ((tail (cdr lis))
+		  (x (f (car lis))))		; Do head first,
+	      (cons x (recur tail)))))))	; then tail.
+
+
+;;; We extend MAP to handle arguments of unequal length.
+(define map map-in-order)	
+
+
+;;; filter, remove, partition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+;;; disorder the elements of their argument.
+
+;; This FILTER shares the longest tail of L that has no deleted elements.
+;; If Scheme had multi-continuation calls, they could be made more efficient.
+
+(define (filter pred lis)			; Sleazing with EQ? makes this
+  (check-arg procedure? pred filter)		; one faster.
+  (let recur ((lis lis))		
+    (if (null-list? lis) lis			; Use NOT-PAIR? to handle dotted lists.
+	(let ((head (car lis))
+	      (tail (cdr lis)))
+	  (if (pred head)
+	      (let ((new-tail (recur tail)))	; Replicate the RECUR call so
+		(if (eq? tail new-tail) lis
+		    (cons head new-tail)))
+	      (recur tail))))))			; this one can be a tail call.
+
+
+;;; Another version that shares longest tail.
+;(define (filter pred lis)
+;  (receive (ans no-del?)
+;      ;; (recur l) returns L with (pred x) values filtered.
+;      ;; It also returns a flag NO-DEL? if the returned value
+;      ;; is EQ? to L, i.e. if it didn't have to delete anything.
+;      (let recur ((l l))
+;	(if (null-list? l) (values l #t)
+;	    (let ((x  (car l))
+;		  (tl (cdr l)))
+;	      (if (pred x)
+;		  (receive (ans no-del?) (recur tl)
+;		    (if no-del?
+;			(values l #t)
+;			(values (cons x ans) #f)))
+;		  (receive (ans no-del?) (recur tl) ; Delete X.
+;		    (values ans #f))))))
+;    ans))
+
+
+
+;(define (filter! pred lis)			; Things are much simpler
+;  (let recur ((lis lis))			; if you are willing to
+;    (if (pair? lis)				; push N stack frames & do N
+;        (cond ((pred (car lis))		; SET-CDR! writes, where N is
+;               (set-cdr! lis (recur (cdr lis))); the length of the answer.
+;               lis)				
+;              (else (recur (cdr lis))))
+;        lis)))
+
+
+;;; This implementation of FILTER!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 
+;;;   usually expensive on modern machines, and can be extremely expensive on 
+;;;   modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the 
+;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the 
+;;; beginning of the next.
+
+(define (filter! pred lis)
+  (check-arg procedure? pred filter!)
+  (let lp ((ans lis))
+    (cond ((null-list? ans)       ans)			; Scan looking for
+	  ((not (pred (car ans))) (lp (cdr ans)))	; first cons of result.
+
+	  ;; ANS is the eventual answer.
+	  ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+	  ;;          Scan over a contiguous segment of the list that
+	  ;;          satisfies PRED.
+	  ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+	  ;;           segment of the list that *doesn't* satisfy PRED.
+	  ;;           When the segment ends, patch in a link from PREV
+	  ;;           to the start of the next good segment, and jump to
+	  ;;           SCAN-IN.
+	  (else (letrec ((scan-in (lambda (prev lis)
+				    (if (pair? lis)
+					(if (pred (car lis))
+					    (scan-in lis (cdr lis))
+					    (scan-out prev (cdr lis))))))
+			 (scan-out (lambda (prev lis)
+				     (let lp ((lis lis))
+				       (if (pair? lis)
+					   (if (pred (car lis))
+					       (begin (set-cdr! prev lis)
+						      (scan-in lis (cdr lis)))
+					       (lp (cdr lis)))
+					   (set-cdr! prev lis))))))
+		  (scan-in ans (cdr ans))
+		  ans)))))
+
+
+
+;;; Answers share common tail with LIS where possible; 
+;;; the technique is slightly subtle.
+
+(define (partition pred lis)
+  (check-arg procedure? pred partition)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle dotted lists.
+	(let ((elt (car lis))
+	      (tail (cdr lis)))
+	  (receive (in out) (recur tail)
+	    (if (pred elt)
+		(values (if (pair? out) (cons elt in) lis) out)
+		(values in (if (pair? in) (cons elt out) lis))))))))
+
+
+
+;(define (partition! pred lis)			; Things are much simpler
+;  (let recur ((lis lis))			; if you are willing to
+;    (if (null-list? lis) (values lis lis)	; push N stack frames & do N
+;        (let ((elt (car lis)))			; SET-CDR! writes, where N is
+;          (receive (in out) (recur (cdr lis))	; the length of LIS.
+;            (cond ((pred elt)
+;                   (set-cdr! lis in)
+;                   (values lis out))
+;                  (else (set-cdr! lis out)
+;                        (values in lis))))))))
+
+
+;;; This implementation of PARTITION!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;;   usually expensive on modern machines, and can be extremely expensive on 
+;;;   modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice these runs together into the result 
+;;; lists.
+
+(define (partition! pred lis)
+  (check-arg procedure? pred partition!)
+  (if (null-list? lis) (values lis lis)
+
+      ;; This pair of loops zips down contiguous in & out runs of the
+      ;; list, splicing the runs together. The invariants are
+      ;;   SCAN-IN:  (cdr in-prev)  = LIS.
+      ;;   SCAN-OUT: (cdr out-prev) = LIS.
+      (letrec ((scan-in (lambda (in-prev out-prev lis)
+			  (let lp ((in-prev in-prev) (lis lis))
+			    (if (pair? lis)
+				(if (pred (car lis))
+				    (lp lis (cdr lis))
+				    (begin (set-cdr! out-prev lis)
+					   (scan-out in-prev lis (cdr lis))))
+				(set-cdr! out-prev lis))))) ; Done.
+
+	       (scan-out (lambda (in-prev out-prev lis)
+			   (let lp ((out-prev out-prev) (lis lis))
+			     (if (pair? lis)
+				 (if (pred (car lis))
+				     (begin (set-cdr! in-prev lis)
+					    (scan-in lis out-prev (cdr lis)))
+				     (lp lis (cdr lis)))
+				 (set-cdr! in-prev lis)))))) ; Done.
+
+	;; Crank up the scan&splice loops.
+	(if (pred (car lis))
+	    ;; LIS begins in-list. Search for out-list's first pair.
+	    (let lp ((prev-l lis) (l (cdr lis)))
+	      (cond ((not (pair? l)) (values lis l))
+		    ((pred (car l)) (lp l (cdr l)))
+		    (else (scan-out prev-l l (cdr l))
+			  (values lis l))))	; Done.
+
+	    ;; LIS begins out-list. Search for in-list's first pair.
+	    (let lp ((prev-l lis) (l (cdr lis)))
+	      (cond ((not (pair? l)) (values l lis))
+		    ((pred (car l))
+		     (scan-in l prev-l (cdr l))
+		     (values l lis))		; Done.
+		    (else (lp l (cdr l)))))))))
+
+
+;;; Inline us, please.
+(define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+
+
+;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
+;;; (I don't actually think these are the world's most important
+;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
+;;; are far more general.)
+;;;
+;;; Function			Action
+;;; ---------------------------------------------------------------------------
+;;; remove pred lis		Delete by general predicate
+;;; delete x lis [=]		Delete by element comparison
+;;;					     
+;;; find pred lis		Search by general predicate
+;;; find-tail pred lis		Search by general predicate
+;;; member x lis [=]		Search by element comparison
+;;;
+;;; assoc key lis [=]		Search alist by key comparison
+;;; alist-delete key alist [=]	Alist-delete by key comparison
+
+(define (delete x lis . maybe-=) 
+  (let ((= (#\:optional maybe-= equal?)))
+    (filter (lambda (y) (not (= x y))) lis)))
+
+(define (delete! x lis . maybe-=)
+  (let ((= (#\:optional maybe-= equal?)))
+    (filter! (lambda (y) (not (= x y))) lis)))
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (member x lis . maybe-=)
+  (let ((= (#\:optional maybe-= equal?)))
+    (find-tail (lambda (y) (= x y)) lis)))
+
+;;; R4RS, hence we don't bother to define.
+;;; The MEMBER and then FIND-TAIL call should definitely
+;;; be inlined for MEMQ & MEMV.
+;(define (memq    x lis) (member x lis eq?))
+;(define (memv    x lis) (member x lis eqv?))
+
+
+;;; right-duplicate deletion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; delete-duplicates delete-duplicates!
+;;;
+;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+;;; in long lists, sort the list to bring duplicates together, then use a 
+;;; linear-time algorithm to kill the dups. Or use an algorithm based on
+;;; element-marking. The former gives you O(n lg n), the latter is linear.
+
+(define (delete-duplicates lis . maybe-=)
+  (let ((elt= (#\:optional maybe-= equal?)))
+    (check-arg procedure? elt= delete-duplicates)
+    (let recur ((lis lis))
+      (if (null-list? lis) lis
+	  (let* ((x (car lis))
+		 (tail (cdr lis))
+		 (new-tail (recur (delete x tail elt=))))
+	    (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+(define (delete-duplicates! lis maybe-=)
+  (let ((elt= (#\:optional maybe-= equal?)))
+    (check-arg procedure? elt= delete-duplicates!)
+    (let recur ((lis lis))
+      (if (null-list? lis) lis
+	  (let* ((x (car lis))
+		 (tail (cdr lis))
+		 (new-tail (recur (delete! x tail elt=))))
+	    (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+
+;;; alist stuff
+;;;;;;;;;;;;;;;
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (assoc x lis . maybe-=)
+  (let ((= (#\:optional maybe-= equal?)))
+    (find (lambda (entry) (= x (car entry))) lis)))
+
+(define (alist-cons key datum alist) (cons (cons key datum) alist))
+
+(define (alist-copy alist)
+  (map (lambda (elt) (cons (car elt) (cdr elt)))
+       alist))
+
+(define (alist-delete key alist . maybe-=)
+  (let ((= (#\:optional maybe-= equal?)))
+    (filter (lambda (elt) (not (= key (car elt)))) alist)))
+
+(define (alist-delete! key alist . maybe-=)
+  (let ((= (#\:optional maybe-= equal?)))
+    (filter! (lambda (elt) (not (= key (car elt)))) alist)))
+
+
+;;; find find-tail take-while drop-while span break any every list-index
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (find pred list)
+  (cond ((find-tail pred list) => car)
+	(else #f)))
+
+(define (find-tail pred list)
+  (check-arg procedure? pred find-tail)
+  (let lp ((list list))
+    (and (not (null-list? list))
+	 (if (pred (car list)) list
+	     (lp (cdr list))))))
+
+(define (take-while pred lis)
+  (check-arg procedure? pred take-while)
+  (let recur ((lis lis))
+    (if (null-list? lis) '()
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (cons x (recur (cdr lis)))
+	      '())))))
+
+(define (drop-while pred lis)
+  (check-arg procedure? pred drop-while)
+  (let lp ((lis lis))
+    (if (null-list? lis) '()
+	(if (pred (car lis))
+	    (lp (cdr lis))
+	    lis))))
+
+(define (take-while! pred lis)
+  (check-arg procedure? pred take-while!)
+  (if (or (null-list? lis) (not (pred (car lis)))) '()
+      (begin (let lp ((prev lis) (rest (cdr lis)))
+	       (if (pair? rest)
+		   (let ((x (car rest)))
+		     (if (pred x) (lp rest (cdr rest))
+			 (set-cdr! prev '())))))
+	     lis)))
+
+(define (span pred lis)
+  (check-arg procedure? pred span)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values '() '())
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (receive (prefix suffix) (recur (cdr lis))
+		(values (cons x prefix) suffix))
+	      (values '() lis))))))
+
+(define (span! pred lis)
+  (check-arg procedure? pred span!)
+  (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+      (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+		      (if (null-list? rest) rest
+			  (let ((x (car rest)))
+			    (if (pred x) (lp rest (cdr rest))
+				(begin (set-cdr! prev '())
+				       rest)))))))
+	(values lis suffix))))
+  
+
+(define (break  pred lis) (span  (lambda (x) (not (pred x))) lis))
+(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+
+(define (any pred lis1 . lists)
+  (check-arg procedure? pred any)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+	(and (pair? heads)
+	     (let lp ((heads heads) (tails tails))
+	       (receive (next-heads next-tails) (%cars+cdrs tails)
+		 (if (pair? next-heads)
+		     (or (apply pred heads) (lp next-heads next-tails))
+		     (apply pred heads)))))) ; Last PRED app is tail call.
+
+      ;; Fast path
+      (and (not (null-list? lis1))
+	   (let lp ((head (car lis1)) (tail (cdr lis1)))
+	     (if (null-list? tail)
+		 (pred head)		; Last PRED app is tail call.
+		 (or (pred head) (lp (car tail) (cdr tail))))))))
+
+
+;(define (every pred list)              ; Simple definition.
+;  (let lp ((list list))                ; Doesn't return the last PRED value.
+;    (or (not (pair? list))
+;        (and (pred (car list))
+;             (lp (cdr list))))))
+
+(define (every pred lis1 . lists)
+  (check-arg procedure? pred every)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+	(or (not (pair? heads))
+	    (let lp ((heads heads) (tails tails))
+	      (receive (next-heads next-tails) (%cars+cdrs tails)
+		(if (pair? next-heads)
+		    (and (apply pred heads) (lp next-heads next-tails))
+		    (apply pred heads)))))) ; Last PRED app is tail call.
+
+      ;; Fast path
+      (or (null-list? lis1)
+	  (let lp ((head (car lis1))  (tail (cdr lis1)))
+	    (if (null-list? tail)
+		(pred head)	; Last PRED app is tail call.
+		(and (pred head) (lp (car tail) (cdr tail))))))))
+
+(define (list-index pred lis1 . lists)
+  (check-arg procedure? pred list-index)
+  (if (pair? lists)
+
+      ;; N-ary case
+      (let lp ((lists (cons lis1 lists)) (n 0))
+	(receive (heads tails) (%cars+cdrs lists)
+	  (and (pair? heads)
+	       (if (apply pred heads) n
+		   (lp tails (+ n 1))))))
+
+      ;; Fast path
+      (let lp ((lis lis1) (n 0))
+	(and (not (null-list? lis))
+	     (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;; Reverse
+;;;;;;;;;;;
+
+;R4RS, so not defined here.
+;(define (reverse lis) (fold cons '() lis))
+				      
+;(define (reverse! lis)
+;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
+
+(define (reverse! lis)
+  (let lp ((lis lis) (ans '()))
+    (if (null-list? lis) ans
+        (let ((tail (cdr lis)))
+          (set-cdr! lis ans)
+          (lp tail lis)))))
+
+;;; Lists-as-sets
+;;;;;;;;;;;;;;;;;
+
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;; - It tries to avoid linear-time scans in special cases where constant-time
+;;;   computations can be performed.
+;;; - It relies on similar properties from the other list-lib procs it calls.
+;;;   For example, it uses the fact that the implementations of MEMBER and
+;;;   FILTER in this source code share longest common tails between args
+;;;   and results to get structure sharing in the lset procedures.
+
+(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
+
+(define (lset<= = . lists)
+  (check-arg procedure? = lset<=)
+  (or (not (pair? lists)) ; 0-ary case
+      (let lp ((s1 (car lists)) (rest (cdr lists)))
+	(or (not (pair? rest))
+	    (let ((s2 (car rest))  (rest (cdr rest)))
+	      (and (or (eq? s2 s1)	; Fast path
+		       (%lset2<= = s1 s2)) ; Real test
+		   (lp s2 rest)))))))
+
+(define (lset= = . lists)
+  (check-arg procedure? = lset=)
+  (or (not (pair? lists)) ; 0-ary case
+      (let lp ((s1 (car lists)) (rest (cdr lists)))
+	(or (not (pair? rest))
+	    (let ((s2   (car rest))
+		  (rest (cdr rest)))
+	      (and (or (eq? s1 s2)	; Fast path
+		       (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
+		   (lp s2 rest)))))))
+
+
+(define (lset-adjoin = lis . elts)
+  (check-arg procedure? = lset-adjoin)
+  (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
+	lis elts))
+
+
+(define (lset-union = . lists)
+  (check-arg procedure? = lset-union)
+  (reduce (lambda (lis ans)		; Compute ANS + LIS.
+	    (cond ((null? lis) ans)	; Don't copy any lists
+		  ((null? ans) lis) 	; if we don't have to.
+		  ((eq? lis ans) ans)
+		  (else
+		   (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+					       ans
+					       (cons elt ans)))
+			 ans lis))))
+	  '() lists))
+
+(define (lset-union! = . lists)
+  (check-arg procedure? = lset-union!)
+  (reduce (lambda (lis ans)		; Splice new elts of LIS onto the front of ANS.
+	    (cond ((null? lis) ans)	; Don't copy any lists
+		  ((null? ans) lis) 	; if we don't have to.
+		  ((eq? lis ans) ans)
+		  (else
+		   (pair-fold (lambda (pair ans)
+				(let ((elt (car pair)))
+				  (if (any (lambda (x) (= x elt)) ans)
+				      ans
+				      (begin (set-cdr! pair ans) pair))))
+			      ans lis))))
+	  '() lists))
+
+
+(define (lset-intersection = lis1 . lists)
+  (check-arg procedure? = lset-intersection)
+  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+    (cond ((any null-list? lists) '())		; Short cut
+	  ((null? lists)          lis1)		; Short cut
+	  (else (filter (lambda (x)
+			  (every (lambda (lis) (member x lis =)) lists))
+			lis1)))))
+
+(define (lset-intersection! = lis1 . lists)
+  (check-arg procedure? = lset-intersection!)
+  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+    (cond ((any null-list? lists) '())		; Short cut
+	  ((null? lists)          lis1)		; Short cut
+	  (else (filter! (lambda (x)
+			   (every (lambda (lis) (member x lis =)) lists))
+			 lis1)))))
+
+
+(define (lset-difference = lis1 . lists)
+  (check-arg procedure? = lset-difference)
+  (let ((lists (filter pair? lists)))	; Throw out empty lists.
+    (cond ((null? lists)     lis1)	; Short cut
+	  ((memq lis1 lists) '())	; Short cut
+	  (else (filter (lambda (x)
+			  (every (lambda (lis) (not (member x lis =)))
+				 lists))
+			lis1)))))
+
+(define (lset-difference! = lis1 . lists)
+  (check-arg procedure? = lset-difference!)
+  (let ((lists (filter pair? lists)))	; Throw out empty lists.
+    (cond ((null? lists)     lis1)	; Short cut
+	  ((memq lis1 lists) '())	; Short cut
+	  (else (filter! (lambda (x)
+			   (every (lambda (lis) (not (member x lis =)))
+				  lists))
+			 lis1)))))
+
+
+(define (lset-xor = . lists)
+  (check-arg procedure? = lset-xor)
+  (reduce (lambda (b a)			; Compute A xor B:
+	    ;; Note that this code relies on the constant-time
+	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+	    ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+	    ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+	    ;; a careful case analysis to see it, but it's carefully
+	    ;; built in.
+
+	    ;; Compute a-b and a^b, then compute b-(a^b) and
+	    ;; cons it onto the front of a-b.
+	    (receive (a-b a-int-b)   (lset-diff+intersection = a b)
+	      (cond ((null? a-b)     (lset-difference = b a))
+		    ((null? a-int-b) (append b a))
+		    (else (fold (lambda (xb ans)
+				  (if (member xb a-int-b =) ans (cons xb ans)))
+				a-b
+				b)))))
+	  '() lists))
+
+
+(define (lset-xor! = . lists)
+  (check-arg procedure? = lset-xor!)
+  (reduce (lambda (b a)			; Compute A xor B:
+	    ;; Note that this code relies on the constant-time
+	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+	    ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+	    ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+	    ;; a careful case analysis to see it, but it's carefully
+	    ;; built in.
+
+	    ;; Compute a-b and a^b, then compute b-(a^b) and
+	    ;; cons it onto the front of a-b.
+	    (receive (a-b a-int-b)   (lset-diff+intersection! = a b)
+	      (cond ((null? a-b)     (lset-difference! = b a))
+		    ((null? a-int-b) (append! b a))
+		    (else (pair-fold (lambda (b-pair ans)
+				       (if (member (car b-pair) a-int-b =) ans
+					   (begin (set-cdr! b-pair ans) b-pair)))
+				     a-b
+				     b)))))
+	  '() lists))
+
+
+(define (lset-diff+intersection = lis1 . lists)
+  (check-arg procedure? = lset-diff+intersection)
+  (cond ((every null-list? lists) (values lis1 '()))	; Short cut
+	((memq lis1 lists)        (values '() lis1))	; Short cut
+	(else (partition (lambda (elt)
+			   (not (any (lambda (lis) (member elt lis =))
+				     lists)))
+			 lis1))))
+
+(define (lset-diff+intersection! = lis1 . lists)
+  (check-arg procedure? = lset-diff+intersection!)
+  (cond ((every null-list? lists) (values lis1 '()))	; Short cut
+	((memq lis1 lists)        (values '() lis1))	; Short cut
+	(else (partition! (lambda (elt)
+			    (not (any (lambda (lis) (member elt lis =))
+				      lists)))
+			  lis1))))
+;;; Copyright (C) John Cowan 2013. All Rights Reserved.
+
+;;; 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-library (srfi 111)
+  (export box box? unbox set-box!)
+  (import (scheme base))
+  (begin
+    (define-record-type <box>
+      (box value)
+      box?
+      (value unbox set-box!))))
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved.
+
+;; 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-library (srfi 17)
+  (export set! setter getter-with-setter)
+  (import
+   (rename (scheme base) (set! %set!))
+   (srfi 1))
+  (begin
+
+    (define-syntax set!
+      (syntax-rules ()
+        ((_ (getter arg ...) val)
+         ((setter getter) arg ... val))
+        ((_ var val)
+         (%set! var val))))
+
+    (define setter
+      (let ((setters `((,car . ,set-car!)
+                       (,cdr . ,set-cdr!)
+                       (,caar . ,(lambda (p v) (set-car! (car p) v)))
+                       (,cadr . ,(lambda (p v) (set-car! (cdr p) v)))
+                       (,cdar . ,(lambda (p v) (set-cdr! (car p) v)))
+                       (,cddr . ,(lambda (p v) (set-cdr! (cdr p) v)))
+                       (,list-ref . ,list-set!)
+                       (,vector-ref . ,vector-set!)
+                       (,string-ref . ,string-set!)
+                       (,bytevector-u8-ref . ,bytevector-u8-set!))))
+        (letrec ((setter
+                  (lambda (proc)
+                    (let ((probe (assv proc setters)))
+                      (if probe
+                          (cdr probe)
+                          (error "No setter for " proc)))))
+                 (set-setter!
+                  (lambda (proc setter)
+                    (set! setters (cons (cons proc setter) setters)))))
+          (set-setter! setter set-setter!)
+          setter)))
+
+    (define (getter-with-setter get set)
+      (let ((proc (lambda args (apply get args))))
+        (set! (setter proc) set)
+        proc))
+
+    ))
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved.
+
+;; 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.
+
+;;; The SRFI claims that having the same variable appear multiple times is an
+;;; error in let* and so also in and-let*.  In fact let* allows rebinding the
+;;; same variable, so we also allow it here.
+
+(define-library (srfi 2)
+  (export and-let*)
+  (import (scheme base))
+  (begin
+    (define-syntax and-let*
+      (syntax-rules ()
+
+        ;; Handle zero-clauses special-case.
+        ((_ () . body)
+         (begin #t . body))
+
+        ;; Reduce clauses down to one regardless of body.
+        ((_ ((var expr) rest . rest*) . body)
+         (let ((var expr))
+           (and var (and-let* (rest . rest*) . body))))
+        ((_ ((expr) rest . rest*) . body)
+         (and expr (and-let* (rest . rest*) . body)))
+        ((_ (var rest . rest*) . body)
+         (begin
+           (let ((var #f)) #f)          ;(identifier? var)
+           (and var (and-let* (rest . rest*) . body))))
+
+        ;; Handle 1-clause cases without a body.
+        ((_ ((var expr)))
+         expr)
+        ((_ ((expr)))
+         expr)
+        ((_ (var))
+         (begin
+           (let ((var #f)) #f)          ;(identifier? var)
+           var))
+
+        ;; Handle 1-clause cases with a body.
+        ((_ ((var expr)) . body)
+         (let ((var expr))
+           (and var (begin . body))))
+        ((_ ((expr)) . body)
+         (and expr (begin . body)))
+        ((_ (var) . body)
+         (begin
+           (let ((var #f)) #f)          ;(identifier? var)
+           (and var (begin . body))))))))
+;;; Copyright (C) André van Tonder (2004). All Rights Reserved.
+
+;;; 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.
+
+;============================================================================================
+; IMPLEMENTATION:
+;
+; Andre van Tonder, 2004.
+;
+;============================================================================================
+
+(define-syntax define-record-type    
+  (syntax-rules ()
+    ((define-record-type . body)
+     (parse-declaration #f . body))))
+
+(define-syntax define-record-scheme    
+  (syntax-rules ()
+    ((define-record-scheme . body)
+     (parse-declaration #t . body))))
+
+(define-syntax parse-declaration    
+  (syntax-rules ()
+    ((parse-declaration is-scheme? (name super ...) constructor-clause predicate field-clause ...)
+     (build-record 0 constructor-clause (super ...) (field-clause ...) name predicate is-scheme?))
+    ((parse-declaration is-scheme? (name super ...) constructor-clause)
+     (parse-declaration is-scheme? (name super ...) constructor-clause #f))  
+    ((parse-declaration is-scheme? (name super ...))
+     (parse-declaration is-scheme? (name super ...) #f #f))
+    ((parse-declaration is-scheme? name . rest)
+     (parse-declaration is-scheme? (name) . rest))))
+
+(define-syntax record-update!
+  (syntax-rules ()
+    ((record-update! record name (label exp) ...)
+     (meta
+      `(let ((r record)) 
+         ((meta ,(name ("setter") label)) r exp)
+         ...
+         r)))))
+
+(define-syntax record-update
+  (syntax-rules ()
+    ((record-update record name (label exp) ...)
+     (name ("is-scheme?")
+           (meta                                                         
+            `(let ((new ((meta ,(name ("copier"))) record)))
+               (record-update! new name (label exp) ...)))
+           (record-compose (name record) (name (label exp) ...))))))    
+           
+(define-syntax record-compose
+  (syntax-rules ()
+    ((record-compose (export-name (label exp) ...))
+     (export-name (label exp) ...))
+    ((record-compose (import-name record) ... (export-name (label exp) ...))
+     (help-compose 1 (import-name record) ... (export-name (label exp) ...)))))
+
+(define-syntax help-compose
+  (syntax-rules ()
+    ((help-compose 1 (import-name record) import ... (export-name (label exp) ...))
+     (meta
+      `(help-compose 2
+                     (meta ,(intersection
+                             (meta ,(export-name ("labels")))
+                             (meta ,(remove-from (meta ,(import-name ("labels")))
+                                                 (label ...)
+                                                 if-free=))
+                             if-free=))
+                     (import-name record) 
+                     import ...
+                     (export-name (label exp) ...))))
+    ((help-compose 2 (copy-label ...) (import-name record) import ... (export-name . bindings))
+     (meta
+      `(let ((r record))
+         (record-compose import ...
+           (export-name (copy-label ((meta ,(import-name ("getter") copy-label)) r))
+                        ...
+                        . bindings)))))))
+
+(define-syntax build-record
+  (syntax-rules ()
+   ((build-record 0 (constructor . pos-labels) . rest)              ; extract positional labels from constructor clause
+    (build-record 1 (constructor . pos-labels) pos-labels . rest))  ; 
+   ((build-record 0 constructor . rest)                             ; 
+    (build-record 1 (constructor . #f) () . rest))                  ; 
+   ((build-record 1 constructor-clause (pos-label ...) (super ...)  
+                    ((label . accessors) ...) . rest)
+    (meta 
+     `(build-record 2
+                    constructor-clause
+                    (meta ,(union (meta ,(super ("labels")))        ; compute union of labels from supers,
+                                  ...                               ; constructor clause and field clauses
+                                  (pos-label ...) 
+                                  (label ...)      
+                                  top:if-free=))
+                    ((label . accessors) ...)
+                    (meta  ,(union (meta ,(super ("supers")))       ; compute transitive union of supers
+                                   ...
+                                   top:if-free=))
+                    . rest)))
+    ((build-record 2 (constructor . pos-labels) labels . rest)      ; insert default constructor labels if not given
+     (syntax-if pos-labels
+                (build-record 3 (constructor . pos-labels) labels . rest)
+                (build-record 3 (constructor . labels)     labels . rest)))
+    ((build-record 3 constructor-clause labels ((label . accessors) ...) . rest)
+     (meta 
+      `(build-record 4
+                     (meta ,(remove-from labels                     ; separate the labels that do not appear in a
+                                         (label ...)                ; field clause for next step
+                                         top:if-free=))
+                     ((label . accessors) ...) 
+                     constructor-clause
+                     labels
+                     . rest)))
+    ((build-record 4
+                   (undeclared-label ...)
+                   (field-clause ...)
+                   (constructor . pos-labels)
+                   labels
+                   supers
+                   name
+                   predicate
+                   is-scheme?)
+     (meta
+      `(build-record 5                                              ; generate identifiers for constructor, predicate
+                     is-scheme?                                     ; getters and setters as needed 
+                     name
+                     supers
+                     supers
+                     labels 
+                     (meta ,(to-identifier constructor))   
+                     (meta ,(add-temporaries pos-labels))           ; needed for constructor below
+                     (meta ,(to-identifier predicate))
+                     (meta ,(augment-field field-clause)) 
+                     ... 
+                     (undeclared-label (meta ,(generate-identifier))
+                                       (meta ,(generate-identifier)))
+                     ...)))
+    ((build-record 5
+                   is-scheme?
+                   name
+                   (super ...)
+                   supers
+                   (label ...)
+                   constructor  
+                   ((pos-label pos-temp) ...) 
+                   predicate
+                   (field-label getter setter)
+                   ...)  
+     
+     (begin
+       (syntax-if is-scheme?
+                  
+                  (begin
+                    (define-generic (predicate x) (lambda (x) #f))
+                    (define-generic (getter x))
+                    ...
+                    (define-generic (setter x v))
+                    ...
+                    (define-generic (copy x)))
+                  
+                  (begin
+                    (srfi-9:define-record-type internal-name
+                                               (maker field-label ...)
+                                               predicate
+                                               (field-label getter setter) ...)  
+       
+                    (define constructor 
+                      (lambda (pos-temp ...)
+                        (populate 1 maker (field-label ...) (pos-label pos-temp) ...)))
+       
+                    (extend-predicates supers predicate)
+                    (extend-accessors supers field-label predicate getter setter)
+                    ...
+       
+                    (define (copy x)
+                      (maker (getter x) ...))
+                    (extend-copiers supers copy predicate)
+   
+                    (define-method (show (r predicate))
+                      (list 'name
+                            (list 'field-label (getter r)) 
+                            ...))))    
+       
+       (define-syntax name
+         (syntax-rules (field-label ...)
+           ((name ("is-scheme?") sk fk)     (syntax-if is-scheme? sk fk))
+           ((name ("predicate") k)          (syntax-apply k predicate))
+           ((name ("supers") k)             (syntax-apply k (super ... name)))  
+           ((name ("labels") k)             (syntax-apply k (label ...)))
+           ((name ("pos-labels") k)         (syntax-apply k (pos-label ...)))
+           ((name ("getter") field-label k) (syntax-apply k getter))   
+           ...
+           ((name ("getter") other k)       (syntax-apply k #f))
+           ((name ("setter") field-label k) (syntax-apply k setter))  
+           ...
+           ((name ("setter") other k)       (syntax-apply k #f))
+           ((name ("copier") k)             (syntax-apply k copy))
+           ((name . bindings)               (populate 1 maker (field-label ...) . bindings))))))))
+
+
+(define-syntax to-identifier
+  (syntax-rules ()
+    ((to-identifier #f k) (syntax-apply k generated-identifier))
+    ((to-identifier id k) (syntax-apply k id))))
+
+(define-syntax augment-field 
+  (syntax-rules ()
+    ((augment-field (label) k)               (syntax-apply k (label generated-getter generated-setter)))
+    ((augment-field (label getter) k)        (meta `(label (meta ,(to-identifier getter)) generated-setter) k))
+    ((augment-field (label getter setter) k) (meta `(label (meta ,(to-identifier getter)) 
+                                                           (meta ,(to-identifier setter))) k))))
+
+(define-syntax extend-predicates
+  (syntax-rules ()
+    ((extend-predicates (super ...) predicate)
+     (begin
+       (meta
+        `(define-method (meta ,(super ("predicate")))
+                        (predicate)
+                        (x)
+                        any?))   
+       ...))))
+
+(define-syntax extend-copiers
+  (syntax-rules ()
+    ((extend-copiers (super ...) copy predicate)
+     (begin
+       (meta
+        `(define-method (meta ,(super ("copier")))
+                        (predicate)
+                        (x)
+                        copy))    
+       ...))))
+
+(define-syntax extend-accessors
+  (syntax-rules ()
+    ((extend-accessors (super ...) label predicate selector modifier)
+     (meta
+      `(begin 
+         (syntax-if (meta ,(super ("getter") label))
+                    (define-method (meta ,(super ("getter") label))
+                                   (predicate)
+                                   (x)
+                                   selector)
+                    (begin))
+         ...
+         (syntax-if (meta ,(super ("setter") label))
+                    (define-method (meta ,(super ("setter") label))
+                                   (predicate any?)
+                                   (x v)
+                                   modifier)
+                    (begin))
+         ...)))))
+
+(define-syntax populate
+  (syntax-rules ()
+    ((populate 1 maker labels . bindings)
+     (meta 
+      `(populate 2 maker
+                   (meta ,(order labels bindings ('<undefined>))))))
+    ((populate 2 maker ((label exp) ...))
+     (maker exp ...))))
+
+(define-syntax order
+  (syntax-rules ()
+    ((order (label ...) ((label* . binding) ...) default k)
+     (meta
+      `(if-empty? (meta ,(remove-from (label* ...) 
+                                      (label ...) 
+                                      if-free=))
+                  (order "emit" (label ...) ((label* . binding) ...) default k)
+                  (syntax-error "Illegal labels in" ((label* . binding) ...)
+                                "Legal labels are" (label ...)))))
+    ((order "emit" (label ...) bindings default k)
+     (meta 
+      `((label . (meta ,(syntax-lookup label 
+                                       bindings 
+                                       if-free= 
+                                       default)))
+        ...)
+      k))))
+
+
+;============================================================================================
+; Simple generic functions:
+
+(define-syntax define-generic
+  (syntax-rules ()
+    ((define-generic (name arg ...))
+     (define-generic (name arg ...)
+       (lambda (arg ...) (error "Inapplicable method:" 'name
+                                "Arguments:" (show arg) ... ))))
+    ((define-generic (name arg ...) proc)
+     (define name (make-generic (arg ...) proc)))))  
+  
+(define-syntax define-method
+  (syntax-rules ()
+    ((define-method (generic (arg pred?) ...) . body)
+     (define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body))) 
+    ((define-method generic (pred? ...) (arg ...) procedure)
+     (let ((next ((generic) 'get-proc))
+           (proc procedure))
+       (((generic) 'set-proc)
+        (lambda (arg ...)
+          (if (and (pred? arg) ...)
+              (proc arg ...)
+              (next arg ...))))))))
+
+(define-syntax make-generic
+  (syntax-rules ()
+    ((make-generic (arg arg+ ...) default-proc)
+     (let ((proc default-proc))
+       (case-lambda
+         ((arg arg+ ...)
+          (proc arg arg+ ...))
+         (()
+          (lambda (msg)
+            (case msg
+              ((get-proc) proc)
+              ((set-proc) (lambda (new)
+                            (set! proc new)))))))))))
+
+(define-generic (show x) 
+  (lambda (x) x))
+
+(define (any? x) #t)
+
+
+;============================================================================================
+; Syntax utilities:
+
+(define-syntax syntax-error
+  (syntax-rules ()))
+
+(define-syntax syntax-apply
+  (syntax-rules ()
+    ((syntax-apply (f . args) exp ...) 
+     (f exp ... . args))))
+
+(define-syntax syntax-cons
+  (syntax-rules ()
+    ((syntax-cons x rest k) 
+     (syntax-apply k (x . rest)))))
+
+(define-syntax syntax-cons-after
+  (syntax-rules ()
+    ((syntax-cons-after rest x k)
+     (syntax-apply k (x . rest)))))
+
+(define-syntax if-empty?
+  (syntax-rules ()
+    ((if-empty? () sk fk)      sk)
+    ((if-empty? (h . t) sk fk) fk)))
+
+(define-syntax add-temporaries   
+  (syntax-rules () 
+    ((add-temporaries lst k)                (add-temporaries lst () k))
+    ((add-temporaries () lst-temps k)       (syntax-apply k lst-temps))
+    ((add-temporaries (h . t) (done ...) k) (add-temporaries t (done ... (h temp)) k))))
+
+(define-syntax if-free=
+  (syntax-rules ()
+    ((if-free= x y kt kf)
+      (let-syntax
+          ((test (syntax-rules (x)
+                   ((test x kt* kf*) kt*)
+                   ((test z kt* kf*) kf*))))
+        (test y kt kf)))))
+
+(define-syntax top:if-free=
+  (syntax-rules ()
+    ((top:if-free= x y kt kf)
+     (begin
+       (define-syntax if-free=:test
+         (syntax-rules (x)
+           ((if-free=:test x kt* kf*) kt*)
+           ((if-free=:test z kt* kf*) kf*)))
+       (if-free=:test y kt kf)))))
+
+(define-syntax meta
+  (syntax-rules (meta quasiquote unquote)
+    ((meta `(meta ,(function argument ...)) k)
+     (meta `(argument ...) (syntax-apply-to function k)))
+    ((meta `(a . b) k)
+     (meta `a (descend-right b k)))
+    ((meta `whatever k) (syntax-apply k whatever))
+    ((meta `arg)
+     (meta `arg (syntax-id)))))
+
+(define-syntax syntax-apply-to
+  (syntax-rules ()
+    ((syntax-apply-to (argument ...) function k)
+     (function argument ... k))))
+
+(define-syntax descend-right
+  (syntax-rules ()
+    ((descend-right evaled b k)
+     (meta `b (syntax-cons-after evaled k)))))
+
+(define-syntax syntax-id
+  (syntax-rules ()
+    ((syntax-id arg) arg))) 
+
+(define-syntax remove-duplicates
+  (syntax-rules ()
+    ((remove-duplicates lst compare? k)
+     (remove-duplicates lst () compare? k))
+    ((remove-duplicates () done compare? k)
+     (syntax-apply k done))
+    ((remove-duplicates (h . t) (d ...) compare? k)
+     (if-member? h (d ...) compare? 
+                 (remove-duplicates t (d ...) compare? k)
+                 (remove-duplicates t (d ... h) compare? k)))))
+
+(define-syntax syntax-filter
+  (syntax-rules ()
+    ((syntax-filter () (if-p? arg ...) k)
+     (syntax-apply k ()))
+    ((syntax-filter (h . t) (if-p? arg ...) k)
+     (if-p? h arg ...
+            (syntax-filter t (if-p? arg ...) (syntax-cons-after h k))
+            (syntax-filter t (if-p? arg ...) k)))))
+
+(define-syntax if-member?
+  (syntax-rules ()
+    ((if-member? x () compare? sk fk) 
+     fk)
+    ((if-member? x (h . t) compare? sk fk)
+     (compare? x h
+               sk
+               (if-member? x t compare? sk fk)))))
+
+(define-syntax union
+  (syntax-rules ()
+    ((union (x ...) ... compare? k)
+     (remove-duplicates (x ... ...) compare? k))))
+
+(define-syntax intersection
+  (syntax-rules ()
+    ((intersection list1 list2 compare? k)
+     (syntax-filter list1 (if-member? list2 compare?) k))))
+
+(define-syntax remove-from
+  (syntax-rules ()
+    ((remove-from list1 list2 compare? k)
+     (syntax-filter list1 (if-not-member? list2 compare?) k))))
+
+(define-syntax if-not-member?
+  (syntax-rules ()
+    ((if-not-member? x list compare? sk fk)
+     (if-member? x list compare? fk sk))))
+
+(define-syntax generate-identifier
+  (syntax-rules ()
+    ((generate-identifier k) (syntax-apply k generated-identifier))))
+
+(define-syntax syntax-if
+  (syntax-rules ()
+    ((syntax-if #f sk fk)    fk)
+    ((syntax-if other sk fk) sk)))
+
+(define-syntax syntax-lookup
+  (syntax-rules ()
+    ((syntax-lookup label () compare fail k)
+     (syntax-apply k fail))
+    ((syntax-lookup label ((label* . value) . bindings) compare fail k)
+     (compare label label*
+              (syntax-apply k value)
+              (syntax-lookup label bindings compare fail k)))))
+;;; array as-srfi-9-record
+;;; 2001 Jussi Piitulainen
+
+;;; Untested.
+
+(define-record-type
+ array:srfi-9-record-type-descriptor
+ (array:make vec ind shp)
+ array:array?
+ (vec array:vector)
+ (ind array:index)
+ (shp array:shape))
+(define-library (srfi 60)
+  (export
+   ;; Bitwise Operations
+   logand
+   bitwise-and
+   logior
+   bitwise-ior
+   logxor
+   bitwise-xor
+   lognot
+   bitwise-not
+   bitwise-if
+   bitwise-merge
+   logtest
+   any-bits-set?
+   
+   ;; Integer Properties
+   logcount
+   bit-count
+   integer-length
+   log2-binary-factors
+   first-set-bit
+   
+   ;; Bit Within Word
+   logbit?
+   bit-set?
+   copy-bit
+   
+   ;; Field of Bits
+   bit-field
+   copy-bit-field
+   ash
+   arithmetic-shift
+   rotate-bit-field
+   reverse-bit-field
+   
+   ;; Bits as Booleans
+   integer->list
+   list->integer
+   booleans->integer
+   )
+  (import (scheme base))
+  (include "60.upstream.scm"))
+;;; Copyright (C) Jussi Piitulainen (2001). All Rights Reserved.
+
+;;; 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 (array-ref a . xs)
+  (or (array:array? a)
+      (error "not an array"))
+  (let ((shape (array:shape a)))
+    (if (null? xs)
+        (array:check-indices "array-ref" xs shape)
+        (let ((x (car xs)))
+          (if (vector? x)
+              (array:check-index-vector "array-ref" x shape)
+              (if (integer? x)
+                  (array:check-indices "array-ref" xs shape)
+                  (if (array:array? x)
+                      (array:check-index-actor "array-ref" x shape)
+                      (error "not an index object"))))))
+    (vector-ref
+     (array:vector a)
+     (if (null? xs)
+         (vector-ref (array:index a) 0)
+         (let ((x (car xs)))
+           (if (vector? x)
+               (array:index/vector
+                (quotient (vector-length shape) 2)
+                (array:index a)
+                x)
+               (if (integer? x)
+                   (array:vector-index (array:index a) xs)
+                   (if (array:array? x)
+                       (array:index/array
+                        (quotient (vector-length shape) 2)
+                        (array:index a)
+                        (array:vector x)
+                        (array:index x))
+                       (error "array-ref: bad index object")))))))))
+
+(define (array-set! a x . xs)
+  (or (array:array? a)
+      (error "array-set!: not an array"))
+  (let ((shape (array:shape a)))
+    (if (null? xs)
+        (array:check-indices "array-set!" '() shape)
+        (if (vector? x)
+            (array:check-index-vector "array-set!" x shape)
+            (if (integer? x)
+                (array:check-indices.o "array-set!" (cons x xs) shape)
+                (if (array:array? x)
+                    (array:check-index-actor "array-set!" x shape)
+                    (error "not an index object")))))
+    (if (null? xs)
+        (vector-set! (array:vector a) (vector-ref (array:index a) 0) x)
+        (if (vector? x)
+            (vector-set! (array:vector a)
+                         (array:index/vector
+                          (quotient (vector-length shape) 2)
+                          (array:index a)
+                          x)
+                         (car xs))
+            (if (integer? x)
+                (let ((v (array:vector a))
+                      (i (array:index a))
+                      (r (quotient (vector-length shape) 2)))
+                  (do ((sum (* (vector-ref i 0) x)
+                            (+ sum (* (vector-ref i k) (car ks))))
+                       (ks xs (cdr ks))
+                       (k 1 (+ k 1)))
+                    ((= k r)
+                     (vector-set! v (+ sum (vector-ref i k)) (car ks)))))
+                (if (array:array? x)
+                    (vector-set! (array:vector a)
+                                 (array:index/array
+                                  (quotient (vector-length shape) 2)
+                                  (array:index a)
+                                  (array:vector x)
+                                  (array:index x))
+                                 (car xs))
+                    (error (string-append
+                            "array-set!: bad index object: "
+                            (array:thing->string x)))))))))
+(define-library (srfi 63)
+  (export
+   array?
+   equal?
+   array-rank
+   array-dimensions
+   make-array
+   make-shared-array
+   list->array
+   array->list
+   vector->array
+   array->vector
+   array-in-bounds?
+   array-ref
+   array-set!
+   a:floc128b
+   a:floc64b
+   a:floc32b
+   a:floc16b
+   a:flor128b
+   a:flor64b
+   a:flor32b
+   a:flor16b
+   a:fixz64b
+   a:fixz32b
+   a:fixz16b
+   a:fixz8b
+   a:fixn64b
+   a:fixn32b
+   a:fixn16b
+   a:fixn8b
+   a:bool
+   )
+  (import (except (scheme base) equal?))
+  (include "63.body.scm"))
+;;; array
+;;; 1997 - 2001 Jussi Piitulainen
+
+;;; --- Intro ---
+
+;;; This interface to arrays is based on Alan Bawden's array.scm of
+;;; 1993 (earlier version in the Internet Repository and another
+;;; version in SLIB). This is a complete rewrite, to be consistent
+;;; with the rest of Scheme and to make arrays independent of lists.
+
+;;; Some modifications are due to discussion in srfi-25 mailing list.
+
+;;; (array? obj)
+;;; (make-array shape [obj])             changed arguments
+;;; (shape bound ...)                    new
+;;; (array shape obj ...)                new
+;;; (array-rank array)                   changed name back
+;;; (array-start array dimension)        new
+;;; (array-end array dimension)          new
+;;; (array-ref array k ...)
+;;; (array-ref array index)              new variant
+;;; (array-set! array k ... obj)         changed argument order
+;;; (array-set! array index obj)         new variant
+;;; (share-array array shape proc)       changed arguments
+
+;;; All other variables in this file have names in "array:".
+
+;;; Should there be a way to make arrays with initial values mapped
+;;; from indices? Sure. The current "initial object" is lame.
+;;;
+;;; Removed (array-shape array) from here. There is a new version
+;;; in arlib though.
+
+;;; --- Representation type dependencies ---
+
+;;; The mapping from array indices to the index to the underlying vector
+;;; is whatever array:optimize returns. The file "opt" provides three
+;;; representations:
+;;; 
+;;; mbda) mapping is a procedure that allows an optional argument
+;;; tter) mapping is two procedures that takes exactly the indices
+;;; ctor) mapping is a vector of a constant term and coefficients
+;;;
+;;; Choose one in "opt" to make the optimizer. Then choose the matching
+;;; implementation of array-ref and array-set!.
+;;;
+;;; These should be made macros to inline them. Or have a good compiler
+;;; and plant the package as a module.
+
+;;; 1. Pick an optimizer.
+;;; 2. Pick matching index representation.
+;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
+;;; 3. This file is otherwise portable.
+
+;;; --- Portable R5RS (R4RS and multiple values) ---
+
+;;; (array? obj)
+;;; returns #t if `obj' is an array and #t or #f otherwise.
+
+(define (array? obj)
+   (array:array? obj))
+
+;;; (make-array shape)
+;;; (make-array shape obj)
+;;; makes array of `shape' with each cell containing `obj' initially.
+
+(define (make-array shape . rest)
+  (or (array:good-shape? shape)
+      (error "make-array: shape is not a shape"))
+  (apply array:make-array shape rest))
+
+(define (array:make-array shape . rest)
+  (let ((size (array:size shape)))
+    (array:make
+     (if (pair? rest)
+         (apply (lambda (o) (make-vector size o)) rest)
+         (make-vector size))
+     (if (= size 0)
+         (array:optimize-empty
+          (vector-ref (array:shape shape) 1))
+         (array:optimize
+          (array:make-index shape)
+          (vector-ref (array:shape shape) 1)))
+     (array:shape->vector shape))))
+
+;;; (shape bound ...)
+;;; makes a shape. Bounds must be an even number of exact, pairwise
+;;; non-decreasing integers. Note that any such array can be a shape.
+
+(define (shape . bounds)
+  (let ((v (list->vector bounds)))
+    (or (even? (vector-length v))
+        (error (string-append "shape: uneven number of bounds: "
+                              (array:list->string bounds))))
+    (let ((shp (array:make
+                v
+                (if (pair? bounds)
+                    (array:shape-index)
+                    (array:empty-shape-index))
+                (vector 0 (quotient (vector-length v) 2)
+                        0 2))))
+      (or (array:good-shape? shp)
+          (error (string-append "shape: bounds are not pairwise "
+                                "non-decreasing exact integers: "
+                                (array:list->string bounds))))
+      shp)))
+
+;;; (array shape obj ...)
+;;; is analogous to `vector'.
+
+(define (array shape . elts)
+  (or (array:good-shape? shape)
+      (error (string-append "array: shape " (array:thing->string shape)
+                            " is not a shape")))
+  (let ((size (array:size shape)))
+    (let ((vector (list->vector elts)))
+      (or (= (vector-length vector) size)
+          (error (string-append "array: an array of shape "
+                                (array:shape-vector->string
+                                 (array:vector shape))
+                                " has "
+                                (number->string size)
+                                " elements but got "
+                                (number->string (vector-length vector))
+                                " values: "
+                                (array:list->string elts))))
+      (array:make
+       vector
+       (if (= size 0)
+           (array:optimize-empty
+            (vector-ref (array:shape shape) 1))
+           (array:optimize
+            (array:make-index shape)
+            (vector-ref (array:shape shape) 1)))
+       (array:shape->vector shape)))))
+
+;;; (array-rank array)
+;;; returns the number of dimensions of `array'.
+
+(define (array-rank array)
+   (quotient (vector-length (array:shape array)) 2))
+
+;;; (array-start array k)
+;;; returns the lower bound index of array along dimension k. This is
+;;; the least valid index along that dimension if the dimension is not
+;;; empty.
+
+(define (array-start array d)
+  (vector-ref (array:shape array) (+ d d)))
+
+;;; (array-end array k)
+;;; returns the upper bound index of array along dimension k. This is
+;;; not a valid index. If the dimension is empty, this is the same as
+;;; the lower bound along it.
+
+(define (array-end array d)
+  (vector-ref (array:shape array) (+ d d 1)))
+
+;;; (share-array array shape proc)
+;;; makes an array that shares elements of `array' at shape `shape'.
+;;; The arguments to `proc' are indices of the result.  The values of
+;;; `proc' are indices of `array'.
+
+;;; Todo: in the error message, should recognise the mapping and show it.
+
+(define (share-array array subshape f)
+  (or (array:good-shape? subshape)
+      (error (string-append "share-array: shape "
+                            (array:thing->string subshape)
+                            " is not a shape")))
+  (let ((subsize (array:size subshape)))
+    (or (array:good-share? subshape subsize f (array:shape array))
+        (error (string-append "share-array: subshape "
+                              (array:shape-vector->string
+                               (array:vector subshape))
+                              " does not map into supershape "
+                              (array:shape-vector->string
+                               (array:shape array))
+                              " under mapping "
+                              (array:map->string
+                               f
+                               (vector-ref (array:shape subshape) 1)))))    
+    (let ((g (array:index array)))
+      (array:make
+       (array:vector array)
+       (if (= subsize 0)
+           (array:optimize-empty
+            (vector-ref (array:shape subshape) 1))
+           (array:optimize
+            (lambda ks
+              (call-with-values
+               (lambda () (apply f ks))
+               (lambda ks (array:vector-index g ks))))
+            (vector-ref (array:shape subshape) 1)))
+       (array:shape->vector subshape)))))
+
+;;; --- Hrmph ---
+
+;;; (array:share/index! ...)
+;;; reuses a user supplied index object when recognising the
+;;; mapping. The mind balks at the very nasty side effect that
+;;; exposes the implementation. So this is not in the spec.
+;;; But letting index objects in at all creates a pressure
+;;; to go the whole hog. Arf.
+
+;;; Use array:optimize-empty for an empty array to get a
+;;; clearly invalid vector index.
+
+;;; Surely it's perverse to use an actor for index here? But
+;;; the possibility is provided for completeness.
+
+(define (array:share/index! array subshape proc index)
+  (array:make
+   (array:vector array)
+   (if (= (array:size subshape) 0)
+       (array:optimize-empty
+        (quotient (vector-length (array:shape array)) 2))
+       ((if (vector? index)
+            array:optimize/vector
+            array:optimize/actor)
+        (lambda (subindex)
+          (let ((superindex (proc subindex)))
+            (if (vector? superindex)
+                (array:index/vector
+                 (quotient (vector-length (array:shape array)) 2)
+                 (array:index array)
+                 superindex)
+                (array:index/array
+                 (quotient (vector-length (array:shape array)) 2)
+                 (array:index array)
+                 (array:vector superindex)
+                 (array:index superindex)))))
+        index))
+   (array:shape->vector subshape)))
+
+(define (array:optimize/vector f v)
+  (let ((r (vector-length v)))
+    (do ((k 0 (+ k 1)))
+      ((= k r))
+      (vector-set! v k 0))
+    (let ((n0 (f v))
+          (cs (make-vector (+ r 1)))
+          (apply (array:applier-to-vector (+ r 1))))
+      (vector-set! cs 0 n0)
+      (let wok ((k 0))
+        (if (< k r)
+            (let ((k1 (+ k 1)))
+              (vector-set! v k 1)
+              (let ((nk (- (f v) n0)))
+                (vector-set! v k 0)
+                (vector-set! cs k1 nk)
+                (wok k1)))))
+      (apply (array:maker r) cs))))
+
+(define (array:optimize/actor f a)
+  (let ((r (array-end a 0))
+        (v (array:vector a))
+        (i (array:index a)))
+    (do ((k 0 (+ k 1)))
+      ((= k r))
+      (vector-set! v (array:actor-index i k) 0))
+    (let ((n0 (f a))
+          (cs (make-vector (+ r 1)))
+          (apply (array:applier-to-vector (+ r 1))))
+      (vector-set! cs 0 n0)
+      (let wok ((k 0))
+        (if (< k r)
+            (let ((k1 (+ k 1))
+                  (t (array:actor-index i k)))
+              (vector-set! v t 1)
+              (let ((nk (- (f a) n0)))
+                (vector-set! v t 0)
+                (vector-set! cs k1 nk)
+                (wok k1)))))
+      (apply (array:maker r) cs))))
+
+;;; --- Internals ---
+
+(define (array:shape->vector shape)
+  (let ((idx (array:index shape))
+        (shv (array:vector shape))
+        (rnk (vector-ref (array:shape shape) 1)))
+    (let ((vec (make-vector (* rnk 2))))
+      (do ((k 0 (+ k 1)))
+        ((= k rnk)
+         vec)
+        (vector-set! vec (+ k k)
+                     (vector-ref shv (array:shape-vector-index idx k 0)))
+        (vector-set! vec (+ k k 1)
+                     (vector-ref shv (array:shape-vector-index idx k 1)))))))
+
+;;; (array:size shape)
+;;; returns the number of elements in arrays of shape `shape'.
+
+(define (array:size shape)
+   (let ((idx (array:index shape))
+         (shv (array:vector shape))
+         (rnk (vector-ref (array:shape shape) 1)))
+     (do   ((k 0 (+ k 1))
+            (s 1 (* s
+                    (- (vector-ref shv (array:shape-vector-index idx k 1))
+                       (vector-ref shv (array:shape-vector-index idx k 0))))))
+       ((= k rnk) s))))
+
+;;; (array:make-index shape)
+;;; returns an index function for arrays of shape `shape'. This is a
+;;; runtime composition of several variable arity procedures, to be
+;;; passed to array:optimize for recognition as an affine function of
+;;; as many variables as there are dimensions in arrays of this shape.
+
+(define (array:make-index shape)
+   (let ((idx (array:index shape))
+         (shv (array:vector shape))
+         (rnk (vector-ref (array:shape shape) 1)))
+     (do ((f (lambda () 0)
+             (lambda (k . ks)
+               (+ (* s (- k (vector-ref
+                             shv
+                             (array:shape-vector-index idx (- j 1) 0))))
+                  (apply f ks))))
+          (s 1 (* s (- (vector-ref
+                        shv
+                        (array:shape-vector-index idx (- j 1) 1))
+                       (vector-ref
+                        shv
+                        (array:shape-vector-index idx (- j 1) 0)))))
+          (j rnk (- j 1)))
+       ((= j 0)
+        f))))
+
+
+;;; --- Error checking ---
+
+;;; (array:good-shape? shape)
+;;; returns true if `shape' is an array of the right shape and its
+;;; elements are exact integers that pairwise bound intervals `[lo..hi)´.
+
+(define (array:good-shape? shape)
+  (and (array:array? shape)
+       (let ((u (array:shape shape))
+             (v (array:vector shape))
+             (x (array:index shape)))
+         (and (= (vector-length u) 4)
+              (= (vector-ref u 0) 0)
+              (= (vector-ref u 2) 0)
+              (= (vector-ref u 3) 2))
+         (let ((p (vector-ref u 1)))
+           (do ((k 0 (+ k 1))
+                (true #t (let ((lo (vector-ref
+                                    v
+                                    (array:shape-vector-index x k 0)))
+                               (hi (vector-ref
+                                    v
+                                    (array:shape-vector-index x k 1))))
+                           (and true
+                                (integer? lo)
+                                (exact? lo)
+                                (integer? hi)
+                                (exact? hi)
+                                (<= lo hi)))))
+             ((= k p) true))))))
+
+;;; (array:good-share? subv subsize mapping superv)
+;;; returns true if the extreme indices in the subshape vector map
+;;; into the bounds in the supershape vector.
+
+;;; If some interval in `subv' is empty, then `subv' is empty and its
+;;; image under `f' is empty and it is trivially alright.  One must
+;;; not call `f', though.
+
+(define (array:good-share? subshape subsize f super)
+  (or (zero? subsize)
+      (letrec
+          ((sub (array:vector subshape))
+           (dex (array:index subshape))
+           (ck (lambda (k ks)
+		 (if (zero? k)
+                     (call-with-values
+                      (lambda () (apply f ks))
+                      (lambda qs (array:good-indices? qs super)))
+                     (and (ck (- k 1)
+                              (cons (vector-ref
+                                     sub
+                                     (array:shape-vector-index
+                                      dex
+                                      (- k 1)
+                                      0))
+                                    ks))
+                          (ck (- k 1)
+                              (cons (- (vector-ref
+                                        sub
+                                        (array:shape-vector-index
+                                         dex
+                                         (- k 1)
+                                         1))
+                                       1)
+                                    ks)))))))
+        (let ((rnk (vector-ref (array:shape subshape) 1)))
+          (or (array:unchecked-share-depth? rnk)
+              (ck rnk '()))))))
+
+;;; Check good-share on 10 dimensions at most. The trouble is,
+;;; the cost of this check is exponential in the number of dimensions.
+
+(define (array:unchecked-share-depth? rank)
+  (if (> rank 10)
+      (begin
+        (display `(warning unchecked depth in share
+                            ,rank subdimensions))
+        (newline)
+        #t)
+      #f))
+
+;;; (array:check-indices caller indices shape-vector)
+;;; (array:check-indices.o caller indices shape-vector)
+;;; (array:check-index-vector caller index-vector shape-vector)
+;;; return if the index is in bounds, else signal error.
+;;;
+;;; Shape-vector is the internal representation, with
+;;; b and e for dimension k at 2k and 2k + 1.
+
+(define (array:check-indices who ks shv)
+  (or (array:good-indices? ks shv)
+      (error (array:not-in who ks shv))))
+
+(define (array:check-indices.o who ks shv)
+  (or (array:good-indices.o? ks shv)
+      (error (array:not-in who (reverse (cdr (reverse ks))) shv))))
+
+(define (array:check-index-vector who ks shv)
+  (or (array:good-index-vector? ks shv)
+      (error (array:not-in who (vector->list ks) shv))))
+
+(define (array:check-index-actor who ks shv)
+  (let ((shape (array:shape ks)))
+    (or (and (= (vector-length shape) 2)
+             (= (vector-ref shape 0) 0))
+        (error "not an actor"))
+    (or (array:good-index-actor?
+         (vector-ref shape 1)
+         (array:vector ks)
+         (array:index ks)
+         shv)
+        (array:not-in who (do ((k (vector-ref shape 1) (- k 1))
+                               (m '() (cons (vector-ref
+                                             (array:vector ks)
+                                             (array:actor-index
+                                              (array:index ks)
+                                              (- k 1)))
+                                            m)))
+                            ((= k 0) m))
+                      shv))))
+
+(define (array:good-indices? ks shv)
+   (let ((d2 (vector-length shv)))
+      (do ((kp ks (if (pair? kp)
+                      (cdr kp)))
+           (k 0 (+ k 2))
+           (true #t (and true (pair? kp)
+                         (array:good-index? (car kp) shv k))))
+        ((= k d2)
+         (and true (null? kp))))))
+
+(define (array:good-indices.o? ks.o shv)
+   (let ((d2 (vector-length shv)))
+     (do   ((kp ks.o (if (pair? kp)
+                         (cdr kp)))
+            (k 0 (+ k 2))
+            (true #t (and true (pair? kp)
+                          (array:good-index? (car kp) shv k))))
+       ((= k d2)
+        (and true (pair? kp) (null? (cdr kp)))))))
+
+(define (array:good-index-vector? ks shv)
+  (let ((r2 (vector-length shv)))
+    (and (= (* 2 (vector-length ks)) r2)
+         (do ((j 0 (+ j 1))
+              (k 0 (+ k 2))
+              (true #t (and true
+                            (array:good-index? (vector-ref ks j) shv k))))
+           ((= k r2) true)))))
+
+(define (array:good-index-actor? r v i shv)
+  (and (= (* 2 r) (vector-length shv))
+       (do ((j 0 (+ j 1))
+            (k 0 (+ k 2))
+            (true #t (and true
+                          (array:good-index? (vector-ref
+                                              v
+                                              (array:actor-index i j))
+                                             shv
+                                             k))))
+         ((= j r) true))))
+
+;;; (array:good-index? index shape-vector 2d)
+;;; returns true if index is within bounds for dimension 2d/2.
+
+(define (array:good-index? w shv k)
+  (and (integer? w)
+       (exact? w)
+       (<= (vector-ref shv k) w)
+       (< w (vector-ref shv (+ k 1)))))
+
+(define (array:not-in who ks shv)
+  (let ((index (array:list->string ks))
+        (bounds (array:shape-vector->string shv)))
+    (error (string-append who
+                          ": index " index
+                          " not in bounds " bounds))))
+
+(define (array:list->string ks)
+  (do ((index "" (string-append index (array:thing->string (car ks)) " "))
+       (ks ks (cdr ks)))
+    ((null? ks) index)))
+
+(define (array:shape-vector->string shv)
+  (do ((bounds "" (string-append bounds
+                                 "["
+                                 (number->string (vector-ref shv t))
+                                 ".."
+                                 (number->string (vector-ref shv (+ t 1)))
+                                 ")"
+                                 " "))
+       (t 0 (+ t 2)))
+    ((= t (vector-length shv)) bounds)))
+
+(define (array:thing->string thing)
+  (cond
+    ((number? thing) (number->string thing))
+    ((symbol? thing) (string-append "#<symbol>" (symbol->string thing)))
+    ((char? thing) "#<char>")
+    ((string? thing) "#<string>")
+    ((list? thing) (string-append "#" (number->string (length thing))
+                                  "<list>"))
+                                  
+    ((pair? thing) "#<pair>")
+    ((array? thing) "#<array>")
+    ((vector? thing) (string-append "#" (number->string
+                                         (vector-length thing))
+                                    "<vector>"))
+    ((procedure? thing) "#<procedure>")
+    (else
+     (case thing
+       ((()) "()")
+       ((#t) "#t")
+       ((#f) "#f")
+       (else
+        "#<whatsit>")))))
+
+;;; And to grok an affine map, vector->vector type. Column k of arr
+;;; will contain coefficients n0 ... nm of 1 k1 ... km for kth value.
+;;; 
+;;; These are for the error message when share fails.
+
+(define (array:index-ref ind k)
+  (if (vector? ind)
+      (vector-ref ind k)
+      (vector-ref
+       (array:vector ind)
+       (array:actor-index (array:index ind) k))))
+
+(define (array:index-set! ind k o)
+  (if (vector? ind)
+      (vector-set! ind k o)
+      (vector-set!
+       (array:vector ind)
+       (array:actor-index (array:index ind) k)
+       o)))
+
+(define (array:index-length ind)
+  (if (vector? ind)
+      (vector-length ind)
+      (vector-ref (array:shape ind) 1)))
+
+(define (array:map->string proc r)
+  (let* ((m (array:grok/arguments proc r))
+         (s (vector-ref (array:shape m) 3)))
+    (do ((i "" (string-append i c "k" (number->string k)))
+         (c "" ", ")
+         (k 1 (+ k 1)))
+      ((< r k)
+       (do ((o "" (string-append o c (array:map-column->string m r k)))
+            (c "" ", ")
+            (k 0 (+ k 1)))
+         ((= k s)
+          (string-append i " => " o)))))))
+
+(define (array:map-column->string m r k)
+  (let ((v (array:vector m))
+        (i (array:index m)))
+    (let ((n0 (vector-ref v (array:vector-index i (list 0 k)))))
+      (let wok ((j 1)
+                (e (if (= n0 0) "" (number->string n0))))
+        (if (<= j r)
+            (let ((nj (vector-ref v (array:vector-index i (list j k)))))
+              (if (= nj 0)
+                  (wok (+ j 1) e)
+                  (let* ((nj (if (= nj 1) ""
+                                 (if (= nj -1) "-"
+                                     (string-append (number->string nj)
+                                                    " "))))
+                         (njkj (string-append nj "k" (number->string j))))
+                    (if (string=? e "")
+                        (wok (+ j 1) njkj)
+                        (wok (+ j 1) (string-append e " + " njkj))))))
+            (if (string=? e "") "0" e))))))
+
+(define (array:grok/arguments proc r)
+  (array:grok/index!
+   (lambda (vec)
+     (call-with-values
+      (lambda ()
+        (array:apply-to-vector r proc vec))
+      vector))
+   (make-vector r)))
+
+(define (array:grok/index! proc in)
+  (let ((m (array:index-length in)))
+    (do ((k 0 (+ k 1)))
+      ((= k m))
+      (array:index-set! in k 0))
+    (let* ((n0 (proc in))
+           (n (array:index-length n0)))
+      (let ((arr (make-array (shape 0 (+ m 1) 0 n))))  ; (*)
+        (do ((k 0 (+ k 1)))
+          ((= k n))
+          (array-set! arr 0 k (array:index-ref n0 k))) ; (**)
+        (do ((j 0 (+ j 1)))
+          ((= j m))
+          (array:index-set! in j 1)
+          (let ((nj (proc in)))
+            (array:index-set! in j 0)
+            (do ((k 0 (+ k 1)))
+              ((= k n))
+              (array-set! arr (+ j 1) k (- (array:index-ref nj k) ; (**)
+                                           (array:index-ref n0 k))))))
+        arr))))
+;; (*)  Should not use `make-array' and `shape' here
+;; (**) Should not use `array-set!' here
+;; Should use something internal to the library instead: either lower
+;; level code (preferable but complex) or alternative names to these same.
+;; Copyright (C) John David Stone (1999). All Rights Reserved.
+
+;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;; 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-library (srfi 8)
+  (export receive)
+  (import (scheme base))
+  (begin
+    (define-syntax receive
+      (syntax-rules ()
+        ((receive formals expression body ...)
+         (call-with-values (lambda () expression)
+           (lambda formals body ...)))))))
+;;; Copyright (C) Jussi Piitulainen (2001). All Rights Reserved.
+
+;;; 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.
+
+(begin
+  (define array:opt-args '(ctor (4)))
+  (define (array:optimize f r)
+    (case r
+      ((0) (let ((n0 (f))) (array:0 n0)))
+      ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
+      ((2)
+       (let ((n0 (f 0 0)))
+         (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
+      ((3)
+       (let ((n0 (f 0 0 0)))
+         (array:3
+           n0
+           (- (f 1 0 0) n0)
+           (- (f 0 1 0) n0)
+           (- (f 0 0 1) n0))))
+      (else
+       (let ((v
+              (do ((k 0 (+ k 1)) (v '() (cons 0 v)))
+                  ((= k r) v))))
+         (let ((n0 (apply f v)))
+           (apply
+            array:n
+            n0
+            (array:coefficients f n0 v v)))))))
+  (define (array:optimize-empty r)
+    (let ((x (make-vector (+ r 1) 0)))
+      (vector-set! x r -1)
+      x))
+  (define (array:coefficients f n0 vs vp)
+    (case vp
+      ((()) '())
+      (else
+       (set-car! vp 1)
+       (let ((n (- (apply f vs) n0)))
+         (set-car! vp 0)
+         (cons n (array:coefficients f n0 vs (cdr vp)))))))
+  (define (array:vector-index x ks)
+    (do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
+         (ks ks (cdr ks))
+         (k 0 (+ k 1)))
+        ((null? ks) (+ sum (vector-ref x k)))))
+  (define (array:shape-index) '#(2 1 0))
+  (define (array:empty-shape-index) '#(0 0 -1))
+  (define (array:shape-vector-index x r k)
+    (+
+     (* (vector-ref x 0) r)
+     (* (vector-ref x 1) k)
+     (vector-ref x 2)))
+  (define (array:actor-index x k)
+    (+ (* (vector-ref x 0) k) (vector-ref x 1)))
+  (define (array:0 n0) (vector n0))
+  (define (array:1 n0 n1) (vector n1 n0))
+  (define (array:2 n0 n1 n2) (vector n1 n2 n0))
+  (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
+  (define (array:n n0 n1 n2 n3 n4 . ns)
+    (apply vector n1 n2 n3 n4 (append ns (list n0))))
+  (define (array:maker r)
+    (case r
+      ((0) array:0)
+      ((1) array:1)
+      ((2) array:2)
+      ((3) array:3)
+      (else array:n)))
+  (define array:indexer/vector
+    (let ((em
+           (vector
+             (lambda (x i) (+ (vector-ref x 0)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (vector-ref x 1)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (vector-ref x 2)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (vector-ref x 3)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (vector-ref x 4)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (vector-ref x 5)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (vector-ref x 6)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (vector-ref x 7)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (vector-ref x 8)))
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (* (vector-ref x 8) (vector-ref i 8))
+                (vector-ref x 9)))))
+          (it
+           (lambda (w)
+             (lambda (x i)
+               (+
+                (* (vector-ref x 0) (vector-ref i 0))
+                (* (vector-ref x 1) (vector-ref i 1))
+                (* (vector-ref x 2) (vector-ref i 2))
+                (* (vector-ref x 3) (vector-ref i 3))
+                (* (vector-ref x 4) (vector-ref i 4))
+                (* (vector-ref x 5) (vector-ref i 5))
+                (* (vector-ref x 6) (vector-ref i 6))
+                (* (vector-ref x 7) (vector-ref i 7))
+                (* (vector-ref x 8) (vector-ref i 8))
+                (* (vector-ref x 9) (vector-ref i 9))
+                (do ((xi
+                      0
+                      (+
+                       (* (vector-ref x u) (vector-ref i u))
+                       xi))
+                     (u (- w 1) (- u 1)))
+                    ((< u 10) xi))
+                (vector-ref x w))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:indexer/array
+    (let ((em
+           (vector
+             (lambda (x v i) (+ (vector-ref x 0)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (vector-ref x 1)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (vector-ref x 2)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (vector-ref x 3)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (vector-ref x 4)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (vector-ref x 5)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (vector-ref x 6)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (vector-ref x 7)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (vector-ref x 8)))
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (*
+                 (vector-ref x 8)
+                 (vector-ref v (array:actor-index i 8)))
+                (vector-ref x 9)))))
+          (it
+           (lambda (w)
+             (lambda (x v i)
+               (+
+                (*
+                 (vector-ref x 0)
+                 (vector-ref v (array:actor-index i 0)))
+                (*
+                 (vector-ref x 1)
+                 (vector-ref v (array:actor-index i 1)))
+                (*
+                 (vector-ref x 2)
+                 (vector-ref v (array:actor-index i 2)))
+                (*
+                 (vector-ref x 3)
+                 (vector-ref v (array:actor-index i 3)))
+                (*
+                 (vector-ref x 4)
+                 (vector-ref v (array:actor-index i 4)))
+                (*
+                 (vector-ref x 5)
+                 (vector-ref v (array:actor-index i 5)))
+                (*
+                 (vector-ref x 6)
+                 (vector-ref v (array:actor-index i 6)))
+                (*
+                 (vector-ref x 7)
+                 (vector-ref v (array:actor-index i 7)))
+                (*
+                 (vector-ref x 8)
+                 (vector-ref v (array:actor-index i 8)))
+                (*
+                 (vector-ref x 9)
+                 (vector-ref v (array:actor-index i 9)))
+                (do ((xi
+                      0
+                      (+
+                       (*
+                        (vector-ref x u)
+                        (vector-ref
+                          v
+                          (array:actor-index i u)))
+                       xi))
+                     (u (- w 1) (- u 1)))
+                    ((< u 10) xi))
+                (vector-ref x w))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-vector
+    (let ((em
+           (vector
+             (lambda (p v) (p))
+             (lambda (p v) (p (vector-ref v 0)))
+             (lambda (p v)
+               (p (vector-ref v 0) (vector-ref v 1)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)))
+             (lambda (p v)
+               (p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)
+                (vector-ref v 8)))))
+          (it
+           (lambda (r)
+             (lambda (p v)
+               (apply
+                p
+                (vector-ref v 0)
+                (vector-ref v 1)
+                (vector-ref v 2)
+                (vector-ref v 3)
+                (vector-ref v 4)
+                (vector-ref v 5)
+                (vector-ref v 6)
+                (vector-ref v 7)
+                (vector-ref v 8)
+                (vector-ref v 9)
+                (do ((k r (- k 1))
+                     (r
+                      '()
+                      (cons (vector-ref v (- k 1)) r)))
+                    ((= k 10) r)))))))
+      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-actor
+    (let ((em
+           (vector
+             (lambda (p a) (p))
+             (lambda (p a) (p (array-ref a 0)))
+             (lambda (p a)
+               (p (array-ref a 0) (array-ref a 1)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)))
+             (lambda (p a)
+               (p
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)
+                (array-ref a 8)))))
+          (it
+           (lambda (r)
+             (lambda (p a)
+               (apply
+                a
+                (array-ref a 0)
+                (array-ref a 1)
+                (array-ref a 2)
+                (array-ref a 3)
+                (array-ref a 4)
+                (array-ref a 5)
+                (array-ref a 6)
+                (array-ref a 7)
+                (array-ref a 8)
+                (array-ref a 9)
+                (do ((k r (- k 1))
+                     (r '() (cons (array-ref a (- k 1)) r)))
+                    ((= k 10) r)))))))
+      (lambda (r)
+        "These are high level, hiding implementation at call site."
+        (if (< r 10) (vector-ref em r) (it r)))))
+  (define array:applier-to-backing-vector
+    (let ((em
+           (vector
+             (lambda (p ai av) (p))
+             (lambda (p ai av)
+               (p (vector-ref av (array:actor-index ai 0))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))))
+             (lambda (p ai av)
+               (p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))
+                (vector-ref av (array:actor-index ai 8))))))
+          (it
+           (lambda (r)
+             (lambda (p ai av)
+               (apply
+                p
+                (vector-ref av (array:actor-index ai 0))
+                (vector-ref av (array:actor-index ai 1))
+                (vector-ref av (array:actor-index ai 2))
+                (vector-ref av (array:actor-index ai 3))
+                (vector-ref av (array:actor-index ai 4))
+                (vector-ref av (array:actor-index ai 5))
+                (vector-ref av (array:actor-index ai 6))
+                (vector-ref av (array:actor-index ai 7))
+                (vector-ref av (array:actor-index ai 8))
+                (vector-ref av (array:actor-index ai 9))
+                (do ((k r (- k 1))
+                     (r
+                      '()
+                      (cons
+                       (vector-ref
+                         av
+                         (array:actor-index ai (- k 1)))
+                       r)))
+                    ((= k 10) r)))))))
+      (lambda (r)
+        "These are low level, exposing implementation at call site."
+        (if (< r 10) (vector-ref em r) (it r)))))
+  (define (array:index/vector r x v)
+    ((array:indexer/vector r) x v))
+  (define (array:index/array r x av ai)
+    ((array:indexer/array r) x av ai))
+  (define (array:apply-to-vector r p v)
+    ((array:applier-to-vector r) p v))
+  (define (array:apply-to-actor r p a)
+    ((array:applier-to-actor r) p a)))
+(define-library (srfi 25)
+  (export
+   array?
+   make-array
+   shape
+   array
+   array-rank
+   array-start
+   array-end
+   array-ref
+   array-set!
+   share-array
+   )
+  (import
+   (scheme base)
+   (scheme write))
+  (include "25.as-srfi-9-record.upstream.scm")
+  (include "25.ix-ctor.upstream.scm")
+  (include "25.op-ctor.upstream.scm")
+  (include "25.main.upstream.scm"))
+(define-library (srfi 26)
+  (export cut cute)
+  (import (scheme base))
+  (include "26.upstream.scm"))
+;;;;"array.scm" Arrays for Scheme
+; Copyright (C) 2001, 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@code{(require 'array)} or @code{(require 'srfi-63)}
+;;@ftindex array
+
+(require 'record)
+
+(define array:rtd
+  (make-record-type "array"
+                    '(dimensions
+                      scales            ;list of dimension scales
+                      offset            ;exact integer
+                      store             ;data
+                      )))
+
+(define array:dimensions
+  (let ((dimensions (record-accessor array:rtd 'dimensions)))
+    (lambda (array)
+      (cond ((vector? array) (list (vector-length array)))
+            ((string? array) (list (string-length array)))
+            (else (dimensions array))))))
+
+(define array:scales
+  (let ((scales (record-accessor array:rtd 'scales)))
+    (lambda (obj)
+      (cond ((string? obj) '(1))
+            ((vector? obj) '(1))
+            (else (scales obj))))))
+
+(define array:store
+  (let ((store (record-accessor array:rtd 'store)))
+    (lambda (obj)
+      (cond ((string? obj) obj)
+            ((vector? obj) obj)
+            (else (store obj))))))
+
+(define array:offset
+  (let ((offset (record-accessor array:rtd 'offset)))
+    (lambda (obj)
+      (cond ((string? obj) 0)
+            ((vector? obj) 0)
+            (else (offset obj))))))
+
+(define array:construct
+  (record-constructor array:rtd '(dimensions scales offset store)))
+
+;;@args obj
+;;Returns @code{#t} if the @1 is an array, and @code{#f} if not.
+(define array?
+  (let ((array:array? (record-predicate array:rtd)))
+    (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj)))))
+
+;;@noindent
+;;@emph{Note:} Arrays are not disjoint from other Scheme types.
+;;Vectors and possibly strings also satisfy @code{array?}.
+;;A disjoint array predicate can be written:
+;;
+;;@example
+;;(define (strict-array? obj)
+;;  (and (array? obj) (not (string? obj)) (not (vector? obj))))
+;;@end example
+
+;;@body
+;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the
+;;corresponding elements of @1 and @2 are @code{equal?}.
+
+;;@body
+;;@0 recursively compares the contents of pairs, vectors, strings, and
+;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers
+;;and symbols.  A rule of thumb is that objects are generally @0 if
+;;they print the same.  @0 may fail to terminate if its arguments are
+;;circular data structures.
+;;
+;;@example
+;;(equal? 'a 'a)                             @result{}  #t
+;;(equal? '(a) '(a))                         @result{}  #t
+;;(equal? '(a (b) c)
+;;        '(a (b) c))                        @result{}  #t
+;;(equal? "abc" "abc")                       @result{}  #t
+;;(equal? 2 2)                               @result{}  #t
+;;(equal? (make-vector 5 'a)
+;;        (make-vector 5 'a))                @result{}  #t
+;;(equal? (make-array (A:fixN32b 4) 5 3)
+;;        (make-array (A:fixN32b 4) 5 3))    @result{}  #t
+;;(equal? (make-array '#(foo) 3 3)
+;;        (make-array '#(foo) 3 3))          @result{}  #t
+;;(equal? (lambda (x) x)
+;;        (lambda (y) y))                    @result{}  @emph{unspecified}
+;;@end example
+(define (equal? obj1 obj2)
+  (cond ((eqv? obj1 obj2) #t)
+        ((or (pair? obj1) (pair? obj2))
+         (and (pair? obj1) (pair? obj2)
+              (equal? (car obj1) (car obj2))
+              (equal? (cdr obj1) (cdr obj2))))
+        ((or (string? obj1) (string? obj2))
+         (and (string? obj1) (string? obj2)
+              (string=? obj1 obj2)))
+        ((or (vector? obj1) (vector? obj2))
+         (and (vector? obj1) (vector? obj2)
+              (equal? (vector-length obj1) (vector-length obj2))
+              (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx)))
+                  ((or (negative? idx)
+                       (not (equal? (vector-ref obj1 idx)
+                                    (vector-ref obj2 idx))))
+                   (negative? idx)))))
+        ((or (array? obj1) (array? obj2))
+         (and (array? obj1) (array? obj2)
+              (equal? (array:dimensions obj1) (array:dimensions obj2))
+              (equal? (array:store obj1) (array:store obj2))))
+        (else #f)))
+
+;;@body
+;;Returns the number of dimensions of @1.  If @1 is not an array, 0 is
+;;returned.
+(define (array-rank obj)
+  (if (array? obj) (length (array:dimensions obj)) 0))
+
+;;@args array
+;;Returns a list of dimensions.
+;;
+;;@example
+;;(array-dimensions (make-array '#() 3 5))
+;;   @result{} (3 5)
+;;@end example
+(define array-dimensions array:dimensions)
+
+;;@args prototype k1 @dots{}
+;;
+;;Creates and returns an array of type @1 with dimensions @2, @dots{}
+;;and filled with elements from @1.  @1 must be an array, vector, or
+;;string.  The implementation-dependent type of the returned array
+;;will be the same as the type of @1; except if that would be a vector
+;;or string with rank not equal to one, in which case some variety of
+;;array will be returned.
+;;
+;;If the @1 has no elements, then the initial contents of the returned
+;;array are unspecified.  Otherwise, the returned array will be filled
+;;with the element at the origin of @1.
+(define (make-array prototype . dimensions)
+  (define tcnt (apply * dimensions))
+  (let ((store
+         (if (string? prototype)
+             (case (string-length prototype)
+               ((0) (make-string tcnt))
+               (else (make-string tcnt
+                                  (string-ref prototype 0))))
+             (let ((pdims (array:dimensions prototype)))
+               (case (apply * pdims)
+                 ((0) (make-vector tcnt))
+                 (else (make-vector tcnt
+                                    (apply array-ref prototype
+                                           (map (lambda (x) 0) pdims)))))))))
+    (define (loop dims scales)
+      (if (null? dims)
+          (array:construct dimensions (cdr scales) 0 store)
+          (loop (cdr dims) (cons (* (car dims) (car scales)) scales))))
+    (loop (reverse dimensions) '(1))))
+;;@args prototype k1 @dots{}
+;;@0 is an alias for @code{make-array}.
+(define create-array make-array)
+
+;;@args array mapper k1 @dots{}
+;;@0 can be used to create shared subarrays of other
+;;arrays.  The @var{mapper} is a function that translates coordinates in
+;;the new array into coordinates in the old array.  A @var{mapper} must be
+;;linear, and its range must stay within the bounds of the old array, but
+;;it can be otherwise arbitrary.  A simple example:
+;;
+;;@example
+;;(define fred (make-array '#(#f) 8 8))
+;;(define freds-diagonal
+;;  (make-shared-array fred (lambda (i) (list i i)) 8))
+;;(array-set! freds-diagonal 'foo 3)
+;;(array-ref fred 3 3)
+;;   @result{} FOO
+;;(define freds-center
+;;  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j)))
+;;                     2 2))
+;;(array-ref freds-center 0 0)
+;;   @result{} FOO
+;;@end example
+(define (make-shared-array array mapper . dimensions)
+  (define odl (array:scales array))
+  (define rank (length dimensions))
+  (define shape
+    (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions))
+  (do ((idx (+ -1 rank) (+ -1 idx))
+       (uvt (append (cdr (vector->list (make-vector rank 0))) '(1))
+            (append (cdr uvt) '(0)))
+       (uvts '() (cons uvt uvts)))
+      ((negative? idx)
+       (let ((ker0 (apply + (map * odl (apply mapper uvt)))))
+         (array:construct
+          (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape)
+          (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0))
+               uvts)
+          (apply +
+                 (array:offset array)
+                 (map * odl (apply mapper (map car shape))))
+          (array:store array))))))
+
+;;@args rank proto list
+;;@3 must be a rank-nested list consisting of all the elements, in
+;;row-major order, of the array to be created.
+;;
+;;@0 returns an array of rank @1 and type @2 consisting of all the
+;;elements, in row-major order, of @3.  When @1 is 0, @3 is the lone
+;;array element; not necessarily a list.
+;;
+;;@example
+;;(list->array 2 '#() '((1 2) (3 4)))
+;;                @result{} #2A((1 2) (3 4))
+;;(list->array 0 '#() 3)
+;;                @result{} #0A 3
+;;@end example
+(define (list->array rank proto lst)
+  (define dimensions
+    (do ((shp '() (cons (length row) shp))
+         (row lst (car lst))
+         (rnk (+ -1 rank) (+ -1 rnk)))
+        ((negative? rnk) (reverse shp))))
+  (let ((nra (apply make-array proto dimensions)))
+    (define (l2ra dims idxs row)
+      (cond ((null? dims)
+             (apply array-set! nra row (reverse idxs)))
+            ((if (not (eqv? (car dims) (length row)))
+                 (slib:error 'list->array
+                             'non-rectangular 'array dims dimensions))
+             (do ((idx 0 (+ 1 idx))
+                  (row row (cdr row)))
+                 ((>= idx (car dims)))
+               (l2ra (cdr dims) (cons idx idxs) (car row))))))
+    (l2ra dimensions '() lst)
+    nra))
+
+;;@args array
+;;Returns a rank-nested list consisting of all the elements, in
+;;row-major order, of @1.  In the case of a rank-0 array, @0 returns
+;;the single element.
+;;
+;;@example
+;;(array->list #2A((ho ho ho) (ho oh oh)))
+;;                @result{} ((ho ho ho) (ho oh oh))
+;;(array->list #0A ho)
+;;                @result{} ho
+;;@end example
+(define (array->list ra)
+  (define (ra2l dims idxs)
+    (if (null? dims)
+        (apply array-ref ra (reverse idxs))
+        (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst))
+             (idx (+ -1 (car dims)) (+ -1 idx)))
+            ((negative? idx) lst))))
+  (ra2l (array-dimensions ra) '()))
+
+;;@args vect proto dim1 @dots{}
+;;@1 must be a vector of length equal to the product of exact
+;;nonnegative integers @3, @dots{}.
+;;
+;;@0 returns an array of type @2 consisting of all the elements, in
+;;row-major order, of @1.  In the case of a rank-0 array, @1 has a
+;;single element.
+;;
+;;@example
+;;(vector->array #(1 2 3 4) #() 2 2)
+;;                @result{} #2A((1 2) (3 4))
+;;(vector->array '#(3) '#())
+;;                @result{} #0A 3
+;;@end example
+(define (vector->array vect prototype . dimensions)
+  (define vdx (vector-length vect))
+  (if (not (eqv? vdx (apply * dimensions)))
+      (slib:error 'vector->array vdx '<> (cons '* dimensions)))
+  (let ((ra (apply make-array prototype dimensions)))
+    (define (v2ra dims idxs)
+      (cond ((null? dims)
+             (set! vdx (+ -1 vdx))
+             (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
+            (else
+             (do ((idx (+ -1 (car dims)) (+ -1 idx)))
+                 ((negative? idx) vect)
+               (v2ra (cdr dims) (cons idx idxs))))))
+    (v2ra dimensions '())
+    ra))
+
+;;@args array
+;;Returns a new vector consisting of all the elements of @1 in
+;;row-major order.
+;;
+;;@example
+;;(array->vector #2A ((1 2)( 3 4)))
+;;                @result{} #(1 2 3 4)
+;;(array->vector #0A ho)
+;;                @result{} #(ho)
+;;@end example
+(define (array->vector ra)
+  (define dims (array-dimensions ra))
+  (let* ((vdx (apply * dims))
+         (vect (make-vector vdx)))
+    (define (ra2v dims idxs)
+      (if (null? dims)
+          (let ((val (apply array-ref ra (reverse idxs))))
+            (set! vdx (+ -1 vdx))
+            (vector-set! vect vdx val)
+            vect)
+          (do ((idx (+ -1 (car dims)) (+ -1 idx)))
+              ((negative? idx) vect)
+            (ra2v (cdr dims) (cons idx idxs)))))
+    (ra2v dims '())))
+
+(define (array:in-bounds? array indices)
+  (do ((bnds (array:dimensions array) (cdr bnds))
+       (idxs indices (cdr idxs)))
+      ((or (null? bnds)
+           (null? idxs)
+           (not (integer? (car idxs)))
+           (not (< -1 (car idxs) (car bnds))))
+       (and (null? bnds) (null? idxs)))))
+
+;;@args array index1 @dots{}
+;;Returns @code{#t} if its arguments would be acceptable to
+;;@code{array-ref}.
+(define (array-in-bounds? array . indices)
+  (array:in-bounds? array indices))
+
+;;@args array k1 @dots{}
+;;Returns the (@2, @dots{}) element of @1.
+(define (array-ref array . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (slib:error 'array-ref 'bad-indices indices))
+  ((if (string? store) string-ref vector-ref)
+   store (apply + (array:offset array) (map * (array:scales array) indices))))
+
+;;@args array obj k1 @dots{}
+;;Stores @2 in the (@3, @dots{}) element of @1.  The value returned
+;;by @0 is unspecified.
+(define (array-set! array obj . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (slib:error 'array-set! 'bad-indices indices))
+  ((if (string? store) string-set! vector-set!)
+   store (apply + (array:offset array) (map * (array:scales array) indices))
+   obj))
+
+;;@noindent
+;;These functions return a prototypical uniform-array enclosing the
+;;optional argument (which must be of the correct type).  If the
+;;uniform-array type is supported by the implementation, then it is
+;;returned; defaulting to the next larger precision type; resorting
+;;finally to vector.
+
+(define (make-prototype-checker name pred? creator)
+  (lambda args
+    (case (length args)
+      ((1) (if (pred? (car args))
+               (creator (car args))
+               (slib:error name 'incompatible 'type (car args))))
+      ((0) (creator))
+      (else (slib:error name 'wrong 'number 'of 'args args)))))
+
+(define (integer-bytes?? n)
+  (lambda (obj)
+    (and (integer? obj)
+         (exact? obj)
+         (or (negative? n) (not (negative? obj)))
+         (do ((num obj (quotient num 256))
+              (n (+ -1 (abs n)) (+ -1 n)))
+             ((or (zero? num) (negative? n))
+              (zero? num))))))
+
+;;@args z
+;;@args
+;;Returns an inexact 128.bit flonum complex uniform-array prototype.
+(define A:floC128b (make-prototype-checker 'A:floC128b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 64.bit flonum complex uniform-array prototype.
+(define A:floC64b (make-prototype-checker 'A:floC64b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 32.bit flonum complex uniform-array prototype.
+(define A:floC32b (make-prototype-checker 'A:floC32b complex? vector))
+;;@args z
+;;@args
+;;Returns an inexact 16.bit flonum complex uniform-array prototype.
+(define A:floC16b (make-prototype-checker 'A:floC16b complex? vector))
+
+;;@args z
+;;@args
+;;Returns an inexact 128.bit flonum real uniform-array prototype.
+(define A:floR128b (make-prototype-checker 'A:floR128b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 64.bit flonum real uniform-array prototype.
+(define A:floR64b (make-prototype-checker 'A:floR64b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 32.bit flonum real uniform-array prototype.
+(define A:floR32b (make-prototype-checker 'A:floR32b real? vector))
+;;@args z
+;;@args
+;;Returns an inexact 16.bit flonum real uniform-array prototype.
+(define A:floR16b (make-prototype-checker 'A:floR16b real? vector))
+
+;;@args z
+;;@args
+;;Returns an exact 128.bit decimal flonum rational uniform-array prototype.
+(define A:floR128b (make-prototype-checker 'A:floR128b real? vector))
+;;@args z
+;;@args
+;;Returns an exact 64.bit decimal flonum rational uniform-array prototype.
+(define A:floR64b (make-prototype-checker 'A:floR64b real? vector))
+;;@args z
+;;@args
+;;Returns an exact 32.bit decimal flonum rational uniform-array prototype.
+(define A:floR32b (make-prototype-checker 'A:floR32b real? vector))
+
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;64 bits of precision.
+(define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;32 bits of precision.
+(define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;16 bits of precision.
+(define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector))
+;;@args n
+;;@args
+;;Returns an exact binary fixnum uniform-array prototype with at least
+;;8 bits of precision.
+(define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector))
+
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 64 bits of precision.
+(define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 32 bits of precision.
+(define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 16 bits of precision.
+(define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative binary fixnum uniform-array prototype with at
+;;least 8 bits of precision.
+(define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector))
+
+;;@args bool
+;;@args
+;;Returns a boolean uniform-array prototype.
+(define A:bool (make-prototype-checker 'A:bool boolean? vector))
+; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT"
+; ==========================================
+;
+; Sebastian.Egner@philips.com, 5-Jun-2002.
+; adapted from the posting by Al Petrofsky <al@petrofsky.org>
+; placed in the public domain
+;
+; The code to handle the variable argument case was originally
+; proposed by Michael Sperber and has been adapted to the new
+; syntax of the macro using an explicit rest-slot symbol. The
+; code to evaluate the non-slots for cute has been proposed by
+; Dale Jordan. The code to allow a slot for the procedure position
+; and to process the macro using an internal macro is based on 
+; a suggestion by Al Petrofsky. The code found below is, with
+; exception of this header and some changes in variable names,
+; entirely written by Al Petrofsky.
+;
+; compliance:
+;   Scheme R5RS (including macros).
+;
+; loading this file into Scheme 48 0.57:
+;   ,load cut.scm
+;
+; history of this file:
+;   SE,  6-Feb-2002: initial version as 'curry' with ". <>" notation
+;   SE, 14-Feb-2002: revised for <___>
+;   SE, 27-Feb-2002: revised for 'cut'
+;   SE, 03-Jun-2002: revised for proc-slot, cute
+;   SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern)
+;   SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc.
+;     to match the convention in the SRFI-document
+
+; (srfi-26-internal-cut slot-names combination . se)
+;   transformer used internally
+;     slot-names  : the internal names of the slots
+;     combination : procedure being specialized, followed by its arguments
+;     se          : slots-or-exprs, the qualifiers of the macro
+
+(define-syntax srfi-26-internal-cut
+  (syntax-rules (<> <___>)
+
+    ;; construct fixed- or variable-arity procedure:
+    ;;   (begin proc) throws an error if proc is not an <expression>
+    ((srfi-26-internal-cut (slot-name ...) (proc arg ...))
+     (lambda (slot-name ...) ((begin proc) arg ...)))
+    ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <___>)
+     (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
+
+    ;; process one slot-or-expr
+    ((srfi-26-internal-cut (slot-name ...)   (position ...)      <>  . se)
+     (srfi-26-internal-cut (slot-name ... x) (position ... x)        . se))
+    ((srfi-26-internal-cut (slot-name ...)   (position ...)      nse . se)
+     (srfi-26-internal-cut (slot-name ...)   (position ... nse)      . se))))
+
+; (srfi-26-internal-cute slot-names nse-bindings combination . se)
+;   transformer used internally
+;     slot-names     : the internal names of the slots
+;     nse-bindings   : let-style bindings for the non-slot expressions.
+;     combination    : procedure being specialized, followed by its arguments
+;     se             : slots-or-exprs, the qualifiers of the macro
+
+(define-syntax srfi-26-internal-cute
+  (syntax-rules (<> <___>)
+
+    ;; If there are no slot-or-exprs to process, then:
+    ;; construct a fixed-arity procedure,
+    ((srfi-26-internal-cute
+      (slot-name ...) nse-bindings (proc arg ...))
+     (let nse-bindings (lambda (slot-name ...) (proc arg ...))))
+    ;; or a variable-arity procedure
+    ((srfi-26-internal-cute
+      (slot-name ...) nse-bindings (proc arg ...) <___>)
+     (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x))))
+
+    ;; otherwise, process one slot:
+    ((srfi-26-internal-cute
+      (slot-name ...)         nse-bindings  (position ...)   <>  . se)
+     (srfi-26-internal-cute
+      (slot-name ... x)       nse-bindings  (position ... x)     . se))
+    ;; or one non-slot expression
+    ((srfi-26-internal-cute
+      slot-names              nse-bindings  (position ...)   nse . se)
+     (srfi-26-internal-cute
+      slot-names ((x nse) . nse-bindings) (position ... x)       . se))))
+
+; exported syntax
+
+(define-syntax cut
+  (syntax-rules ()
+    ((cut . slots-or-exprs)
+     (srfi-26-internal-cut () () . slots-or-exprs))))
+
+(define-syntax cute
+  (syntax-rules ()
+    ((cute . slots-or-exprs)
+     (srfi-26-internal-cute () () () . slots-or-exprs))))
+;;;; "logical.scm", bit access and operations for integers for Scheme
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define logical:boole-xor
+ '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+    #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
+    #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13)
+    #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12)
+    #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11)
+    #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10)
+    #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9)
+    #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8)
+    #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7)
+    #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6)
+    #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5)
+    #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4)
+    #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3)
+    #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2)
+    #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1)
+    #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)))
+
+(define logical:boole-and
+ '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
+    #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1)
+    #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2)
+    #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3)
+    #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4)
+    #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5)
+    #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6)
+    #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7)
+    #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8)
+    #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9)
+    #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10)
+    #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11)
+    #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12)
+    #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13)
+    #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14)
+    #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
+
+(define (logical:ash-4 x)
+  (if (negative? x)
+      (+ -1 (quotient (+ 1 x) 16))
+      (quotient x 16)))
+
+(define (logical:reduce op4 ident)
+  (lambda args
+    (do ((res ident (op4 res (car rgs) 1 0))
+         (rgs args (cdr rgs)))
+        ((null? rgs) res))))
+
+;@
+(define logand
+  (letrec
+      ((lgand
+        (lambda (n2 n1 scl acc)
+          (cond ((= n1 n2) (+ acc (* scl n1)))
+                ((zero? n2) acc)
+                ((zero? n1) acc)
+                (else (lgand (logical:ash-4 n2)
+                             (logical:ash-4 n1)
+                             (* 16 scl)
+                             (+ (* (vector-ref (vector-ref logical:boole-and
+                                                           (modulo n1 16))
+                                               (modulo n2 16))
+                                   scl)
+                                acc)))))))
+    (logical:reduce lgand -1)))
+;@
+(define logior
+  (letrec
+      ((lgior
+        (lambda (n2 n1 scl acc)
+          (cond ((= n1 n2) (+ acc (* scl n1)))
+                ((zero? n2) (+ acc (* scl n1)))
+                ((zero? n1) (+ acc (* scl n2)))
+                (else (lgior (logical:ash-4 n2)
+                             (logical:ash-4 n1)
+                             (* 16 scl)
+                             (+ (* (- 15 (vector-ref
+                                          (vector-ref logical:boole-and
+                                                      (- 15 (modulo n1 16)))
+                                          (- 15 (modulo n2 16))))
+                                   scl)
+                                acc)))))))
+    (logical:reduce lgior 0)))
+;@
+(define logxor
+  (letrec
+      ((lgxor
+        (lambda (n2 n1 scl acc)
+          (cond ((= n1 n2) acc)
+                ((zero? n2) (+ acc (* scl n1)))
+                ((zero? n1) (+ acc (* scl n2)))
+                (else (lgxor (logical:ash-4 n2)
+                             (logical:ash-4 n1)
+                             (* 16 scl)
+                             (+ (* (vector-ref (vector-ref logical:boole-xor
+                                                           (modulo n1 16))
+                                               (modulo n2 16))
+                                   scl)
+                                acc)))))))
+    (logical:reduce lgxor 0)))
+;@
+(define (lognot n) (- -1 n))
+;@
+(define (logtest n1 n2)
+  (not (zero? (logand n1 n2))))
+;@
+(define (logbit? index n)
+  (logtest (expt 2 index) n))
+;@
+(define (copy-bit index to bool)
+  (if bool
+      (logior to (arithmetic-shift 1 index))
+      (logand to (lognot (arithmetic-shift 1 index)))))
+;@
+(define (bitwise-if mask n0 n1)
+  (logior (logand mask n0)
+          (logand (lognot mask) n1)))
+;@
+(define (bit-field n start end)
+  (logand (lognot (ash -1 (- end start)))
+          (arithmetic-shift n (- start))))
+;@
+(define (copy-bit-field to from start end)
+  (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start)
+              (arithmetic-shift from start)
+              to))
+;@
+(define (rotate-bit-field n count start end)
+  (define width (- end start))
+  (set! count (modulo count width))
+  (let ((mask (lognot (ash -1 width))))
+    (define zn (logand mask (arithmetic-shift n (- start))))
+    (logior (arithmetic-shift
+             (logior (logand mask (arithmetic-shift zn count))
+                     (arithmetic-shift zn (- count width)))
+             start)
+            (logand (lognot (ash mask start)) n))))
+;@
+(define (arithmetic-shift n count)
+  (if (negative? count)
+      (let ((k (expt 2 (- count))))
+        (if (negative? n)
+            (+ -1 (quotient (+ 1 n) k))
+            (quotient n k)))
+      (* (expt 2 count) n)))
+;@
+(define integer-length
+  (letrec ((intlen (lambda (n tot)
+                     (case n
+                       ((0 -1) (+ 0 tot))
+                       ((1 -2) (+ 1 tot))
+                       ((2 3 -3 -4) (+ 2 tot))
+                       ((4 5 6 7 -5 -6 -7 -8) (+ 3 tot))
+                       (else (intlen (logical:ash-4 n) (+ 4 tot)))))))
+    (lambda (n) (intlen n 0))))
+;@
+(define logcount
+  (letrec ((logcnt (lambda (n tot)
+                     (if (zero? n)
+                         tot
+                         (logcnt (quotient n 16)
+                                 (+ (vector-ref
+                                     '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
+                                     (modulo n 16))
+                                    tot))))))
+    (lambda (n)
+      (cond ((negative? n) (logcnt (lognot n) 0))
+            ((positive? n) (logcnt n 0))
+            (else 0)))))
+;@
+(define (log2-binary-factors n)
+  (+ -1 (integer-length (logand n (- n)))))
+
+(define (bit-reverse k n)
+  (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
+       (k (+ -1 k) (+ -1 k))
+       (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
+      ((negative? k) (if (negative? n) (lognot rvs) rvs))))
+;@
+(define (reverse-bit-field n start end)
+  (define width (- end start))
+  (let ((mask (lognot (ash -1 width))))
+    (define zn (logand mask (arithmetic-shift n (- start))))
+    (logior (arithmetic-shift (bit-reverse width zn) start)
+            (logand (lognot (ash mask start)) n))))
+;@
+(define (integer->list k . len)
+  (if (null? len)
+      (do ((k k (arithmetic-shift k -1))
+           (lst '() (cons (odd? k) lst)))
+          ((<= k 0) lst))
+      (do ((idx (+ -1 (car len)) (+ -1 idx))
+           (k k (arithmetic-shift k -1))
+           (lst '() (cons (odd? k) lst)))
+          ((negative? idx) lst))))
+;@
+(define (list->integer bools)
+  (do ((bs bools (cdr bs))
+       (acc 0 (+ acc acc (if (car bs) 1 0))))
+      ((null? bs) acc)))
+(define (booleans->integer . bools)
+  (list->integer bools))
+
+;;;;@ SRFI-60 aliases
+(define ash arithmetic-shift)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-and logand)
+(define bitwise-not lognot)
+(define bit-count logcount)
+(define bit-set?   logbit?)
+(define any-bits-set? logtest)
+(define first-set-bit log2-binary-factors)
+(define bitwise-merge bitwise-if)
+
+;;; Legacy
+;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len))
+;;(define (logical:ones deg) (lognot (ash -1 deg)))
+;;(define integer-expt expt)            ; legacy name
+; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR

+; =========================================================

+;

+; Sebastian.Egner@philips.com, Mar-2002.

+;

+; This file is an implementation of Pierre L'Ecuyer's MRG32k3a

+; pseudo random number generator. Please refer to 'mrg32k3a.scm'

+; for more information.

+;

+; compliance:

+;   Scheme R5RS with integers covering at least {-2^53..2^53-1}.

+;

+; history of this file:

+;   SE, 18-Mar-2002: initial version

+;   SE, 22-Mar-2002: comments adjusted, range added

+;   SE, 25-Mar-2002: pack/unpack just return their argument

+

+; the actual generator

+

+(define (mrg32k3a-random-m1 state)

+  (let ((x11 (vector-ref state 0))

+	(x12 (vector-ref state 1))

+	(x13 (vector-ref state 2))

+	(x21 (vector-ref state 3))

+	(x22 (vector-ref state 4))

+	(x23 (vector-ref state 5)))

+    (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087))

+	  (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443)))

+      (vector-set! state 0 x10)

+      (vector-set! state 1 x11)

+      (vector-set! state 2 x12)

+      (vector-set! state 3 x20)

+      (vector-set! state 4 x21)

+      (vector-set! state 5 x22)

+      (modulo (- x10 x20) 4294967087))))

+

+; interface to the generic parts of the generator

+

+(define (mrg32k3a-pack-state unpacked-state)

+  unpacked-state)

+

+(define (mrg32k3a-unpack-state state)

+  state)

+

+(define (mrg32k3a-random-range) ; m1

+  4294967087)

+

+(define (mrg32k3a-random-integer state range) ; rejection method

+  (let* ((q (quotient 4294967087 range))

+	 (qn (* q range)))

+    (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state)))

+	((< x qn) (quotient x q)))))

+

+(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1)

+  (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state))))

+

+;;; Copyright (C) 2004 Taylor Campbell. All rights reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; 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-library (srfi 61)
+  (export cond)
+  (import (except (scheme base) cond))
+  (begin
+
+    (define-syntax cond
+      (syntax-rules (=> else)
+
+        ((cond (else else1 else2 ...))
+         ;; The (if #t (begin ...)) wrapper ensures that there may be no
+         ;; internal definitions in the body of the clause.  R5RS mandates
+         ;; this in text (by referring to each subform of the clauses as
+         ;; <expression>) but not in its reference implementation of `cond',
+         ;; which just expands to (begin ...) with no (if #t ...) wrapper.
+         (if #t (begin else1 else2 ...)))
+
+        ((cond (test => receiver) more-clause ...)
+         (let ((t test))
+              (cond/maybe-more t
+                               (receiver t)
+                               more-clause ...)))
+
+        ((cond (generator guard => receiver) more-clause ...)
+         (call-with-values (lambda () generator)
+                           (lambda t
+                                   (cond/maybe-more (apply guard    t)
+                                                    (apply receiver t)
+                                                    more-clause ...))))
+
+        ((cond (test) more-clause ...)
+         (let ((t test))
+              (cond/maybe-more t t more-clause ...)))
+
+        ((cond (test body1 body2 ...) more-clause ...)
+         (cond/maybe-more test
+                          (begin body1 body2 ...)
+                          more-clause ...))))
+
+    (define-syntax cond/maybe-more
+      (syntax-rules ()
+        ((cond/maybe-more test consequent)
+         (if test
+             consequent))
+        ((cond/maybe-more test consequent clause ...)
+         (if test
+             consequent
+             (cond clause ...)))))
+
+    ))
+; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27
+; ==============================================
+;
+; Sebastian.Egner@philips.com, 2002.
+;
+; This is the generic R5RS-part of the implementation of the MRG32k3a
+; generator to be used in SRFI-27. It is based on a separate implementation
+; of the core generator (presumably in native code) and on code to
+; provide essential functionality not available in R5RS (see below).
+;
+; compliance:
+;   Scheme R5RS with integer covering at least {-2^53..2^53-1}.
+;   In addition,
+;     SRFI-23: error
+;
+; history of this file:
+;   SE, 22-Mar-2002: refactored from earlier versions
+;   SE, 25-Mar-2002: pack/unpack need not allocate
+;   SE, 27-Mar-2002: changed interface to core generator
+;   SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer
+
+; Generator
+; =========
+;
+; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive 
+; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} 
+; defined by the two recursive generators
+;
+;   x[1,n] = (               a12 x[1,n-2] + a13 x[1,n-3]) mod m1,
+;   x[2,n] = (a21 x[2,n-1] +                a23 x[2,n-3]) mod m2,
+;
+; where the constants are
+;   m1       = 4294967087 = 2^32 - 209    modulus of 1st component
+;   m2       = 4294944443 = 2^32 - 22853  modulus of 2nd component
+;   a12      =  1403580                   recursion coefficients
+;   a13      =  -810728
+;   a21      =   527612
+;   a23      = -1370589
+;
+; The generator passes all tests of G. Marsaglia's Diehard testsuite.
+; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191.
+; L'Ecuyer reports: "This generator is well-behaved in all dimensions
+; up to at least 45: ..." [with respect to the spectral test, SE].
+;
+; The period is maximal for all values of the seed as long as the
+; state of both recursive generators is not entirely zero.
+;
+; As the successor state is a linear combination of previous
+; states, it is possible to advance the generator by more than one
+; iteration by applying a linear transformation. The following
+; publication provides detailed information on how to do that:
+;
+;    [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton:
+;        An Object-Oriented Random-Number Package With Many Long 
+;        Streams and Substreams. 2001.
+;        To appear in Operations Research.
+;
+; Arithmetics
+; ===========
+;
+; The MRG32k3a generator produces values in {0..2^32-209-1}. All 
+; subexpressions of the actual generator fit into {-2^53..2^53-1}. 
+; The code below assumes that Scheme's "integer" covers this range.
+; In addition, it is assumed that floating point literals can be
+; read and there is some arithmetics with inexact numbers.
+;
+; However, for advancing the state of the generator by more than
+; one step at a time, the full range {0..2^32-209-1} is needed.
+
+
+; Required: Backbone Generator
+; ============================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to execute the core generator:
+;
+;   (mrg32k3a-pack-state unpacked-state) -> packed-state
+;   (mrg32k3a-unpack-state packed-state) -> unpacked-state
+;      pack/unpack a state of the generator. The core generator works
+;      on packed states, passed as an explicit argument, only. This
+;      allows native code implementations to store their state in a
+;      suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) 
+;      with integer x_ij. Pack/unpack need not allocate new objects
+;      in case packed and unpacked states are identical.
+;
+;   (mrg32k3a-random-range) -> m-max
+;   (mrg32k3a-random-integer packed-state range) -> x in {0..range-1}
+;      advance the state of the generator and return the next random
+;      range-limited integer. 
+;        Note that the state is not necessarily advanced by just one 
+;      step because we use the rejection method to avoid any problems 
+;      with distribution anomalies.
+;        The range argument must be an exact integer in {1..m-max}.
+;      It can be assumed that range is a fixnum if the Scheme system
+;      has such a number representation.
+;
+;   (mrg32k3a-random-real packed-state) -> x in (0,1)
+;      advance the state of the generator and return the next random
+;      real number between zero and one (both excluded). The type of
+;      the result should be a flonum if possible.
+
+; Required: Record Data Type
+; ==========================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to create and access a new record data type:
+;
+;   (\:random-source-make a0 a1 a2 a3 a4 a5) -> s
+;     constructs a new random source object s consisting of the 
+;     objects a0 .. a5 in this order.
+;
+;   (\:random-source? obj) -> bool
+;     tests if a Scheme object is a :random-source.
+;
+;   (\:random-source-state-ref         s) -> a0
+;   (\:random-source-state-set!        s) -> a1
+;   (\:random-source-randomize!        s) -> a2
+;   (\:random-source-pseudo-randomize! s) -> a3
+;   (\:random-source-make-integers     s) -> a4
+;   (\:random-source-make-reals        s) -> a5
+;     retrieve the values in the fields of the object s.
+
+; Required: Current Time as an Integer
+; ====================================
+;
+; At this point in the code, the following procedure is assumed
+; to be defined to obtain a value that is likely to be different
+; for each invokation of the Scheme system:
+;
+;   (\:random-source-current-time) -> x
+;     an integer that depends on the system clock. It is desired
+;     that the integer changes as fast as possible.
+
+
+; Accessing the State
+; ===================
+
+(define (mrg32k3a-state-ref packed-state)
+  (cons 'lecuyer-mrg32k3a 
+        (vector->list (mrg32k3a-unpack-state packed-state))))
+
+(define (mrg32k3a-state-set external-state)
+
+  (define (check-value x m)
+    (if (and (integer? x)
+             (exact? x)
+             (<= 0 x (- m 1)))
+        #t
+        (error "illegal value" x)))
+
+  (if (and (list? external-state)
+           (= (length external-state) 7)
+           (eq? (car external-state) 'lecuyer-mrg32k3a))
+      (let ((s (cdr external-state)))
+        (check-value (list-ref s 0) mrg32k3a-m1)
+        (check-value (list-ref s 1) mrg32k3a-m1)
+        (check-value (list-ref s 2) mrg32k3a-m1)
+        (check-value (list-ref s 3) mrg32k3a-m2)
+        (check-value (list-ref s 4) mrg32k3a-m2)
+        (check-value (list-ref s 5) mrg32k3a-m2)
+        (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2)))
+                (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5))))
+            (error "illegal degenerate state" external-state))
+        (mrg32k3a-pack-state (list->vector s)))
+      (error "malformed state" external-state)))
+
+
+; Pseudo-Randomization
+; ====================
+;
+; Reference [1] above shows how to obtain many long streams and 
+; substream from the backbone generator.
+;
+; The idea is that the generator is a linear operation on the state.
+; Hence, we can express this operation as a 3x3-matrix acting on the
+; three most recent states. Raising the matrix to the k-th power, we
+; obtain the operation to advance the state by k steps at once. The
+; virtual streams and substreams are now simply parts of the entire
+; periodic sequence (which has period around 2^191).
+;
+; For the implementation it is necessary to compute with matrices in
+; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this
+; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair
+; of matrices 
+;   [ [[x00 x01 x02],
+;      [x10 x11 x12],
+;      [x20 x21 x22]], mod m1
+;     [[y00 y01 y02],
+;      [y10 y11 y12],
+;      [y20 y21 y22]]  mod m2]
+; as a vector of length 18 of the integers as writen above:
+;   #(x00 x01 x02 x10 x11 x12 x20 x21 x22
+;     y00 y01 y02 y10 y11 y12 y20 y21 y22)
+;
+; As the implementation should only use the range {-2^53..2^53-1}, the
+; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, 
+; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 
+; where w = 2^16. In this case, all operations fit the range because 
+; w^2 mod m is a small number. If proper multiprecision integers are
+; available this is not necessary, but pseudo-randomize! is an expected
+; to be called only occasionally so we do not provide this implementation.
+
+(define mrg32k3a-m1 4294967087) ; modulus of component 1
+(define mrg32k3a-m2 4294944443) ; modulus of component 2
+
+(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below
+  '#( 1062452522
+      2961816100 
+       342112271 
+      2854655037 
+      3321940838 
+      3542344109))
+
+(define mrg32k3a-generators #f) ; computed when needed
+
+(define (mrg32k3a-pseudo-randomize-state i j)
+
+  (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3)
+
+    (define w      65536) ; wordsize to split {0..2^32-1}
+    (define w-sqr1 209)   ; w^2 mod m1
+    (define w-sqr2 22853) ; w^2 mod m2
+
+    (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination
+      (let ((a0h (quotient (vector-ref A i0) w))
+            (a0l (modulo   (vector-ref A i0) w))
+            (a1h (quotient (vector-ref A i1) w))
+            (a1l (modulo   (vector-ref A i1) w))
+            (a2h (quotient (vector-ref A i2) w))
+            (a2l (modulo   (vector-ref A i2) w))
+            (b0h (quotient (vector-ref B j0) w))
+            (b0l (modulo   (vector-ref B j0) w))
+            (b1h (quotient (vector-ref B j1) w))
+            (b1l (modulo   (vector-ref B j1) w))
+            (b2h (quotient (vector-ref B j2) w))
+            (b2l (modulo   (vector-ref B j2) w)))
+        (modulo
+         (+ (* (+ (* a0h b0h) 
+                  (* a1h b1h) 
+                  (* a2h b2h)) 
+               w-sqr)
+            (* (+ (* a0h b0l) 
+                  (* a0l b0h)
+                  (* a1h b1l) 
+                  (* a1l b1h)
+                  (* a2h b2l) 
+                  (* a2l b2h))
+               w)
+            (* a0l b0l)
+            (* a1l b1l)
+            (* a2l b2l))
+         m)))
+    
+    (vector
+     (lc  0  1  2   0  3  6  mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1
+     (lc  0  1  2   1  4  7  mrg32k3a-m1 w-sqr1) ; (A*B)_01
+     (lc  0  1  2   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  3  4  5   0  3  6  mrg32k3a-m1 w-sqr1) ; (A*B)_10
+     (lc  3  4  5   1  4  7  mrg32k3a-m1 w-sqr1)
+     (lc  3  4  5   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   0  3  6  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   1  4  7  mrg32k3a-m1 w-sqr1)
+     (lc  6  7  8   2  5  8  mrg32k3a-m1 w-sqr1)
+     (lc  9 10 11   9 12 15  mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2
+     (lc  9 10 11  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc  9 10 11  11 14 17  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14   9 12 15  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc 12 13 14  11 14 17  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17   9 12 15  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17  10 13 16  mrg32k3a-m2 w-sqr2)
+     (lc 15 16 17  11 14 17  mrg32k3a-m2 w-sqr2)))
+
+  (define (power A e) ; A^e
+    (cond
+     ((zero? e)
+      '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1))
+     ((= e 1)
+      A)
+     ((even? e)
+      (power (product A A) (quotient e 2)))
+     (else
+      (product (power A (- e 1)) A))))
+
+  (define (power-power A b) ; A^(2^b)
+    (if (zero? b)
+        A
+        (power-power (product A A) (- b 1))))
+
+  (define A                        ; the MRG32k3a recursion
+    '#(     0 1403580 4294156359
+            1       0          0
+            0       1          0
+       527612       0 4293573854
+            1       0          0
+            0       1          0))
+
+  ; check arguments
+  (if (not (and (integer? i) 
+                (exact? i)
+                (integer? j)
+                (exact? j)))
+      (error "i j must be exact integer" i j))
+
+  ; precompute A^(2^127) and A^(2^76) only once
+
+  (if (not mrg32k3a-generators)
+      (set! mrg32k3a-generators
+            (list (power-power A 127)
+                  (power-power A  76)
+                  (power A 16))))
+
+  ; compute M = A^(16 + i*2^127 + j*2^76)
+  (let ((M (product 
+            (list-ref mrg32k3a-generators 2)
+            (product
+             (power (list-ref mrg32k3a-generators 0)
+                    (modulo i (expt 2 28)))
+             (power (list-ref mrg32k3a-generators 1) 
+                    (modulo j (expt 2 28)))))))
+    (mrg32k3a-pack-state
+     (vector
+      (vector-ref M 0)
+      (vector-ref M 3)
+      (vector-ref M 6)
+      (vector-ref M 9)
+      (vector-ref M 12)
+      (vector-ref M 15)))))
+
+; True Randomization
+; ==================
+;
+; The value obtained from the system time is feed into a very
+; simple pseudo random number generator. This in turn is used
+; to obtain numbers to randomize the state of the MRG32k3a
+; generator, avoiding period degeneration.
+
+(define (mrg32k3a-randomize-state state)
+  ;; G. Marsaglia's simple 16-bit generator with carry
+  (let* ((m 65536)
+	 (x (modulo (random-source-current-time) m)))
+    (define (random-m)
+      (let ((y (modulo x m)))
+	(set! x (+ (* 30903 y) (quotient x m)))
+	y))
+    (define (random n)			; m < n < m^2
+      (modulo (+ (* (random-m) m) (random-m)) n))
+
+					; modify the state
+    (let ((m1 mrg32k3a-m1)
+	  (m2 mrg32k3a-m2)
+	  (s (mrg32k3a-unpack-state state)))
+      (mrg32k3a-pack-state
+       (vector
+	(+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1)))
+	(modulo (+ (vector-ref s 1) (random m1)) m1)
+	(modulo (+ (vector-ref s 2) (random m1)) m1)
+	(+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1)))
+	(modulo (+ (vector-ref s 4) (random m2)) m2)
+	(modulo (+ (vector-ref s 5) (random m2)) m2))))))
+
+
+; Large Integers
+; ==============
+;
+; To produce large integer random deviates, for n > m-max, we first 
+; construct large random numbers in the range {0..m-max^k-1} for some 
+; k such that m-max^k >= n and then use the rejection method to choose
+; uniformly from the range {0..n-1}.
+
+(define mrg32k3a-m-max
+  (mrg32k3a-random-range))
+
+(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1
+  (if (= k 1)
+      (mrg32k3a-random-integer state mrg32k3a-m-max)
+      (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max)
+         (mrg32k3a-random-integer state mrg32k3a-m-max))))
+
+(define (mrg32k3a-random-large state n) ; n > m-max
+  (do ((k 2 (+ k 1))
+       (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max)))
+      ((>= mk n)
+       (let* ((mk-by-n (quotient mk n))
+              (a (* mk-by-n n)))
+         (do ((x (mrg32k3a-random-power state k)
+                 (mrg32k3a-random-power state k)))
+             ((< x a) (quotient x mk-by-n)))))))
+
+
+; Multiple Precision Reals
+; ========================
+;
+; To produce multiple precision reals we produce a large integer value
+; and convert it into a real value. This value is then normalized.
+; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k.
+; If you know more about the floating point number types of the
+; Scheme system, this can be improved.
+
+(define (mrg32k3a-random-real-mp state unit)
+  (do ((k 1 (+ k 1))
+       (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1)))
+      ((<= u 1)
+       (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1))
+          (exact->inexact (+ (expt mrg32k3a-m-max k) 1))))))
+
+
+; Provide the Interface as Specified in the SRFI
+; ==============================================
+;
+; An object of type random-source is a record containing the procedures
+; as components. The actual state of the generator is stored in the
+; binding-time environment of make-random-source.
+
+(define (make-random-source)
+  (let ((state (mrg32k3a-pack-state ; make a new copy
+                (list->vector (vector->list mrg32k3a-initial-state)))))
+    (\:random-source-make
+     (lambda ()
+       (mrg32k3a-state-ref state))
+     (lambda (new-state)
+       (set! state (mrg32k3a-state-set new-state)))
+     (lambda ()
+       (set! state (mrg32k3a-randomize-state state)))
+     (lambda (i j)
+       (set! state (mrg32k3a-pseudo-randomize-state i j)))
+     (lambda ()
+       (lambda (n)
+         (cond
+          ((not (and (integer? n) (exact? n) (positive? n)))
+           (error "range must be exact positive integer" n))           
+          ((<= n mrg32k3a-m-max)
+           (mrg32k3a-random-integer state n))
+          (else
+           (mrg32k3a-random-large state n)))))
+     (lambda args
+       (cond
+        ((null? args)
+         (lambda () 
+           (mrg32k3a-random-real state)))
+        ((null? (cdr args))
+         (let ((unit (car args)))
+           (cond
+            ((not (and (real? unit) (< 0 unit 1)))
+             (error "unit must be real in (0,1)" unit))
+            ((<= (- (/ 1 unit) 1) mrg32k3a-m1)
+             (lambda () 
+               (mrg32k3a-random-real state)))
+            (else
+             (lambda () 
+               (mrg32k3a-random-real-mp state unit))))))
+        (else
+         (error "illegal arguments" args)))))))
+
+(define random-source? 
+  \:random-source?)
+
+(define (random-source-state-ref s)
+  ((\:random-source-state-ref s)))
+
+(define (random-source-state-set! s state)
+  ((\:random-source-state-set! s) state))
+
+(define (random-source-randomize! s)
+  ((\:random-source-randomize! s)))
+
+(define (random-source-pseudo-randomize! s i j)
+  ((\:random-source-pseudo-randomize! s) i j))
+
+; ---
+
+(define (random-source-make-integers s)
+  ((\:random-source-make-integers s)))
+
+(define (random-source-make-reals s . unit)
+  (apply (\:random-source-make-reals s) unit))
+
+; ---
+
+(define default-random-source 
+  (make-random-source))
+
+(define random-integer
+  (random-source-make-integers default-random-source))
+
+(define random-real
+  (random-source-make-reals default-random-source))
+(define-library (srfi 27)
+  (export
+   random-integer
+   random-real
+   default-random-source
+   make-random-source
+   random-source?
+   random-source-state-ref
+   random-source-state-set!
+   random-source-randomize!
+   random-source-pseudo-randomize!
+   random-source-make-integers
+   random-source-make-reals
+   )
+  (import
+   (scheme base)
+   (scheme time))
+  (begin
+
+    (define-record-type \:random-source
+      (\\:random-source-make
+       state-ref
+       state-set!
+       randomize!
+       pseudo-randomize!
+       make-integers
+       make-reals)
+      \:random-source?
+      (state-ref \:random-source-state-ref)
+      (state-set! \:random-source-state-set!)
+      (randomize! \:random-source-randomize!)
+      (pseudo-randomize! \:random-source-pseudo-randomize!)
+      (make-integers \:random-source-make-integers)
+      (make-reals \:random-source-make-reals))
+    
+    (define (\\:random-source-current-time)
+      (current-jiffy))
+
+    (define exact->inexact inexact)
+
+    )
+  (include "27.mrg32k3a-a.upstream.scm")
+  (include "27.mrg32k3a.upstream.scm"))
+;; Copyright (C) Scott G. Miller (2002). All Rights Reserved.
+
+;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;; 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-library (srfi 28)
+  (export format)
+  (import
+   (scheme base)
+   (scheme write))
+  (begin
+    (define format
+      (lambda (format-string . objects)
+        (let ((buffer (open-output-string)))
+          (let loop ((format-list (string->list format-string))
+                     (objects objects))
+            (cond ((null? format-list) (get-output-string buffer))
+                  ((char=? (car format-list) #\~)
+                   (if (null? (cdr format-list))
+                       (error 'format "Incomplete escape sequence")
+                       (case (cadr format-list)
+                         ((#\a)
+                          (if (null? objects)
+                              (error 'format "No value for escape sequence")
+                              (begin
+                                (display (car objects) buffer)
+                                (loop (cddr format-list) (cdr objects)))))
+                         ((#\s)
+                          (if (null? objects)
+                              (error 'format "No value for escape sequence")
+                              (begin
+                                (write (car objects) buffer)
+                                (loop (cddr format-list) (cdr objects)))))
+                         ((#\%)
+                          (newline buffer)
+                          (loop (cddr format-list) objects))
+                         ((#\~)
+                          (write-char #\~ buffer)
+                          (loop (cddr format-list) objects))
+                         (else
+                          (error 'format "Unrecognized escape sequence")))))
+                  (else (write-char (car format-list) buffer)
+                        (loop (cdr format-list) objects)))))))))
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved.
+
+;; 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-library (srfi 31)
+  (export rec)
+  (import (scheme base))
+  (begin
+    (define-syntax rec
+      (syntax-rules ()
+        ((rec (name . args) body ...)
+         (letrec ((name (lambda args body ...)))
+           name))
+        ((rec name expr)
+         (letrec ((name expr))
+           name))))))
+;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved.
+;;
+;; 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-record-type <condition-type>
+  (really-make-condition-type name supertype fields all-fields)
+  condition-type?
+  (name condition-type-name)
+  (supertype condition-type-supertype)
+  (fields condition-type-fields)
+  (all-fields condition-type-all-fields))
+
+(define (make-condition-type name supertype fields)
+  (if (not (symbol? name))
+      (error "make-condition-type: name is not a symbol"
+             name))
+  (if (not (condition-type? supertype))
+      (error "make-condition-type: supertype is not a condition type"
+             supertype))
+  (if (not
+       (null? (lset-intersection eq?
+                                 (condition-type-all-fields supertype)
+                                 fields)))
+      (error "duplicate field name" ))
+  (really-make-condition-type name
+                              supertype
+                              fields
+                              (append (condition-type-all-fields supertype)
+                                      fields)))
+
+(define-syntax define-condition-type
+  (syntax-rules ()
+    ((define-condition-type ?name ?supertype ?predicate
+       (?field1 ?accessor1) ...)
+     (begin
+       (define ?name
+         (make-condition-type '?name
+                              ?supertype
+                              '(?field1 ...)))
+       (define (?predicate thing)
+         (and (condition? thing)
+              (condition-has-type? thing ?name)))
+       (define (?accessor1 condition)
+         (condition-ref (extract-condition condition ?name)
+                        '?field1))
+       ...))))
+
+(define (condition-subtype? subtype supertype)
+  (let recur ((subtype subtype))
+    (cond ((not subtype) #f)
+          ((eq? subtype supertype) #t)
+          (else
+           (recur (condition-type-supertype subtype))))))
+
+(define (condition-type-field-supertype condition-type field)
+  (let loop ((condition-type condition-type))
+    (cond ((not condition-type) #f)
+          ((memq field (condition-type-fields condition-type))
+           condition-type)
+          (else
+           (loop (condition-type-supertype condition-type))))))
+
+; The type-field-alist is of the form
+; ((<type> (<field-name> . <value>) ...) ...)
+(define-record-type <condition>
+  (really-make-condition type-field-alist)
+  condition?
+  (type-field-alist condition-type-field-alist))
+
+(define (make-condition type . field-plist)
+  (let ((alist (let label ((plist field-plist))
+                 (if (null? plist)
+                            '()
+                     (cons (cons (car plist)
+                                 (cadr plist))
+                           (label (cddr plist)))))))
+    (if (not (lset= eq?
+                    (condition-type-all-fields type)
+                    (map car alist)))
+        (error "condition fields don't match condition type"))
+    (really-make-condition (list (cons type alist)))))
+
+(define (condition-has-type? condition type)
+  (any (lambda (has-type)
+         (condition-subtype? has-type type))
+       (condition-types condition)))
+
+(define (condition-ref condition field)
+  (type-field-alist-ref (condition-type-field-alist condition)
+                        field))
+
+(define (type-field-alist-ref type-field-alist field)
+  (let loop ((type-field-alist type-field-alist))
+    (cond ((null? type-field-alist)
+           (error "type-field-alist-ref: field not found"
+                  type-field-alist field))
+          ((assq field (cdr (car type-field-alist)))
+           => cdr)
+          (else
+           (loop (cdr type-field-alist))))))
+
+(define (make-compound-condition condition-1 . conditions)
+  (really-make-condition
+   (apply append (map condition-type-field-alist
+                      (cons condition-1 conditions)))))
+
+(define (extract-condition condition type)
+  (let ((entry (find (lambda (entry)
+                              (condition-subtype? (car entry) type))
+                            (condition-type-field-alist condition))))
+    (if (not entry)
+        (error "extract-condition: invalid condition type"
+                      condition type))
+    (really-make-condition
+      (list (cons type
+                  (map (lambda (field)
+                         (assq field (cdr entry)))
+                       (condition-type-all-fields type)))))))
+
+(define-syntax condition
+  (syntax-rules ()
+    ((condition (?type1 (?field1 ?value1) ...) ...)
+     (type-field-alist->condition
+      (list
+       (cons ?type1
+             (list (cons '?field1 ?value1) ...))
+       ...)))))
+
+(define (type-field-alist->condition type-field-alist)
+  (really-make-condition
+   (map (lambda (entry)
+          (cons (car entry)
+                (map (lambda (field)
+                       (or (assq field (cdr entry))
+                           (cons field
+                                 (type-field-alist-ref type-field-alist field))))
+                     (condition-type-all-fields (car entry)))))
+        type-field-alist)))
+
+(define (condition-types condition)
+  (map car (condition-type-field-alist condition)))
+
+(define (check-condition-type-field-alist the-type-field-alist)
+  (let loop ((type-field-alist the-type-field-alist))
+    (if (not (null? type-field-alist))
+        (let* ((entry (car type-field-alist))
+               (type (car entry))
+               (field-alist (cdr entry))
+               (fields (map car field-alist))
+               (all-fields (condition-type-all-fields type)))
+          (for-each (lambda (missing-field)
+                      (let ((supertype
+                             (condition-type-field-supertype type missing-field)))
+                        (if (not
+                             (any (lambda (entry)
+                                    (let ((type (car entry)))
+                                      (condition-subtype? type supertype)))
+                                  the-type-field-alist))
+                            (error "missing field in condition construction"
+                                   type
+                                   missing-field))))
+                    (lset-difference eq? all-fields fields))
+          (loop (cdr type-field-alist))))))
+
+(define &condition (really-make-condition-type '&condition
+                                               #f
+                                               '()
+                                               '()))
+
+(define-condition-type &message &condition
+  message-condition?
+  (message condition-message))
+
+(define-condition-type &serious &condition
+  serious-condition?)
+
+(define-condition-type &error &serious
+  error?)
+(define-library (srfi 35)
+  (export
+   make-condition-type
+   condition-type?
+   make-condition
+   condition?
+   condition-has-type?
+   condition-ref
+   make-compound-condition
+   extract-condition
+   define-condition-type
+   condition
+   &condition
+   &message
+   &serious
+   &error
+   )
+  (import
+   (scheme base)
+   (srfi 1))
+  (include "35.body.scm"))
+(define-library (srfi 64)
+  (import
+   (srfi 64 test-runner)
+   (srfi 64 test-runner-simple)
+   (srfi 64 execution))
+  (export
+   ;; Execution
+   test-begin test-end test-group test-group-with-cleanup
+
+   test-skip test-expect-fail
+   test-match-name test-match-nth
+   test-match-all test-match-any
+
+   test-assert test-eqv test-eq test-equal test-approximate
+   test-error test-read-eval-string
+
+   test-apply test-with-runner
+
+   test-exit
+
+   ;; Test runner
+   test-runner-null test-runner? test-runner-reset
+
+   test-result-alist test-result-alist!
+   test-result-ref test-result-set!
+   test-result-remove test-result-clear
+
+   test-runner-pass-count
+   test-runner-fail-count
+   test-runner-xpass-count
+   test-runner-xfail-count
+   test-runner-skip-count
+
+   test-runner-test-name
+
+   test-runner-group-path
+   test-runner-group-stack
+
+   test-runner-aux-value test-runner-aux-value!
+
+   test-result-kind test-passed?
+
+   test-runner-on-test-begin test-runner-on-test-begin!
+   test-runner-on-test-end test-runner-on-test-end!
+   test-runner-on-group-begin test-runner-on-group-begin!
+   test-runner-on-group-end test-runner-on-group-end!
+   test-runner-on-final test-runner-on-final!
+   test-runner-on-bad-count test-runner-on-bad-count!
+   test-runner-on-bad-end-name test-runner-on-bad-end-name!
+
+   test-runner-factory test-runner-create
+   test-runner-current test-runner-get
+
+   ;; Simple test runner
+   test-runner-simple
+   test-on-group-begin-simple test-on-group-end-simple test-on-final-simple
+   test-on-test-begin-simple test-on-test-end-simple
+   test-on-bad-count-simple test-on-bad-end-name-simple
+   ))
+;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved.
+;;
+;; 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-record-type condition-type
+  (really-make-condition-type name supertype fields all-fields)
+  condition-type?
+  (name condition-type-name)
+  (supertype condition-type-supertype)
+  (fields condition-type-fields)
+  (all-fields condition-type-all-fields))
+
+(define (make-condition-type name supertype fields)
+  (if (not (symbol? name))
+      (error "make-condition-type: name is not a symbol"
+             name))
+  (if (not (condition-type? supertype))
+      (error "make-condition-type: supertype is not a condition type"
+             supertype))
+  (if (not
+       (null? (lset-intersection eq?
+                                 (condition-type-all-fields supertype)
+                                 fields)))
+      (error "duplicate field name" ))
+  (really-make-condition-type name
+                              supertype
+                              fields
+                              (append (condition-type-all-fields supertype)
+                                      fields)))
+
+(define-syntax define-condition-type
+  (syntax-rules ()
+    ((define-condition-type ?name ?supertype ?predicate
+       (?field1 ?accessor1) ...)
+     (begin
+       (define ?name
+         (make-condition-type '?name
+                              ?supertype
+                              '(?field1 ...)))
+       (define (?predicate thing)
+         (and (condition? thing)
+              (condition-has-type? thing ?name)))
+       (define (?accessor1 condition)
+         (condition-ref (extract-condition condition ?name)
+                        '?field1))
+       ...))))
+
+(define (condition-subtype? subtype supertype)
+  (let recur ((subtype subtype))
+    (cond ((not subtype) #f)
+          ((eq? subtype supertype) #t)
+          (else
+           (recur (condition-type-supertype subtype))))))
+
+(define (condition-type-field-supertype condition-type field)
+  (let loop ((condition-type condition-type))
+    (cond ((not condition-type) #f)
+          ((memq field (condition-type-fields condition-type))
+           condition-type)
+          (else
+           (loop (condition-type-supertype condition-type))))))
+
+; The type-field-alist is of the form
+; ((<type> (<field-name> . <value>) ...) ...)
+(define-record-type condition
+  (really-make-condition type-field-alist)
+  condition?
+  (type-field-alist condition-type-field-alist))
+
+(define (make-condition type . field-plist)
+  (let ((alist (let label ((plist field-plist))
+                 (if (null? plist)
+                            '()
+                     (cons (cons (car plist)
+                                 (cadr plist))
+                           (label (cddr plist)))))))
+    (if (not (lset= eq?
+                    (condition-type-all-fields type)
+                    (map car alist)))
+        (error "condition fields don't match condition type"))
+    (really-make-condition (list (cons type alist)))))
+
+(define (condition-has-type? condition type)
+  (any (lambda (has-type)
+         (condition-subtype? has-type type))
+       (condition-types condition)))
+
+(define (condition-ref condition field)
+  (type-field-alist-ref (condition-type-field-alist condition)
+                        field))
+
+(define (type-field-alist-ref type-field-alist field)
+  (let loop ((type-field-alist type-field-alist))
+    (cond ((null? type-field-alist)
+           (error "type-field-alist-ref: field not found"
+                  type-field-alist field))
+          ((assq field (cdr (car type-field-alist)))
+           => cdr)
+          (else
+           (loop (cdr type-field-alist))))))
+
+(define (make-compound-condition condition-1 . conditions)
+  (really-make-condition
+   (apply append (map condition-type-field-alist
+                      (cons condition-1 conditions)))))
+
+(define (extract-condition condition type)
+  (let ((entry (find (lambda (entry)
+                              (condition-subtype? (car entry) type))
+                            (condition-type-field-alist condition))))
+    (if (not entry)
+        (error "extract-condition: invalid condition type"
+                      condition type))
+    (really-make-condition
+      (list (cons type
+                  (map (lambda (field)
+                         (assq field (cdr entry)))
+                       (condition-type-all-fields type)))))))
+
+(define-syntax condition
+  (syntax-rules ()
+    ((condition (?type1 (?field1 ?value1) ...) ...)
+     (type-field-alist->condition
+      (list
+       (cons ?type1
+             (list (cons '?field1 ?value1) ...))
+       ...)))))
+
+(define (type-field-alist->condition type-field-alist)
+  (really-make-condition
+   (map (lambda (entry)
+          (cons (car entry)
+                (map (lambda (field)
+                       (or (assq field (cdr entry))
+                           (cons field
+                                 (type-field-alist-ref type-field-alist field))))
+                     (condition-type-all-fields (car entry)))))
+        type-field-alist)))
+
+(define (condition-types condition)
+  (map car (condition-type-field-alist condition)))
+
+(define (check-condition-type-field-alist the-type-field-alist)
+  (let loop ((type-field-alist the-type-field-alist))
+    (if (not (null? type-field-alist))
+        (let* ((entry (car type-field-alist))
+               (type (car entry))
+               (field-alist (cdr entry))
+               (fields (map car field-alist))
+               (all-fields (condition-type-all-fields type)))
+          (for-each (lambda (missing-field)
+                      (let ((supertype
+                             (condition-type-field-supertype type missing-field)))
+                        (if (not
+                             (any (lambda (entry)
+                                    (let ((type (car entry)))
+                                      (condition-subtype? type supertype)))
+                                  the-type-field-alist))
+                            (error "missing field in condition construction"
+                                   type
+                                   missing-field))))
+                    (lset-difference eq? all-fields fields))
+          (loop (cdr type-field-alist))))))
+
+(define &condition (really-make-condition-type '&condition
+                                               #f
+                                               '()
+                                               '()))
+
+(define-condition-type &message &condition
+  message-condition?
+  (message condition-message))
+
+(define-condition-type &serious &condition
+  serious-condition?)
+
+(define-condition-type &error &serious
+  error?)
+;;; args-fold.scm - a program argument processor
+;;;
+;;; Copyright (c) 2002 Anthony Carrico
+;;; Copyright (c) 2014 Taylan Ulrich Bayırlı/Kammer
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;;    derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(define-record-type <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 (args-fold args options unrecognized-option-proc operand-proc . seeds)
+  
+  (define (find-option name)
+    ;; ISSUE: This is a brute force search. Could use a table.
+    (find (lambda (option)
+            (find (lambda (test-name)
+                    (equal? name test-name))
+                  (option-names option)))
+          options))
+
+  (define (scan-short-options index shorts args seeds)
+    (if (= index (string-length shorts))
+        (scan-args args seeds)
+        (let* ((name (string-ref shorts index))
+               (option (or (find-option name)
+                           (option (list name)
+                                   #f
+                                   #f
+                                   unrecognized-option-proc))))
+          (cond
+           ((and (< (+ index 1) (string-length shorts))
+                 (or (option-required-arg? option)
+                     (option-optional-arg? option)))
+            (let-values
+                ((seeds (apply (option-processor option)
+                               option
+                               name
+                               (substring
+                                shorts
+                                (+ index 1)
+                                (string-length shorts))
+                               seeds)))
+              (scan-args args seeds)))
+           ((and (option-required-arg? option)
+                 (pair? args))
+            (let-values
+                ((seeds (apply (option-processor option)
+                               option
+                               name
+                               (car args)
+                               seeds)))
+              (scan-args (cdr args) seeds)))
+           (else
+            (let-values
+                ((seeds (apply (option-processor option)
+                               option
+                               name
+                               #f
+                               seeds)))
+              (scan-short-options
+               (+ index 1)
+               shorts
+               args
+               seeds)))))))
+
+  (define (scan-operands operands seeds)
+    (if (null? operands)
+        (apply values seeds)
+        (let-values ((seeds (apply operand-proc
+                                   (car operands)
+                                   seeds)))
+          (scan-operands (cdr operands) seeds))))
+
+  (define (scan-args args seeds)
+    (if (null? args)
+        (apply values seeds)
+        (let ((arg (car args))
+              (args (cdr args)))
+          ;; NOTE: This string matching code would be simpler
+          ;; using a regular expression matcher.
+          (cond
+           ((string=? "--" arg)
+            ;; End option scanning:
+            (scan-operands args seeds))
+           ((and (> (string-length arg) 4)
+                 (char=? #\- (string-ref arg 0))
+                 (char=? #\- (string-ref arg 1))
+                 (not (char=? #\= (string-ref arg 2)))
+                 (let loop ((index 3))
+                   (cond ((= index (string-length arg))
+                          #f)
+                         ((char=? #\= (string-ref arg index))
+                          index)
+                         (else
+                          (loop (+ 1 index))))))
+            ;; Found long option with arg:
+            => (lambda (=-index)
+                 (let*-values
+                     (((name)
+                       (substring arg 2 =-index))
+                      ((option-arg)
+                       (substring arg
+                                  (+ =-index 1)
+                                  (string-length arg)))
+                      ((option)
+                       (or (find-option name)
+                           (option (list name)
+                                   #t
+                                   #f
+                                   unrecognized-option-proc)))
+                      (seeds
+                       (apply (option-processor option)
+                              option
+                              name
+                              option-arg
+                              seeds)))
+                   (scan-args args seeds))))
+           ((and (> (string-length arg) 3)
+                 (char=? #\- (string-ref arg 0))
+                 (char=? #\- (string-ref arg 1)))
+            ;; Found long option:
+            (let* ((name (substring arg 2 (string-length arg)))
+                   (option (or (find-option name)
+                               (option
+                                (list name)
+                                #f
+                                #f
+                                unrecognized-option-proc))))
+              (if (and (option-required-arg? option)
+                       (pair? args))
+                  (let-values
+                      ((seeds (apply (option-processor option)
+                                     option
+                                     name
+                                     (car args)
+                                     seeds)))
+                    (scan-args (cdr args) seeds))
+                  (let-values
+                      ((seeds (apply (option-processor option)
+                                     option
+                                     name
+                                     #f
+                                     seeds)))
+                    (scan-args args seeds)))))
+           ((and (> (string-length arg) 1)
+                 (char=? #\- (string-ref arg 0)))
+            ;; Found short options
+            (let ((shorts (substring arg 1 (string-length arg))))
+              (scan-short-options 0 shorts args seeds)))
+           (else
+            (let-values ((seeds (apply operand-proc arg seeds)))
+              (scan-args args seeds)))))))
+
+  (scan-args args seeds))
+(define-library (srfi 37)
+  (export
+   args-fold
+   option
+   option-names
+   option-required-arg?
+   option-optional-arg?
+   option-processor
+   )
+  (import
+   (scheme base)
+   (srfi 1))
+  (include "37.body.scm"))
+;;; Copyright (C) 2006 Chongkai Zhu. All Rights Reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; 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-library (srfi 87)
+  (export case)
+  (import (except (scheme base) case))
+  (begin
+    (define-syntax case
+      (syntax-rules (else =>)
+        ((case (key ...)
+           clauses ...)
+         (let ((atom-key (key ...)))
+           (case atom-key clauses ...)))
+        ((case key
+           (else => result))
+         (result key))
+        ((case key
+           ((atoms ...) => result))
+         (if (memv key '(atoms ...))
+             (result key)))
+        ((case key
+           ((atoms ...) => result)
+           clause clauses ...)
+         (if (memv key '(atoms ...))
+             (result key)
+             (case key clause clauses ...)))
+        ((case key
+           (else result1 result2 ...))
+         (begin result1 result2 ...))
+        ((case key
+           ((atoms ...) result1 result2 ...))
+         (if (memv key '(atoms ...))
+             (begin result1 result2 ...)))
+        ((case key
+           ((atoms ...) result1 result2 ...)
+           clause clauses ...)
+         (if (memv key '(atoms ...))
+             (begin result1 result2 ...)
+             (case key clause clauses ...)))))))
+;;; args-fold.scm - a program argument processor
+;;;
+;;; Copyright (c) 2002 Anthony Carrico
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;;    derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; NOTE: This implementation uses the following SRFIs:
+;;;   "SRFI 9: Defining Record Types"
+;;;   "SRFI 11: Syntax for receiving multiple values"
+;;;
+;;; NOTE: The scsh-utils and Chicken implementations use regular
+;;; expressions. These might be easier to read and understand.
+
+(define option #f)
+(define option-names #f)
+(define option-required-arg? #f)
+(define option-optional-arg? #f)
+(define option-processor #f)
+(define option? #f)
+
+(let ()
+  (define-record-type option-type
+    ($option names required-arg? optional-arg? processor)
+    $option?
+    (names $option-names)
+    (required-arg? $option-required-arg?)
+    (optional-arg? $option-optional-arg?)
+    (processor $option-processor))
+  (set! option $option)
+  (set! option-names $option-names)
+  (set! option-required-arg? $option-required-arg?)
+  (set! option-optional-arg? $option-optional-arg?)
+  (set! option-processor $option-processor)
+  (set! option? $option?))
+
+(define args-fold
+  (lambda (args
+           options
+           unrecognized-option-proc
+           operand-proc
+           . seeds)
+    (letrec
+        ((find
+          (lambda (l ?)
+            (cond ((null? l) #f)
+                  ((? (car l)) (car l))
+                  (else (find (cdr l) ?)))))
+         (find-option
+          ;; ISSUE: This is a brute force search. Could use a table.
+          (lambda (name)
+            (find
+             options
+             (lambda (option)
+               (find
+                (option-names option)
+                (lambda (test-name)
+                  (equal? name test-name)))))))
+         (scan-short-options
+          (lambda (index shorts args seeds)
+            (if (= index (string-length shorts))
+                (scan-args args seeds)
+                (let* ((name (string-ref shorts index))
+                       (option (or (find-option name)
+                                   (option (list name)
+                                           #f
+                                           #f
+                                           unrecognized-option-proc))))
+                  (cond ((and (< (+ index 1) (string-length shorts))
+                              (or (option-required-arg? option)
+                                  (option-optional-arg? option)))
+                         (let-values
+                             ((seeds (apply (option-processor option)
+                                            option
+                                            name
+                                            (substring
+                                             shorts
+                                             (+ index 1)
+                                             (string-length shorts))
+                                            seeds)))
+                           (scan-args args seeds)))
+                        ((and (option-required-arg? option)
+                              (pair? args))
+                         (let-values
+                             ((seeds (apply (option-processor option)
+                                            option
+                                            name
+                                            (car args)
+                                            seeds)))
+                           (scan-args (cdr args) seeds)))
+                        (else
+                         (let-values
+                             ((seeds (apply (option-processor option)
+                                            option
+                                            name
+                                            #f
+                                            seeds)))
+                           (scan-short-options
+                            (+ index 1)
+                            shorts
+                            args
+                            seeds))))))))
+         (scan-operands
+          (lambda (operands seeds)
+            (if (null? operands)
+                (apply values seeds)
+                (let-values ((seeds (apply operand-proc
+                                           (car operands)
+                                           seeds)))
+                  (scan-operands (cdr operands) seeds)))))
+         (scan-args
+          (lambda (args seeds)
+            (if (null? args)
+                (apply values seeds)
+                (let ((arg (car args))
+                      (args (cdr args)))
+                  ;; NOTE: This string matching code would be simpler
+                  ;; using a regular expression matcher.
+                  (cond
+                   (;; (rx bos "--" eos)
+                    (string=? "--" arg)
+                    ;; End option scanning:
+                    (scan-operands args seeds))
+                   (;;(rx bos
+                    ;;    "--"
+                    ;;    (submatch (+ (~ "=")))
+                    ;;    "="
+                    ;;    (submatch (* any)))
+                    (and (> (string-length arg) 4)
+                         (char=? #\- (string-ref arg 0))
+                         (char=? #\- (string-ref arg 1))
+                         (not (char=? #\= (string-ref arg 2)))
+                         (let loop ((index 3))
+                           (cond ((= index (string-length arg))
+                                  #f)
+                                 ((char=? #\= (string-ref arg index))
+                                  index)
+                                 (else
+                                  (loop (+ 1 index))))))
+                    ;; Found long option with arg:
+                    => (lambda (=-index)
+                         (let*-values
+                             (((name)
+                               (substring arg 2 =-index))
+                              ((option-arg)
+                               (substring arg
+                                          (+ =-index 1)
+                                          (string-length arg)))
+                              ((option)
+                               (or (find-option name)
+                                   (option (list name)
+                                           #t
+                                           #f
+                                           unrecognized-option-proc)))
+                              (seeds
+                               (apply (option-processor option)
+                                      option
+                                      name
+                                      option-arg
+                                      seeds)))
+                           (scan-args args seeds))))
+                   (;;(rx bos "--" (submatch (+ any)))
+                    (and (> (string-length arg) 3)
+                         (char=? #\- (string-ref arg 0))
+                         (char=? #\- (string-ref arg 1)))
+                    ;; Found long option:
+                    (let* ((name (substring arg 2 (string-length arg)))
+                           (option (or (find-option name)
+                                       (option
+                                        (list name)
+                                        #f
+                                        #f
+                                        unrecognized-option-proc))))
+                      (if (and (option-required-arg? option)
+                               (pair? args))
+                          (let-values
+                              ((seeds (apply (option-processor option)
+                                             option
+                                             name
+                                             (car args)
+                                             seeds)))
+                            (scan-args (cdr args) seeds))
+                          (let-values
+                              ((seeds (apply (option-processor option)
+                                             option
+                                             name
+                                             #f
+                                             seeds)))
+                            (scan-args args seeds)))))
+                   (;; (rx bos "-" (submatch (+ any)))
+                    (and (> (string-length arg) 1)
+                         (char=? #\- (string-ref arg 0)))
+                    ;; Found short options
+                    (let ((shorts (substring arg 1 (string-length arg))))
+                      (scan-short-options 0 shorts args seeds)))
+                   (else
+                    (let-values ((seeds (apply operand-proc arg seeds)))
+                      (scan-args args seeds)))))))))
+      (scan-args args seeds))))
+(define-library (srfi 41)
+  (export
+   stream-null stream-cons stream? stream-null? stream-pair? stream-car
+   stream-cdr stream-lambda define-stream list->stream port->stream stream
+   stream->list stream-append stream-concat stream-constant stream-drop
+   stream-drop-while stream-filter stream-fold stream-for-each stream-from
+   stream-iterate stream-length stream-let stream-map stream-match _
+   stream-of stream-range stream-ref stream-reverse stream-scan stream-take
+   stream-take-while stream-unfold stream-unfolds stream-zip
+   )
+  (import
+   (srfi 41 primitive)
+   (srfi 41 derived)))
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+; 
+; Loading the implementation into Scheme48 0.57:
+;   ,open srfi-23
+;   ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+;   ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+;   (require 'macro) (require 'record) 
+;   (load "ec.scm")
+;
+; Implementation comments:
+;   * All local (not exported) identifiers are named ec-<something>.
+;   * This implementation focuses on portability, performance, 
+;     readability, and simplicity roughly in this order. Design
+;     decisions related to performance are taken for Scheme48.
+;   * Alternative implementations, Comments and Warnings are 
+;     mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do. 
+;
+; We use the following short names for syntactic variables
+;   q    - qualifier
+;   cc   - current continuation, thing to call at the end;
+;          the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+;   cmd  - an expression being evaluated for its side-effects
+;   expr - an expression
+;   gen  - a generator of an eager comprehension
+;   ob   - outer binding
+;   oc   - outer command
+;   lb   - loop binding
+;   ne1? - not-end1? (before the payload)
+;   ib   - inner binding
+;   ic   - inner command
+;   ne2? - not-end2? (after the payload)
+;   ls   - loop step
+;   etc  - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+;   handles nested, if/not/and/or, begin, :let, and calls generator 
+;   macros in CPS to transform them into fully decorated :do.
+;   The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+  (syntax-rules (nested if not and or begin do let)
+
+    ; explicit nesting -> implicit nesting
+    ((do-ec (nested q ...) etc ...)
+     (do-ec q ... etc ...) )
+
+    ; implicit nesting -> fold do-ec
+    ((do-ec q1 q2 etc1 etc ...)
+     (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+    ; no qualifiers at all -> evaluate cmd once
+    ((do-ec cmd)
+     (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+    ; filter -> make conditional
+    ((do-ec (if test) cmd)
+     (if test (do-ec cmd)) )
+    ((do-ec (not test) cmd)
+     (if (not test) (do-ec cmd)) )
+    ((do-ec (and test ...) cmd)
+     (if (and test ...) (do-ec cmd)) )
+    ((do-ec (or test ...) cmd)
+     (if (or test ...) (do-ec cmd)) )
+
+    ; begin -> make a sequence
+    ((do-ec (begin etc ...) cmd)
+     (begin etc ... (do-ec cmd)) )
+
+    ; fully decorated :do-generator -> delegate to do-ec:do
+    ((do-ec (#\:do olet lbs ne1? ilet ne2? lss) cmd)
+     (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+    ((do-ec (g arg1 arg ...) cmd)
+     (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss))
+;   generates code for a single fully decorated :do-generator
+;   with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+  (syntax-rules (#\:do let)
+
+    ; reentry point (*) -> generate code
+    ((do-ec:do cmd 
+               (#\:do (let obs oc ...) 
+                    lbs 
+                    ne1? 
+                    (let ibs ic ...) 
+                    ne2? 
+                    (ls ...) ))
+     (ec-simplify
+       (let obs
+         oc ...
+         (let loop lbs
+           (ec-simplify
+             (if ne1?
+                 (ec-simplify
+                   (let ibs
+                      ic ...
+                      cmd
+                      (ec-simplify
+                        (if ne2?
+                            (loop ls ...) )))))))))) ))
+
+    
+; (ec-simplify <expression>)
+;   generates potentially more efficient code for <expression>.
+;   The macro handles if, (begin <command>*), and (let () <command>*)
+;   and takes care of special cases.
+
+(define-syntax ec-simplify
+  (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+    ; literal <test>
+    ((ec-simplify (if #t consequent))
+     consequent )
+    ((ec-simplify (if #f consequent))
+     (if #f #f) )
+    ((ec-simplify (if #t consequent alternate))
+     consequent )
+    ((ec-simplify (if #f consequent alternate))
+     alternate )
+
+    ; (not (not <test>))
+    ((ec-simplify (if (not (not test)) consequent))
+     (ec-simplify (if test consequent)) )
+    ((ec-simplify (if (not (not test)) consequent alternate))
+     (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*) 
+
+    ; empty <binding spec>*
+    ((ec-simplify (let () command ...))
+     (ec-simplify (begin command ...)) )
+
+; begin 
+
+    ; flatten use helper (ec-simplify 1 done to-do)
+    ((ec-simplify (begin command ...))
+     (ec-simplify 1 () (command ...)) )
+    ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+     (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+    ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+     (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+    ; exit helper
+    ((ec-simplify 1 () ())
+     (if #f #f) )
+    ((ec-simplify 1 (command) ())
+     command )
+    ((ec-simplify 1 (command1 command ...) ())
+     (begin command1 command ...) )
+
+; anything else
+
+    ((ec-simplify expression)
+     expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax \:do
+  (syntax-rules ()
+
+    ; full decorated -> continue with cc, reentry at (*)
+    ((#\:do (cc ...) olet lbs ne1? ilet ne2? lss)
+     (cc ... (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+    ; short form -> fill in default values
+    ((#\:do cc lbs ne1? lss)
+     (#\:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+    
+
+(define-syntax \:let
+  (syntax-rules (index)
+    ((\:let cc var (index i) expression)
+     (#\:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+    ((\:let cc var expression)
+     (#\:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax \:parallel
+  (syntax-rules (#\:do)
+    ((\:parallel cc)
+     cc )
+    ((\:parallel cc (g arg1 arg ...) gen ...)
+     (g (\:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (\:parallel-1 cc (to-do ...) result [ next ] )
+;    iterates over to-do by converting the first generator into 
+;    the :do-generator next and merging next into result.
+
+(define-syntax \:parallel-1  ; used as 
+  (syntax-rules (#\:do let)
+
+    ; process next element of to-do, reentry at (**)
+    ((\:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+     (g (\:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+    ; reentry point (**) -> merge next into result
+    ((\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ...) oc1 ...) 
+            (lb1 ...) 
+            ne1?1 
+            (let (ib1 ...) ic1 ...) 
+            ne2?1 
+            (ls1 ...) )
+       (#\:do (let (ob2 ...) oc2 ...) 
+            (lb2 ...) 
+            ne1?2 
+            (let (ib2 ...) ic2 ...) 
+            ne2?2 
+            (ls2 ...) ))
+     (\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) 
+            (lb1 ... lb2 ...) 
+            (and ne1?1 ne1?2) 
+            (let (ib1 ... ib2 ...) ic1 ... ic2 ...) 
+            (and ne2?1 ne2?2) 
+            (ls1 ... ls2 ...) )))
+
+    ; no more gens -> continue with cc, reentry at (*)
+    ((\:parallel-1 (cc ...) () result)
+     (cc ... result) )))
+
+(define-syntax \:while
+  (syntax-rules ()
+    ((\:while cc (g arg1 arg ...) test)
+     (g (\:while-1 cc test) arg1 arg ...) )))
+
+; (\:while-1 cc test (#\:do ...))
+;    modifies the fully decorated :do-generator such that it
+;    runs while test is a true value. 
+;       The original implementation just replaced ne1? by
+;    (and ne1? test) as follows:
+;
+;      (define-syntax \:while-1
+;        (syntax-rules (#\:do)
+;          ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+;           (#\:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+;    Unfortunately, this code is wrong because ne1? may depend
+;    in the inner bindings introduced in ilet, but ne1? is evaluated
+;    outside of the inner bindings. (Refer to the specification of
+;    :do to see the structure.) 
+;       The problem manifests itself (as sunnan@handgranat.org 
+;    observed, 25-Apr-2005) when the :list-generator is modified:
+; 
+;      (do-ec (\:while (\:list x '(1 2)) (= x 1)) (display x)).
+;
+;    In order to generate proper code, we introduce temporary
+;    variables saving the values of the inner bindings. The inner
+;    bindings are executed in a new ne1?, which also evaluates ne1?
+;    outside the scope of the inner bindings, then the inner commands
+;    are executed (possibly changing the variables), and then the
+;    values of the inner bindings are saved and (and ne1? test) is
+;    returned. In the new ilet, the inner variables are bound and
+;    initialized and their values are restored. So we construct:
+;
+;     (let (ob .. (ib-tmp #f) ...)
+;       oc ...
+;       (let loop (lb ...)
+;         (if (let (ne1?-value ne1?)
+;               (let ((ib-var ib-rhs) ...)
+;                 ic ...
+;                 (set! ib-tmp ib-var) ...)
+;               (and ne1?-value test))
+;             (let ((ib-var ib-tmp) ...)
+;               /payload/
+;               (if ne2?
+;                   (loop ls ...) )))))
+; 
+; Bug #2:
+;    Unfortunately, the above expansion is still incorrect (as Jens-Axel 
+;    Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+;    if ne1?-value is #f, indicating that the loop has ended.
+;       The problem manifests itself in the following example:
+;
+;      (do-ec (\:while (\:list x '(1)) #t) (display x))
+;
+;    Which iterates :list beyond exhausting the list '(1).
+;
+;    For the fix, we follow Jens-Axel's approach of guarding the evaluation
+;    of ib-rhs with a check on ne1?-value.
+
+(define-syntax \:while-1
+  (syntax-rules (#\:do let)
+    ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (\:while-2 cc test () () () (#\:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax \:while-2
+  (syntax-rules (#\:do let)
+    ((\:while-2 cc 
+               test 
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let ((ib-var ib-rhs) ib ...) ic ...)
+                    ne2? 
+                    lss))
+     (\:while-2 cc 
+               test 
+               (ib-let     ... (ib-tmp #f))
+               (ib-save    ... (ib-var ib-rhs))
+               (ib-restore ... (ib-var ib-tmp))
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let (ib ...) ic ... (set! ib-tmp ib-var)) 
+                    ne2? 
+                    lss)))
+    ((\:while-2 cc
+               test
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+     (#\:do cc
+          (let (ob ... ib-let ...) oc ...)
+          lbs
+          (let ((ne1?-value ne1?))
+	    (and ne1?-value
+		 (let (ib-save ...)
+		   ic ...
+		   test)))
+          (let (ib-restore ...))
+          ne2?
+          lss))))
+
+
+(define-syntax \:until
+  (syntax-rules ()
+    ((\:until cc (g arg1 arg ...) test)
+     (g (\:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax \:until-1
+  (syntax-rules (#\:do)
+    ((\:until-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (#\:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax \:list
+  (syntax-rules (index)
+    ((\:list cc var (index i) arg ...)
+     (\:parallel cc (\:list var arg ...) (\:integers i)) )
+    ((\:list cc var arg1 arg2 arg ...)
+     (\:list cc var (append arg1 arg2 arg ...)) )
+    ((\:list cc var arg)
+     (#\:do cc
+          (let ())
+          ((t arg))
+          (not (null? t))
+          (let ((var (car t))))
+          #t
+          ((cdr t)) ))))
+
+
+(define-syntax \:string
+  (syntax-rules (index)
+    ((\:string cc var (index i) arg)
+     (#\:do cc
+          (let ((str arg) (len 0)) 
+            (set! len (string-length str)))
+          ((i 0))
+          (< i len)
+          (let ((var (string-ref str i))))
+          #t
+          ((+ i 1)) ))
+    ((\:string cc var (index i) arg1 arg2 arg ...)
+     (\:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+    ((\:string cc var arg1 arg ...)
+     (\:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+;   be used for :string. However, it is less interesting as the
+;   overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax \:vector
+  (syntax-rules (index)
+    ((\:vector cc var arg)
+     (\:vector cc var (index i) arg) )
+    ((\:vector cc var (index i) arg)
+     (#\:do cc
+          (let ((vec arg) (len 0)) 
+            (set! len (vector-length vec)))
+          ((i 0))
+          (< i len)
+          (let ((var (vector-ref vec i))))
+          #t
+          ((+ i 1)) ))
+
+    ((\:vector cc var (index i) arg1 arg2 arg ...)
+     (\:parallel cc (\:vector cc var arg1 arg2 arg ...) (\:integers i)) )
+    ((\:vector cc var arg1 arg2 arg ...)
+     (#\:do cc
+          (let ((vec #f)
+                (len 0)
+                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+          ((k 0))
+          (if (< k len)
+              #t
+              (if (null? vecs)
+                  #f
+                  (begin (set! vec (car vecs))
+                         (set! vecs (cdr vecs))
+                         (set! len (vector-length vec))
+                         (set! k 0)
+                         #t )))
+          (let ((var (vector-ref vec k))))
+          #t
+          ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+  (if (null? vecs)
+      '()
+      (if (zero? (vector-length (car vecs)))
+          (ec-:vector-filter (cdr vecs))
+          (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+;   append and :list in the multi-argument case. Please refer to the
+;   'design.scm' for more details.
+
+
+(define-syntax \:integers
+  (syntax-rules (index)
+    ((\:integers cc var (index i))
+     (#\:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+    ((\:integers cc var)
+     (#\:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax \:range
+  (syntax-rules (index)
+
+    ; handle index variable and add optional args
+    ((\:range cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:range var arg1 arg ...) (\:integers i)) )
+    ((\:range cc var arg1)
+     (\:range cc var 0 arg1 1) )
+    ((\:range cc var arg1 arg2)
+     (\:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+    ((\:range cc var 0 arg2 1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var 0 arg2 -1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+    ((\:range cc var arg1 arg2 1)
+     (#\:do cc
+          (let ((a arg1) (b arg2))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b 1 )) )
+          ((var a))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var arg1 arg2 -1)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s -1) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b -1 )) )
+          ((var a))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+; the general case
+
+    ((\:range cc var arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b)
+                          (integer? s) (exact? s) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b s ))
+            (if (zero? s)
+                (error "step size must not be zero in :range") )
+            (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+          ((var a))
+          (not (= var stop))
+          (let ())
+          #t
+          ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+;   are exact integers. This overhead has proven very helpful for 
+;   saving users from themselves.
+
+
+(define-syntax \:real-range
+  (syntax-rules (index)
+
+    ; add optional args and index variable
+    ((\:real-range cc var arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var (index i) arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var (index i) arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var arg1 arg2 arg3)
+     (\:real-range cc var (index i) arg1 arg2 arg3) )
+
+    ; the fully qualified case
+    ((\:real-range cc var (index i) arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (istop 0))
+            (if (not (and (real? a) (real? b) (real? s)))
+                (error "arguments of :real-range are not real" a b s) )
+            (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+                (set! a (inexact a)) )
+            (set! istop (/ (- b a) s)) )
+          ((i 0))
+          (< i istop)
+          (let ((var (+ a (* s i)))))
+          #t
+          ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+;   value in case any of the other values is inexact. This is a
+;   precaution to avoid (list-ec (\: x 0 3.0) x) => '(0 1.0 2.0).
+
+    
+(define-syntax \:char-range
+  (syntax-rules (index)
+    ((\:char-range cc var (index i) arg1 arg2)
+     (\:parallel cc (\:char-range var arg1 arg2) (\:integers i)) )
+    ((\:char-range cc var arg1 arg2)
+     (#\:do cc
+          (let ((imax (char->integer arg2))))
+          ((i (char->integer arg1)))
+          (<= i imax)
+          (let ((var (integer->char i))))
+          #t
+          ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator 
+;   because the integers obtained by char->integer are not necessarily 
+;   consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax \:port
+  (syntax-rules (index)
+    ((\:port cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:port var arg1 arg ...) (\:integers i)) )
+    ((\:port cc var arg)
+     (\:port cc var arg read) )
+    ((\:port cc var arg1 arg2)
+     (#\:do cc
+          (let ((port arg1) (read-proc arg2)))
+          ((var (read-proc port)))
+          (not (eof-object? var))
+          (let ())
+          #t
+          ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax \:dispatched
+  (syntax-rules (index)
+    ((\:dispatched cc var (index i) dispatch arg1 arg ...)
+     (\:parallel cc 
+                (\:integers i)
+                (\:dispatched var dispatch arg1 arg ...) ))
+    ((\:dispatched cc var dispatch arg1 arg ...)
+     (#\:do cc
+          (let ((d dispatch) 
+                (args (list arg1 arg ...)) 
+                (g #f) 
+                (empty (list #f)) )
+            (set! g (d args))
+            (if (not (procedure? g))
+                (error "unrecognized arguments in dispatching" 
+                       args 
+                       (d '()) )))
+          ((var (g empty)))
+          (not (eq? var empty))
+          (let ())
+          #t
+          ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+;   non-empty list. It is compared using eq? which distinguishes
+;   the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax \:generator-proc
+  (syntax-rules (#\:do let)
+
+    ; call g with a variable, reentry at (**)
+    ((\:generator-proc (g arg ...))
+     (g (\:generator-proc var) var arg ...) )
+
+    ; reentry point (**) -> make the code from a single :do
+    ((\:generator-proc
+       var 
+       (#\:do (let obs oc ...) 
+            ((lv li) ...) 
+            ne1? 
+            (let ((i v) ...) ic ...) 
+            ne2? 
+            (ls ...)) )
+     (ec-simplify 
+      (let obs
+          oc ...
+          (let ((lv li) ... (ne2 #t))
+            (ec-simplify
+             (let ((i #f) ...) ; v not yet valid
+               (lambda (empty)
+                 (if (and ne1? ne2)
+                     (ec-simplify
+                      (begin 
+                        (set! i v) ...
+                        ic ...
+                        (let ((value var))
+                          (ec-simplify
+                           (if ne2?
+                               (ec-simplify 
+                                (begin (set! lv ls) ...) )
+                               (set! ne2 #f) ))
+                          value )))
+                     empty ))))))))
+
+    ; silence warnings of some macro expanders
+    ((\:generator-proc var)
+     (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+  (lambda (args)
+    (let ((g1 (d1 args)) (g2 (d2 args)))
+      (if g1
+          (if g2 
+              (if (null? args)
+                  (append (if (list? g1) g1 (list g1)) 
+                          (if (list? g2) g2 (list g2)) )
+                  (error "dispatching conflict" args (d1 '()) (d2 '())) )
+              g1 )
+          (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+  (lambda (args)
+    (case (length args)
+      ((0) 'SRFI42)
+      ((1) (let ((a1 (car args)))
+             (cond
+              ((list? a1)
+               (\:generator-proc (\:list a1)) )
+              ((string? a1)
+               (\:generator-proc (\:string a1)) )
+              ((vector? a1)
+               (\:generator-proc (\:vector a1)) )
+              ((and (integer? a1) (exact? a1))
+               (\:generator-proc (\:range a1)) )
+              ((real? a1)
+               (\:generator-proc (\:real-range a1)) )
+              ((input-port? a1)
+               (\:generator-proc (\:port a1)) )
+              (else
+               #f ))))
+      ((2) (let ((a1 (car args)) (a2 (cadr args)))
+             (cond
+              ((and (list? a1) (list? a2))
+               (\:generator-proc (\:list a1 a2)) )
+              ((and (string? a1) (string? a1))
+               (\:generator-proc (\:string a1 a2)) )
+              ((and (vector? a1) (vector? a2))
+               (\:generator-proc (\:vector a1 a2)) )
+              ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+               (\:generator-proc (\:range a1 a2)) )
+              ((and (real? a1) (real? a2))
+               (\:generator-proc (\:real-range a1 a2)) )
+              ((and (char? a1) (char? a2))
+               (\:generator-proc (\:char-range a1 a2)) )
+              ((and (input-port? a1) (procedure? a2))
+               (\:generator-proc (\:port a1 a2)) )
+              (else
+               #f ))))
+      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+             (cond
+              ((and (list? a1) (list? a2) (list? a3))
+               (\:generator-proc (\:list a1 a2 a3)) )
+              ((and (string? a1) (string? a1) (string? a3))
+               (\:generator-proc (\:string a1 a2 a3)) )
+              ((and (vector? a1) (vector? a2) (vector? a3))
+               (\:generator-proc (\:vector a1 a2 a3)) )
+              ((and (integer? a1) (exact? a1) 
+                    (integer? a2) (exact? a2)
+                    (integer? a3) (exact? a3))
+               (\:generator-proc (\:range a1 a2 a3)) )
+              ((and (real? a1) (real? a2) (real? a3))
+               (\:generator-proc (\:real-range a1 a2 a3)) )
+              (else
+               #f ))))
+      (else
+       (letrec ((every? 
+                 (lambda (pred args)
+                   (if (null? args)
+                       #t
+                       (and (pred (car args))
+                            (every? pred (cdr args)) )))))
+         (cond
+          ((every? list? args)
+           (\:generator-proc (\:list (apply append args))) )
+          ((every? string? args)
+           (\:generator-proc (\:string (apply string-append args))) )
+          ((every? vector? args)
+           (\:generator-proc (\:list (apply append (map vector->list args)))) )
+          (else
+           #f )))))))
+
+(define \:-dispatch
+  (make-initial-:-dispatch) )
+
+(define (\:-dispatch-ref)
+  \:-dispatch )
+
+(define (\:-dispatch-set! dispatch)
+  (if (not (procedure? dispatch))
+      (error "not a procedure" dispatch) )
+  (set! \:-dispatch dispatch) )
+
+(define-syntax \:
+  (syntax-rules (index)
+    ((\: cc var (index i) arg1 arg ...)
+     (\:dispatched cc var (index i) \:-dispatch arg1 arg ...) )
+    ((\: cc var arg1 arg ...)
+     (\:dispatched cc var \:-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+  (syntax-rules (nested)
+    ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 expression f1 f2)
+     (fold3-ec x0 (nested) expression f1 f2) )
+
+    ((fold3-ec x0 qualifier expression f1 f2)
+     (let ((result #f) (empty #t))
+       (do-ec qualifier
+              (let ((value expression)) ; don't duplicate
+                (if empty
+                    (begin (set! result (f1 value))
+                           (set! empty #f) )
+                    (set! result (f2 value result)) )))
+       (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+  (syntax-rules (nested)
+    ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+    ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+    ((fold-ec x0 expression f2)
+     (fold-ec x0 (nested) expression f2) )
+
+    ((fold-ec x0 qualifier expression f2)
+     (let ((result x0))
+       (do-ec qualifier (set! result (f2 expression result)))
+       result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+  (syntax-rules ()
+    ((list-ec etc1 etc ...)
+     (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+;   using set-cdr! to add at the tail. This removes the overhead of copying
+;   at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+  (syntax-rules ()
+    ((append-ec etc1 etc ...)
+     (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+  (syntax-rules ()
+    ((string-ec etc1 etc ...)
+     (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+;   problem. A more space-aware implementation collect the characters 
+;   in an intermediate list and when this list becomes too large it is
+;   converted into an intermediate string. At the end, the intermediate
+;   strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+  (syntax-rules ()
+    ((string-append-ec etc1 etc ...)
+     (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+  (syntax-rules ()
+    ((vector-ec etc1 etc ...)
+     (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+;   However, the space overhead for the intermediate list is much lower
+;   than for string-ec and as there is no vector-append, the intermediate
+;   vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+  (syntax-rules (nested)
+    ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+     (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+    ((vector-of-length-ec k q1 q2             etc1 etc ...)
+     (vector-of-length-ec k (nested q1 q2)    etc1 etc ...) )
+    ((vector-of-length-ec k expression)
+     (vector-of-length-ec k (nested) expression) )
+
+    ((vector-of-length-ec k qualifier expression)
+     (let ((len k))
+       (let ((vec (make-vector len))
+             (i 0) )
+         (do-ec qualifier
+                (if (< i len)
+                    (begin (vector-set! vec i expression)
+                           (set! i (+ i 1)) )
+                    (error "vector is too short for the comprehension") ))
+         (if (= i len)
+             vec
+             (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+  (syntax-rules ()
+    ((sum-ec etc1 etc ...)
+     (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+  (syntax-rules ()
+    ((product-ec etc1 etc ...)
+     (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+  (syntax-rules ()
+    ((min-ec etc1 etc ...)
+     (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+  (syntax-rules ()
+    ((max-ec etc1 etc ...)
+     (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+  (syntax-rules (nested)
+    ((last-ec default (nested q1 ...) q etc1 etc ...)
+     (last-ec default (nested q1 ... q) etc1 etc ...) )
+    ((last-ec default q1 q2             etc1 etc ...)
+     (last-ec default (nested q1 q2)    etc1 etc ...) )
+    ((last-ec default expression)
+     (last-ec default (nested) expression) )
+
+    ((last-ec default qualifier expression)
+     (let ((result default))
+       (do-ec qualifier (set! result expression))
+       result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+  (syntax-rules (nested)
+    ((first-ec default (nested q1 ...) q etc1 etc ...)
+     (first-ec default (nested q1 ... q) etc1 etc ...) )
+    ((first-ec default q1 q2             etc1 etc ...)
+     (first-ec default (nested q1 q2)    etc1 etc ...) )
+    ((first-ec default expression)
+     (first-ec default (nested) expression) )
+
+    ((first-ec default qualifier expression)
+     (let ((result default) (stop #f))
+       (ec-guarded-do-ec 
+         stop 
+         (nested qualifier)
+         (begin (set! result expression)
+                (set! stop #t) ))
+       result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+;   constructs (do-ec q ... cmd) where the generators gen in q ... are
+;   replaced by (\:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+  (syntax-rules (nested if not and or begin)
+
+    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+    ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+     (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+     (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+     (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+     (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+     (do-ec 
+       (\:until gen stop) 
+       (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+    ((ec-guarded-do-ec stop (nested) cmd)
+     (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+;   possible to use call-with-current-continuation:
+;
+;   (define-synatx first-ec 
+;     ...same as above...
+;     ((first-ec default qualifier expression)
+;      (call-with-current-continuation 
+;       (lambda (cc)
+;        (do-ec qualifier (cc expression))
+;        default ))) ))
+;
+;   This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+  (syntax-rules (nested)
+    ((any?-ec (nested q1 ...) q etc1 etc ...)
+     (any?-ec (nested q1 ... q) etc1 etc ...) )
+    ((any?-ec q1 q2             etc1 etc ...)
+     (any?-ec (nested q1 q2)    etc1 etc ...) )
+    ((any?-ec expression)
+     (any?-ec (nested) expression) )
+
+    ((any?-ec qualifier expression)
+     (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+  (syntax-rules (nested)
+    ((every?-ec (nested q1 ...) q etc1 etc ...)
+     (every?-ec (nested q1 ... q) etc1 etc ...) )
+    ((every?-ec q1 q2             etc1 etc ...)
+     (every?-ec (nested q1 q2)    etc1 etc ...) )
+    ((every?-ec expression)
+     (every?-ec (nested) expression) )
+
+    ((every?-ec qualifier expression)
+     (first-ec #t qualifier (if (not expression)) #f) )))
+
+(define-library (srfi 42)
+  (export
+   \:
+   \:-dispatch-ref
+   \:-dispatch-set!
+   \:char-range
+   \:dispatched
+   \:do
+   \:generator-proc
+   \:integers
+   \:let
+   \:list
+   \:parallel
+   \:port
+   \:range
+   \:real-range
+   \:string
+   \:until
+   \:vector
+   \:while
+   any?-ec
+   append-ec
+   dispatch-union
+   do-ec
+   every?-ec
+   first-ec
+   fold-ec
+   fold3-ec
+   last-ec
+   list-ec
+   make-initial-\:-dispatch
+   max-ec
+   min-ec
+   product-ec
+   string-append-ec
+   string-ec
+   sum-ec
+   vector-ec
+   vector-of-length-ec
+   )
+  (import
+   (scheme base)
+   (scheme cxr)
+   (scheme read))
+  (include "42.body.scm"))
+;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+;;;
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; Copyright (C) Aubrey Jaffer 2006. All Rights Reserved.
+
+;;; 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.
+
+;;; Updated: 11 June 1991
+;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
+;;; Updated: 19 June 1995
+;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
+;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
+;;; jaffer: 2006-10-08:
+;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
+;;; jaffer: 2006-11-05:
+;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
+;;; per element.
+
+;;; (sorted? sequence less?)
+;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;; such that for all 1 <= i <= m,
+;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
+;@
+(define (sorted? seq less? . opt-key)
+  (define key (if (null? opt-key) values (car opt-key)))
+  (cond ((null? seq) #t)
+	((array? seq)
+	 (let ((dimax (+ -1 (car (array-dimensions seq)))))
+	   (or (<= dimax 1)
+	       (let loop ((idx (+ -1 dimax))
+			  (last (key (array-ref seq dimax))))
+		 (or (negative? idx)
+		     (let ((nxt (key (array-ref seq idx))))
+		       (and (less? nxt last)
+			    (loop (+ -1 idx) nxt))))))))
+	((null? (cdr seq)) #t)
+	(else
+	 (let loop ((last (key (car seq)))
+		    (next (cdr seq)))
+	   (or (null? next)
+	       (let ((nxt (key (car next))))
+		 (and (not (less? nxt last))
+		      (loop nxt (cdr next)))))))))
+
+;;; (merge a b less?)
+;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+;;; and returns a new list in which the elements of a and b have been stably
+;;; interleaved so that (sorted? (merge a b less?) less?).
+;;; Note:  this does _not_ accept arrays.  See below.
+;@
+(define (merge a b less? . opt-key)
+  (define key (if (null? opt-key) values (car opt-key)))
+  (cond ((null? a) b)
+	((null? b) a)
+	(else
+	 (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
+		    (y (car b)) (ky (key (car b))) (b (cdr b)))
+	   ;; The loop handles the merging of non-empty lists.  It has
+	   ;; been written this way to save testing and car/cdring.
+	   (if (less? ky kx)
+	       (if (null? b)
+		   (cons y (cons x a))
+		   (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
+	       ;; x <= y
+	       (if (null? a)
+		   (cons x (cons y b))
+		   (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
+
+(define (sort:merge! a b less? key)
+  (define (loop r a kcara b kcarb)
+    (cond ((less? kcarb kcara)
+	   (set-cdr! r b)
+	   (if (null? (cdr b))
+	       (set-cdr! b a)
+	       (loop b a kcara (cdr b) (key (cadr b)))))
+	  (else				; (car a) <= (car b)
+	   (set-cdr! r a)
+	   (if (null? (cdr a))
+	       (set-cdr! a b)
+	       (loop a (cdr a) (key (cadr a)) b kcarb)))))
+  (cond ((null? a) b)
+	((null? b) a)
+	(else
+	 (let ((kcara (key (car a)))
+	       (kcarb (key (car b))))
+	   (cond
+	    ((less? kcarb kcara)
+	     (if (null? (cdr b))
+		 (set-cdr! b a)
+		 (loop b a kcara (cdr b) (key (cadr b))))
+	     b)
+	    (else			; (car a) <= (car b)
+	     (if (null? (cdr a))
+		 (set-cdr! a b)
+		 (loop a (cdr a) (key (cadr a)) b kcarb))
+	     a))))))
+
+;;; takes two sorted lists a and b and smashes their cdr fields to form a
+;;; single sorted list including the elements of both.
+;;; Note:  this does _not_ accept arrays.
+;@
+(define (merge! a b less? . opt-key)
+  (sort:merge! a b less? (if (null? opt-key) values (car opt-key))))
+
+(define (sort:sort-list! seq less? key)
+  (define keyer (if key car values))
+  (define (step n)
+    (cond ((> n 2) (let* ((j (quotient n 2))
+			  (a (step j))
+			  (k (- n j))
+			  (b (step k)))
+		     (sort:merge! a b less? keyer)))
+	  ((= n 2) (let ((x (car seq))
+			 (y (cadr seq))
+			 (p seq))
+		     (set! seq (cddr seq))
+		     (cond ((less? (keyer y) (keyer x))
+			    (set-car! p y)
+			    (set-car! (cdr p) x)))
+		     (set-cdr! (cdr p) '())
+		     p))
+	  ((= n 1) (let ((p seq))
+		     (set! seq (cdr seq))
+		     (set-cdr! p '())
+		     p))
+	  (else '())))
+  (define (key-wrap! lst)
+    (cond ((null? lst))
+	  (else (set-car! lst (cons (key (car lst)) (car lst)))
+		(key-wrap! (cdr lst)))))
+  (define (key-unwrap! lst)
+    (cond ((null? lst))
+	  (else (set-car! lst (cdar lst))
+		(key-unwrap! (cdr lst)))))
+  (cond (key
+	 (key-wrap! seq)
+	 (set! seq (step (length seq)))
+	 (key-unwrap! seq)
+	 seq)
+	(else
+	 (step (length seq)))))
+
+(define (rank-1-array->list array)
+  (define dimensions (array-dimensions array))
+  (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
+       (lst '() (cons (array-ref array idx) lst)))
+      ((< idx 0) lst)))
+
+;;; (sort! sequence less?)
+;;; sorts the list, array, or string sequence destructively.  It uses
+;;; a version of merge-sort invented, to the best of my knowledge, by
+;;; David H. D.  Warren, and first used in the DEC-10 Prolog system.
+;;; R. A. O'Keefe adapted it to work destructively in Scheme.
+;;; A. Jaffer modified to always return the original list.
+;@
+(define (sort! seq less? . opt-key)
+  (define key (if (null? opt-key) #f (car opt-key)))
+  (cond ((array? seq)
+	 (let ((dims (array-dimensions seq)))
+	   (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+			(cdr sorted))
+		(i 0 (+ i 1)))
+	       ((null? sorted) seq)
+	     (array-set! seq (car sorted) i))))
+	(else			      ; otherwise, assume it is a list
+	 (let ((ret (sort:sort-list! seq less? key)))
+	   (if (not (eq? ret seq))
+	       (do ((crt ret (cdr crt)))
+		   ((eq? (cdr crt) seq)
+		    (set-cdr! crt ret)
+		    (let ((scar (car seq)) (scdr (cdr seq)))
+		      (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
+		      (set-car! ret scar) (set-cdr! ret scdr)))))
+	   seq))))
+
+;;; (sort sequence less?)
+;;; sorts a array, string, or list non-destructively.  It does this
+;;; by sorting a copy of the sequence.  My understanding is that the
+;;; Standard says that the result of append is always "newly
+;;; allocated" except for sharing structure with "the last argument",
+;;; so (append x '()) ought to be a standard way of copying a list x.
+;@
+(define (sort seq less? . opt-key)
+  (define key (if (null? opt-key) #f (car opt-key)))
+  (cond ((array? seq)
+	 (let ((dims (array-dimensions seq)))
+	   (define newra (apply make-array seq dims))
+	   (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+			(cdr sorted))
+		(i 0 (+ i 1)))
+	       ((null? sorted) newra)
+	     (array-set! newra (car sorted) i))))
+	(else (sort:sort-list! (append seq '()) less? key))))
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+; 
+; Loading the implementation into Scheme48 0.57:
+;   ,open srfi-23
+;   ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+;   ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+;   (require 'macro) (require 'record) 
+;   (load "ec.scm")
+;
+; Implementation comments:
+;   * All local (not exported) identifiers are named ec-<something>.
+;   * This implementation focuses on portability, performance, 
+;     readability, and simplicity roughly in this order. Design
+;     decisions related to performance are taken for Scheme48.
+;   * Alternative implementations, Comments and Warnings are 
+;     mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do. 
+;
+; We use the following short names for syntactic variables
+;   q    - qualifier
+;   cc   - current continuation, thing to call at the end;
+;          the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+;   cmd  - an expression being evaluated for its side-effects
+;   expr - an expression
+;   gen  - a generator of an eager comprehension
+;   ob   - outer binding
+;   oc   - outer command
+;   lb   - loop binding
+;   ne1? - not-end1? (before the payload)
+;   ib   - inner binding
+;   ic   - inner command
+;   ne2? - not-end2? (after the payload)
+;   ls   - loop step
+;   etc  - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+;   handles nested, if/not/and/or, begin, :let, and calls generator 
+;   macros in CPS to transform them into fully decorated :do.
+;   The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+  (syntax-rules (nested if not and or begin \:do let)
+
+    ; explicit nesting -> implicit nesting
+    ((do-ec (nested q ...) etc ...)
+     (do-ec q ... etc ...) )
+
+    ; implicit nesting -> fold do-ec
+    ((do-ec q1 q2 etc1 etc ...)
+     (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+    ; no qualifiers at all -> evaluate cmd once
+    ((do-ec cmd)
+     (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+    ; filter -> make conditional
+    ((do-ec (if test) cmd)
+     (if test (do-ec cmd)) )
+    ((do-ec (not test) cmd)
+     (if (not test) (do-ec cmd)) )
+    ((do-ec (and test ...) cmd)
+     (if (and test ...) (do-ec cmd)) )
+    ((do-ec (or test ...) cmd)
+     (if (or test ...) (do-ec cmd)) )
+
+    ; begin -> make a sequence
+    ((do-ec (begin etc ...) cmd)
+     (begin etc ... (do-ec cmd)) )
+
+    ; fully decorated :do-generator -> delegate to do-ec:do
+    ((do-ec (#\:do olet lbs ne1? ilet ne2? lss) cmd)
+     (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+    ((do-ec (g arg1 arg ...) cmd)
+     (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss))
+;   generates code for a single fully decorated :do-generator
+;   with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+  (syntax-rules (#\:do let)
+
+    ; reentry point (*) -> generate code
+    ((do-ec:do cmd 
+               (#\:do (let obs oc ...) 
+                    lbs 
+                    ne1? 
+                    (let ibs ic ...) 
+                    ne2? 
+                    (ls ...) ))
+     (ec-simplify
+       (let obs
+         oc ...
+         (let loop lbs
+           (ec-simplify
+             (if ne1?
+                 (ec-simplify
+                   (let ibs
+                      ic ...
+                      cmd
+                      (ec-simplify
+                        (if ne2?
+                            (loop ls ...) )))))))))) ))
+
+    
+; (ec-simplify <expression>)
+;   generates potentially more efficient code for <expression>.
+;   The macro handles if, (begin <command>*), and (let () <command>*)
+;   and takes care of special cases.
+
+(define-syntax ec-simplify
+  (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+    ; literal <test>
+    ((ec-simplify (if #t consequent))
+     consequent )
+    ((ec-simplify (if #f consequent))
+     (if #f #f) )
+    ((ec-simplify (if #t consequent alternate))
+     consequent )
+    ((ec-simplify (if #f consequent alternate))
+     alternate )
+
+    ; (not (not <test>))
+    ((ec-simplify (if (not (not test)) consequent))
+     (ec-simplify (if test consequent)) )
+    ((ec-simplify (if (not (not test)) consequent alternate))
+     (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*) 
+
+    ; empty <binding spec>*
+    ((ec-simplify (let () command ...))
+     (ec-simplify (begin command ...)) )
+
+; begin 
+
+    ; flatten use helper (ec-simplify 1 done to-do)
+    ((ec-simplify (begin command ...))
+     (ec-simplify 1 () (command ...)) )
+    ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+     (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+    ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+     (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+    ; exit helper
+    ((ec-simplify 1 () ())
+     (if #f #f) )
+    ((ec-simplify 1 (command) ())
+     command )
+    ((ec-simplify 1 (command1 command ...) ())
+     (begin command1 command ...) )
+
+; anything else
+
+    ((ec-simplify expression)
+     expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax \:do
+  (syntax-rules ()
+
+    ; full decorated -> continue with cc, reentry at (*)
+    ((#\:do (cc ...) olet lbs ne1? ilet ne2? lss)
+     (cc ... (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+    ; short form -> fill in default values
+    ((#\:do cc lbs ne1? lss)
+     (#\:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+    
+
+(define-syntax \:let
+  (syntax-rules (index)
+    ((\:let cc var (index i) expression)
+     (#\:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+    ((\:let cc var expression)
+     (#\:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax \:parallel
+  (syntax-rules (#\:do)
+    ((\:parallel cc)
+     cc )
+    ((\:parallel cc (g arg1 arg ...) gen ...)
+     (g (\:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (\:parallel-1 cc (to-do ...) result [ next ] )
+;    iterates over to-do by converting the first generator into 
+;    the :do-generator next and merging next into result.
+
+(define-syntax \:parallel-1  ; used as 
+  (syntax-rules (#\:do let)
+
+    ; process next element of to-do, reentry at (**)
+    ((\:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+     (g (\:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+    ; reentry point (**) -> merge next into result
+    ((\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ...) oc1 ...) 
+            (lb1 ...) 
+            ne1?1 
+            (let (ib1 ...) ic1 ...) 
+            ne2?1 
+            (ls1 ...) )
+       (#\:do (let (ob2 ...) oc2 ...) 
+            (lb2 ...) 
+            ne1?2 
+            (let (ib2 ...) ic2 ...) 
+            ne2?2 
+            (ls2 ...) ))
+     (\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) 
+            (lb1 ... lb2 ...) 
+            (and ne1?1 ne1?2) 
+            (let (ib1 ... ib2 ...) ic1 ... ic2 ...) 
+            (and ne2?1 ne2?2) 
+            (ls1 ... ls2 ...) )))
+
+    ; no more gens -> continue with cc, reentry at (*)
+    ((\:parallel-1 (cc ...) () result)
+     (cc ... result) )))
+
+(define-syntax \:while
+  (syntax-rules ()
+    ((\:while cc (g arg1 arg ...) test)
+     (g (\:while-1 cc test) arg1 arg ...) )))
+
+; (\:while-1 cc test (#\:do ...))
+;    modifies the fully decorated :do-generator such that it
+;    runs while test is a true value. 
+;       The original implementation just replaced ne1? by
+;    (and ne1? test) as follows:
+;
+;      (define-syntax \:while-1
+;        (syntax-rules (#\:do)
+;          ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+;           (#\:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+;    Unfortunately, this code is wrong because ne1? may depend
+;    in the inner bindings introduced in ilet, but ne1? is evaluated
+;    outside of the inner bindings. (Refer to the specification of
+;    :do to see the structure.) 
+;       The problem manifests itself (as sunnan@handgranat.org 
+;    observed, 25-Apr-2005) when the :list-generator is modified:
+; 
+;      (do-ec (\:while (\:list x '(1 2)) (= x 1)) (display x)).
+;
+;    In order to generate proper code, we introduce temporary
+;    variables saving the values of the inner bindings. The inner
+;    bindings are executed in a new ne1?, which also evaluates ne1?
+;    outside the scope of the inner bindings, then the inner commands
+;    are executed (possibly changing the variables), and then the
+;    values of the inner bindings are saved and (and ne1? test) is
+;    returned. In the new ilet, the inner variables are bound and
+;    initialized and their values are restored. So we construct:
+;
+;     (let (ob .. (ib-tmp #f) ...)
+;       oc ...
+;       (let loop (lb ...)
+;         (if (let (ne1?-value ne1?)
+;               (let ((ib-var ib-rhs) ...)
+;                 ic ...
+;                 (set! ib-tmp ib-var) ...)
+;               (and ne1?-value test))
+;             (let ((ib-var ib-tmp) ...)
+;               /payload/
+;               (if ne2?
+;                   (loop ls ...) )))))
+; 
+; Bug #2:
+;    Unfortunately, the above expansion is still incorrect (as Jens-Axel 
+;    Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+;    if ne1?-value is #f, indicating that the loop has ended.
+;       The problem manifests itself in the following example:
+;
+;      (do-ec (\:while (\:list x '(1)) #t) (display x))
+;
+;    Which iterates :list beyond exhausting the list '(1).
+;
+;    For the fix, we follow Jens-Axel's approach of guarding the evaluation
+;    of ib-rhs with a check on ne1?-value.
+
+(define-syntax \:while-1
+  (syntax-rules (#\:do let)
+    ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (\:while-2 cc test () () () (#\:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax \:while-2
+  (syntax-rules (#\:do let)
+    ((\:while-2 cc 
+               test 
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let ((ib-var ib-rhs) ib ...) ic ...)
+                    ne2? 
+                    lss))
+     (\:while-2 cc 
+               test 
+               (ib-let     ... (ib-tmp #f))
+               (ib-save    ... (ib-var ib-rhs))
+               (ib-restore ... (ib-var ib-tmp))
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let (ib ...) ic ... (set! ib-tmp ib-var)) 
+                    ne2? 
+                    lss)))
+    ((\:while-2 cc
+               test
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+     (#\:do cc
+          (let (ob ... ib-let ...) oc ...)
+          lbs
+          (let ((ne1?-value ne1?))
+	    (and ne1?-value
+		 (let (ib-save ...)
+		   ic ...
+		   test)))
+          (let (ib-restore ...))
+          ne2?
+          lss))))
+
+
+(define-syntax \:until
+  (syntax-rules ()
+    ((\:until cc (g arg1 arg ...) test)
+     (g (\:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax \:until-1
+  (syntax-rules (#\:do)
+    ((\:until-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (#\:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax \:list
+  (syntax-rules (index)
+    ((\:list cc var (index i) arg ...)
+     (\:parallel cc (\:list var arg ...) (\:integers i)) )
+    ((\:list cc var arg1 arg2 arg ...)
+     (\:list cc var (append arg1 arg2 arg ...)) )
+    ((\:list cc var arg)
+     (#\:do cc
+          (let ())
+          ((t arg))
+          (not (null? t))
+          (let ((var (car t))))
+          #t
+          ((cdr t)) ))))
+
+
+(define-syntax \:string
+  (syntax-rules (index)
+    ((\:string cc var (index i) arg)
+     (#\:do cc
+          (let ((str arg) (len 0)) 
+            (set! len (string-length str)))
+          ((i 0))
+          (< i len)
+          (let ((var (string-ref str i))))
+          #t
+          ((+ i 1)) ))
+    ((\:string cc var (index i) arg1 arg2 arg ...)
+     (\:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+    ((\:string cc var arg1 arg ...)
+     (\:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+;   be used for :string. However, it is less interesting as the
+;   overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax \:vector
+  (syntax-rules (index)
+    ((\:vector cc var arg)
+     (\:vector cc var (index i) arg) )
+    ((\:vector cc var (index i) arg)
+     (#\:do cc
+          (let ((vec arg) (len 0)) 
+            (set! len (vector-length vec)))
+          ((i 0))
+          (< i len)
+          (let ((var (vector-ref vec i))))
+          #t
+          ((+ i 1)) ))
+
+    ((\:vector cc var (index i) arg1 arg2 arg ...)
+     (\:parallel cc (\:vector cc var arg1 arg2 arg ...) (\:integers i)) )
+    ((\:vector cc var arg1 arg2 arg ...)
+     (#\:do cc
+          (let ((vec #f)
+                (len 0)
+                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+          ((k 0))
+          (if (< k len)
+              #t
+              (if (null? vecs)
+                  #f
+                  (begin (set! vec (car vecs))
+                         (set! vecs (cdr vecs))
+                         (set! len (vector-length vec))
+                         (set! k 0)
+                         #t )))
+          (let ((var (vector-ref vec k))))
+          #t
+          ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+  (if (null? vecs)
+      '()
+      (if (zero? (vector-length (car vecs)))
+          (ec-:vector-filter (cdr vecs))
+          (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+;   append and :list in the multi-argument case. Please refer to the
+;   'design.scm' for more details.
+
+
+(define-syntax \:integers
+  (syntax-rules (index)
+    ((\:integers cc var (index i))
+     (#\:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+    ((\:integers cc var)
+     (#\:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax \:range
+  (syntax-rules (index)
+
+    ; handle index variable and add optional args
+    ((\:range cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:range var arg1 arg ...) (\:integers i)) )
+    ((\:range cc var arg1)
+     (\:range cc var 0 arg1 1) )
+    ((\:range cc var arg1 arg2)
+     (\:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+    ((\:range cc var 0 arg2 1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var 0 arg2 -1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+    ((\:range cc var arg1 arg2 1)
+     (#\:do cc
+          (let ((a arg1) (b arg2))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b 1 )) )
+          ((var a))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var arg1 arg2 -1)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s -1) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b -1 )) )
+          ((var a))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+; the general case
+
+    ((\:range cc var arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b)
+                          (integer? s) (exact? s) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b s ))
+            (if (zero? s)
+                (error "step size must not be zero in :range") )
+            (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+          ((var a))
+          (not (= var stop))
+          (let ())
+          #t
+          ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+;   are exact integers. This overhead has proven very helpful for 
+;   saving users from themselves.
+
+
+(define-syntax \:real-range
+  (syntax-rules (index)
+
+    ; add optional args and index variable
+    ((\:real-range cc var arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var (index i) arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var (index i) arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var arg1 arg2 arg3)
+     (\:real-range cc var (index i) arg1 arg2 arg3) )
+
+    ; the fully qualified case
+    ((\:real-range cc var (index i) arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (istop 0))
+            (if (not (and (real? a) (real? b) (real? s)))
+                (error "arguments of :real-range are not real" a b s) )
+            (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+                (set! a (exact->inexact a)) )
+            (set! istop (/ (- b a) s)) )
+          ((i 0))
+          (< i istop)
+          (let ((var (+ a (* s i)))))
+          #t
+          ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+;   value in case any of the other values is inexact. This is a
+;   precaution to avoid (list-ec (\: x 0 3.0) x) => '(0 1.0 2.0).
+
+    
+(define-syntax \:char-range
+  (syntax-rules (index)
+    ((\:char-range cc var (index i) arg1 arg2)
+     (\:parallel cc (\:char-range var arg1 arg2) (\:integers i)) )
+    ((\:char-range cc var arg1 arg2)
+     (#\:do cc
+          (let ((imax (char->integer arg2))))
+          ((i (char->integer arg1)))
+          (<= i imax)
+          (let ((var (integer->char i))))
+          #t
+          ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator 
+;   because the integers obtained by char->integer are not necessarily 
+;   consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax \:port
+  (syntax-rules (index)
+    ((\:port cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:port var arg1 arg ...) (\:integers i)) )
+    ((\:port cc var arg)
+     (\:port cc var arg read) )
+    ((\:port cc var arg1 arg2)
+     (#\:do cc
+          (let ((port arg1) (read-proc arg2)))
+          ((var (read-proc port)))
+          (not (eof-object? var))
+          (let ())
+          #t
+          ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax \:dispatched
+  (syntax-rules (index)
+    ((\:dispatched cc var (index i) dispatch arg1 arg ...)
+     (\:parallel cc 
+                (\:integers i)
+                (\:dispatched var dispatch arg1 arg ...) ))
+    ((\:dispatched cc var dispatch arg1 arg ...)
+     (#\:do cc
+          (let ((d dispatch) 
+                (args (list arg1 arg ...)) 
+                (g #f) 
+                (empty (list #f)) )
+            (set! g (d args))
+            (if (not (procedure? g))
+                (error "unrecognized arguments in dispatching" 
+                       args 
+                       (d '()) )))
+          ((var (g empty)))
+          (not (eq? var empty))
+          (let ())
+          #t
+          ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+;   non-empty list. It is compared using eq? which distinguishes
+;   the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax \:generator-proc
+  (syntax-rules (#\:do let)
+
+    ; call g with a variable, reentry at (**)
+    ((\:generator-proc (g arg ...))
+     (g (\:generator-proc var) var arg ...) )
+
+    ; reentry point (**) -> make the code from a single :do
+    ((\:generator-proc
+       var 
+       (#\:do (let obs oc ...) 
+            ((lv li) ...) 
+            ne1? 
+            (let ((i v) ...) ic ...) 
+            ne2? 
+            (ls ...)) )
+     (ec-simplify 
+      (let obs
+          oc ...
+          (let ((lv li) ... (ne2 #t))
+            (ec-simplify
+             (let ((i #f) ...) ; v not yet valid
+               (lambda (empty)
+                 (if (and ne1? ne2)
+                     (ec-simplify
+                      (begin 
+                        (set! i v) ...
+                        ic ...
+                        (let ((value var))
+                          (ec-simplify
+                           (if ne2?
+                               (ec-simplify 
+                                (begin (set! lv ls) ...) )
+                               (set! ne2 #f) ))
+                          value )))
+                     empty ))))))))
+
+    ; silence warnings of some macro expanders
+    ((\:generator-proc var)
+     (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+  (lambda (args)
+    (let ((g1 (d1 args)) (g2 (d2 args)))
+      (if g1
+          (if g2 
+              (if (null? args)
+                  (append (if (list? g1) g1 (list g1)) 
+                          (if (list? g2) g2 (list g2)) )
+                  (error "dispatching conflict" args (d1 '()) (d2 '())) )
+              g1 )
+          (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-\:-dispatch)
+  (lambda (args)
+    (case (length args)
+      ((0) 'SRFI42)
+      ((1) (let ((a1 (car args)))
+             (cond
+              ((list? a1)
+               (\:generator-proc (\:list a1)) )
+              ((string? a1)
+               (\:generator-proc (\:string a1)) )
+              ((vector? a1)
+               (\:generator-proc (\:vector a1)) )
+              ((and (integer? a1) (exact? a1))
+               (\:generator-proc (\:range a1)) )
+              ((real? a1)
+               (\:generator-proc (\:real-range a1)) )
+              ((input-port? a1)
+               (\:generator-proc (\:port a1)) )
+              (else
+               #f ))))
+      ((2) (let ((a1 (car args)) (a2 (cadr args)))
+             (cond
+              ((and (list? a1) (list? a2))
+               (\:generator-proc (\:list a1 a2)) )
+              ((and (string? a1) (string? a1))
+               (\:generator-proc (\:string a1 a2)) )
+              ((and (vector? a1) (vector? a2))
+               (\:generator-proc (\:vector a1 a2)) )
+              ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+               (\:generator-proc (\:range a1 a2)) )
+              ((and (real? a1) (real? a2))
+               (\:generator-proc (\:real-range a1 a2)) )
+              ((and (char? a1) (char? a2))
+               (\:generator-proc (\:char-range a1 a2)) )
+              ((and (input-port? a1) (procedure? a2))
+               (\:generator-proc (\:port a1 a2)) )
+              (else
+               #f ))))
+      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+             (cond
+              ((and (list? a1) (list? a2) (list? a3))
+               (\:generator-proc (\:list a1 a2 a3)) )
+              ((and (string? a1) (string? a1) (string? a3))
+               (\:generator-proc (\:string a1 a2 a3)) )
+              ((and (vector? a1) (vector? a2) (vector? a3))
+               (\:generator-proc (\:vector a1 a2 a3)) )
+              ((and (integer? a1) (exact? a1) 
+                    (integer? a2) (exact? a2)
+                    (integer? a3) (exact? a3))
+               (\:generator-proc (\:range a1 a2 a3)) )
+              ((and (real? a1) (real? a2) (real? a3))
+               (\:generator-proc (\:real-range a1 a2 a3)) )
+              (else
+               #f ))))
+      (else
+       (letrec ((every? 
+                 (lambda (pred args)
+                   (if (null? args)
+                       #t
+                       (and (pred (car args))
+                            (every? pred (cdr args)) )))))
+         (cond
+          ((every? list? args)
+           (\:generator-proc (\:list (apply append args))) )
+          ((every? string? args)
+           (\:generator-proc (\:string (apply string-append args))) )
+          ((every? vector? args)
+           (\:generator-proc (\:list (apply append (map vector->list args)))) )
+          (else
+           #f )))))))
+
+(define \\:-dispatch
+  (make-initial-\:-dispatch) )
+
+(define (\\:-dispatch-ref)
+  \:-dispatch )
+
+(define (\\:-dispatch-set! dispatch)
+  (if (not (procedure? dispatch))
+      (error "not a procedure" dispatch) )
+  (set! \:-dispatch dispatch) )
+
+(define-syntax \:
+  (syntax-rules (index)
+    ((\: cc var (index i) arg1 arg ...)
+     (\:dispatched cc var (index i) \:-dispatch arg1 arg ...) )
+    ((\: cc var arg1 arg ...)
+     (\:dispatched cc var \:-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+  (syntax-rules (nested)
+    ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 expression f1 f2)
+     (fold3-ec x0 (nested) expression f1 f2) )
+
+    ((fold3-ec x0 qualifier expression f1 f2)
+     (let ((result #f) (empty #t))
+       (do-ec qualifier
+              (let ((value expression)) ; don't duplicate
+                (if empty
+                    (begin (set! result (f1 value))
+                           (set! empty #f) )
+                    (set! result (f2 value result)) )))
+       (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+  (syntax-rules (nested)
+    ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+    ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+    ((fold-ec x0 expression f2)
+     (fold-ec x0 (nested) expression f2) )
+
+    ((fold-ec x0 qualifier expression f2)
+     (let ((result x0))
+       (do-ec qualifier (set! result (f2 expression result)))
+       result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+  (syntax-rules ()
+    ((list-ec etc1 etc ...)
+     (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+;   using set-cdr! to add at the tail. This removes the overhead of copying
+;   at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+  (syntax-rules ()
+    ((append-ec etc1 etc ...)
+     (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+  (syntax-rules ()
+    ((string-ec etc1 etc ...)
+     (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+;   problem. A more space-aware implementation collect the characters 
+;   in an intermediate list and when this list becomes too large it is
+;   converted into an intermediate string. At the end, the intermediate
+;   strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+  (syntax-rules ()
+    ((string-append-ec etc1 etc ...)
+     (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+  (syntax-rules ()
+    ((vector-ec etc1 etc ...)
+     (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+;   However, the space overhead for the intermediate list is much lower
+;   than for string-ec and as there is no vector-append, the intermediate
+;   vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+  (syntax-rules (nested)
+    ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+     (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+    ((vector-of-length-ec k q1 q2             etc1 etc ...)
+     (vector-of-length-ec k (nested q1 q2)    etc1 etc ...) )
+    ((vector-of-length-ec k expression)
+     (vector-of-length-ec k (nested) expression) )
+
+    ((vector-of-length-ec k qualifier expression)
+     (let ((len k))
+       (let ((vec (make-vector len))
+             (i 0) )
+         (do-ec qualifier
+                (if (< i len)
+                    (begin (vector-set! vec i expression)
+                           (set! i (+ i 1)) )
+                    (error "vector is too short for the comprehension") ))
+         (if (= i len)
+             vec
+             (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+  (syntax-rules ()
+    ((sum-ec etc1 etc ...)
+     (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+  (syntax-rules ()
+    ((product-ec etc1 etc ...)
+     (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+  (syntax-rules ()
+    ((min-ec etc1 etc ...)
+     (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+  (syntax-rules ()
+    ((max-ec etc1 etc ...)
+     (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+  (syntax-rules (nested)
+    ((last-ec default (nested q1 ...) q etc1 etc ...)
+     (last-ec default (nested q1 ... q) etc1 etc ...) )
+    ((last-ec default q1 q2             etc1 etc ...)
+     (last-ec default (nested q1 q2)    etc1 etc ...) )
+    ((last-ec default expression)
+     (last-ec default (nested) expression) )
+
+    ((last-ec default qualifier expression)
+     (let ((result default))
+       (do-ec qualifier (set! result expression))
+       result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+  (syntax-rules (nested)
+    ((first-ec default (nested q1 ...) q etc1 etc ...)
+     (first-ec default (nested q1 ... q) etc1 etc ...) )
+    ((first-ec default q1 q2             etc1 etc ...)
+     (first-ec default (nested q1 q2)    etc1 etc ...) )
+    ((first-ec default expression)
+     (first-ec default (nested) expression) )
+
+    ((first-ec default qualifier expression)
+     (let ((result default) (stop #f))
+       (ec-guarded-do-ec 
+         stop 
+         (nested qualifier)
+         (begin (set! result expression)
+                (set! stop #t) ))
+       result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+;   constructs (do-ec q ... cmd) where the generators gen in q ... are
+;   replaced by (\:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+  (syntax-rules (nested if not and or begin)
+
+    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+    ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+     (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+     (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+     (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+     (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+     (do-ec 
+       (\:until gen stop) 
+       (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+    ((ec-guarded-do-ec stop (nested) cmd)
+     (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+;   possible to use call-with-current-continuation:
+;
+;   (define-synatx first-ec 
+;     ...same as above...
+;     ((first-ec default qualifier expression)
+;      (call-with-current-continuation 
+;       (lambda (cc)
+;        (do-ec qualifier (cc expression))
+;        default ))) ))
+;
+;   This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+  (syntax-rules (nested)
+    ((any?-ec (nested q1 ...) q etc1 etc ...)
+     (any?-ec (nested q1 ... q) etc1 etc ...) )
+    ((any?-ec q1 q2             etc1 etc ...)
+     (any?-ec (nested q1 q2)    etc1 etc ...) )
+    ((any?-ec expression)
+     (any?-ec (nested) expression) )
+
+    ((any?-ec qualifier expression)
+     (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+  (syntax-rules (nested)
+    ((every?-ec (nested q1 ...) q etc1 etc ...)
+     (every?-ec (nested q1 ... q) etc1 etc ...) )
+    ((every?-ec q1 q2             etc1 etc ...)
+     (every?-ec (nested q1 q2)    etc1 etc ...) )
+    ((every?-ec expression)
+     (every?-ec (nested) expression) )
+
+    ((every?-ec qualifier expression)
+     (first-ec #t qualifier (if (not expression)) #f) )))
+
+;;;;;; SRFI 43: Vector library                           -*- Scheme -*-
+;;;
+;;; $Id: vector-lib.scm,v 1.7 2009/03/29 09:46:03 sperber Exp $
+;;;
+;;; Taylor Campbell wrote this code; he places it in the public domain.
+;;; Will Clinger [wdc] made some corrections, also in the public domain.
+
+;;; Copyright (C) Taylor Campbell (2003). All rights reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014.
+
+;;; 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.
+
+;;; --------------------
+;;; Exported procedure index
+;;;
+;;; * Constructors
+;;; make-vector vector
+;;; vector-unfold                   vector-unfold-right
+;;; vector-copy                     vector-reverse-copy
+;;; vector-append                   vector-concatenate
+;;;
+;;; * Predicates
+;;; vector?
+;;; vector-empty?
+;;; vector=
+;;;
+;;; * Selectors
+;;; vector-ref
+;;; vector-length
+;;;
+;;; * Iteration
+;;; vector-fold                     vector-fold-right
+;;; vector-map                      vector-map!
+;;; vector-for-each
+;;; vector-count
+;;;
+;;; * Searching
+;;; vector-index                    vector-skip
+;;; vector-index-right              vector-skip-right
+;;; vector-binary-search
+;;; vector-any                      vector-every
+;;;
+;;; * Mutators
+;;; vector-set!
+;;; vector-swap!
+;;; vector-fill!
+;;; vector-reverse!
+;;; vector-copy!                    vector-reverse-copy!
+;;; vector-reverse!
+;;;
+;;; * Conversion
+;;; vector->list                    reverse-vector->list
+;;; list->vector                    reverse-list->vector
+
+
+
+;;; --------------------
+;;; Commentary on efficiency of the code
+
+;;; This code is somewhat tuned for efficiency.  There are several
+;;; internal routines that can be optimized greatly to greatly improve
+;;; the performance of much of the library.  These internal procedures
+;;; are already carefully tuned for performance, and lambda-lifted by
+;;; hand.  Some other routines are lambda-lifted by hand, but only the
+;;; loops are lambda-lifted, and only if some routine has two possible
+;;; loops -- a fast path and an n-ary case --, whereas _all_ of the
+;;; internal routines' loops are lambda-lifted so as to never cons a
+;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop),
+;;; even in Scheme systems that perform no loop optimization (which is
+;;; most of them, unfortunately).
+;;;
+;;; Fast paths are provided for common cases in most of the loops in
+;;; this library.
+;;;
+;;; All calls to primitive vector operations are protected by a prior
+;;; type check; they can be safely converted to use unsafe equivalents
+;;; of the operations, if available.  Ideally, the compiler should be
+;;; able to determine this, but the state of Scheme compilers today is
+;;; not a happy one.
+;;;
+;;; Efficiency of the actual algorithms is a rather mundane point to
+;;; mention; vector operations are rarely beyond being straightforward.
+
+
+
+;;; --------------------
+;;; Utilities
+
+(define (nonneg-int? x)
+  (and (integer? x)
+       (not (negative? x))))
+
+(define (between? x y z)
+  (and (<  x y)
+       (<= y z)))
+
+(define (unspecified-value) (if #f #f))
+
+;++ This should be implemented more efficiently.  It shouldn't cons a
+;++ closure, and the cons cells used in the loops when using this could
+;++ be reused.
+(define (vectors-ref vectors i)
+  (map (lambda (v) (vector-ref v i)) vectors))
+
+
+
+;;; --------------------
+;;; Internal routines
+
+;;; These should all be integrated, native, or otherwise optimized --
+;;; they're used a _lot_ --.  All of the loops and LETs inside loops
+;;; are lambda-lifted by hand, just so as not to cons closures in the
+;;; loops.  (If your compiler can do better than that if they're not
+;;; lambda-lifted, then lambda-drop (?) them.)
+
+;;; (VECTOR-PARSE-START+END <vector> <arguments>
+;;;                         <start-name> <end-name>
+;;;                         <callee>)
+;;;       -> [start end]
+;;;   Return two values, composing a valid range within VECTOR, as
+;;;   extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START
+;;;   and the length of VECTOR for END --; START-NAME and END-NAME are
+;;;   purely for error checking.
+(define (vector-parse-start+end vec args start-name end-name callee)
+  (let ((len (vector-length vec)))
+    (cond ((null? args)
+           (values 0 len))
+          ((null? (cdr args))
+           (check-indices vec
+                          (car args) start-name
+                          len end-name
+                          callee))
+          ((null? (cddr args))
+           (check-indices vec
+                          (car  args) start-name
+                          (cadr args) end-name
+                          callee))
+          (else
+           (error "too many arguments"
+                  `(extra args were ,(cddr args))
+                  `(while calling ,callee))))))
+
+(define-syntax let-vector-start+end
+  (syntax-rules ()
+    ((let-vector-start+end ?callee ?vec ?args (?start ?end)
+       ?body1 ?body2 ...)
+     (let ((?vec (check-type vector? ?vec ?callee)))
+       (receive (?start ?end)
+                (vector-parse-start+end ?vec ?args '?start '?end
+                                        ?callee)
+         ?body1 ?body2 ...)))))
+
+;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
+;;;       -> exact, nonnegative integer
+;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
+;;;   the length that is returned if VECTOR-LIST is empty.  Common use
+;;;   of this is in n-ary vector routines:
+;;;     (define (f vec . vectors)
+;;;       (let ((vec (check-type vector? vec f)))
+;;;         ...(%smallest-length vectors (vector-length vec) f)...))
+;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
+;;;   the CALLEE argument is for --; thus, the design is tuned for
+;;;   avoiding redundant type checks.
+(define %smallest-length
+  (letrec ((loop (lambda (vector-list length callee)
+                   (if (null? vector-list)
+                       length
+                       (loop (cdr vector-list)
+                             (min (vector-length
+                                   (check-type vector?
+                                               (car vector-list)
+                                               callee))
+                                  length)
+                             callee)))))
+    loop))
+
+;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
+;;;   Copy elements from SSTART to SEND from SOURCE to TARGET, in the
+;;;   reverse order.
+(define %vector-reverse-copy!
+  (letrec ((loop (lambda (target source sstart i j)
+                   (cond ((>= i sstart)
+                          (vector-set! target j (vector-ref source i))
+                          (loop target source sstart
+                                (- i 1)
+                                (+ j 1)))))))
+    (lambda (target tstart source sstart send)
+      (loop target source sstart
+            (- send 1)
+            tstart))))
+
+;;; (%VECTOR-REVERSE! <vector>)
+(define %vector-reverse!
+  (letrec ((loop (lambda (vec i j)
+                   (cond ((<= i j)
+                          (let ((v (vector-ref vec i)))
+                            (vector-set! vec i (vector-ref vec j))
+                            (vector-set! vec j v)
+                            (loop vec (+ i 1) (- j 1))))))))
+    (lambda (vec start end)
+      (loop vec start (- end 1)))))
+
+;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
+;;;     (KONS <index> <knil> <elt>) -> knil'
+(define %vector-fold1
+  (letrec ((loop (lambda (kons knil len vec i)
+                   (if (= i len)
+                       knil
+                       (loop kons
+                             (kons i knil (vector-ref vec i))
+                             len vec (+ i 1))))))
+    (lambda (kons knil len vec)
+      (loop kons knil len vec 0))))
+
+;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
+;;;     (KONS <index> <knil> <elt> ...) -> knil'
+(define %vector-fold2+
+  (letrec ((loop (lambda (kons knil len vectors i)
+                   (if (= i len)
+                       knil
+                       (loop kons
+                             (apply kons i knil
+                                    (vectors-ref vectors i))
+                             len vectors (+ i 1))))))
+    (lambda (kons knil len vectors)
+      (loop kons knil len vectors 0))))
+
+;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
+;;;     (F <index> <elt>) -> elt'
+(define %vector-map1!
+  (letrec ((loop (lambda (f target vec i)
+                   (if (zero? i)
+                       target
+                       (let ((j (- i 1)))
+                         (vector-set! target j
+                                      (f j (vector-ref vec j)))
+                         (loop f target vec j))))))
+    (lambda (f target vec len)
+      (loop f target vec len))))
+
+;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
+;;;     (F <index> <elt> ...) -> elt'
+(define %vector-map2+!
+  (letrec ((loop (lambda (f target vectors i)
+                   (if (zero? i)
+                       target
+                       (let ((j (- i 1)))
+                         (vector-set! target j
+                           (apply f j (vectors-ref vectors j)))
+                         (loop f target vectors j))))))
+    (lambda (f target vectors len)
+      (loop f target vectors len))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; --------------------
+;;; Constructors
+
+;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
+;;;     (F <index> <seed> ...) -> [elt seed' ...]
+;;;   The fundamental vector constructor.  Creates a vector whose
+;;;   length is LENGTH and iterates across each index K between 0 and
+;;;   LENGTH, applying F at each iteration to the current index and the
+;;;   current seeds to receive N+1 values: first, the element to put in
+;;;   the Kth slot and then N new seeds for the next iteration.
+(define vector-unfold
+  (letrec ((tabulate!                   ; Special zero-seed case.
+            (lambda (f vec i len)
+              (cond ((< i len)
+                     (vector-set! vec i (f i))
+                     (tabulate! f vec (+ i 1) len)))))
+           (unfold1!                    ; Fast path for one seed.
+            (lambda (f vec i len seed)
+              (if (< i len)
+                  (receive (elt new-seed)
+                           (f i seed)
+                    (vector-set! vec i elt)
+                    (unfold1! f vec (+ i 1) len new-seed)))))
+           (unfold2+!                   ; Slower variant for N seeds.
+            (lambda (f vec i len seeds)
+              (if (< i len)
+                  (receive (elt . new-seeds)
+                           (apply f i seeds)
+                    (vector-set! vec i elt)
+                    (unfold2+! f vec (+ i 1) len new-seeds))))))
+    (lambda (f len . initial-seeds)
+      (let ((f   (check-type procedure?  f   vector-unfold))
+            (len (check-type nonneg-int? len vector-unfold)))
+        (let ((vec (make-vector len)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec 0 len))
+                ((null? (cdr initial-seeds))
+                 (unfold1! f vec 0 len (car initial-seeds)))
+                (else
+                 (unfold2+! f vec 0 len initial-seeds)))
+          vec)))))
+
+;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
+;;;     (F <seed> ...) -> [seed' ...]
+;;;   Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
+;;;   (still exclusive with  LENGTH and inclusive with 0), not 0 to
+;;;   LENGTH as with VECTOR-UNFOLD.
+(define vector-unfold-right
+  (letrec ((tabulate!
+            (lambda (f vec i)
+              (cond ((>= i 0)
+                     (vector-set! vec i (f i))
+                     (tabulate! f vec (- i 1))))))
+           (unfold1!
+            (lambda (f vec i seed)
+              (if (>= i 0)
+                  (receive (elt new-seed)
+                           (f i seed)
+                    (vector-set! vec i elt)
+                    (unfold1! f vec (- i 1) new-seed)))))
+           (unfold2+!
+            (lambda (f vec i seeds)
+              (if (>= i 0)
+                  (receive (elt . new-seeds)
+                           (apply f i seeds)
+                    (vector-set! vec i elt)
+                    (unfold2+! f vec (- i 1) new-seeds))))))
+    (lambda (f len . initial-seeds)
+      (let ((f   (check-type procedure?  f   vector-unfold-right))
+            (len (check-type nonneg-int? len vector-unfold-right)))
+        (let ((vec (make-vector len))
+              (i (- len 1)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec i))
+                ((null? (cdr initial-seeds))
+                 (unfold1!  f vec i (car initial-seeds)))
+                (else
+                 (unfold2+! f vec i initial-seeds)))
+          vec)))))
+
+;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
+;;;   Create a newly allocated vector whose elements are the reversed
+;;;   sequence of elements between START and END in VECTOR.  START's
+;;;   default is 0; END's default is the length of VECTOR.
+(define (vector-reverse-copy vec . maybe-start+end)
+  (let-vector-start+end vector-reverse-copy vec maybe-start+end
+                        (start end)
+    (let ((new (make-vector (- end start))))
+      (%vector-reverse-copy! new 0 vec start end)
+      new)))
+
+;;; (VECTOR-CONCATENATE <vector-list>) -> vector
+;;;   Concatenate the vectors in VECTOR-LIST.  This is equivalent to
+;;;     (apply vector-append VECTOR-LIST)
+;;;   but VECTOR-APPEND tends to be implemented in terms of
+;;;   VECTOR-CONCATENATE, and some Schemes bork when the list to apply
+;;;   a function to is too long.
+;;;
+;;; Actually, they're both implemented in terms of an internal routine.
+(define (vector-concatenate vector-list)
+  (vector-concatenate:aux vector-list vector-concatenate))
+
+;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
+(define vector-concatenate:aux
+  (letrec ((compute-length
+            (lambda (vectors len callee)
+              (if (null? vectors)
+                  len
+                  (let ((vec (check-type vector? (car vectors)
+                                         callee)))
+                    (compute-length (cdr vectors)
+                                    (+ (vector-length vec) len)
+                                    callee)))))
+           (concatenate!
+            (lambda (vectors target to)
+              (if (null? vectors)
+                  target
+                  (let* ((vec1 (car vectors))
+                         (len (vector-length vec1)))
+                    (vector-copy! target to vec1 0 len)
+                    (concatenate! (cdr vectors) target
+                                  (+ to len)))))))
+    (lambda (vectors callee)
+      (cond ((null? vectors)            ;+++
+             (make-vector 0))
+            ((null? (cdr vectors))      ;+++
+             ;; Blech, we still have to allocate a new one.
+             (let* ((vec (check-type vector? (car vectors) callee))
+                    (len (vector-length vec))
+                    (new (make-vector len)))
+               (vector-copy! new 0 vec 0 len)
+               new))
+            (else
+             (let ((new-vector
+                    (make-vector (compute-length vectors 0 callee))))
+               (concatenate! vectors new-vector 0)
+               new-vector))))))
+
+
+
+;;; --------------------
+;;; Predicates
+
+;;; (VECTOR-EMPTY? <vector>) -> boolean
+;;;   Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
+;;;   is 0, and #F if not.
+(define (vector-empty? vec)
+  (let ((vec (check-type vector? vec vector-empty?)))
+    (zero? (vector-length vec))))
+
+;;; (VECTOR= <elt=?> <vector> ...) -> boolean
+;;;     (ELT=? <value> <value>) -> boolean
+;;;   Determine vector equality generalized across element comparators.
+;;;   Vectors A and B are equal iff their lengths are the same and for
+;;;   each respective elements E_a and E_b (element=? E_a E_b) returns
+;;;   a true value.  ELT=? is always applied to two arguments.  Element
+;;;   comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
+;;;   results in a true value, then (ELEMENT=? E_a E_b) must result in a
+;;;   true value.  This may be exploited to avoid multiple unnecessary
+;;;   element comparisons.  (This implementation does, but does not deal
+;;;   with the situation that ELEMENT=? is EQ? to avoid more unnecessary
+;;;   comparisons, but I believe this optimization is probably fairly
+;;;   insignificant.)
+;;;   
+;;;   If the number of vector arguments is zero or one, then #T is
+;;;   automatically returned.  If there are N vector arguments,
+;;;   VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
+;;;   compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
+;;;   are compared.  The precise order in which ELT=? is applied is not
+;;;   specified.
+(define (vector= elt=? . vectors)
+  (let ((elt=? (check-type procedure? elt=? vector=)))
+    (cond ((null? vectors)
+           #t)
+          ((null? (cdr vectors))
+           (check-type vector? (car vectors) vector=)
+           #t)
+          (else
+           (let loop ((vecs vectors))
+             (let ((vec1 (check-type vector? (car vecs) vector=))
+                   (vec2+ (cdr vecs)))
+               (or (null? vec2+)
+                   (and (binary-vector= elt=? vec1 (car vec2+))
+                        (loop vec2+)))))))))
+(define (binary-vector= elt=? vector-a vector-b)
+  (or (eq? vector-a vector-b)           ;+++
+      (let ((length-a (vector-length vector-a))
+            (length-b (vector-length vector-b)))
+        (letrec ((loop (lambda (i)
+                         (or (= i length-a)
+                             (and (< i length-b)
+                                  (test (vector-ref vector-a i)
+                                        (vector-ref vector-b i)
+                                        i)))))
+                 (test (lambda (elt-a elt-b i)
+                         (and (or (eq? elt-a elt-b) ;+++
+                                  (elt=? elt-a elt-b))
+                              (loop (+ i 1))))))
+          (and (= length-a length-b)
+               (loop 0))))))
+
+
+
+;;; --------------------
+;;; Iteration
+
+;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
+;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
+;;;   The fundamental vector iterator.  KONS is iterated over each
+;;;   index in all of the vectors in parallel, stopping at the end of
+;;;   the shortest; KONS is applied to an argument list of (list I
+;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
+;;;   value -- the state value begins with KNIL and becomes whatever
+;;;   KONS returned at the respective iteration --, and I is the
+;;;   current index in the iteration.  The iteration is strictly left-
+;;;   to-right.
+;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
+;;;       <=>
+;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
+(define (vector-fold kons knil vec . vectors)
+  (let ((kons (check-type procedure? kons vector-fold))
+        (vec  (check-type vector?    vec  vector-fold)))
+    (if (null? vectors)
+        (%vector-fold1 kons knil (vector-length vec) vec)
+        (%vector-fold2+ kons knil
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-fold)
+                        (cons vec vectors)))))
+
+;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
+;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
+;;;   The fundamental vector recursor.  Iterates in parallel across
+;;;   VECTOR ... right to left, applying KONS to the elements and the
+;;;   current state value; the state value becomes what KONS returns
+;;;   at each next iteration.  KNIL is the initial state value.
+;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
+;;;       <=>
+;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
+;;;
+;;; Not implemented in terms of a more primitive operations that might
+;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
+;;; useful elsewhere.
+(define vector-fold-right
+  (letrec ((loop1 (lambda (kons knil vec i)
+                    (if (negative? i)
+                        knil
+                        (loop1 kons (kons i knil (vector-ref vec i))
+                               vec
+                               (- i 1)))))
+           (loop2+ (lambda (kons knil vectors i)
+                     (if (negative? i)
+                         knil
+                         (loop2+ kons
+                                 (apply kons i knil
+                                        (vectors-ref vectors i))
+                                 vectors
+                                 (- i 1))))))
+    (lambda (kons knil vec . vectors)
+      (let ((kons (check-type procedure? kons vector-fold-right))
+            (vec  (check-type vector?    vec  vector-fold-right)))
+        (if (null? vectors)
+            (loop1  kons knil vec (- (vector-length vec) 1))
+            (loop2+ kons knil (cons vec vectors)
+                    (- (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-fold-right)
+                       1)))))))
+
+;;; (VECTOR-MAP <f> <vector> ...) -> vector
+;;;     (F <elt> ...) -> value ; N vectors -> N args
+;;;   Constructs a new vector of the shortest length of the vector
+;;;   arguments.  Each element at index I of the new vector is mapped
+;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
+;;;   dynamic order of application of F is unspecified.
+(define (vector-map f vec . vectors)
+  (let ((f   (check-type procedure? f   vector-map))
+        (vec (check-type vector?    vec vector-map)))
+    (if (null? vectors)
+        (let ((len (vector-length vec)))
+          (%vector-map1! f (make-vector len) vec len))
+        (let ((len (%smallest-length vectors
+                                     (vector-length vec)
+                                     vector-map)))
+          (%vector-map2+! f (make-vector len) (cons vec vectors)
+                          len)))))
+
+;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
+;;;     (F <elt> ...) -> element' ; N vectors -> N args
+;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
+;;;   into a new vector, the new mapped elements are destructively
+;;;   inserted into the first vector.  Again, the dynamic order of
+;;;   application of F is unspecified, so it is dangerous for F to
+;;;   manipulate the first VECTOR.
+(define (vector-map! f vec . vectors)
+  (let ((f   (check-type procedure? f   vector-map!))
+        (vec (check-type vector?    vec vector-map!)))
+    (if (null? vectors)
+        (%vector-map1!  f vec vec (vector-length vec))
+        (%vector-map2+! f vec (cons vec vectors)
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-map!)))
+    (unspecified-value)))
+
+;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
+;;;     (F <elt> ...) ; N vectors -> N args
+;;;   Simple vector iterator: applies F to each index in the range [0,
+;;;   LENGTH), where LENGTH is the length of the smallest vector
+;;;   argument passed, and the respective element at that index.  In
+;;;   contrast with VECTOR-MAP, F is reliably applied to each
+;;;   subsequent elements, starting at index 0 from left to right, in
+;;;   the vectors.
+(define vector-for-each
+  (letrec ((for-each1
+            (lambda (f vec i len)
+              (cond ((< i len)
+                     (f i (vector-ref vec i))
+                     (for-each1 f vec (+ i 1) len)))))
+           (for-each2+
+            (lambda (f vecs i len)
+              (cond ((< i len)
+                     (apply f i (vectors-ref vecs i))
+                     (for-each2+ f vecs (+ i 1) len))))))
+    (lambda (f vec . vectors)
+      (let ((f   (check-type procedure? f   vector-for-each))
+            (vec (check-type vector?    vec vector-for-each)))
+        (if (null? vectors)
+            (for-each1 f vec 0 (vector-length vec))
+            (for-each2+ f (cons vec vectors) 0
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-for-each)))))))
+
+;;; (VECTOR-COUNT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer
+;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
+;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
+;;;   and a count is tallied of the number of elements for which a
+;;;   true value is produced by PREDICATE?.  This count is returned.
+(define (vector-count pred? vec . vectors)
+  (let ((pred? (check-type procedure? pred? vector-count))
+        (vec   (check-type vector?    vec   vector-count)))
+    (if (null? vectors)
+        (%vector-fold1 (lambda (index count elt)
+                         (if (pred? index elt)
+                             (+ count 1)
+                             count))
+                       0
+                       (vector-length vec)
+                       vec)
+        (%vector-fold2+ (lambda (index count . elts)
+                          (if (apply pred? index elts)
+                              (+ count 1)
+                              count))
+                        0
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-count)
+                        (cons vec vectors)))))
+
+
+
+;;; --------------------
+;;; Searching
+
+;;; (VECTOR-INDEX <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Search left-to-right across VECTOR ... in parallel, returning the
+;;;   index of the first set of values VALUE ... such that (PREDICATE?
+;;;   VALUE ...) returns a true value; if no such set of elements is
+;;;   reached, return #F.
+(define (vector-index pred? vec . vectors)
+  (vector-index/skip pred? vec vectors vector-index))
+
+;;; (VECTOR-SKIP <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   (vector-index (lambda elts (not (apply PREDICATE? elts)))
+;;;                 VECTOR ...)
+;;;   Like VECTOR-INDEX, but find the index of the first set of values
+;;;   that do _not_ satisfy PREDICATE?.
+(define (vector-skip pred? vec . vectors)
+  (vector-index/skip (lambda elts (not (apply pred? elts)))
+                     vec vectors
+                     vector-skip))
+
+;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP
+(define vector-index/skip
+  (letrec ((loop1  (lambda (pred? vec len i)
+                     (cond ((= i len) #f)
+                           ((pred? (vector-ref vec i)) i)
+                           (else (loop1 pred? vec len (+ i 1))))))
+           (loop2+ (lambda (pred? vectors len i)
+                     (cond ((= i len) #f)
+                           ((apply pred? (vectors-ref vectors i)) i)
+                           (else (loop2+ pred? vectors len
+                                         (+ i 1)))))))
+    (lambda (pred? vec vectors callee)
+      (let ((pred? (check-type procedure? pred? callee))
+            (vec   (check-type vector?    vec   callee)))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec) 0)
+            (loop2+ pred? (cons vec vectors)
+                    (%smallest-length vectors
+                                      (vector-length vec)
+                                      callee)
+                    0))))))
+
+;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Right-to-left variant of VECTOR-INDEX.
+(define (vector-index-right pred? vec . vectors)
+  (vector-index/skip-right pred? vec vectors vector-index-right))
+
+;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Right-to-left variant of VECTOR-SKIP.
+(define (vector-skip-right pred? vec . vectors)
+  (vector-index/skip-right (lambda elts (not (apply pred? elts)))
+                           vec vectors
+                           vector-index-right))
+
+(define vector-index/skip-right
+  (letrec ((loop1  (lambda (pred? vec i)
+                     (cond ((negative? i) #f)
+                           ((pred? (vector-ref vec i)) i)
+                           (else (loop1 pred? vec (- i 1))))))
+           (loop2+ (lambda (pred? vectors i)
+                     (cond ((negative? i) #f)
+                           ((apply pred? (vectors-ref vectors i)) i)
+                           (else (loop2+ pred? vectors (- i 1)))))))
+    (lambda (pred? vec vectors callee)
+      (let ((pred? (check-type procedure? pred? callee))
+            (vec   (check-type vector?    vec   callee)))
+        (if (null? vectors)
+            (loop1 pred? vec (- (vector-length vec) 1))
+            (loop2+ pred? (cons vec vectors)
+                    (- (%smallest-length vectors
+                                         (vector-length vec)
+                                         callee)
+                       1)))))))
+
+;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>])
+;;;       -> exact, nonnegative integer or #F
+;;;     (CMP <value1> <value2>) -> integer
+;;;       positive -> VALUE1 > VALUE2
+;;;       zero     -> VALUE1 = VALUE2
+;;;       negative -> VALUE1 < VALUE2
+;;;   Perform a binary search through VECTOR for VALUE, comparing each
+;;;   element to VALUE with CMP.
+(define (vector-binary-search vec value cmp . maybe-start+end)
+  (let ((cmp (check-type procedure? cmp vector-binary-search)))
+    (let-vector-start+end vector-binary-search vec maybe-start+end
+                          (start end)
+      (let loop ((start start) (end end) (j #f))
+        (let ((i (quotient (+ start end) 2)))
+          (if (or (= start end) (and j (= i j)))
+              #f
+              (let ((comparison
+                     (check-type integer?
+                                 (cmp (vector-ref vec i) value)
+                                 `(,cmp for ,vector-binary-search))))
+                (cond ((zero?     comparison) i)
+                      ((positive? comparison) (loop start i i))
+                      (else                   (loop i end i))))))))))
+
+;;; (VECTOR-ANY <pred?> <vector> ...) -> value
+;;;   Apply PRED? to each parallel element in each VECTOR ...; if PRED?
+;;;   should ever return a true value, immediately stop and return that
+;;;   value; otherwise, when the shortest vector runs out, return #F.
+;;;   The iteration and order of application of PRED? across elements
+;;;   is of the vectors is strictly left-to-right.
+(define vector-any
+  (letrec ((loop1 (lambda (pred? vec i len len-1)
+                    (and (not (= i len))
+                         (if (= i len-1)
+                             (pred? (vector-ref vec i))
+                             (or (pred? (vector-ref vec i))
+                                 (loop1 pred? vec (+ i 1)
+                                        len len-1))))))
+           (loop2+ (lambda (pred? vectors i len len-1)
+                     (and (not (= i len))
+                          (if (= i len-1)
+                              (apply pred? (vectors-ref vectors i))
+                              (or (apply pred? (vectors-ref vectors i))
+                                  (loop2+ pred? vectors (+ i 1)
+                                         len len-1)))))))
+    (lambda (pred? vec . vectors)
+      (let ((pred? (check-type procedure? pred? vector-any))
+            (vec   (check-type vector?    vec   vector-any)))
+        (if (null? vectors)
+            (let ((len (vector-length vec)))
+              (loop1 pred? vec 0 len (- len 1)))
+            (let ((len (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-any)))
+              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
+
+;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
+;;;   Apply PRED? to each parallel value in each VECTOR ...; if PRED?
+;;;   should ever return #F, immediately stop and return #F; otherwise,
+;;;   if PRED? should return a true value for each element, stopping at
+;;;   the end of the shortest vector, return the last value that PRED?
+;;;   returned.  In the case that there is an empty vector, return #T.
+;;;   The iteration and order of application of PRED? across elements
+;;;   is of the vectors is strictly left-to-right.
+(define vector-every
+  (letrec ((loop1 (lambda (pred? vec i len len-1)
+                    (or (= i len)
+                        (if (= i len-1)
+                            (pred? (vector-ref vec i))
+                            (and (pred? (vector-ref vec i))
+                                 (loop1 pred? vec (+ i 1)
+                                        len len-1))))))
+           (loop2+ (lambda (pred? vectors i len len-1)
+                     (or (= i len)
+                         (if (= i len-1)
+                             (apply pred? (vectors-ref vectors i))
+                             (and (apply pred? (vectors-ref vectors i))
+                                  (loop2+ pred? vectors (+ i 1)
+                                          len len-1)))))))
+    (lambda (pred? vec . vectors)
+      (let ((pred? (check-type procedure? pred? vector-every))
+            (vec   (check-type vector?    vec   vector-every)))
+        (if (null? vectors)
+            (let ((len (vector-length vec)))
+              (loop1 pred? vec 0 len (- len 1)))
+            (let ((len (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-every)))
+              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
+
+
+
+;;; --------------------
+;;; Mutators
+
+;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
+;;;   Swap the values in the locations at INDEX1 and INDEX2.
+(define (vector-swap! vec i j)
+  (let ((vec (check-type vector? vec vector-swap!)))
+    (let ((i (check-index vec i vector-swap!))
+          (j (check-index vec j vector-swap!)))
+      (let ((x (vector-ref vec i)))
+        (vector-set! vec i (vector-ref vec j))
+        (vector-set! vec j x)))))
+
+;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
+;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source).
+(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
+  (define (doit! sstart send source-length)
+    (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!))
+          (sstart (check-type nonneg-int? sstart vector-reverse-copy!))
+          (send   (check-type nonneg-int? send vector-reverse-copy!)))
+      (cond ((and (eq? target source)
+                  (or (between? sstart tstart send)
+                      (between? tstart sstart
+                                (+ tstart (- send sstart)))))
+               (error "vector range for self-copying overlaps"
+                      vector-reverse-copy!
+                      `(vector was ,target)
+                      `(tstart was ,tstart)
+                      `(sstart was ,sstart)
+                      `(send   was ,send)))
+            ((and (<= 0 sstart send source-length)
+                  (<= (+ tstart (- send sstart)) (vector-length target)))
+             (%vector-reverse-copy! target tstart source sstart send))
+            (else
+             (error "illegal arguments"
+                    `(while calling ,vector-reverse-copy!)
+                    `(target was ,target)
+                    `(target-length was ,(vector-length target))
+                    `(tstart was ,tstart)
+                    `(source was ,source)
+                    `(source-length was ,source-length)
+                    `(sstart was ,sstart)
+                    `(send   was ,send))))))
+  (let ((n (vector-length source)))
+    (cond ((null? maybe-sstart+send)
+           (doit! 0 n n))
+          ((null? (cdr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) n n))
+          ((null? (cddr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n))
+          (else
+           (error "too many arguments"
+                  vector-reverse-copy!
+                  (cddr maybe-sstart+send))))))
+
+;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
+;;;   Destructively reverse the contents of the sequence of locations
+;;;   in VECTOR between START, whose default is 0, and END, whose
+;;;   default is the length of VECTOR.
+(define (vector-reverse! vec . start+end)
+  (let-vector-start+end vector-reverse! vec start+end
+                        (start end)
+    (%vector-reverse! vec start end)))
+
+
+
+;;; --------------------
+;;; Conversion
+
+;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
+;;;   Produce a list containing the elements in the locations between
+;;;   START, whose default is 0, and END, whose default is the length
+;;;   of VECTOR, from VECTOR, in reverse order.
+(define (reverse-vector->list vec . maybe-start+end)
+  (let-vector-start+end reverse-vector->list vec maybe-start+end
+                        (start end)
+    ;(unfold (lambda (i) (= i end))     ; No SRFI 1.
+    ;        (lambda (i) (vector-ref vec i))
+    ;        (lambda (i) (+ i 1))
+    ;        start)
+    (do ((i start (+ i 1))
+         (result '() (cons (vector-ref vec i) result)))
+        ((= i end) result))))
+
+;;; (LIST->VECTOR <list> [<start> <end>]) -> vector
+;;;   [R5RS+] Produce a vector containing the elements in LIST, which
+;;;   must be a proper list, between START, whose default is 0, & END,
+;;;   whose default is the length of LIST.  It is suggested that if the
+;;;   length of LIST is known in advance, the START and END arguments
+;;;   be passed, so that LIST->VECTOR need not call LENGTH to determine
+;;;   the the length.
+;;;
+;;; This implementation diverges on circular lists, unless LENGTH fails
+;;; and causes - to fail as well.  Given a LENGTH* that computes the
+;;; length of a list's cycle, this wouldn't diverge, and would work
+;;; great for circular lists.
+(define list->vector
+  (case-lambda
+    ((lst) (%list->vector lst))
+    ((lst start) (list->vector lst start (length lst)))
+    ((lst start end)
+     (let ((start (check-type nonneg-int? start list->vector))
+           (end   (check-type nonneg-int? end   list->vector)))
+       ((lambda (f)
+          (vector-unfold f (- end start) (list-tail lst start)))
+        (lambda (index l)
+          (cond ((null? l)
+                 (error "list was too short"
+                        `(list was ,lst)
+                        `(attempted end was ,end)
+                        `(while calling ,list->vector)))
+                ((pair? l)
+                 (values (car l) (cdr l)))
+                (else
+                 ;; Make this look as much like what CHECK-TYPE
+                 ;; would report as possible.
+                 (error "erroneous value"
+                        ;; We want SRFI 1's PROPER-LIST?, but it
+                        ;; would be a waste to link all of SRFI
+                        ;; 1 to this module for only the single
+                        ;; function PROPER-LIST?.
+                        (list list? lst)
+                        `(while calling
+                           ,list->vector))))))))))
+
+;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
+;;;   Produce a vector containing the elements in LIST, which must be a
+;;;   proper list, between START, whose default is 0, and END, whose
+;;;   default is the length of LIST, in reverse order.  It is suggested
+;;;   that if the length of LIST is known in advance, the START and END
+;;;   arguments be passed, so that REVERSE-LIST->VECTOR need not call
+;;;   LENGTH to determine the the length.
+;;;
+;;; This also diverges on circular lists unless, again, LENGTH returns
+;;; something that makes - bork.
+(define reverse-list->vector
+  (case-lambda
+    ((lst) (reverse-list->vector lst 0 (length lst)))
+    ((lst start) (reverse-list->vector start (length lst)))
+    ((lst start end)
+     (let ((start (check-type nonneg-int? start reverse-list->vector))
+           (end   (check-type nonneg-int? end   reverse-list->vector)))
+       ((lambda (f)
+          (vector-unfold-right f (- end start) (list-tail lst start)))
+        (lambda (index l)
+          (cond ((null? l)
+                 (error "list too short"
+                        `(list was ,lst)
+                        `(attempted end was ,end)
+                        `(while calling ,reverse-list->vector)))
+                ((pair? l)
+                 (values (car l) (cdr l)))
+                (else
+                 (error "erroneous value"
+                        (list list? lst)
+                        `(while calling ,reverse-list->vector))))))))))
+(define-library (srfi 43)
+  (export
+
+   ;; Constructors
+   vector-unfold vector-unfold-right
+   vector-reverse-copy
+   vector-concatenate
+
+   ;; Predicates
+   vector-empty?
+   vector=
+
+   ;; Iteration
+   vector-fold vector-fold-right
+   vector-map vector-map!
+   vector-for-each
+   vector-count
+
+   ;; Searching
+   vector-index vector-index-right
+   vector-skip vector-skip-right
+   vector-binary-search
+   vector-any vector-every
+
+   ;; Mutators
+   vector-swap!
+   vector-reverse!
+   vector-reverse-copy!
+
+   ;; Conversion
+   reverse-vector->list
+   list->vector
+   reverse-list->vector
+
+   )
+  (import
+   (rename (scheme base) (list->vector %list->vector))
+   (scheme case-lambda)
+   (scheme cxr)
+   (srfi 8)
+   (srfi aux))
+  (begin
+
+    (define-aux-forms check-type let-optionals* #\:optional)
+
+    ;; (CHECK-INDEX <vector> <index> <callee>) -> index
+    ;;   Ensure that INDEX is a valid index into VECTOR; if not, signal an
+    ;;   error stating that it is not and that this happened in a call to
+    ;;   CALLEE.  Return INDEX when it is valid.  (Note that this does NOT
+    ;;   check that VECTOR is indeed a vector.)
+    (define check-index
+      (if (debug-mode)
+          (lambda (vec index callee)
+            (let ((index (check-type integer? index callee)))
+              (cond ((< index 0)
+                     (check-index vec
+                                  (error "vector index too low"
+                                         index
+                                         `(into vector ,vec)
+                                         `(while calling ,callee))
+                                  callee))
+                    ((>= index (vector-length vec))
+                     (check-index vec
+                                  (error "vector index too high"
+                                         index
+                                         `(into vector ,vec)
+                                         `(while calling ,callee))
+                                  callee))
+                    (else index))))
+          (lambda (vec index callee)
+            index)))
+
+    ;; (CHECK-INDICES <vector>
+    ;;                <start> <start-name>
+    ;;                <end> <end-name>
+    ;;                <caller>) -> [start end]
+    ;;   Ensure that START and END are valid bounds of a range within
+    ;;   VECTOR; if not, signal an error stating that they are not, with
+    ;;   the message being informative about what the argument names were
+    ;;   called -- by using START-NAME & END-NAME --, and that it occurred
+    ;;   while calling CALLEE.  Also ensure that VEC is in fact a vector.
+    ;;   Returns no useful value.
+    (define check-indices
+      (if (debug-mode)
+          (lambda (vec start start-name end end-name callee)
+            (let ((lose (lambda things
+                          (apply error "vector range out of bounds"
+                                 (append things
+                                         `(vector was ,vec)
+                                         `(,start-name was ,start)
+                                         `(,end-name was ,end)
+                                         `(while calling ,callee)))))
+                  (start (check-type integer? start callee))
+                  (end   (check-type integer? end   callee)))
+              (cond ((> start end)
+                     ;; I'm not sure how well this will work.  The intent is that
+                     ;; the programmer tells the debugger to proceed with both a
+                     ;; new START & a new END by returning multiple values
+                     ;; somewhere.
+                     (receive (new-start new-end)
+                         (lose `(,end-name < ,start-name))
+                       (check-indices vec
+                                      new-start start-name
+                                      new-end end-name
+                                      callee)))
+                    ((< start 0)
+                     (check-indices vec
+                                    (lose `(,start-name < 0))
+                                    start-name
+                                    end end-name
+                                    callee))
+                    ((>= start (vector-length vec))
+                     (check-indices vec
+                                    (lose `(,start-name > len)
+                                          `(len was ,(vector-length vec)))
+                                    start-name
+                                    end end-name
+                                    callee))
+                    ((> end (vector-length vec))
+                     (check-indices vec
+                                    start start-name
+                                    (lose `(,end-name > len)
+                                          `(len was ,(vector-length vec)))
+                                    end-name
+                                    callee))
+                    (else
+                     (values start end)))))
+          (lambda (vec start start-name end end-name callee)
+            (values start end))))
+
+    )
+  (include "43.body.scm"))
+(define-library (srfi 95)
+  (export sorted? merge merge! sort sort!)
+  (import
+   (except (scheme base) equal?)
+   (srfi 63))
+  (include "95.body.scm"))
+;;;;;; SRFI 43: Vector library                           -*- Scheme -*-
+;;;
+;;; $Id: vector-lib.scm,v 1.7 2009/03/29 09:46:03 sperber Exp $
+;;;
+;;; Taylor Campbell wrote this code; he places it in the public domain.
+;;; Will Clinger [wdc] made some corrections, also in the public domain.
+
+;;; Copyright (C) Taylor Campbell (2003). All rights reserved.
+
+;;; 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.
+
+;;; --------------------
+;;; Exported procedure index
+;;;
+;;; * Constructors
+;;; make-vector vector
+;;; vector-unfold                   vector-unfold-right
+;;; vector-copy                     vector-reverse-copy
+;;; vector-append                   vector-concatenate
+;;;
+;;; * Predicates
+;;; vector?
+;;; vector-empty?
+;;; vector=
+;;;
+;;; * Selectors
+;;; vector-ref
+;;; vector-length
+;;;
+;;; * Iteration
+;;; vector-fold                     vector-fold-right
+;;; vector-map                      vector-map!
+;;; vector-for-each
+;;; vector-count
+;;;
+;;; * Searching
+;;; vector-index                    vector-skip
+;;; vector-index-right              vector-skip-right
+;;; vector-binary-search
+;;; vector-any                      vector-every
+;;;
+;;; * Mutators
+;;; vector-set!
+;;; vector-swap!
+;;; vector-fill!
+;;; vector-reverse!
+;;; vector-copy!                    vector-reverse-copy!
+;;; vector-reverse!
+;;;
+;;; * Conversion
+;;; vector->list                    reverse-vector->list
+;;; list->vector                    reverse-list->vector
+
+
+
+;;; --------------------
+;;; Commentary on efficiency of the code
+
+;;; This code is somewhat tuned for efficiency.  There are several
+;;; internal routines that can be optimized greatly to greatly improve
+;;; the performance of much of the library.  These internal procedures
+;;; are already carefully tuned for performance, and lambda-lifted by
+;;; hand.  Some other routines are lambda-lifted by hand, but only the
+;;; loops are lambda-lifted, and only if some routine has two possible
+;;; loops -- a fast path and an n-ary case --, whereas _all_ of the
+;;; internal routines' loops are lambda-lifted so as to never cons a
+;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop),
+;;; even in Scheme systems that perform no loop optimization (which is
+;;; most of them, unfortunately).
+;;;
+;;; Fast paths are provided for common cases in most of the loops in
+;;; this library.
+;;;
+;;; All calls to primitive vector operations are protected by a prior
+;;; type check; they can be safely converted to use unsafe equivalents
+;;; of the operations, if available.  Ideally, the compiler should be
+;;; able to determine this, but the state of Scheme compilers today is
+;;; not a happy one.
+;;;
+;;; Efficiency of the actual algorithms is a rather mundane point to
+;;; mention; vector operations are rarely beyond being straightforward.
+
+
+
+;;; --------------------
+;;; Utilities
+
+;;; SRFI 8, too trivial to put in the dependencies list.
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?formals ?producer ?body1 ?body2 ...)
+     (call-with-values (lambda () ?producer)
+       (lambda ?formals ?body1 ?body2 ...)))))
+
+;;; Not the best LET*-OPTIONALS, but not the worst, either.  Use Olin's
+;;; if it's available to you.
+(define-syntax let*-optionals
+  (syntax-rules ()
+    ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...)
+     (let ((args (?x ...)))
+       (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...)))
+    ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...)
+     (let*-optionals:aux ?args ?args ((?var ?default) ...)
+       ?body1 ?body2 ...))))
+
+(define-syntax let*-optionals:aux
+  (syntax-rules ()
+    ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...)
+     (if (null? ?args-var)
+         (let () ?body1 ?body2 ...)
+         (error "too many arguments" (length ?orig-args-var)
+                ?orig-args-var)))
+    ((aux ?orig-args-var ?args-var
+         ((?var ?default) ?more ...)
+       ?body1 ?body2 ...)
+     (if (null? ?args-var)
+         (let* ((?var ?default) ?more ...) ?body1 ?body2 ...)
+         (let ((?var (car ?args-var))
+               (new-args (cdr ?args-var)))
+           (let*-optionals:aux ?orig-args-var new-args
+               (?more ...)
+             ?body1 ?body2 ...))))))
+
+(define (nonneg-int? x)
+  (and (integer? x)
+       (not (negative? x))))
+
+(define (between? x y z)
+  (and (<  x y)
+       (<= y z)))
+
+(define (unspecified-value) (if #f #f))
+
+;++ This should be implemented more efficiently.  It shouldn't cons a
+;++ closure, and the cons cells used in the loops when using this could
+;++ be reused.
+(define (vectors-ref vectors i)
+  (map (lambda (v) (vector-ref v i)) vectors))
+
+
+
+;;; --------------------
+;;; Error checking
+
+;;; Error signalling (not checking) is done in a way that tries to be
+;;; as helpful to the person who gets the debugging prompt as possible.
+;;; That said, error _checking_ tries to be as unredundant as possible.
+
+;;; I don't use any sort of general condition mechanism; I use simply
+;;; SRFI 23's ERROR, even in cases where it might be better to use such
+;;; a general condition mechanism.  Fix that when porting this to a
+;;; Scheme implementation that has its own condition system.
+
+;;; In argument checks, upon receiving an invalid argument, the checker
+;;; procedure recursively calls itself, but in one of the arguments to
+;;; itself is a call to ERROR; this mechanism is used in the hopes that
+;;; the user may be thrown into a debugger prompt, proceed with another
+;;; value, and let it be checked again.
+
+;;; Type checking is pretty basic, but easily factored out and replaced
+;;; with whatever your implementation's preferred type checking method
+;;; is.  I doubt there will be many other methods of index checking,
+;;; though the index checkers might be better implemented natively.
+
+;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
+;;;   Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
+;;;   error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
+;;;   that this happened while calling CALLEE.  Return VALUE if no
+;;;   error was signalled.
+(define (check-type pred? value callee)
+  (if (pred? value)
+      value
+      ;; Recur: when (or if) the user gets a debugger prompt, he can
+      ;; proceed where the call to ERROR was with the correct value.
+      (check-type pred?
+                  (error "erroneous value"
+                         (list pred? value)
+                         `(while calling ,callee))
+                  callee)))
+
+;;; (CHECK-INDEX <vector> <index> <callee>) -> index
+;;;   Ensure that INDEX is a valid index into VECTOR; if not, signal an
+;;;   error stating that it is not and that this happened in a call to
+;;;   CALLEE.  Return INDEX when it is valid.  (Note that this does NOT
+;;;   check that VECTOR is indeed a vector.)
+(define (check-index vec index callee)
+  (let ((index (check-type integer? index callee)))
+    (cond ((< index 0)
+           (check-index vec
+                        (error "vector index too low"
+                               index
+                               `(into vector ,vec)
+                               `(while calling ,callee))
+                        callee))
+          ((>= index (vector-length vec))
+           (check-index vec
+                        (error "vector index too high"
+                               index
+                               `(into vector ,vec)
+                               `(while calling ,callee))
+                        callee))
+          (else index))))
+
+;;; (CHECK-INDICES <vector>
+;;;                <start> <start-name>
+;;;                <end> <end-name>
+;;;                <caller>) -> [start end]
+;;;   Ensure that START and END are valid bounds of a range within
+;;;   VECTOR; if not, signal an error stating that they are not, with
+;;;   the message being informative about what the argument names were
+;;;   called -- by using START-NAME & END-NAME --, and that it occurred
+;;;   while calling CALLEE.  Also ensure that VEC is in fact a vector.
+;;;   Returns no useful value.
+(define (check-indices vec start start-name end end-name callee)
+  (let ((lose (lambda things
+                (apply error "vector range out of bounds"
+                       (append things
+                               `(vector was ,vec)
+                               `(,start-name was ,start)
+                               `(,end-name was ,end)
+                               `(while calling ,callee)))))
+        (start (check-type integer? start callee))
+        (end   (check-type integer? end   callee)))
+    (cond ((> start end)
+           ;; I'm not sure how well this will work.  The intent is that
+           ;; the programmer tells the debugger to proceed with both a
+           ;; new START & a new END by returning multiple values
+           ;; somewhere.
+           (receive (new-start new-end)
+                    (lose `(,end-name < ,start-name))
+             (check-indices vec
+                            new-start start-name
+                            new-end end-name
+                            callee)))
+          ((< start 0)
+           (check-indices vec
+                          (lose `(,start-name < 0))
+                          start-name
+                          end end-name
+                          callee))
+          ((>= start (vector-length vec))
+           (check-indices vec
+                          (lose `(,start-name > len)
+                                `(len was ,(vector-length vec)))
+                          start-name
+                          end end-name
+                          callee))
+          ((> end (vector-length vec))
+           (check-indices vec
+                          start start-name
+                          (lose `(,end-name > len)
+                                `(len was ,(vector-length vec)))
+                          end-name
+                          callee))
+          (else
+           (values start end)))))
+
+
+
+;;; --------------------
+;;; Internal routines
+
+;;; These should all be integrated, native, or otherwise optimized --
+;;; they're used a _lot_ --.  All of the loops and LETs inside loops
+;;; are lambda-lifted by hand, just so as not to cons closures in the
+;;; loops.  (If your compiler can do better than that if they're not
+;;; lambda-lifted, then lambda-drop (?) them.)
+
+;;; (VECTOR-PARSE-START+END <vector> <arguments>
+;;;                         <start-name> <end-name>
+;;;                         <callee>)
+;;;       -> [start end]
+;;;   Return two values, composing a valid range within VECTOR, as
+;;;   extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START
+;;;   and the length of VECTOR for END --; START-NAME and END-NAME are
+;;;   purely for error checking.
+(define (vector-parse-start+end vec args start-name end-name callee)
+  (let ((len (vector-length vec)))
+    (cond ((null? args)
+           (values 0 len))
+          ((null? (cdr args))
+           (check-indices vec
+                          (car args) start-name
+                          len end-name
+                          callee))
+          ((null? (cddr args))
+           (check-indices vec
+                          (car  args) start-name
+                          (cadr args) end-name
+                          callee))
+          (else
+           (error "too many arguments"
+                  `(extra args were ,(cddr args))
+                  `(while calling ,callee))))))
+
+(define-syntax let-vector-start+end
+  (syntax-rules ()
+    ((let-vector-start+end ?callee ?vec ?args (?start ?end)
+       ?body1 ?body2 ...)
+     (let ((?vec (check-type vector? ?vec ?callee)))
+       (receive (?start ?end)
+                (vector-parse-start+end ?vec ?args '?start '?end
+                                        ?callee)
+         ?body1 ?body2 ...)))))
+
+;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
+;;;       -> exact, nonnegative integer
+;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
+;;;   the length that is returned if VECTOR-LIST is empty.  Common use
+;;;   of this is in n-ary vector routines:
+;;;     (define (f vec . vectors)
+;;;       (let ((vec (check-type vector? vec f)))
+;;;         ...(%smallest-length vectors (vector-length vec) f)...))
+;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
+;;;   the CALLEE argument is for --; thus, the design is tuned for
+;;;   avoiding redundant type checks.
+(define %smallest-length
+  (letrec ((loop (lambda (vector-list length callee)
+                   (if (null? vector-list)
+                       length
+                       (loop (cdr vector-list)
+                             (min (vector-length
+                                   (check-type vector?
+                                               (car vector-list)
+                                               callee))
+                                  length)
+                             callee)))))
+    loop))
+
+;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
+;;;   Copy elements at locations SSTART to SEND from SOURCE to TARGET,
+;;;   starting at TSTART in TARGET.
+;;;
+;;; Optimize this!  Probably with some combination of:
+;;;   - Force it to be integrated.
+;;;   - Let it use unsafe vector element dereferencing routines: bounds
+;;;     checking already happens outside of it.  (Or use a compiler
+;;;     that figures this out, but Olin Shivers' PhD thesis seems to
+;;;     have been largely ignored in actual implementations...)
+;;;   - Implement it natively as a VM primitive: the VM can undoubtedly
+;;;     perform much faster than it can make Scheme perform, even with
+;;;     bounds checking.
+;;;   - Implement it in assembly: you _want_ the fine control that
+;;;     assembly can give you for this.
+;;; I already lambda-lift it by hand, but you should be able to make it
+;;; even better than that.
+(define %vector-copy!
+  (letrec ((loop/l->r (lambda (target source send i j)
+                        (cond ((< i send)
+                               (vector-set! target j
+                                            (vector-ref source i))
+                               (loop/l->r target source send
+                                          (+ i 1) (+ j 1))))))
+           (loop/r->l (lambda (target source sstart i j)
+                        (cond ((>= i sstart)
+                               (vector-set! target j
+                                            (vector-ref source i))
+                               (loop/r->l target source sstart
+                                          (- i 1) (- j 1)))))))
+    (lambda (target tstart source sstart send)
+      (if (> sstart tstart)             ; Make sure we don't copy over
+                                        ;   ourselves.
+          (loop/l->r target source send sstart tstart)
+          (loop/r->l target source sstart (- send 1)
+                     (+ -1 tstart send (- sstart)))))))
+
+;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
+;;;   Copy elements from SSTART to SEND from SOURCE to TARGET, in the
+;;;   reverse order.
+(define %vector-reverse-copy!
+  (letrec ((loop (lambda (target source sstart i j)
+                   (cond ((>= i sstart)
+                          (vector-set! target j (vector-ref source i))
+                          (loop target source sstart
+                                (- i 1)
+                                (+ j 1)))))))
+    (lambda (target tstart source sstart send)
+      (loop target source sstart
+            (- send 1)
+            tstart))))
+
+;;; (%VECTOR-REVERSE! <vector>)
+(define %vector-reverse!
+  (letrec ((loop (lambda (vec i j)
+                   (cond ((<= i j)
+                          (let ((v (vector-ref vec i)))
+                            (vector-set! vec i (vector-ref vec j))
+                            (vector-set! vec j v)
+                            (loop vec (+ i 1) (- j 1))))))))
+    (lambda (vec start end)
+      (loop vec start (- end 1)))))
+
+;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
+;;;     (KONS <index> <knil> <elt>) -> knil'
+(define %vector-fold1
+  (letrec ((loop (lambda (kons knil len vec i)
+                   (if (= i len)
+                       knil
+                       (loop kons
+                             (kons i knil (vector-ref vec i))
+                             len vec (+ i 1))))))
+    (lambda (kons knil len vec)
+      (loop kons knil len vec 0))))
+
+;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
+;;;     (KONS <index> <knil> <elt> ...) -> knil'
+(define %vector-fold2+
+  (letrec ((loop (lambda (kons knil len vectors i)
+                   (if (= i len)
+                       knil
+                       (loop kons
+                             (apply kons i knil
+                                    (vectors-ref vectors i))
+                             len vectors (+ i 1))))))
+    (lambda (kons knil len vectors)
+      (loop kons knil len vectors 0))))
+
+;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
+;;;     (F <index> <elt>) -> elt'
+(define %vector-map1!
+  (letrec ((loop (lambda (f target vec i)
+                   (if (zero? i)
+                       target
+                       (let ((j (- i 1)))
+                         (vector-set! target j
+                                      (f j (vector-ref vec j)))
+                         (loop f target vec j))))))
+    (lambda (f target vec len)
+      (loop f target vec len))))
+
+;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
+;;;     (F <index> <elt> ...) -> elt'
+(define %vector-map2+!
+  (letrec ((loop (lambda (f target vectors i)
+                   (if (zero? i)
+                       target
+                       (let ((j (- i 1)))
+                         (vector-set! target j
+                           (apply f j (vectors-ref vectors j)))
+                         (loop f target vectors j))))))
+    (lambda (f target vectors len)
+      (loop f target vectors len))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; --------------------
+;;; Constructors
+
+;;; (MAKE-VECTOR <size> [<fill>]) -> vector
+;;;   [R5RS] Create a vector of length LENGTH.  If FILL is present,
+;;;   initialize each slot in the vector with it; if not, the vector's
+;;;   initial contents are unspecified.
+(define make-vector make-vector)
+
+;;; (VECTOR <elt> ...) -> vector
+;;;   [R5RS] Create a vector containing ELEMENT ..., in order.
+(define vector vector)
+
+;;; This ought to be able to be implemented much more efficiently -- if
+;;; we have the number of arguments available to us, we can create the
+;;; vector without using LENGTH to determine the number of elements it
+;;; should have.
+;(define (vector . elements) (list->vector elements))
+
+;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
+;;;     (F <index> <seed> ...) -> [elt seed' ...]
+;;;   The fundamental vector constructor.  Creates a vector whose
+;;;   length is LENGTH and iterates across each index K between 0 and
+;;;   LENGTH, applying F at each iteration to the current index and the
+;;;   current seeds to receive N+1 values: first, the element to put in
+;;;   the Kth slot and then N new seeds for the next iteration.
+(define vector-unfold
+  (letrec ((tabulate!                   ; Special zero-seed case.
+            (lambda (f vec i len)
+              (cond ((< i len)
+                     (vector-set! vec i (f i))
+                     (tabulate! f vec (+ i 1) len)))))
+           (unfold1!                    ; Fast path for one seed.
+            (lambda (f vec i len seed)
+              (if (< i len)
+                  (receive (elt new-seed)
+                           (f i seed)
+                    (vector-set! vec i elt)
+                    (unfold1! f vec (+ i 1) len new-seed)))))
+           (unfold2+!                   ; Slower variant for N seeds.
+            (lambda (f vec i len seeds)
+              (if (< i len)
+                  (receive (elt . new-seeds)
+                           (apply f i seeds)
+                    (vector-set! vec i elt)
+                    (unfold2+! f vec (+ i 1) len new-seeds))))))
+    (lambda (f len . initial-seeds)
+      (let ((f   (check-type procedure?  f   vector-unfold))
+            (len (check-type nonneg-int? len vector-unfold)))
+        (let ((vec (make-vector len)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec 0 len))
+                ((null? (cdr initial-seeds))
+                 (unfold1! f vec 0 len (car initial-seeds)))
+                (else
+                 (unfold2+! f vec 0 len initial-seeds)))
+          vec)))))
+
+;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
+;;;     (F <seed> ...) -> [seed' ...]
+;;;   Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
+;;;   (still exclusive with  LENGTH and inclusive with 0), not 0 to
+;;;   LENGTH as with VECTOR-UNFOLD.
+(define vector-unfold-right
+  (letrec ((tabulate!
+            (lambda (f vec i)
+              (cond ((>= i 0)
+                     (vector-set! vec i (f i))
+                     (tabulate! f vec (- i 1))))))
+           (unfold1!
+            (lambda (f vec i seed)
+              (if (>= i 0)
+                  (receive (elt new-seed)
+                           (f i seed)
+                    (vector-set! vec i elt)
+                    (unfold1! f vec (- i 1) new-seed)))))
+           (unfold2+!
+            (lambda (f vec i seeds)
+              (if (>= i 0)
+                  (receive (elt . new-seeds)
+                           (apply f i seeds)
+                    (vector-set! vec i elt)
+                    (unfold2+! f vec (- i 1) new-seeds))))))
+    (lambda (f len . initial-seeds)
+      (let ((f   (check-type procedure?  f   vector-unfold-right))
+            (len (check-type nonneg-int? len vector-unfold-right)))
+        (let ((vec (make-vector len))
+              (i (- len 1)))
+          (cond ((null? initial-seeds)
+                 (tabulate! f vec i))
+                ((null? (cdr initial-seeds))
+                 (unfold1!  f vec i (car initial-seeds)))
+                (else
+                 (unfold2+! f vec i initial-seeds)))
+          vec)))))
+
+;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
+;;;   Create a newly allocated vector containing the elements from the
+;;;   range [START,END) in VECTOR.  START defaults to 0; END defaults
+;;;   to the length of VECTOR.  END may be greater than the length of
+;;;   VECTOR, in which case the vector is enlarged; if FILL is passed,
+;;;   the new locations from which there is no respective element in
+;;;   VECTOR are filled with FILL.
+(define (vector-copy vec . args)
+  (let ((vec (check-type vector? vec vector-copy)))
+    ;; We can't use LET-VECTOR-START+END, because we have one more
+    ;; argument, and we want finer control, too.
+    ;;
+    ;; Olin's implementation of LET*-OPTIONALS would prove useful here:
+    ;; the built-in argument-checks-as-you-go-along produces almost
+    ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS.
+    (receive (start end fill)
+             (vector-copy:parse-args vec args)
+      (let ((new-vector (make-vector (- end start) fill)))
+        (%vector-copy! new-vector 0
+                       vec        start
+                       (if (> end (vector-length vec))
+                           (vector-length vec)
+                           end))
+        new-vector))))
+
+;;; Auxiliary for VECTOR-COPY.
+;;; [wdc] Corrected to allow 0 <= start <= (vector-length vec).
+(define (vector-copy:parse-args vec args)
+  (define (parse-args start end n fill)
+    (let ((start (check-type nonneg-int? start vector-copy))
+          (end   (check-type nonneg-int? end vector-copy)))
+      (cond ((and (<= 0 start end)
+                  (<= start n))
+             (values start end fill))
+            (else
+             (error "illegal arguments"
+                    `(while calling ,vector-copy)
+                    `(start was ,start)
+                    `(end was ,end)
+                    `(vector was ,vec))))))
+  (let ((n (vector-length vec)))
+    (cond ((null? args)
+           (parse-args 0 n n (unspecified-value)))
+          ((null? (cdr args))
+           (parse-args (car args) n n (unspecified-value)))
+          ((null? (cddr args))
+           (parse-args (car args) (cadr args) n (unspecified-value)))
+          ((null? (cdddr args))
+           (parse-args (car args) (cadr args) n (caddr args)))
+          (else
+           (error "too many arguments"
+                  vector-copy
+                  (cdddr args))))))
+
+;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
+;;;   Create a newly allocated vector whose elements are the reversed
+;;;   sequence of elements between START and END in VECTOR.  START's
+;;;   default is 0; END's default is the length of VECTOR.
+(define (vector-reverse-copy vec . maybe-start+end)
+  (let-vector-start+end vector-reverse-copy vec maybe-start+end
+                        (start end)
+    (let ((new (make-vector (- end start))))
+      (%vector-reverse-copy! new 0 vec start end)
+      new)))
+
+;;; (VECTOR-APPEND <vector> ...) -> vector
+;;;   Append VECTOR ... into a newly allocated vector and return that
+;;;   new vector.
+(define (vector-append . vectors)
+  (vector-concatenate:aux vectors vector-append))
+
+;;; (VECTOR-CONCATENATE <vector-list>) -> vector
+;;;   Concatenate the vectors in VECTOR-LIST.  This is equivalent to
+;;;     (apply vector-append VECTOR-LIST)
+;;;   but VECTOR-APPEND tends to be implemented in terms of
+;;;   VECTOR-CONCATENATE, and some Schemes bork when the list to apply
+;;;   a function to is too long.
+;;;
+;;; Actually, they're both implemented in terms of an internal routine.
+(define (vector-concatenate vector-list)
+  (vector-concatenate:aux vector-list vector-concatenate))
+
+;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
+(define vector-concatenate:aux
+  (letrec ((compute-length
+            (lambda (vectors len callee)
+              (if (null? vectors)
+                  len
+                  (let ((vec (check-type vector? (car vectors)
+                                         callee)))
+                    (compute-length (cdr vectors)
+                                    (+ (vector-length vec) len)
+                                    callee)))))
+           (concatenate!
+            (lambda (vectors target to)
+              (if (null? vectors)
+                  target
+                  (let* ((vec1 (car vectors))
+                         (len (vector-length vec1)))
+                    (%vector-copy! target to vec1 0 len)
+                    (concatenate! (cdr vectors) target
+                                  (+ to len)))))))
+    (lambda (vectors callee)
+      (cond ((null? vectors)            ;+++
+             (make-vector 0))
+            ((null? (cdr vectors))      ;+++
+             ;; Blech, we still have to allocate a new one.
+             (let* ((vec (check-type vector? (car vectors) callee))
+                    (len (vector-length vec))
+                    (new (make-vector len)))
+               (%vector-copy! new 0 vec 0 len)
+               new))
+            (else
+             (let ((new-vector
+                    (make-vector (compute-length vectors 0 callee))))
+               (concatenate! vectors new-vector 0)
+               new-vector))))))
+
+
+
+;;; --------------------
+;;; Predicates
+
+;;; (VECTOR? <value>) -> boolean
+;;;   [R5RS] Return #T if VALUE is a vector and #F if not.
+(define vector? vector?)
+
+;;; (VECTOR-EMPTY? <vector>) -> boolean
+;;;   Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
+;;;   is 0, and #F if not.
+(define (vector-empty? vec)
+  (let ((vec (check-type vector? vec vector-empty?)))
+    (zero? (vector-length vec))))
+
+;;; (VECTOR= <elt=?> <vector> ...) -> boolean
+;;;     (ELT=? <value> <value>) -> boolean
+;;;   Determine vector equality generalized across element comparators.
+;;;   Vectors A and B are equal iff their lengths are the same and for
+;;;   each respective elements E_a and E_b (element=? E_a E_b) returns
+;;;   a true value.  ELT=? is always applied to two arguments.  Element
+;;;   comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
+;;;   results in a true value, then (ELEMENT=? E_a E_b) must result in a
+;;;   true value.  This may be exploited to avoid multiple unnecessary
+;;;   element comparisons.  (This implementation does, but does not deal
+;;;   with the situation that ELEMENT=? is EQ? to avoid more unnecessary
+;;;   comparisons, but I believe this optimization is probably fairly
+;;;   insignificant.)
+;;;   
+;;;   If the number of vector arguments is zero or one, then #T is
+;;;   automatically returned.  If there are N vector arguments,
+;;;   VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
+;;;   compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
+;;;   are compared.  The precise order in which ELT=? is applied is not
+;;;   specified.
+(define (vector= elt=? . vectors)
+  (let ((elt=? (check-type procedure? elt=? vector=)))
+    (cond ((null? vectors)
+           #t)
+          ((null? (cdr vectors))
+           (check-type vector? (car vectors) vector=)
+           #t)
+          (else
+           (let loop ((vecs vectors))
+             (let ((vec1 (check-type vector? (car vecs) vector=))
+                   (vec2+ (cdr vecs)))
+               (or (null? vec2+)
+                   (and (binary-vector= elt=? vec1 (car vec2+))
+                        (loop vec2+)))))))))
+(define (binary-vector= elt=? vector-a vector-b)
+  (or (eq? vector-a vector-b)           ;+++
+      (let ((length-a (vector-length vector-a))
+            (length-b (vector-length vector-b)))
+        (letrec ((loop (lambda (i)
+                         (or (= i length-a)
+                             (and (< i length-b)
+                                  (test (vector-ref vector-a i)
+                                        (vector-ref vector-b i)
+                                        i)))))
+                 (test (lambda (elt-a elt-b i)
+                         (and (or (eq? elt-a elt-b) ;+++
+                                  (elt=? elt-a elt-b))
+                              (loop (+ i 1))))))
+          (and (= length-a length-b)
+               (loop 0))))))
+
+
+
+;;; --------------------
+;;; Selectors
+
+;;; (VECTOR-REF <vector> <index>) -> value
+;;;   [R5RS] Return the value that the location in VECTOR at INDEX is
+;;;   mapped to in the store.
+(define vector-ref vector-ref)
+
+;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer
+;;;   [R5RS] Return the length of VECTOR.
+(define vector-length vector-length)
+
+
+
+;;; --------------------
+;;; Iteration
+
+;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
+;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
+;;;   The fundamental vector iterator.  KONS is iterated over each
+;;;   index in all of the vectors in parallel, stopping at the end of
+;;;   the shortest; KONS is applied to an argument list of (list I
+;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
+;;;   value -- the state value begins with KNIL and becomes whatever
+;;;   KONS returned at the respective iteration --, and I is the
+;;;   current index in the iteration.  The iteration is strictly left-
+;;;   to-right.
+;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
+;;;       <=>
+;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
+(define (vector-fold kons knil vec . vectors)
+  (let ((kons (check-type procedure? kons vector-fold))
+        (vec  (check-type vector?    vec  vector-fold)))
+    (if (null? vectors)
+        (%vector-fold1 kons knil (vector-length vec) vec)
+        (%vector-fold2+ kons knil
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-fold)
+                        (cons vec vectors)))))
+
+;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
+;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
+;;;   The fundamental vector recursor.  Iterates in parallel across
+;;;   VECTOR ... right to left, applying KONS to the elements and the
+;;;   current state value; the state value becomes what KONS returns
+;;;   at each next iteration.  KNIL is the initial state value.
+;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
+;;;       <=>
+;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
+;;;
+;;; Not implemented in terms of a more primitive operations that might
+;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
+;;; useful elsewhere.
+(define vector-fold-right
+  (letrec ((loop1 (lambda (kons knil vec i)
+                    (if (negative? i)
+                        knil
+                        (loop1 kons (kons i knil (vector-ref vec i))
+                               vec
+                               (- i 1)))))
+           (loop2+ (lambda (kons knil vectors i)
+                     (if (negative? i)
+                         knil
+                         (loop2+ kons
+                                 (apply kons i knil
+                                        (vectors-ref vectors i))
+                                 vectors
+                                 (- i 1))))))
+    (lambda (kons knil vec . vectors)
+      (let ((kons (check-type procedure? kons vector-fold-right))
+            (vec  (check-type vector?    vec  vector-fold-right)))
+        (if (null? vectors)
+            (loop1  kons knil vec (- (vector-length vec) 1))
+            (loop2+ kons knil (cons vec vectors)
+                    (- (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-fold-right)
+                       1)))))))
+
+;;; (VECTOR-MAP <f> <vector> ...) -> vector
+;;;     (F <elt> ...) -> value ; N vectors -> N args
+;;;   Constructs a new vector of the shortest length of the vector
+;;;   arguments.  Each element at index I of the new vector is mapped
+;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
+;;;   dynamic order of application of F is unspecified.
+(define (vector-map f vec . vectors)
+  (let ((f   (check-type procedure? f   vector-map))
+        (vec (check-type vector?    vec vector-map)))
+    (if (null? vectors)
+        (let ((len (vector-length vec)))
+          (%vector-map1! f (make-vector len) vec len))
+        (let ((len (%smallest-length vectors
+                                     (vector-length vec)
+                                     vector-map)))
+          (%vector-map2+! f (make-vector len) (cons vec vectors)
+                          len)))))
+
+;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
+;;;     (F <elt> ...) -> element' ; N vectors -> N args
+;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
+;;;   into a new vector, the new mapped elements are destructively
+;;;   inserted into the first vector.  Again, the dynamic order of
+;;;   application of F is unspecified, so it is dangerous for F to
+;;;   manipulate the first VECTOR.
+(define (vector-map! f vec . vectors)
+  (let ((f   (check-type procedure? f   vector-map!))
+        (vec (check-type vector?    vec vector-map!)))
+    (if (null? vectors)
+        (%vector-map1!  f vec vec (vector-length vec))
+        (%vector-map2+! f vec (cons vec vectors)
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-map!)))
+    (unspecified-value)))
+
+;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
+;;;     (F <elt> ...) ; N vectors -> N args
+;;;   Simple vector iterator: applies F to each index in the range [0,
+;;;   LENGTH), where LENGTH is the length of the smallest vector
+;;;   argument passed, and the respective element at that index.  In
+;;;   contrast with VECTOR-MAP, F is reliably applied to each
+;;;   subsequent elements, starting at index 0 from left to right, in
+;;;   the vectors.
+(define vector-for-each
+  (letrec ((for-each1
+            (lambda (f vec i len)
+              (cond ((< i len)
+                     (f i (vector-ref vec i))
+                     (for-each1 f vec (+ i 1) len)))))
+           (for-each2+
+            (lambda (f vecs i len)
+              (cond ((< i len)
+                     (apply f i (vectors-ref vecs i))
+                     (for-each2+ f vecs (+ i 1) len))))))
+    (lambda (f vec . vectors)
+      (let ((f   (check-type procedure? f   vector-for-each))
+            (vec (check-type vector?    vec vector-for-each)))
+        (if (null? vectors)
+            (for-each1 f vec 0 (vector-length vec))
+            (for-each2+ f (cons vec vectors) 0
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-for-each)))))))
+
+;;; (VECTOR-COUNT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer
+;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
+;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
+;;;   and a count is tallied of the number of elements for which a
+;;;   true value is produced by PREDICATE?.  This count is returned.
+(define (vector-count pred? vec . vectors)
+  (let ((pred? (check-type procedure? pred? vector-count))
+        (vec   (check-type vector?    vec   vector-count)))
+    (if (null? vectors)
+        (%vector-fold1 (lambda (index count elt)
+                         (if (pred? index elt)
+                             (+ count 1)
+                             count))
+                       0
+                       (vector-length vec)
+                       vec)
+        (%vector-fold2+ (lambda (index count . elts)
+                          (if (apply pred? index elts)
+                              (+ count 1)
+                              count))
+                        0
+                        (%smallest-length vectors
+                                          (vector-length vec)
+                                          vector-count)
+                        (cons vec vectors)))))
+
+
+
+;;; --------------------
+;;; Searching
+
+;;; (VECTOR-INDEX <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Search left-to-right across VECTOR ... in parallel, returning the
+;;;   index of the first set of values VALUE ... such that (PREDICATE?
+;;;   VALUE ...) returns a true value; if no such set of elements is
+;;;   reached, return #F.
+(define (vector-index pred? vec . vectors)
+  (vector-index/skip pred? vec vectors vector-index))
+
+;;; (VECTOR-SKIP <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   (vector-index (lambda elts (not (apply PREDICATE? elts)))
+;;;                 VECTOR ...)
+;;;   Like VECTOR-INDEX, but find the index of the first set of values
+;;;   that do _not_ satisfy PREDICATE?.
+(define (vector-skip pred? vec . vectors)
+  (vector-index/skip (lambda elts (not (apply pred? elts)))
+                     vec vectors
+                     vector-skip))
+
+;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP
+(define vector-index/skip
+  (letrec ((loop1  (lambda (pred? vec len i)
+                     (cond ((= i len) #f)
+                           ((pred? (vector-ref vec i)) i)
+                           (else (loop1 pred? vec len (+ i 1))))))
+           (loop2+ (lambda (pred? vectors len i)
+                     (cond ((= i len) #f)
+                           ((apply pred? (vectors-ref vectors i)) i)
+                           (else (loop2+ pred? vectors len
+                                         (+ i 1)))))))
+    (lambda (pred? vec vectors callee)
+      (let ((pred? (check-type procedure? pred? callee))
+            (vec   (check-type vector?    vec   callee)))
+        (if (null? vectors)
+            (loop1 pred? vec (vector-length vec) 0)
+            (loop2+ pred? (cons vec vectors)
+                    (%smallest-length vectors
+                                      (vector-length vec)
+                                      callee)
+                    0))))))
+
+;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Right-to-left variant of VECTOR-INDEX.
+(define (vector-index-right pred? vec . vectors)
+  (vector-index/skip-right pred? vec vectors vector-index-right))
+
+;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
+;;;       -> exact, nonnegative integer or #F
+;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
+;;;   Right-to-left variant of VECTOR-SKIP.
+(define (vector-skip-right pred? vec . vectors)
+  (vector-index/skip-right (lambda elts (not (apply pred? elts)))
+                           vec vectors
+                           vector-index-right))
+
+(define vector-index/skip-right
+  (letrec ((loop1  (lambda (pred? vec i)
+                     (cond ((negative? i) #f)
+                           ((pred? (vector-ref vec i)) i)
+                           (else (loop1 pred? vec (- i 1))))))
+           (loop2+ (lambda (pred? vectors i)
+                     (cond ((negative? i) #f)
+                           ((apply pred? (vectors-ref vectors i)) i)
+                           (else (loop2+ pred? vectors (- i 1)))))))
+    (lambda (pred? vec vectors callee)
+      (let ((pred? (check-type procedure? pred? callee))
+            (vec   (check-type vector?    vec   callee)))
+        (if (null? vectors)
+            (loop1 pred? vec (- (vector-length vec) 1))
+            (loop2+ pred? (cons vec vectors)
+                    (- (%smallest-length vectors
+                                         (vector-length vec)
+                                         callee)
+                       1)))))))
+
+;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>])
+;;;       -> exact, nonnegative integer or #F
+;;;     (CMP <value1> <value2>) -> integer
+;;;       positive -> VALUE1 > VALUE2
+;;;       zero     -> VALUE1 = VALUE2
+;;;       negative -> VALUE1 < VALUE2
+;;;   Perform a binary search through VECTOR for VALUE, comparing each
+;;;   element to VALUE with CMP.
+(define (vector-binary-search vec value cmp . maybe-start+end)
+  (let ((cmp (check-type procedure? cmp vector-binary-search)))
+    (let-vector-start+end vector-binary-search vec maybe-start+end
+                          (start end)
+      (let loop ((start start) (end end) (j #f))
+        (let ((i (quotient (+ start end) 2)))
+          (if (or (= start end) (and j (= i j)))
+              #f
+              (let ((comparison
+                     (check-type integer?
+                                 (cmp (vector-ref vec i) value)
+                                 `(,cmp for ,vector-binary-search))))
+                (cond ((zero?     comparison) i)
+                      ((positive? comparison) (loop start i i))
+                      (else                   (loop i end i))))))))))
+
+;;; (VECTOR-ANY <pred?> <vector> ...) -> value
+;;;   Apply PRED? to each parallel element in each VECTOR ...; if PRED?
+;;;   should ever return a true value, immediately stop and return that
+;;;   value; otherwise, when the shortest vector runs out, return #F.
+;;;   The iteration and order of application of PRED? across elements
+;;;   is of the vectors is strictly left-to-right.
+(define vector-any
+  (letrec ((loop1 (lambda (pred? vec i len len-1)
+                    (and (not (= i len))
+                         (if (= i len-1)
+                             (pred? (vector-ref vec i))
+                             (or (pred? (vector-ref vec i))
+                                 (loop1 pred? vec (+ i 1)
+                                        len len-1))))))
+           (loop2+ (lambda (pred? vectors i len len-1)
+                     (and (not (= i len))
+                          (if (= i len-1)
+                              (apply pred? (vectors-ref vectors i))
+                              (or (apply pred? (vectors-ref vectors i))
+                                  (loop2+ pred? vectors (+ i 1)
+                                         len len-1)))))))
+    (lambda (pred? vec . vectors)
+      (let ((pred? (check-type procedure? pred? vector-any))
+            (vec   (check-type vector?    vec   vector-any)))
+        (if (null? vectors)
+            (let ((len (vector-length vec)))
+              (loop1 pred? vec 0 len (- len 1)))
+            (let ((len (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-any)))
+              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
+
+;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
+;;;   Apply PRED? to each parallel value in each VECTOR ...; if PRED?
+;;;   should ever return #F, immediately stop and return #F; otherwise,
+;;;   if PRED? should return a true value for each element, stopping at
+;;;   the end of the shortest vector, return the last value that PRED?
+;;;   returned.  In the case that there is an empty vector, return #T.
+;;;   The iteration and order of application of PRED? across elements
+;;;   is of the vectors is strictly left-to-right.
+(define vector-every
+  (letrec ((loop1 (lambda (pred? vec i len len-1)
+                    (or (= i len)
+                        (if (= i len-1)
+                            (pred? (vector-ref vec i))
+                            (and (pred? (vector-ref vec i))
+                                 (loop1 pred? vec (+ i 1)
+                                        len len-1))))))
+           (loop2+ (lambda (pred? vectors i len len-1)
+                     (or (= i len)
+                         (if (= i len-1)
+                             (apply pred? (vectors-ref vectors i))
+                             (and (apply pred? (vectors-ref vectors i))
+                                  (loop2+ pred? vectors (+ i 1)
+                                          len len-1)))))))
+    (lambda (pred? vec . vectors)
+      (let ((pred? (check-type procedure? pred? vector-every))
+            (vec   (check-type vector?    vec   vector-every)))
+        (if (null? vectors)
+            (let ((len (vector-length vec)))
+              (loop1 pred? vec 0 len (- len 1)))
+            (let ((len (%smallest-length vectors
+                                         (vector-length vec)
+                                         vector-every)))
+              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
+
+
+
+;;; --------------------
+;;; Mutators
+
+;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified
+;;;   [R5RS] Assign the location at INDEX in VECTOR to VALUE.
+(define vector-set! vector-set!)
+
+;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
+;;;   Swap the values in the locations at INDEX1 and INDEX2.
+(define (vector-swap! vec i j)
+  (let ((vec (check-type vector? vec vector-swap!)))
+    (let ((i (check-index vec i vector-swap!))
+          (j (check-index vec j vector-swap!)))
+      (let ((x (vector-ref vec i)))
+        (vector-set! vec i (vector-ref vec j))
+        (vector-set! vec j x)))))
+
+;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> unspecified
+;;;   [R5RS+] Fill the locations in VECTOR between START, whose default
+;;;   is 0, and END, whose default is the length of VECTOR, with VALUE.
+;;;
+;;; This one can probably be made really fast natively.
+(define vector-fill!
+  (let ((%vector-fill! vector-fill!))   ; Take the native one, under
+                                        ;   the assumption that it's
+                                        ;   faster, so we can use it if
+                                        ;   there are no optional
+                                        ;   arguments.
+    (lambda (vec value . maybe-start+end)
+      (if (null? maybe-start+end)
+          (%vector-fill! vec value)     ;+++
+          (let-vector-start+end vector-fill! vec maybe-start+end
+                                (start end)
+            (do ((i start (+ i 1)))
+                ((= i end))
+              (vector-set! vec i value)))))))
+
+;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
+;;;       -> unspecified
+;;;   Copy the values in the locations in [SSTART,SEND) from SOURCE to
+;;;   to TARGET, starting at TSTART in TARGET.
+;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source).
+(define (vector-copy! target tstart source . maybe-sstart+send)
+  (define (doit! sstart send source-length)
+    (let ((tstart (check-type nonneg-int? tstart vector-copy!))
+          (sstart (check-type nonneg-int? sstart vector-copy!))
+          (send   (check-type nonneg-int? send vector-copy!)))
+      (cond ((and (<= 0 sstart send source-length)
+                  (<= (+ tstart (- send sstart)) (vector-length target)))
+             (%vector-copy! target tstart source sstart send))
+            (else
+             (error "illegal arguments"
+                    `(while calling ,vector-copy!)
+                    `(target was ,target)
+                    `(target-length was ,(vector-length target))
+                    `(tstart was ,tstart)
+                    `(source was ,source)
+                    `(source-length was ,source-length)
+                    `(sstart was ,sstart)
+                    `(send   was ,send))))))
+  (let ((n (vector-length source)))
+    (cond ((null? maybe-sstart+send)
+           (doit! 0 n n))
+          ((null? (cdr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) n n))
+          ((null? (cddr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n))
+          (else
+           (error "too many arguments"
+                  vector-copy!
+                  (cddr maybe-sstart+send))))))
+
+;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
+;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source).
+(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
+  (define (doit! sstart send source-length)
+    (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!))
+          (sstart (check-type nonneg-int? sstart vector-reverse-copy!))
+          (send   (check-type nonneg-int? send vector-reverse-copy!)))
+      (cond ((and (eq? target source)
+                  (or (between? sstart tstart send)
+                      (between? tstart sstart
+                                (+ tstart (- send sstart)))))
+               (error "vector range for self-copying overlaps"
+                      vector-reverse-copy!
+                      `(vector was ,target)
+                      `(tstart was ,tstart)
+                      `(sstart was ,sstart)
+                      `(send   was ,send)))
+            ((and (<= 0 sstart send source-length)
+                  (<= (+ tstart (- send sstart)) (vector-length target)))
+             (%vector-reverse-copy! target tstart source sstart send))
+            (else
+             (error "illegal arguments"
+                    `(while calling ,vector-reverse-copy!)
+                    `(target was ,target)
+                    `(target-length was ,(vector-length target))
+                    `(tstart was ,tstart)
+                    `(source was ,source)
+                    `(source-length was ,source-length)
+                    `(sstart was ,sstart)
+                    `(send   was ,send))))))
+  (let ((n (vector-length source)))
+    (cond ((null? maybe-sstart+send)
+           (doit! 0 n n))
+          ((null? (cdr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) n n))
+          ((null? (cddr maybe-sstart+send))
+           (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n))
+          (else
+           (error "too many arguments"
+                  vector-reverse-copy!
+                  (cddr maybe-sstart+send))))))
+
+;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
+;;;   Destructively reverse the contents of the sequence of locations
+;;;   in VECTOR between START, whose default is 0, and END, whose
+;;;   default is the length of VECTOR.
+(define (vector-reverse! vec . start+end)
+  (let-vector-start+end vector-reverse! vec start+end
+                        (start end)
+    (%vector-reverse! vec start end)))
+
+
+
+;;; --------------------
+;;; Conversion
+
+;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
+;;;   [R5RS+] Produce a list containing the elements in the locations
+;;;   between START, whose default is 0, and END, whose default is the
+;;;   length of VECTOR, from VECTOR.
+(define vector->list
+  (let ((%vector->list vector->list))
+    (lambda (vec . maybe-start+end)
+      (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
+          (%vector->list vec)           ;+++
+          (let-vector-start+end vector->list vec maybe-start+end
+                                (start end)
+            ;(unfold (lambda (i)        ; No SRFI 1.
+            ;          (< i start))
+            ;        (lambda (i) (vector-ref vec i))
+            ;        (lambda (i) (- i 1))
+            ;        (- end 1))
+            (do ((i (- end 1) (- i 1))
+                 (result '() (cons (vector-ref vec i) result)))
+                ((< i start) result)))))))
+
+;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
+;;;   Produce a list containing the elements in the locations between
+;;;   START, whose default is 0, and END, whose default is the length
+;;;   of VECTOR, from VECTOR, in reverse order.
+(define (reverse-vector->list vec . maybe-start+end)
+  (let-vector-start+end reverse-vector->list vec maybe-start+end
+                        (start end)
+    ;(unfold (lambda (i) (= i end))     ; No SRFI 1.
+    ;        (lambda (i) (vector-ref vec i))
+    ;        (lambda (i) (+ i 1))
+    ;        start)
+    (do ((i start (+ i 1))
+         (result '() (cons (vector-ref vec i) result)))
+        ((= i end) result))))
+
+;;; (LIST->VECTOR <list> [<start> <end>]) -> vector
+;;;   [R5RS+] Produce a vector containing the elements in LIST, which
+;;;   must be a proper list, between START, whose default is 0, & END,
+;;;   whose default is the length of LIST.  It is suggested that if the
+;;;   length of LIST is known in advance, the START and END arguments
+;;;   be passed, so that LIST->VECTOR need not call LENGTH to determine
+;;;   the the length.
+;;;
+;;; This implementation diverges on circular lists, unless LENGTH fails
+;;; and causes - to fail as well.  Given a LENGTH* that computes the
+;;; length of a list's cycle, this wouldn't diverge, and would work
+;;; great for circular lists.
+(define list->vector
+  (let ((%list->vector list->vector))
+    (lambda (lst . maybe-start+end)
+      ;; Checking the type of a proper list is expensive, so we do it
+      ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
+      (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
+          (%list->vector lst)           ;+++
+          ;; We can't use LET-VECTOR-START+END, because we're using the
+          ;; bounds of a _list_, not a vector.
+          (let*-optionals maybe-start+end
+              ((start 0)
+               (end (length lst)))      ; Ugh -- LENGTH
+            (let ((start (check-type nonneg-int? start list->vector))
+                  (end   (check-type nonneg-int? end   list->vector)))
+              ((lambda (f)
+                 (vector-unfold f (- end start) (list-tail lst start)))
+               (lambda (index l)
+                 (cond ((null? l)
+                        (error "list was too short"
+                               `(list was ,lst)
+                               `(attempted end was ,end)
+                               `(while calling ,list->vector)))
+                       ((pair? l)
+                        (values (car l) (cdr l)))
+                       (else
+                        ;; Make this look as much like what CHECK-TYPE
+                        ;; would report as possible.
+                        (error "erroneous value"
+                               ;; We want SRFI 1's PROPER-LIST?, but it
+                               ;; would be a waste to link all of SRFI
+                               ;; 1 to this module for only the single
+                               ;; function PROPER-LIST?.
+                               (list list? lst)
+                               `(while calling
+                                 ,list->vector))))))))))))
+
+;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
+;;;   Produce a vector containing the elements in LIST, which must be a
+;;;   proper list, between START, whose default is 0, and END, whose
+;;;   default is the length of LIST, in reverse order.  It is suggested
+;;;   that if the length of LIST is known in advance, the START and END
+;;;   arguments be passed, so that REVERSE-LIST->VECTOR need not call
+;;;   LENGTH to determine the the length.
+;;;
+;;; This also diverges on circular lists unless, again, LENGTH returns
+;;; something that makes - bork.
+(define (reverse-list->vector lst . maybe-start+end)
+  (let*-optionals maybe-start+end
+      ((start 0)
+       (end (length lst)))              ; Ugh -- LENGTH
+    (let ((start (check-type nonneg-int? start reverse-list->vector))
+          (end   (check-type nonneg-int? end   reverse-list->vector)))
+      ((lambda (f)
+         (vector-unfold-right f (- end start) (list-tail lst start)))
+       (lambda (index l)
+         (cond ((null? l)
+                (error "list too short"
+                       `(list was ,lst)
+                       `(attempted end was ,end)
+                       `(while calling ,reverse-list->vector)))
+               ((pair? l)
+                (values (car l) (cdr l)))
+               (else
+                (error "erroneous value"
+                       (list list? lst)
+                       `(while calling ,reverse-list->vector)))))))))
+;;; SPDX-FileCopyrightText: 2014 Taylan Kammer <taylan.kammer@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 48)
+  (export format)
+  (import (rename (scheme base)
+                  (exact inexact->exact)
+                  (inexact exact->inexact))
+          (scheme char)
+          (scheme complex)
+          (rename (scheme write)
+                  (write-shared write-with-shared-structure)))
+  (include "48.upstream.scm"))
+;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+
+;;; Copyright (C) Aubrey Jaffer 2006. All Rights Reserved.
+
+;;; 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.
+
+;;; Updated: 11 June 1991
+;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
+;;; Updated: 19 June 1995
+;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
+;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
+;;; jaffer: 2006-10-08:
+;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
+;;; jaffer: 2006-11-05:
+;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
+;;; per element.
+
+(require 'array)
+
+;;; (sorted? sequence less?)
+;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;; such that for all 1 <= i <= m,
+;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
+;@
+(define (sorted? seq less? . opt-key)
+  (define key (if (null? opt-key) identity (car opt-key)))
+  (cond ((null? seq) #t)
+	((array? seq)
+	 (let ((dimax (+ -1 (car (array-dimensions seq)))))
+	   (or (<= dimax 1)
+	       (let loop ((idx (+ -1 dimax))
+			  (last (key (array-ref seq dimax))))
+		 (or (negative? idx)
+		     (let ((nxt (key (array-ref seq idx))))
+		       (and (less? nxt last)
+			    (loop (+ -1 idx) nxt))))))))
+	((null? (cdr seq)) #t)
+	(else
+	 (let loop ((last (key (car seq)))
+		    (next (cdr seq)))
+	   (or (null? next)
+	       (let ((nxt (key (car next))))
+		 (and (not (less? nxt last))
+		      (loop nxt (cdr next)))))))))
+
+;;; (merge a b less?)
+;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+;;; and returns a new list in which the elements of a and b have been stably
+;;; interleaved so that (sorted? (merge a b less?) less?).
+;;; Note:  this does _not_ accept arrays.  See below.
+;@
+(define (merge a b less? . opt-key)
+  (define key (if (null? opt-key) identity (car opt-key)))
+  (cond ((null? a) b)
+	((null? b) a)
+	(else
+	 (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
+		    (y (car b)) (ky (key (car b))) (b (cdr b)))
+	   ;; The loop handles the merging of non-empty lists.  It has
+	   ;; been written this way to save testing and car/cdring.
+	   (if (less? ky kx)
+	       (if (null? b)
+		   (cons y (cons x a))
+		   (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
+	       ;; x <= y
+	       (if (null? a)
+		   (cons x (cons y b))
+		   (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
+
+(define (sort:merge! a b less? key)
+  (define (loop r a kcara b kcarb)
+    (cond ((less? kcarb kcara)
+	   (set-cdr! r b)
+	   (if (null? (cdr b))
+	       (set-cdr! b a)
+	       (loop b a kcara (cdr b) (key (cadr b)))))
+	  (else				; (car a) <= (car b)
+	   (set-cdr! r a)
+	   (if (null? (cdr a))
+	       (set-cdr! a b)
+	       (loop a (cdr a) (key (cadr a)) b kcarb)))))
+  (cond ((null? a) b)
+	((null? b) a)
+	(else
+	 (let ((kcara (key (car a)))
+	       (kcarb (key (car b))))
+	   (cond
+	    ((less? kcarb kcara)
+	     (if (null? (cdr b))
+		 (set-cdr! b a)
+		 (loop b a kcara (cdr b) (key (cadr b))))
+	     b)
+	    (else			; (car a) <= (car b)
+	     (if (null? (cdr a))
+		 (set-cdr! a b)
+		 (loop a (cdr a) (key (cadr a)) b kcarb))
+	     a))))))
+
+;;; takes two sorted lists a and b and smashes their cdr fields to form a
+;;; single sorted list including the elements of both.
+;;; Note:  this does _not_ accept arrays.
+;@
+(define (merge! a b less? . opt-key)
+  (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
+
+(define (sort:sort-list! seq less? key)
+  (define keyer (if key car identity))
+  (define (step n)
+    (cond ((> n 2) (let* ((j (quotient n 2))
+			  (a (step j))
+			  (k (- n j))
+			  (b (step k)))
+		     (sort:merge! a b less? keyer)))
+	  ((= n 2) (let ((x (car seq))
+			 (y (cadr seq))
+			 (p seq))
+		     (set! seq (cddr seq))
+		     (cond ((less? (keyer y) (keyer x))
+			    (set-car! p y)
+			    (set-car! (cdr p) x)))
+		     (set-cdr! (cdr p) '())
+		     p))
+	  ((= n 1) (let ((p seq))
+		     (set! seq (cdr seq))
+		     (set-cdr! p '())
+		     p))
+	  (else '())))
+  (define (key-wrap! lst)
+    (cond ((null? lst))
+	  (else (set-car! lst (cons (key (car lst)) (car lst)))
+		(key-wrap! (cdr lst)))))
+  (define (key-unwrap! lst)
+    (cond ((null? lst))
+	  (else (set-car! lst (cdar lst))
+		(key-unwrap! (cdr lst)))))
+  (cond (key
+	 (key-wrap! seq)
+	 (set! seq (step (length seq)))
+	 (key-unwrap! seq)
+	 seq)
+	(else
+	 (step (length seq)))))
+
+(define (rank-1-array->list array)
+  (define dimensions (array-dimensions array))
+  (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
+       (lst '() (cons (array-ref array idx) lst)))
+      ((< idx 0) lst)))
+
+;;; (sort! sequence less?)
+;;; sorts the list, array, or string sequence destructively.  It uses
+;;; a version of merge-sort invented, to the best of my knowledge, by
+;;; David H. D.  Warren, and first used in the DEC-10 Prolog system.
+;;; R. A. O'Keefe adapted it to work destructively in Scheme.
+;;; A. Jaffer modified to always return the original list.
+;@
+(define (sort! seq less? . opt-key)
+  (define key (if (null? opt-key) #f (car opt-key)))
+  (cond ((array? seq)
+	 (let ((dims (array-dimensions seq)))
+	   (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+			(cdr sorted))
+		(i 0 (+ i 1)))
+	       ((null? sorted) seq)
+	     (array-set! seq (car sorted) i))))
+	(else			      ; otherwise, assume it is a list
+	 (let ((ret (sort:sort-list! seq less? key)))
+	   (if (not (eq? ret seq))
+	       (do ((crt ret (cdr crt)))
+		   ((eq? (cdr crt) seq)
+		    (set-cdr! crt ret)
+		    (let ((scar (car seq)) (scdr (cdr seq)))
+		      (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
+		      (set-car! ret scar) (set-cdr! ret scdr)))))
+	   seq))))
+
+;;; (sort sequence less?)
+;;; sorts a array, string, or list non-destructively.  It does this
+;;; by sorting a copy of the sequence.  My understanding is that the
+;;; Standard says that the result of append is always "newly
+;;; allocated" except for sharing structure with "the last argument",
+;;; so (append x '()) ought to be a standard way of copying a list x.
+;@
+(define (sort seq less? . opt-key)
+  (define key (if (null? opt-key) #f (car opt-key)))
+  (cond ((array? seq)
+	 (let ((dims (array-dimensions seq)))
+	   (define newra (apply make-array seq dims))
+	   (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+			(cdr sorted))
+		(i 0 (+ i 1)))
+	       ((null? sorted) newra)
+	     (array-set! newra (car sorted) i))))
+	(else (sort:sort-list! (append seq '()) less? key))))
+;;; SPDX-FileCopyrightText: 2003 Kenneth A Dickey <ken.dickey@allvantage.com>
+;;; SPDX-FileCopyrightText: 2017 Hamayama <hamay1010@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;; IMPLEMENTATION DEPENDENT options
+
+(define ascii-tab   (integer->char  9))  ;; NB: assumes ASCII encoding
+(define dont-print  (if (eq? #t #f) 1))
+;;(define DONT-PRINT (string->symbol ""))
+;;(define DONT-PRINT (void))
+;;(define DONT-PRINT #!void)
+(define pretty-print   write) ; ugly but permitted
+;; (require 'srfi-38)  ;; write-with-shared-structure
+
+;; Following three procedures are used by format ~F .
+;; 'inexact-number->string' determines whether output is fixed-point
+;; notation or exponential notation. In the current definition,
+;; the notation depends on the implementation of 'number->string'.
+;; 'exact-number->string' is expected to output only numeric characters
+;; (not including such as '#', 'e', '.', '/') if the input is an positive
+;; integer or zero.
+;; 'real-number->string' is used when the digits of ~F is not specified.
+(define (inexact-number->string x) (number->string (exact->inexact x)))
+(define (exact-number->string x)   (number->string (inexact->exact x)))
+(define (real-number->string x)    (number->string x))
+
+;; FORMAT
+(define (format . args)
+  (cond
+   ((null? args)
+    (error "FORMAT: required format-string argument is missing")
+    )
+   ((string? (car args))
+    (apply format (cons #f args)))
+   ((< (length args) 2)
+    (error (format #f "FORMAT: too few arguments ~s" (cons 'format args)))
+    )
+   (else
+    (let ( (output-port   (car  args))
+           (format-string (cadr args))
+           (args          (cddr args))
+         )
+      (letrec ( (port
+                 (cond ((output-port? output-port) output-port)
+                       ((eq? output-port #t) (current-output-port))
+                       ((eq? output-port #f) (open-output-string))
+                       (else (error
+                              (format #f "FORMAT: bad output-port argument: ~s"
+                                      output-port)))
+                ) )
+                (return-value
+                 (if (eq? output-port #f)    ;; if format into a string
+                     (lambda () (get-output-string port)) ;; then return the string
+                     (lambda () dont-print)) ;; else do something harmless
+                 )
+             )
+
+         (define (string-index str c)
+           (let ( (len (string-length str)) )
+             (let loop ( (i 0) )
+               (cond ((= i len) #f)
+                     ((eqv? c (string-ref str i)) i)
+                     (else (loop (+ i 1)))))))
+
+         (define (string-grow str len char)
+           (let ( (off (- len (string-length str))) )
+             (if (positive? off)
+               (string-append (make-string off char) str)
+               str)))
+
+         (define (compose-with-digits digits pre-str frac-str exp-str)
+           (let ( (frac-len (string-length frac-str)) )
+             (cond
+              ((< frac-len digits) ;; grow frac part, pad with zeros
+               (string-append pre-str "."
+                              frac-str (make-string (- digits frac-len) #\0)
+                              exp-str)
+               )
+              ((= frac-len digits) ;; frac-part is exactly the right size
+               (string-append pre-str "."
+                              frac-str
+                              exp-str)
+               )
+              (else ;; must round to shrink it
+               (let* ( (minus-flag (and (> (string-length pre-str) 0)
+                                        (char=? (string-ref pre-str 0) #\-)))
+                       (pre-str*   (if minus-flag
+                                       (substring pre-str 1 (string-length pre-str))
+                                       pre-str))
+                       (first-part (substring frac-str 0 digits))
+                       (last-part  (substring frac-str digits frac-len))
+                       (temp-str
+                        (string-grow
+                         (exact-number->string
+                          (round (string->number
+                                  (string-append pre-str* first-part "." last-part))))
+                         digits
+                         #\0))
+                       (temp-len   (string-length temp-str))
+                       (new-pre    (substring temp-str 0 (- temp-len digits)))
+                       (new-frac   (substring temp-str (- temp-len digits) temp-len))
+                     )
+                 (string-append
+                  (if minus-flag "-" "")
+                  (if (string=? new-pre "")
+                      ;; check if the system displays integer part of numbers
+                      ;; whose absolute value is 0 < x < 1.
+                      (if (and (string=? pre-str* "")
+                               (> digits 0)
+                               (not (= (string->number new-frac) 0)))
+                          "" "0")
+                      new-pre)
+                  "."
+                  new-frac
+                  exp-str)))
+         ) ) )
+
+         (define (format-fixed number-or-string width digits) ; returns a string
+           (cond
+            ((string? number-or-string)
+             (string-grow number-or-string width #\space)
+             )
+            ((number? number-or-string)
+             (let ( (real (real-part number-or-string))
+                    (imag (imag-part number-or-string))
+                  )
+               (cond
+                ((not (zero? imag))
+                 (string-grow
+                  (string-append (format-fixed real 0 digits)
+                                 (if (negative? imag) "" "+")
+                                 (format-fixed imag 0 digits)
+                                 "i")
+                  width
+                  #\space)
+                 )
+                (digits
+                 (let* ( (num-str   (inexact-number->string real))
+                         (dot-index (string-index  num-str #\.))
+                         (exp-index (string-index  num-str #\e))
+                         (length    (string-length num-str))
+                         (pre-string
+                          (if dot-index
+                              (substring num-str 0 dot-index)
+                              (if exp-index
+                                  (substring num-str 0 exp-index)
+                                  num-str))
+                          )
+                         (exp-string
+                          (if exp-index
+                              (substring num-str exp-index length)
+                              "")
+                          )
+                         (frac-string
+                          (if dot-index
+                              (if exp-index
+                                  (substring num-str (+ dot-index 1) exp-index)
+                                  (substring num-str (+ dot-index 1) length))
+                              "")
+                          )
+                       )
+                   ;; check +inf.0, -inf.0, +nan.0, -nan.0
+                   (if (string-index num-str #\n)
+                       (string-grow num-str width #\space)
+                       (string-grow
+                        (compose-with-digits digits
+                                             pre-string
+                                             frac-string
+                                             exp-string)
+                        width
+                        #\space))
+                 ))
+                (else ;; no digits
+                 (string-grow (real-number->string real) width #\space)))
+             ))
+            (else
+             (error
+              (format "FORMAT: ~F requires a number or a string, got ~s" number-or-string)))
+            ))
+
+         (define documentation-string
+"(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port
+OPTION  [MNEMONIC]      DESCRIPTION     -- Implementation Assumes ASCII Text Encoding
+~H      [Help]          output this text
+~A      [Any]           (display arg) for humans
+~S      [Slashified]    (write arg) for parsers
+~W      [WriteCircular] like ~s but outputs circular and recursive data structures
+~~      [tilde]         output a tilde
+~T      [Tab]           output a tab character
+~%      [Newline]       output a newline character
+~&      [Freshline]     output a newline character if the previous output was not a newline
+~D      [Decimal]       the arg is a number which is output in decimal radix
+~X      [heXadecimal]   the arg is a number which is output in hexdecimal radix
+~O      [Octal]         the arg is a number which is output in octal radix
+~B      [Binary]        the arg is a number which is output in binary radix
+~w,dF   [Fixed]         the arg is a string or number which has width w and d digits after the decimal
+~C      [Character]     charater arg is output by write-char
+~_      [Space]         a single space character is output
+~Y      [Yuppify]       the list arg is pretty-printed to the output
+~?      [Indirection]   recursive format: next 2 args are format-string and list of arguments
+~K      [Indirection]   same as ~?
+"
+          )
+
+         (define (require-an-arg args)
+           (if (null? args)
+               (error "FORMAT: too few arguments" ))
+         )
+
+         (define (format-help format-strg arglist)
+
+          (letrec (
+             (length-of-format-string (string-length format-strg))
+
+             (anychar-dispatch
+              (lambda (pos arglist last-was-newline)
+                (if (>= pos length-of-format-string)
+                  arglist ; return unused args
+                  (let ( (char (string-ref format-strg pos)) )
+                    (cond
+                     ((eqv? char #\~)
+                      (tilde-dispatch (+ pos 1) arglist last-was-newline))
+                     (else
+                      (write-char char port)
+                      (anychar-dispatch (+ pos 1) arglist #f)
+                      ))
+                    ))
+             )) ; end anychar-dispatch
+
+             (has-newline?
+              (lambda (whatever last-was-newline)
+                (or (eqv? whatever #\newline)
+                    (and (string? whatever)
+                         (let ( (len (string-length whatever)) )
+                           (if (zero? len)
+                               last-was-newline
+                               (eqv? #\newline (string-ref whatever (- len 1)))))))
+              )) ; end has-newline?
+
+             (tilde-dispatch
+              (lambda (pos arglist last-was-newline)
+                (cond
+                 ((>= pos length-of-format-string)
+                  (write-char #\~ port) ; tilde at end of string is just output
+                  arglist ; return unused args
+                  )
+                 (else
+                  (case (char-upcase (string-ref format-strg pos))
+                    ((#\A)       ; Any -- for humans
+                     (require-an-arg arglist)
+                     (let ( (whatever (car arglist)) )
+                       (display whatever port)
+                       (anychar-dispatch (+ pos 1)
+                                         (cdr arglist)
+                                         (has-newline? whatever last-was-newline))
+                     ))
+                    ((#\S)       ; Slashified -- for parsers
+                     (require-an-arg arglist)
+                     (let ( (whatever (car arglist)) )
+                        (write whatever port)
+                        (anychar-dispatch (+ pos 1)
+                                          (cdr arglist)
+                                          (has-newline? whatever last-was-newline))
+                     ))
+                    ((#\W)
+                     (require-an-arg arglist)
+                     (let ( (whatever (car arglist)) )
+                        (write-with-shared-structure whatever port)  ;; srfi-38
+                        (anychar-dispatch (+ pos 1)
+                                          (cdr arglist)
+                                          (has-newline? whatever last-was-newline))
+                     ))
+                    ((#\D)       ; Decimal
+                     (require-an-arg arglist)
+                     (display (number->string (car arglist) 10) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\X)       ; HeXadecimal
+                     (require-an-arg arglist)
+                     (display (number->string (car arglist) 16) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\O)       ; Octal
+                     (require-an-arg arglist)
+                     (display (number->string (car arglist)  8) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\B)       ; Binary
+                     (require-an-arg arglist)
+                     (display (number->string (car arglist)  2) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\C)       ; Character
+                     (require-an-arg arglist)
+                     (write-char (car arglist) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) (eqv? (car arglist) #\newline))
+                     )
+                    ((#\~)       ; Tilde
+                     (write-char #\~ port)
+                     (anychar-dispatch (+ pos 1) arglist #f)
+                     )
+                    ((#\%)       ; Newline
+                     (newline port)
+                     (anychar-dispatch (+ pos 1) arglist #t)
+                     )
+                    ((#\&)      ; Freshline
+                     (if (not last-was-newline) ;; (unless last-was-newline ..
+                         (newline port))
+                     (anychar-dispatch (+ pos 1) arglist #t)
+                     )
+                    ((#\_)       ; Space
+                     (write-char #\space port)
+                     (anychar-dispatch (+ pos 1) arglist #f)
+                     )
+                    ((#\T)       ; Tab -- IMPLEMENTATION DEPENDENT ENCODING
+                     (write-char ascii-tab port)
+                     (anychar-dispatch (+ pos 1) arglist #f)
+                     )
+                    ((#\Y)       ; Pretty-print
+                     (pretty-print (car arglist) port)  ;; IMPLEMENTATION DEPENDENT
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\F)
+                     (require-an-arg arglist)
+                     (display (format-fixed (car arglist) 0 #f) port)
+                     (anychar-dispatch (+ pos 1) (cdr arglist) #f)
+                     )
+                    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ;; gather "~w[,d]F" w and d digits
+                     (let loop ( (index (+ pos 1))
+                                 (w-digits (list (string-ref format-strg pos)))
+                                 (d-digits '())
+                                 (in-width? #t)
+                               )
+                       (if (>= index length-of-format-string)
+                           (error
+                            (format "FORMAT: improper numeric format directive in ~s" format-strg))
+                           (let ( (next-char (string-ref format-strg index)) )
+                             (cond
+                              ((char-numeric? next-char)
+                               (if in-width?
+                                   (loop (+ index 1)
+                                         (cons next-char w-digits)
+                                         d-digits
+                                         in-width?)
+                                   (loop (+ index 1)
+                                         w-digits
+                                         (cons next-char d-digits)
+                                         in-width?))
+                               )
+                              ((char=? (char-upcase next-char) #\F)
+                               (let ( (width  (string->number (list->string (reverse w-digits))))
+                                      (digits (if (zero? (length d-digits))
+                                                  #f
+                                                  (string->number (list->string (reverse d-digits)))))
+                                    )
+                                 (display (format-fixed (car arglist) width digits) port)
+                                 (anychar-dispatch (+ index 1) (cdr arglist) #f))
+                               )
+                              ((char=? next-char #\,)
+                               (if in-width?
+                                   (loop (+ index 1)
+                                         w-digits
+                                         d-digits
+                                         #f)
+                                   (error
+                                    (format "FORMAT: too many commas in directive ~s" format-strg)))
+                               )
+                              (else
+                               (error (format "FORMAT: ~~w.dF directive ill-formed in ~s" format-strg))))))
+                     ))
+                    ((#\? #\K)       ; indirection -- take next arg as format string
+                     (cond           ;  and following arg as list of format args
+                      ((< (length arglist) 2)
+                       (error
+                        (format "FORMAT: less arguments than specified for ~~?: ~s" arglist))
+                       )
+                      ((not (string? (car arglist)))
+                       (error
+                        (format "FORMAT: ~~? requires a string: ~s" (car arglist)))
+                       )
+                      (else
+                       (format-help (car arglist) (cadr arglist))
+                       (anychar-dispatch (+ pos 1) (cddr arglist) #f)
+                     )))
+                    ((#\H)      ; Help
+                     (display documentation-string port)
+                     (anychar-dispatch (+ pos 1) arglist #t)
+                     )
+                    (else
+                     (error (format "FORMAT: unknown tilde escape: ~s"
+                                    (string-ref format-strg pos))))
+                    )))
+                )) ; end tilde-dispatch
+             ) ; end letrec
+
+             ; format-help main
+             (anychar-dispatch 0 arglist #f)
+            )) ; end format-help
+
+        ; format main
+        (let ( (unused-args (format-help format-string args)) )
+          (if (not (null? unused-args))
+              (error
+               (format "FORMAT: unused arguments ~s" unused-args)))
+          (return-value))
+
+      )) ; end letrec, if
+)))  ; end format
+;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved.
+
+;; 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-library (srfi 5)
+  (export (rename let+ let))
+  (import (scheme base))
+  (begin
+
+    (define-syntax let+
+      (syntax-rules ()
+        ;; Unnamed, no rest args.
+        ((_ ((var val) ...) body ...)
+         (let ((var val) ...) body ...))
+        ;; Unnamed, with rest args.
+        ((_ ((var val) spec ...) body ...)
+         (rest ((var val) spec ...) () () body ...))
+        ;; Signature style, no rest args.
+        ((_ (name (var val) ...) body ...)
+         (let name ((var val) ...) body ...))
+        ;; Signature style, with rest args.
+        ((_ (name (var val) spec ...) body ...)
+         (rest/named name ((var val) spec ...) () () body ...))
+        ;; Named let, no rest args.
+        ((_ name ((var val) ...) body ...)
+         (let name ((var val) ...) body ...))
+        ;; Named let, with rest args.
+        ((_ name ((var val) spec ...) body ...)
+         (rest/named name ((var val) spec ...) () () body ...))))
+
+    (define-syntax rest
+      (syntax-rules ()
+        ((_ ((var val) spec ...) (var* ...) (val* ...) body ...)
+         (rest name (spec ...) (var var* ...) (val val* ...) body ...))
+        ((_ (rest-var rest-val ...) (var ...) (val ...) body ...)
+         (let ((var val)
+               ...
+               (rest-var (list rest-val ...)))
+           body ...))))
+
+    (define-syntax rest/named
+      (syntax-rules ()
+        ((_ name ((var val) spec ...) (var* ...) (val* ...) body ...)
+         (rest/named name (spec ...) (var var* ...) (val val* ...) body ...))
+        ((_ name (rest-var rest-val ...) (var ...) (val ...) body ...)
+         (letrec ((name (lambda (var ... . rest-var) body ...)))
+           (name val ... rest-val ...)))))
+
+    ))
+(define-library (srfi 51)
+  (export
+   rest-values
+   arg-and
+   arg-ands
+   err-and
+   err-ands
+   arg-or
+   arg-ors
+   err-or
+   err-ors
+   )
+  (import
+   (scheme base)
+   (srfi 1))
+  (include "51.upstream.scm"))
+(define-library (srfi aux)
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (srfi 31))
+  (export
+   debug-mode
+   define/opt
+   lambda/opt
+   define-check-arg
+   )
+  (begin
+
+    (define debug-mode (make-parameter #f))
+
+    ;; Emacs indentation help:
+    ;; (put 'define/opt 'scheme-indent-function 1)
+    ;; (put 'lambda/opt 'scheme-indent-function 1)
+
+    (define-syntax define/opt
+      (syntax-rules ()
+        ((_ (name . args) . body)
+         (define name (lambda/opt args . body)))))
+
+    (define-syntax lambda/opt
+      (syntax-rules ()
+        ((lambda* args . body)
+         (rec name (opt/split-args name () () args body)))))
+
+    (define-syntax opt/split-args
+      (syntax-rules ()
+        ((_ name non-opts (opts ...) ((opt) . rest) body)
+         (opt/split-args name non-opts (opts ... (opt #f)) rest body))
+        ((_ name non-opts (opts ...) ((opt def) . rest) body)
+         (opt/split-args name non-opts (opts ... (opt def)) rest body))
+        ((_ name (non-opts ...) opts (non-opt . rest) body)
+         (opt/split-args name (non-opts ... non-opt) opts rest body))
+        ;; Rest could be () or a rest-arg here; just propagate it.
+        ((_ name non-opts opts rest body)
+         (opt/make-clauses name () rest non-opts opts body))))
+
+    (define-syntax opt/make-clauses
+      (syntax-rules ()
+        ;; Handle special-case with no optargs.
+        ((_ name () rest (taken ...) () body)
+         (lambda (taken ... . rest)
+           . body))
+        ;; Add clause where no optargs are provided.
+        ((_ name () rest (taken ...) ((opt def) ...) body)
+         (opt/make-clauses
+          name
+          (((taken ...)
+            (name taken ... def ...)))
+          rest
+          (taken ...)
+          ((opt def) ...)
+          body))
+        ;; Add clauses where 1 to n-1 optargs are provided
+        ((_ name (clause ...) rest (taken ...) ((opt def) (opt* def*) ... x) body)
+         (opt/make-clauses
+          name
+          (clause
+           ...
+           ((taken ... opt)
+            (name taken ... opt def* ...)))
+          rest
+          (taken ... opt)
+          ((opt* def*) ... x)
+          body))
+        ;; Add clause where all optargs were given, and possibly more.
+        ((_ name (clause ...) rest (taken ...) ((opt def)) body)
+         (case-lambda
+           clause
+           ...
+           ((taken ... opt . rest)
+            . body)))))
+
+    (define-syntax define-check-arg
+      (syntax-rules ()
+        ((_ check-arg)
+         (define check-arg
+           (if (debug-mode)
+               (lambda (pred val proc)
+                 (if (pred val)
+                     val
+                     (error "Type assertion failed:"
+                            `(value ,val)
+                            `(expected-type ,pred)
+                            `(callee ,proc))))
+               (lambda (pred val proc)
+                 val))))))
+
+    ))
+;;; Copyright (C) Joo ChurlSoo (2004). All Rights Reserved.
+
+;;; 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 (rest-values rest . default)
+  (let* ((caller (if (or (null? default)
+			 (boolean? (car default))
+			 (integer? (car default))
+			 (memq (car default) (list + -)))
+		     '()
+		     (if (string? rest) rest (list rest))))
+	 (rest-list (if (null? caller) rest (car default)))
+	 (rest-length (if (list? rest-list)
+			  (length rest-list)
+			  (if (string? caller)
+			      (error caller rest-list 'rest-list
+				     '(list? rest-list))
+			      (apply error "bad rest list" rest-list 'rest-list
+				     '(list? rest-list) caller))))
+	 (default (if (null? caller) default (cdr default)))
+	 (default-list (if (null? default) default (cdr default)))
+	 (default-length (length default-list))
+	 (number
+	  (and (not (null? default))
+	       (let ((option (car default)))
+		 (or (and (integer? option)
+			  (or (and (> rest-length (abs option))
+				   (if (string? caller)
+				       (error caller rest-list 'rest-list
+					      `(<= (length rest-list)
+						   ,(abs option)))
+				       (apply error "too many arguments"
+					      rest-list 'rest-list
+					      `(<= (length rest-list)
+						   ,(abs option))
+					      caller)))
+			      (and (> default-length (abs option))
+				   (if (string? caller)
+				       (error caller default-list
+					      'default-list
+					      `(<= (length default-list)
+						   ,(abs option)))
+				       (apply error "too many defaults"
+					      default-list 'default-list
+					      `(<= (length default-list)
+						   ,(abs option))
+					      caller)))
+			      option))
+		     (eq? option #t)
+		     (and (not option) 'false)
+		     (and (eq? option +) +)
+		     (and (eq? option -) -)
+		     (if (string? caller)
+			 (error caller option 'option
+				'(or (boolean? option)
+				     (integer? option)
+				     (memq option (list + -))))
+			 (apply error "bad optional argument" option 'option
+				'(or (boolean? option)
+				     (integer? option)
+				     (memq option (list + -)))
+				caller)))))))
+    (cond
+     ((or (eq? #t number) (eq? 'false number))
+      (and (not (every pair? default-list))
+	   (if (string? caller)
+	       (error caller default-list 'default-list
+		      '(every pair? default-list))
+	       (apply error "bad default list" default-list 'default-list
+		      '(every pair? default-list) caller)))
+      (let loop ((rest-list rest-list)
+		 (default-list default-list)
+		 (result '()))
+	(if (null? default-list)
+	    (if (null? rest-list)
+		(apply values (reverse result))
+		(if (eq? #t number)
+		    (if (string? caller)
+			(error caller rest-list 'rest-list '(null? rest-list))
+			(apply error "bad argument" rest-list 'rest-list
+			       '(null? rest-list) caller))
+		    (apply values (append-reverse result rest-list))))
+	    (if (null? rest-list)
+		(apply values (append-reverse result (map car default-list)))
+		(let ((default (car default-list)))
+		  (let lp ((rest rest-list)
+			   (head '()))
+		    (if (null? rest)
+			(loop (reverse head)
+			      (cdr default-list)
+			      (cons (car default) result))
+			(if (list? default)
+			    (if (member (car rest) default)
+				(loop (append-reverse head (cdr rest))
+				      (cdr default-list)
+				      (cons (car rest) result))
+				(lp (cdr rest) (cons (car rest) head)))
+			    (if ((cdr default) (car rest))
+				(loop (append-reverse head (cdr rest))
+				      (cdr default-list)
+				      (cons (car rest) result))
+				(lp (cdr rest) (cons (car rest) head)))))))))))
+     ((or (and (integer? number) (> number 0))
+	  (eq? number +))
+      (and (not (every pair? default-list))
+	   (if (string? caller)
+	       (error caller default-list 'default-list
+		      '(every pair? default-list))
+	       (apply error "bad default list" default-list 'default-list
+		      '(every pair? default-list) caller)))
+      (let loop ((rest rest-list)
+		 (default default-list))
+	(if (or (null? rest) (null? default))
+	    (apply values
+		   (if (> default-length rest-length)
+		       (append rest-list
+			       (map car (list-tail default-list rest-length)))
+		       rest-list))
+	    (let ((arg (car rest))
+		  (par (car default)))
+	      (if (list? par)
+		  (if (member arg par)
+		      (loop (cdr rest) (cdr default))
+		      (if (string? caller)
+			  (error caller arg 'arg `(member arg ,par))
+			  (apply error "unmatched argument"
+				 arg 'arg `(member arg ,par) caller)))
+		  (if ((cdr par) arg)
+		      (loop (cdr rest) (cdr default))
+		      (if (string? caller)
+			  (error caller arg 'arg `(,(cdr par) arg))
+			  (apply error "incorrect argument"
+				 arg 'arg `(,(cdr par) arg) caller))))))))
+     (else
+      (apply values (if (> default-length rest-length)
+			(append rest-list (list-tail default-list rest-length))
+			rest-list))))))
+
+(define-syntax arg-and
+  (syntax-rules()
+    ((arg-and arg (a1 a2 ...) ...)
+     (and (or (symbol? 'arg)
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(arg-and arg (a1 a2 ...) ...)))
+	  (or (a1 a2 ...)
+	      (error "incorrect argument" arg 'arg '(a1 a2 ...)))
+	  ...))
+    ((arg-and caller arg (a1 a2 ...) ...)
+     (and (or (symbol? 'arg)
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(arg-and caller arg (a1 a2 ...) ...)))
+	  (or (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	  ...))))
+
+;; accessory macro for arg-ands
+(define-syntax caller-arg-and
+  (syntax-rules()
+    ((caller-arg-and caller arg (a1 a2 ...) ...)
+     (and (or (symbol? 'arg)
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(caller-arg-and caller arg (a1 a2 ...) ...)))
+	  (or (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	  ...))
+    ((caller-arg-and null caller arg (a1 a2 ...) ...)
+     (and (or (symbol? 'arg)
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(caller-arg-and caller arg (a1 a2 ...) ...)))
+	  (or (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	  ...))))
+
+(define-syntax arg-ands
+  (syntax-rules (common)
+    ((arg-ands (a1 a2 ...) ...)
+     (and (arg-and a1 a2 ...) ...))
+    ((arg-ands common caller (a1 a2 ...) ...)
+     (and (caller-arg-and caller a1 a2 ...) ...))))
+
+(define-syntax arg-or
+  (syntax-rules()
+    ((arg-or arg (a1 a2 ...) ...)
+     (or (and (not (symbol? 'arg))
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(arg-or arg (a1 a2 ...) ...)))
+	 (and (a1 a2 ...)
+	      (error "incorrect argument" arg 'arg '(a1 a2 ...)))
+	 ...))
+    ((arg-or caller arg (a1 a2 ...) ...)
+     (or (and (not (symbol? 'arg))
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(arg-or caller arg (a1 a2 ...) ...)))
+	 (and (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	 ...))))
+
+;; accessory macro for arg-ors
+(define-syntax caller-arg-or
+  (syntax-rules()
+    ((caller-arg-or caller arg (a1 a2 ...) ...)
+     (or (and (not (symbol? 'arg))
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(caller-arg-or caller arg (a1 a2 ...) ...)))
+	 (and (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	 ...))
+    ((caller-arg-or null caller arg (a1 a2 ...) ...)
+     (or (and (not (symbol? 'arg))
+	      (error "bad syntax" 'arg '(symbol? 'arg)
+		     '(caller-arg-or caller arg (a1 a2 ...) ...)))
+	 (and (a1 a2 ...)
+	      (if (string? caller)
+		  (error caller arg 'arg '(a1 a2 ...))
+		  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
+	 ...))))
+
+(define-syntax arg-ors
+  (syntax-rules (common)
+    ((arg-ors (a1 a2 ...) ...)
+     (or (arg-or a1 a2 ...) ...))
+    ((arg-ors common caller (a1 a2 ...) ...)
+     (or (caller-arg-or caller a1 a2 ...) ...))))
+
+(define-syntax err-and
+  (syntax-rules ()
+    ((err-and err expression ...)
+     (and (or expression
+	      (if (string? err)
+		  (error err 'expression)
+		  (error "false expression" 'expression err)))
+	  ...))))
+
+(define-syntax err-ands
+  (syntax-rules ()
+    ((err-ands (err expression ...)  ...)
+     (and (err-and err expression ...)
+	  ...))))
+
+(define-syntax err-or
+  (syntax-rules ()
+    ((err-or err expression ...)
+     (or (and expression
+	      (if (string? err)
+		  (error err 'expression)
+		  (error "true expression" 'expression err)))
+	 ...))))
+
+(define-syntax err-ors
+  (syntax-rules ()
+    ((err-ors (err expression ...) ...)
+     (or (err-or err expression ...)
+	 ...))))
+;;; Copyright (C) Joo ChurlSoo (2004). All Rights Reserved.
+
+;;; 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-syntax alet-cat*		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((alet-cat* z (a . e) bd ...)
+     (let ((y z))
+       (%alet-cat* y (a . e) bd ...)))))
+
+(define-syntax %alet-cat*		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((%alet-cat* z ((n d t ...)) bd ...)
+     (let ((n (if (null? z)
+		  d
+		  (if (null? (cdr z))
+		      (wow-cat-end z n t ...)
+		      (error "cat: too many arguments" (cdr z))))))
+       bd ...))
+    ((%alet-cat* z ((n d t ...) . e) bd ...)
+     (let ((n (if (null? z)
+		  d
+		  (wow-cat! z n d t ...))))
+       (%alet-cat* z e bd ...)))
+    ((%alet-cat* z e bd ...)
+     (let ((e z)) bd ...))))
+
+(define-syntax wow-cat!			; borrowed from SRFI-86
+  (syntax-rules ()
+    ((wow-cat! z n d)
+     (let ((n (car z)))
+       (set! z (cdr z))
+       n))
+    ((wow-cat! z n d t)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) n)
+	   (let lp ((head (list n)) (tail (cdr z)))
+	     (if (null? tail)
+		 d
+		 (let ((n (car tail)))
+		   (if t
+		       (begin (set! z (append (reverse head) (cdr tail))) n)
+		       (lp (cons n head) (cdr tail)))))))))
+    ((wow-cat! z n d t ts)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) ts)
+	   (let lp ((head (list n)) (tail (cdr z)))
+	     (if (null? tail)
+		 d
+		 (let ((n (car tail)))
+		   (if t
+		       (begin (set! z (append (reverse head) (cdr tail))) ts)
+		       (lp (cons n head) (cdr tail)))))))))
+    ((wow-cat! z n d t ts fs)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) ts)
+	   (begin (set! z (cdr z)) fs))))))
+
+(define-syntax wow-cat-end		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((wow-cat-end z n)
+     (car z))
+    ((wow-cat-end z n t)
+     (let ((n (car z)))
+       (if t n (error "cat: too many argument" z))))
+    ((wow-cat-end z n t ts)
+     (let ((n (car z)))
+       (if t ts (error "cat: too many argument" z))))
+    ((wow-cat-end z n t ts fs)
+     (let ((n (car z)))
+       (if t ts fs)))))
+
+(define (str-index str char)
+  (let ((len (string-length str)))
+    (let lp ((n 0))
+      (and (< n len)
+	   (if (char=? char (string-ref str n))
+	       n
+	       (lp (+ n 1)))))))
+
+(define (every? pred ls)
+  (let lp ((ls ls))
+    (or (null? ls)
+	(and (pred (car ls))
+	     (lp (cdr ls))))))
+
+(define (part pred ls)
+  (let lp ((ls ls) (true '()) (false '()))
+    (cond
+     ((null? ls) (cons (reverse true) (reverse false)))
+     ((pred (car ls)) (lp (cdr ls) (cons (car ls) true) false))
+     (else (lp (cdr ls) true (cons (car ls) false))))))
+
+(define (e-mold num pre)
+  (let* ((str (number->string (inexact num)))
+	 (e-index (str-index str #\e)))
+    (if e-index
+	(string-append (mold (substring str 0 e-index) pre)
+		       (substring str e-index (string-length str)))
+	(mold str pre))))
+
+(define (mold str pre)
+  (let ((ind (str-index str #\.)))
+    (if ind
+	(let ((d-len (- (string-length str) (+ ind 1))))
+	  (cond
+	   ((= d-len pre) str)
+	   ((< d-len pre) (string-append str (make-string (- pre d-len) #\0)))
+	   ;;((char<? #\4 (string-ref str (+ 1 ind pre)))
+	   ;;(let ((com (expt 10 pre)))
+	   ;;  (number->string (/ (round (* (string->number str) com)) com))))
+	   ((or (char<? #\5 (string-ref str (+ 1 ind pre)))
+		(and (char=? #\5 (string-ref str (+ 1 ind pre)))
+		     (or (< (+ 1 pre) d-len)
+			 (memv (string-ref str (+ ind (if (= 0 pre) -1 pre)))
+			       '(#\1 #\3 #\5 #\7 #\9)))))
+	    (apply
+	     string
+	     (let* ((minus (char=? #\- (string-ref str 0)))
+		    (str (substring str (if minus 1 0) (+ 1 ind pre)))
+		    (char-list
+		     (reverse
+		      (let lp ((index (- (string-length str) 1))
+			       (raise #t))
+			(if (= -1 index)
+			    (if raise '(#\1) '())
+			    (let ((chr (string-ref str index)))
+			      (if (char=? #\. chr)
+				  (cons chr (lp (- index 1) raise))
+				  (if raise
+				      (if (char=? #\9 chr)
+					  (cons #\0 (lp (- index 1) raise))
+					  (cons (integer->char
+						 (+ 1 (char->integer chr)))
+						(lp (- index 1) #f)))
+				      (cons chr (lp (- index 1) raise))))))))))
+	       (if minus (cons #\- char-list) char-list))))
+	   (else
+	    (substring str 0 (+ 1 ind pre)))))
+	(string-append str "." (make-string pre #\0)))))
+
+(define (separate str sep num opt)
+  (let* ((len (string-length str))
+	 (pos (if opt
+		  (let ((pos (remainder (if (eq? opt 'minus) (- len 1) len)
+					num)))
+		    (if (= 0 pos) num pos))
+		  num)))
+    (apply string-append
+	   (let loop ((ini 0)
+		      (pos (if (eq? opt 'minus) (+ pos 1) pos)))
+	     (if (< pos len)
+		 (cons (substring str ini pos)
+		       (cons sep (loop pos (+ pos num))))
+		 (list (substring str ini len)))))))
+
+(define (cat object . rest)
+  (let* ((str-rest (part string? rest))
+	 (str-list (car str-rest))
+	 (rest-list (cdr str-rest)))
+    (if (null? rest-list)
+	(apply string-append
+	       (cond
+		((number? object) (number->string object))
+		((string? object) object)
+		((char? object) (string object))
+		((boolean? object) (if object "#t" "#f"))
+		((symbol? object) (symbol->string object))
+		(else
+		 (get-output-string
+		  (let ((str-port (open-output-string)))
+		    (write object str-port)
+		    str-port))))
+	       str-list)
+	(alet-cat* rest-list
+	  ((width 0 (and (integer? width) (exact? width)))
+	   (port #f (or (boolean? port) (output-port? port))
+		 (if (eq? port #t) (current-output-port) port))
+	   (char #\space (char? char))
+	   (converter #f (and (pair? converter)
+			      (procedure? (car converter))
+			      (procedure? (cdr converter))))
+	   (precision #f (and (integer? precision)
+			      (inexact? precision)))
+	   (sign #f (eq? 'sign sign))
+	   (radix 'decimal
+		  (memq radix '(decimal octal binary hexadecimal)))
+	   (exactness #f (memq exactness '(exact inexact)))
+	   (separator #f (and (list? separator)
+			      (< 0 (length separator) 3)
+			      (char? (car separator))
+			      (or (null? (cdr separator))
+				  (let ((n (cadr separator)))
+				    (and (integer? n) (exact? n)
+					 (< 0 n))))))
+	   (writer #f (procedure? writer))
+	   (pipe #f (and (list? pipe)
+			 (not (null? pipe))
+			 (every? procedure? pipe)))
+	   (take #f (and (list? take)
+			 (< 0 (length take) 3)
+			 (every? (lambda (x)
+				   (and (integer? x) (exact? x)))
+				 take))))
+	  (let* ((str
+		  (cond
+		   ((and converter
+			 ((car converter) object))
+		    (let* ((str ((cdr converter) object))
+			   (pad (- (abs width) (string-length str))))
+		      (cond
+		       ((<= pad 0) str)
+		       ((< 0 width) (string-append (make-string pad char) str))
+		       (else (string-append str (make-string pad char))))))
+		   ((number? object)
+		    (and (not (eq? radix 'decimal)) precision
+			 (error "cat: non-decimal cannot have a decimal point"))
+		    (and precision (< precision 0) (eq? exactness 'exact)
+			 (error "cat: exact number cannot have a decimal point without exact sign"))
+		    (let* ((exact-sign (and precision
+					    (<= 0 precision)
+					    (or (eq? exactness 'exact)
+						(and (exact? object)
+						     (not (eq? exactness
+							       'inexact))))
+					    "#e"))
+			   (inexact-sign (and (not (eq? radix 'decimal))
+					      (or (and (inexact? object)
+						       (not (eq? exactness
+								 'exact)))
+						  (eq? exactness 'inexact))
+					      "#i"))
+			   (radix-sign (cdr (assq radix
+						  '((decimal . #f)
+						    (octal . "#o")
+						    (binary . "#b")
+						    (hexadecimal . "#x")))))
+			   (plus-sign (and sign (< 0 (real-part object)) "+"))
+			   (exactness-sign (or exact-sign inexact-sign))
+			   (str
+			    (if precision
+				(let ((precision (exact
+						  (abs precision)))
+				      (imag (imag-part object)))
+				  (if (= 0 imag)
+				      (e-mold object precision)
+				      (string-append
+				       (e-mold (real-part object) precision)
+				       (if (< 0 imag) "+" "")
+				       (e-mold imag precision)
+				       "i")))
+				(number->string
+				 (cond
+				  (inexact-sign (exact object))
+				  (exactness
+				   (if (eq? exactness 'exact)
+				       (exact object)
+				       (inexact object)))
+				  (else object))
+				 (cdr (assq radix '((decimal . 10)
+						    (octal . 8)
+						    (binary . 2)
+						    (hexadecimal . 16)))))))
+			   (str
+			    (if (and separator
+				     (not (or (and (eq? radix 'decimal)
+						   (str-index str #\e))
+					      (str-index str #\i)
+					      (str-index str #\/))))
+				(let ((sep (string (car separator)))
+				      (num (if (null? (cdr separator))
+					       3 (cadr separator)))
+				      (dot-index (str-index str #\.)))
+				  (if dot-index
+				      (string-append
+				       (separate (substring str 0 dot-index)
+						 sep num (if (< object 0)
+							     'minus #t))
+				       "."
+				       (separate (substring
+						  str (+ 1 dot-index)
+						  (string-length str))
+						 sep num #f))
+				      (separate str sep num (if (< object 0)
+								'minus #t))))
+				str))
+			   (pad (- (abs width)
+				   (+ (string-length str)
+				      (if exactness-sign 2 0)
+				      (if radix-sign 2 0)
+				      (if plus-sign 1 0))))
+			   (pad (if (< 0 pad) pad 0)))
+		      (if (< 0 width)
+			  (if (char-numeric? char)
+			      (if (< (real-part object) 0)
+				  (string-append (or exactness-sign "")
+						 (or radix-sign "")
+						 "-"
+						 (make-string pad char)
+						 (substring str 1
+							    (string-length
+							     str)))
+				  (string-append (or exactness-sign "")
+						 (or radix-sign "")
+						 (or plus-sign "")
+						 (make-string pad char)
+						 str))
+			      (string-append (make-string pad char)
+					     (or exactness-sign "")
+					     (or radix-sign "")
+					     (or plus-sign "")
+					     str))
+			  (string-append (or exactness-sign "")
+					 (or radix-sign "")
+					 (or plus-sign "")
+					 str
+					 (make-string pad char)))))
+		   (else
+		    (let* ((str (cond
+				 (writer (get-output-string
+					  (let ((str-port
+						 (open-output-string)))
+					    (writer object str-port)
+					    str-port)))
+				 ((string? object) object)
+				 ((char? object) (string object))
+				 ((boolean? object) (if object "#t" "#f"))
+				 ((symbol? object) (symbol->string object))
+				 (else (get-output-string
+					(let ((str-port (open-output-string)))
+					  (write object str-port)
+					  str-port)))))
+			   (str (if pipe
+				    (let loop ((str ((car pipe) str))
+					       (fns (cdr pipe)))
+				      (if (null? fns)
+					  str
+					  (loop ((car fns) str)
+						(cdr fns))))
+				    str))
+			   (str
+			    (if take
+				(let ((left (car take))
+				      (right (if (null? (cdr take))
+						 0 (cadr take)))
+				      (len (string-length str)))
+				  (define (substr str beg end)
+				    (let ((end (cond
+						((< end 0) 0)
+						((< len end) len)
+						(else end)))
+					  (beg (cond
+						((< beg 0) 0)
+						((< len beg) len)
+						(else beg))))
+				      (if (and (= beg 0) (= end len))
+					  str
+					  (substring str beg end))))
+				  (string-append
+				   (if (< left 0)
+				       (substr str (abs left) len)
+				       (substr str 0 left))
+				   (if (< right 0)
+				       (substr str 0 (+ len right))
+				       (substr str (- len right) len))))
+				str))
+			   (pad (- (abs width) (string-length str))))
+		      (cond
+		       ((<= pad 0) str)
+		       ((< 0 width) (string-append (make-string pad char) str))
+		       (else (string-append str (make-string pad char))))))))
+		 (str (apply string-append str str-list)))
+	    (and port (display str port))
+	    str)))))
+
+;;; eof
+(define-library (srfi 54)
+  (export cat)
+  (import
+   (scheme base)
+   (scheme char)
+   (scheme complex)
+   (scheme write)
+   (srfi 1))
+  (include "54.body.scm"))
+;;; Copyright (C) Joo ChurlSoo (2004). All Rights Reserved.
+
+;;; 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 (cat object . rest)
+  (let* ((str-rest (part string? rest))
+	 (str-list (car str-rest))
+	 (rest-list (cdr str-rest)))
+    (if (null? rest-list)
+	(apply string-append
+	       (cond
+		((number? object) (number->string object))
+		((string? object) object)
+		((char? object) (string object))
+		((boolean? object) (if object "#t" "#f"))
+		((symbol? object) (symbol->string object))
+		(else
+		 (get-output-string
+		  (let ((str-port (open-output-string)))
+		    (write object str-port)
+		    str-port))))
+	       str-list)
+	(alet-cat* rest-list
+	  ((width 0 (and (integer? width) (exact? width)))
+	   (port #f (or (boolean? port) (output-port? port))
+		 (if (eq? port #t) (current-output-port) port))
+	   (char #\space (char? char))
+	   (converter #f (and (pair? converter)
+			      (procedure? (car converter))
+			      (procedure? (cdr converter))))
+	   (precision #f (and (integer? precision)
+			      (inexact? precision)))
+	   (sign #f (eq? 'sign sign))
+	   (radix 'decimal
+		  (memq radix '(decimal octal binary hexadecimal)))
+	   (exactness #f (memq exactness '(exact inexact)))
+	   (separator #f (and (list? separator)
+			      (< 0 (length separator) 3)
+			      (char? (car separator))
+			      (or (null? (cdr separator))
+				  (let ((n (cadr separator)))
+				    (and (integer? n) (exact? n)
+					 (< 0 n))))))
+	   (writer #f (procedure? writer))
+	   (pipe #f (and (list? pipe)
+			 (not (null? pipe))
+			 (every? procedure? pipe)))
+	   (take #f (and (list? take)
+			 (< 0 (length take) 3)
+			 (every? (lambda (x)
+				   (and (integer? x) (exact? x)))
+				 take))))
+	  (let* ((str
+		  (cond
+		   ((and converter
+			 ((car converter) object))
+		    (let* ((str ((cdr converter) object))
+			   (pad (- (abs width) (string-length str))))
+		      (cond
+		       ((<= pad 0) str)
+		       ((< 0 width) (string-append (make-string pad char) str))
+		       (else (string-append str (make-string pad char))))))
+		   ((number? object)
+		    (and (not (eq? radix 'decimal)) precision
+			 (error "cat: non-decimal cannot have a decimal point"))
+		    (and precision (< precision 0) (eq? exactness 'exact)
+			 (error "cat: exact number cannot have a decimal point without exact sign"))
+		    (let* ((exact-sign (and precision
+					    (<= 0 precision)
+					    (or (eq? exactness 'exact)
+						(and (exact? object)
+						     (not (eq? exactness
+							       'inexact))))
+					    "#e"))
+			   (inexact-sign (and (not (eq? radix 'decimal))
+					      (or (and (inexact? object)
+						       (not (eq? exactness
+								 'exact)))
+						  (eq? exactness 'inexact))
+					      "#i"))
+			   (radix-sign (cdr (assq radix
+						  '((decimal . #f)
+						    (octal . "#o")
+						    (binary . "#b")
+						    (hexadecimal . "#x")))))
+			   (plus-sign (and sign (< 0 (real-part object)) "+"))
+			   (exactness-sign (or exact-sign inexact-sign))
+			   (str
+			    (if precision
+				(let ((precision (inexact->exact
+						  (abs precision)))
+				      (imag (imag-part object)))
+				  (if (= 0 imag)
+				      (e-mold object precision)
+				      (string-append
+				       (e-mold (real-part object) precision)
+				       (if (< 0 imag) "+" "")
+				       (e-mold imag precision)
+				       "i")))
+				(number->string
+				 (cond
+				  (inexact-sign (inexact->exact object))
+				  (exactness
+				   (if (eq? exactness 'exact)
+				       (inexact->exact object)
+				       (exact->inexact object)))
+				  (else object))
+				 (cdr (assq radix '((decimal . 10)
+						    (octal . 8)
+						    (binary . 2)
+						    (hexadecimal . 16)))))))
+			   (str
+			    (if (and separator
+				     (not (or (and (eq? radix 'decimal)
+						   (str-index str #\e))
+					      (str-index str #\i)
+					      (str-index str #\/))))
+				(let ((sep (string (car separator)))
+				      (num (if (null? (cdr separator))
+					       3 (cadr separator)))
+				      (dot-index (str-index str #\.)))
+				  (if dot-index
+				      (string-append
+				       (separate (substring str 0 dot-index)
+						 sep num (if (< object 0)
+							     'minus #t))
+				       "."
+				       (separate (substring
+						  str (+ 1 dot-index)
+						  (string-length str))
+						 sep num #f))
+				      (separate str sep num (if (< object 0)
+								'minus #t))))
+				str))
+			   (pad (- (abs width)
+				   (+ (string-length str)
+				      (if exactness-sign 2 0)
+				      (if radix-sign 2 0)
+				      (if plus-sign 1 0))))
+			   (pad (if (< 0 pad) pad 0)))
+		      (if (< 0 width)
+			  (if (char-numeric? char)
+			      (if (< (real-part object) 0)
+				  (string-append (or exactness-sign "")
+						 (or radix-sign "")
+						 "-"
+						 (make-string pad char)
+						 (substring str 1
+							    (string-length
+							     str)))
+				  (string-append (or exactness-sign "")
+						 (or radix-sign "")
+						 (or plus-sign "")
+						 (make-string pad char)
+						 str))
+			      (string-append (make-string pad char)
+					     (or exactness-sign "")
+					     (or radix-sign "")
+					     (or plus-sign "")
+					     str))
+			  (string-append (or exactness-sign "")
+					 (or radix-sign "")
+					 (or plus-sign "")
+					 str
+					 (make-string pad char)))))
+		   (else
+		    (let* ((str (cond
+				 (writer (get-output-string
+					  (let ((str-port
+						 (open-output-string)))
+					    (writer object str-port)
+					    str-port)))
+				 ((string? object) object)
+				 ((char? object) (string object))
+				 ((boolean? object) (if object "#t" "#f"))
+				 ((symbol? object) (symbol->string object))
+				 (else (get-output-string
+					(let ((str-port (open-output-string)))
+					  (write object str-port)
+					  str-port)))))
+			   (str (if pipe
+				    (let loop ((str ((car pipe) str))
+					       (fns (cdr pipe)))
+				      (if (null? fns)
+					  str
+					  (loop ((car fns) str)
+						(cdr fns))))
+				    str))
+			   (str
+			    (if take
+				(let ((left (car take))
+				      (right (if (null? (cdr take))
+						 0 (cadr take)))
+				      (len (string-length str)))
+				  (define (substr str beg end)
+				    (let ((end (cond
+						((< end 0) 0)
+						((< len end) len)
+						(else end)))
+					  (beg (cond
+						((< beg 0) 0)
+						((< len beg) len)
+						(else beg))))
+				      (if (and (= beg 0) (= end len))
+					  str
+					  (substring str beg end))))
+				  (string-append
+				   (if (< left 0)
+				       (substr str (abs left) len)
+				       (substr str 0 left))
+				   (if (< right 0)
+				       (substr str 0 (+ len right))
+				       (substr str (- len right) len))))
+				str))
+			   (pad (- (abs width) (string-length str))))
+		      (cond
+		       ((<= pad 0) str)
+		       ((< 0 width) (string-append (make-string pad char) str))
+		       (else (string-append str (make-string pad char))))))))
+		 (str (apply string-append str str-list)))
+	    (and port (display str port))
+	    str)))))
+
+(define-syntax alet-cat*		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((alet-cat* z (a . e) bd ...)
+     (let ((y z))
+       (%alet-cat* y (a . e) bd ...)))))
+
+(define-syntax %alet-cat*		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((%alet-cat* z ((n d t ...)) bd ...)
+     (let ((n (if (null? z)
+		  d
+		  (if (null? (cdr z))
+		      (wow-cat-end z n t ...)
+		      (error "cat: too many arguments" (cdr z))))))
+       bd ...))
+    ((%alet-cat* z ((n d t ...) . e) bd ...)
+     (let ((n (if (null? z)
+		  d
+		  (wow-cat! z n d t ...))))
+       (%alet-cat* z e bd ...)))
+    ((%alet-cat* z e bd ...)
+     (let ((e z)) bd ...))))
+
+(define-syntax wow-cat!			; borrowed from SRFI-86
+  (syntax-rules ()
+    ((wow-cat! z n d)
+     (let ((n (car z)))
+       (set! z (cdr z))
+       n))
+    ((wow-cat! z n d t)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) n)
+	   (let lp ((head (list n)) (tail (cdr z)))
+	     (if (null? tail)
+		 d
+		 (let ((n (car tail)))
+		   (if t
+		       (begin (set! z (append (reverse head) (cdr tail))) n)
+		       (lp (cons n head) (cdr tail)))))))))
+    ((wow-cat! z n d t ts)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) ts)
+	   (let lp ((head (list n)) (tail (cdr z)))
+	     (if (null? tail)
+		 d
+		 (let ((n (car tail)))
+		   (if t
+		       (begin (set! z (append (reverse head) (cdr tail))) ts)
+		       (lp (cons n head) (cdr tail)))))))))
+    ((wow-cat! z n d t ts fs)
+     (let ((n (car z)))
+       (if t
+	   (begin (set! z (cdr z)) ts)
+	   (begin (set! z (cdr z)) fs))))))
+
+(define-syntax wow-cat-end		; borrowed from SRFI-86
+  (syntax-rules ()
+    ((wow-cat-end z n)
+     (car z))
+    ((wow-cat-end z n t)
+     (let ((n (car z)))
+       (if t n (error "cat: too many argument" z))))
+    ((wow-cat-end z n t ts)
+     (let ((n (car z)))
+       (if t ts (error "cat: too many argument" z))))
+    ((wow-cat-end z n t ts fs)
+     (let ((n (car z)))
+       (if t ts fs)))))
+
+(define (str-index str char)
+  (let ((len (string-length str)))
+    (let lp ((n 0))
+      (and (< n len)
+	   (if (char=? char (string-ref str n))
+	       n
+	       (lp (+ n 1)))))))
+
+(define (every? pred ls)
+  (let lp ((ls ls))
+    (or (null? ls)
+	(and (pred (car ls))
+	     (lp (cdr ls))))))
+
+(define (part pred ls)
+  (let lp ((ls ls) (true '()) (false '()))
+    (cond
+     ((null? ls) (cons (reverse true) (reverse false)))
+     ((pred (car ls)) (lp (cdr ls) (cons (car ls) true) false))
+     (else (lp (cdr ls) true (cons (car ls) false))))))
+
+(define (e-mold num pre)
+  (let* ((str (number->string (exact->inexact num)))
+	 (e-index (str-index str #\e)))
+    (if e-index
+	(string-append (mold (substring str 0 e-index) pre)
+		       (substring str e-index (string-length str)))
+	(mold str pre))))
+
+(define (mold str pre)
+  (let ((ind (str-index str #\.)))
+    (if ind
+	(let ((d-len (- (string-length str) (+ ind 1))))
+	  (cond
+	   ((= d-len pre) str)
+	   ((< d-len pre) (string-append str (make-string (- pre d-len) #\0)))
+	   ;;((char<? #\4 (string-ref str (+ 1 ind pre)))
+	   ;;(let ((com (expt 10 pre)))
+	   ;;  (number->string (/ (round (* (string->number str) com)) com))))
+	   ((or (char<? #\5 (string-ref str (+ 1 ind pre)))
+		(and (char=? #\5 (string-ref str (+ 1 ind pre)))
+		     (or (< (+ 1 pre) d-len)
+			 (memv (string-ref str (+ ind (if (= 0 pre) -1 pre)))
+			       '(#\1 #\3 #\5 #\7 #\9)))))
+	    (apply
+	     string
+	     (let* ((minus (char=? #\- (string-ref str 0)))
+		    (str (substring str (if minus 1 0) (+ 1 ind pre)))
+		    (char-list
+		     (reverse
+		      (let lp ((index (- (string-length str) 1))
+			       (raise #t))
+			(if (= -1 index)
+			    (if raise '(#\1) '())
+			    (let ((chr (string-ref str index)))
+			      (if (char=? #\. chr)
+				  (cons chr (lp (- index 1) raise))
+				  (if raise
+				      (if (char=? #\9 chr)
+					  (cons #\0 (lp (- index 1) raise))
+					  (cons (integer->char
+						 (+ 1 (char->integer chr)))
+						(lp (- index 1) #f)))
+				      (cons chr (lp (- index 1) raise))))))))))
+	       (if minus (cons #\- char-list) char-list))))
+	   (else
+	    (substring str 0 (+ 1 ind pre)))))
+	(string-append str "." (make-string pre #\0)))))
+
+(define (separate str sep num opt)
+  (let* ((len (string-length str))
+	 (pos (if opt
+		  (let ((pos (remainder (if (eq? opt 'minus) (- len 1) len)
+					num)))
+		    (if (= 0 pos) num pos))
+		  num)))
+    (apply string-append
+	   (let loop ((ini 0)
+		      (pos (if (eq? opt 'minus) (+ pos 1) pos)))
+	     (if (< pos len)
+		 (cons (substring str ini pos)
+		       (cons sep (loop pos (+ pos num))))
+		 (list (substring str ini len)))))))
+
+;;; eof
+(define-library (srfi 57)
+  (export
+   define-record-type
+   define-record-scheme
+   record-update
+   record-update!
+   record-compose
+   )
+  (import
+   (rename (scheme base) (define-record-type srfi-9:define-record-type))
+   (scheme case-lambda))
+  (include "57.upstream.scm"))
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;;
+;; 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.
+
+(cond-expand
+ (chicken
+  (require-extension syntax-case))
+ (guile-2
+  (use-modules (srfi srfi-9)
+               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
+               ;; with either Guile's native exceptions or R6RS exceptions.
+               ;;(srfi srfi-34) (srfi srfi-35)
+               (srfi srfi-39)))
+ (guile
+  (use-modules (ice-9 syncase) (srfi srfi-9)
+	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
+	       (srfi srfi-39)))
+ (sisc
+  (require-extension (srfi 9 34 35 39)))
+ (kawa
+  (module-compile-options warn-undefined-variable\: #t
+			  warn-invoke-unknown-method\: #t)
+  (provide 'srfi-64)
+  (provide 'testing)
+  (require 'srfi-34)
+  (require 'srfi-35))
+ (else ()
+  ))
+
+(cond-expand
+ (kawa
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export test-begin . other-names)
+       (module-export %test-begin . other-names)))))
+ (else
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export . names) (if #f #f))))))
+
+;; List of exported names
+(%test-export
+ test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
+ test-end test-assert test-eqv test-eq test-equal
+ test-approximate test-assert test-error test-apply test-with-runner
+ test-match-nth test-match-all test-match-any test-match-name
+ test-skip test-expect-fail test-read-eval-string
+ test-runner-group-path test-group test-group-with-cleanup
+ test-result-ref test-result-set! test-result-clear test-result-remove
+ test-result-kind test-passed?
+ test-log-to-file
+ ; Misc test-runner functions
+ test-runner? test-runner-reset test-runner-null
+ test-runner-simple test-runner-current test-runner-factory test-runner-get
+ test-runner-create test-runner-test-name
+ ;; test-runner field setter and getter functions - see %test-record-define:
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+ test-result-alist test-result-alist!
+ test-runner-aux-value test-runner-aux-value!
+ ;; default/simple call-back functions, used in default test-runner,
+ ;; but can be called to construct more complex ones.
+ test-on-group-begin-simple test-on-group-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ test-on-final-simple test-on-test-end-simple
+ test-on-final-simple)
+
+(cond-expand
+ (srfi-9
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index setter getter) ...)
+       (define-record-type test-runner
+	 (alloc)
+	 runner?
+	 (name setter getter) ...)))))
+ (else
+  (define %test-runner-cookie (list "test-runner"))
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index getter setter) ...)
+       (begin
+	 (define (runner? obj)
+	   (and (vector? obj)
+		(> (vector-length obj) 1)
+		(eq (vector-ref obj 0) %test-runner-cookie)))
+	 (define (alloc)
+	   (let ((runner (make-vector 23)))
+	     (vector-set! runner 0 %test-runner-cookie)
+	     runner))
+	 (begin
+	   (define (getter runner)
+	     (vector-ref runner index)) ...)
+	 (begin
+	   (define (setter runner value)
+	     (vector-set! runner index value)) ...)))))))
+
+(%test-record-define
+ %test-runner-alloc test-runner?
+ ;; Cumulate count of all tests that have passed and were expected to.
+ (pass-count 1 test-runner-pass-count test-runner-pass-count!)
+ (fail-count 2 test-runner-fail-count test-runner-fail-count!)
+ (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count 5 test-runner-skip-count test-runner-skip-count!)
+ (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
+ ;; Normally #t, except when in a test-apply.
+ (run-list 8 %test-runner-run-list %test-runner-run-list!)
+ (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
+ (group-stack 11 test-runner-group-stack test-runner-group-stack!)
+ (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
+ ;; Call-back when entering a group. Takes (runner suite-name count).
+ (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
+ ;; Call-back when leaving a group.
+ (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
+ ;; Call-back when leaving the outermost group.
+ (on-final 16 test-runner-on-final test-runner-on-final!)
+ ;; Call-back when expected number of tests was wrong.
+ (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
+ ;; Call-back when name in test=end doesn't match test-begin.
+ (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ ;; Cumulate count of all tests that have been done.
+ (total-count 19 %test-runner-total-count %test-runner-total-count!)
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list 20 %test-runner-count-list %test-runner-count-list!)
+ (result-alist 21 test-result-alist test-result-alist!)
+ ;; Field can be used by test-runner for any purpose.
+ ;; test-runner-simple uses it for a log file.
+ (aux-value 22 test-runner-aux-value test-runner-aux-value!)
+)
+
+(define (test-runner-reset runner)
+  (test-result-alist! runner '())
+  (test-runner-pass-count! runner 0)
+  (test-runner-fail-count! runner 0)
+  (test-runner-xpass-count! runner 0)
+  (test-runner-xfail-count! runner 0)
+  (test-runner-skip-count! runner 0)
+  (%test-runner-total-count! runner 0)
+  (%test-runner-count-list! runner '())
+  (%test-runner-run-list! runner #t)
+  (%test-runner-skip-list! runner '())
+  (%test-runner-fail-list! runner '())
+  (%test-runner-skip-save! runner '())
+  (%test-runner-fail-save! runner '())
+  (test-runner-group-stack! runner '()))
+
+(define (test-runner-group-path runner)
+  (reverse (test-runner-group-stack runner)))
+
+(define (%test-null-callback runner) #f)
+
+(define (test-runner-null)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
+    (test-runner-on-group-end! runner %test-null-callback)
+    (test-runner-on-final! runner %test-null-callback)
+    (test-runner-on-test-begin! runner %test-null-callback)
+    (test-runner-on-test-end! runner %test-null-callback)
+    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
+    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
+    runner))
+
+;; Not part of the specification.  FIXME
+;; Controls whether a log file is generated.
+(define test-log-to-file #t)
+
+(define (test-runner-simple)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner test-on-group-begin-simple)
+    (test-runner-on-group-end! runner test-on-group-end-simple)
+    (test-runner-on-final! runner test-on-final-simple)
+    (test-runner-on-test-begin! runner test-on-test-begin-simple)
+    (test-runner-on-test-end! runner test-on-test-end-simple)
+    (test-runner-on-bad-count! runner test-on-bad-count-simple)
+    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+    runner))
+
+(cond-expand
+ (srfi-39
+  (define test-runner-current (make-parameter #f))
+  (define test-runner-factory (make-parameter test-runner-simple)))
+ (else
+  (define %test-runner-current #f)
+  (define-syntax test-runner-current
+    (syntax-rules ()
+      ((test-runner-current)
+       %test-runner-current)
+      ((test-runner-current runner)
+       (set! %test-runner-current runner))))
+  (define %test-runner-factory test-runner-simple)
+  (define-syntax test-runner-factory
+    (syntax-rules ()
+      ((test-runner-factory)
+       %test-runner-factory)
+      ((test-runner-factory runner)
+       (set! %test-runner-factory runner))))))
+
+;; A safer wrapper to test-runner-current.
+(define (test-runner-get)
+  (let ((r (test-runner-current)))
+    (if (not r)
+	(cond-expand
+	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
+	 (else #t)))
+    r))
+
+(define (%test-specifier-matches spec runner)
+  (spec runner))
+
+(define (test-runner-create)
+  ((test-runner-factory)))
+
+(define (%test-any-specifier-matches list runner)
+  (let ((result #f))
+    (let loop ((l list))
+      (cond ((null? l) result)
+	    (else
+	     (if (%test-specifier-matches (car l) runner)
+		 (set! result #t))
+	     (loop (cdr l)))))))
+
+;; Returns #f, #t, or 'xfail.
+(define (%test-should-execute runner)
+  (let ((run (%test-runner-run-list runner)))
+    (cond ((or
+	    (not (or (eqv? run #t)
+		     (%test-any-specifier-matches run runner)))
+	    (%test-any-specifier-matches
+	     (%test-runner-skip-list runner)
+	     runner))
+	    (test-result-set! runner 'result-kind 'skip)
+	    #f)
+	  ((%test-any-specifier-matches
+	    (%test-runner-fail-list runner)
+	    runner)
+	   (test-result-set! runner 'result-kind 'xfail)
+	   'xfail)
+	  (else #t))))
+
+(define (%test-begin suite-name count)
+  (if (not (test-runner-current))
+      (test-runner-current (test-runner-create)))
+  (let ((runner (test-runner-current)))
+    ((test-runner-on-group-begin runner) runner suite-name count)
+    (%test-runner-skip-save! runner
+			       (cons (%test-runner-skip-list runner)
+				     (%test-runner-skip-save runner)))
+    (%test-runner-fail-save! runner
+			       (cons (%test-runner-fail-list runner)
+				     (%test-runner-fail-save runner)))
+    (%test-runner-count-list! runner
+			     (cons (cons (%test-runner-total-count runner)
+					 count)
+				   (%test-runner-count-list runner)))
+    (test-runner-group-stack! runner (cons suite-name
+					(test-runner-group-stack runner)))))
+(cond-expand
+ (kawa
+  ;; Kawa has test-begin built in, implemented as:
+  ;; (begin
+  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
+  ;;   (%test-begin suite-name [count]))
+  ;; This puts test-begin but only test-begin in the default environment.,
+  ;; which makes normal test suites loadable without non-portable commands.
+  )
+ (else
+  (define-syntax test-begin
+    (syntax-rules ()
+      ((test-begin suite-name)
+       (%test-begin suite-name #f))
+      ((test-begin suite-name count)
+       (%test-begin suite-name count))))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+  (if (null? (test-runner-group-stack runner))
+      (begin
+	(display "%%%% Starting test ")
+	(display suite-name)
+	(if test-log-to-file
+	    (let* ((log-file-name
+		    (if (string? test-log-to-file) test-log-to-file
+			(string-append suite-name ".log")))
+		   (log-file
+		    (cond-expand (mzscheme
+				  (open-output-file log-file-name 'truncate/replace))
+				 (else (open-output-file log-file-name)))))
+	      (display "%%%% Starting test " log-file)
+	      (display suite-name log-file)
+	      (newline log-file)
+	      (test-runner-aux-value! runner log-file)
+	      (display "  (Writing full log to \"")
+	      (display log-file-name)
+	      (display "\")")))
+	(newline)))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group begin: " log)
+	  (display suite-name log)
+	  (newline log))))
+  #f)
+
+(define (test-on-group-end-simple runner)
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group end: " log)
+	  (display (car (test-runner-group-stack runner)) log)
+	  (newline log))))
+  #f)
+
+(define (%test-on-bad-count-write runner count expected-count port)
+  (display "*** Total number of tests was " port)
+  (display count port)
+  (display " but should be " port)
+  (display expected-count port)
+  (display ". ***" port)
+  (newline port)
+  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
+  (newline port))
+
+(define (test-on-bad-count-simple runner count expected-count)
+  (%test-on-bad-count-write runner count expected-count (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-on-bad-count-write runner count expected-count log))))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
+			    " does not match test-begin " end-name)))
+    (cond-expand
+     (srfi-23 (error msg))
+     (else (display msg) (newline)))))
+  
+
+(define (%test-final-report1 value label port)
+  (if (> value 0)
+      (begin
+	(display label port)
+	(display value port)
+	(newline port))))
+
+(define (%test-final-report-simple runner port)
+  (%test-final-report1 (test-runner-pass-count runner)
+		      "# of expected passes      " port)
+  (%test-final-report1 (test-runner-xfail-count runner)
+		      "# of expected failures    " port)
+  (%test-final-report1 (test-runner-xpass-count runner)
+		      "# of unexpected successes " port)
+  (%test-final-report1 (test-runner-fail-count runner)
+		      "# of unexpected failures  " port)
+  (%test-final-report1 (test-runner-skip-count runner)
+		      "# of skipped tests        " port))
+
+(define (test-on-final-simple runner)
+  (%test-final-report-simple runner (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-final-report-simple runner log))))
+
+(define (%test-format-line runner)
+   (let* ((line-info (test-result-alist runner))
+	  (source-file (assq 'source-file line-info))
+	  (source-line (assq 'source-line line-info))
+	  (file (if source-file (cdr source-file) "")))
+     (if source-line
+	 (string-append file ":"
+			(number->string (cdr source-line)) ": ")
+	 "")))
+
+(define (%test-end suite-name line-info)
+  (let* ((r (test-runner-get))
+	 (groups (test-runner-group-stack r))
+	 (line (%test-format-line r)))
+    (test-result-alist! r line-info)
+    (if (null? groups)
+	(let ((msg (string-append line "test-end not in a group")))
+	  (cond-expand
+	   (srfi-23 (error msg))
+	   (else (display msg) (newline)))))
+    (if (and suite-name (not (equal? suite-name (car groups))))
+	((test-runner-on-bad-end-name r) r suite-name (car groups)))
+    (let* ((count-list (%test-runner-count-list r))
+	   (expected-count (cdar count-list))
+	   (saved-count (caar count-list))
+	   (group-count (- (%test-runner-total-count r) saved-count)))
+      (if (and expected-count
+	       (not (= expected-count group-count)))
+	  ((test-runner-on-bad-count r) r group-count expected-count))
+      ((test-runner-on-group-end r) r)
+      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+      (%test-runner-count-list! r (cdr count-list))
+      (if (null? (test-runner-group-stack r))
+	  ((test-runner-on-final r) r)))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((test-group suite-name . body)
+     (let ((r (test-runner-current)))
+       ;; Ideally should also set line-number, if available.
+       (test-result-alist! r (list (cons 'test-name suite-name)))
+       (if (%test-should-execute r)
+	   (dynamic-wind
+	       (lambda () (test-begin suite-name))
+	       (lambda () . body)
+	       (lambda () (test-end  suite-name))))))))
+
+(define-syntax test-group-with-cleanup
+  (syntax-rules ()
+    ((test-group-with-cleanup suite-name form cleanup-form)
+     (test-group suite-name
+		    (dynamic-wind
+			(lambda () #f)
+			(lambda () form)
+			(lambda () cleanup-form))))
+    ((test-group-with-cleanup suite-name cleanup-form)
+     (test-group-with-cleanup suite-name #f cleanup-form))
+    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
+     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
+
+(define (test-on-test-begin-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (source-form (assq 'source-form results))
+	       (test-name (assq 'test-name results)))
+	  (display "Test begin:" log)
+	  (newline log)
+	  (if test-name (%test-write-result1 test-name log))
+	  (if source-file (%test-write-result1 source-file log))
+	  (if source-line (%test-write-result1 source-line log))
+	  (if source-form (%test-write-result1 source-form log))))))
+
+(define-syntax test-result-ref
+  (syntax-rules ()
+    ((test-result-ref runner pname)
+     (test-result-ref runner pname #f))
+    ((test-result-ref runner pname default)
+     (let ((p (assq pname (test-result-alist runner))))
+       (if p (cdr p) default)))))
+
+(define (test-on-test-end-simple runner)
+  (let ((log (test-runner-aux-value runner))
+	(kind (test-result-ref runner 'result-kind)))
+    (if (memq kind '(fail xpass))
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (test-name (assq 'test-name results)))
+	  (if (or source-file source-line)
+	      (begin
+		(if source-file (display (cdr source-file)))
+		(display ":")
+		(if source-line (display (cdr source-line)))
+		(display ": ")))
+	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
+	  (if test-name
+	      (begin
+		(display " ")
+		(display (cdr test-name))))
+	  (newline)))
+    (if (output-port? log)
+	(begin
+	  (display "Test end:" log)
+	  (newline log)
+	  (let loop ((list (test-result-alist runner)))
+	    (if (pair? list)
+		(let ((pair (car list)))
+		  ;; Write out properties not written out by on-test-begin.
+		  (if (not (memq (car pair)
+				 '(test-name source-file source-line source-form)))
+		      (%test-write-result1 pair log))
+		  (loop (cdr list)))))))))
+
+(define (%test-write-result1 pair port)
+  (display "  " port)
+  (display (car pair) port)
+  (display ": " port)
+  (write (cdr pair) port)
+  (newline port))
+
+(define (test-result-set! runner pname value)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(set-cdr! p value)
+	(test-result-alist! runner (cons (cons pname value) alist)))))
+
+(define (test-result-clear runner)
+  (test-result-alist! runner '()))
+
+(define (test-result-remove runner pname)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(test-result-alist! runner
+				   (let loop ((r alist))
+				     (if (eq? r p) (cdr r)
+					 (cons (car r) (loop (cdr r)))))))))
+
+(define (test-result-kind . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
+    (test-result-ref runner 'result-kind)))
+
+(define (test-passed? . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
+    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
+
+(define (%test-report-result)
+  (let* ((r (test-runner-get))
+	 (result-kind (test-result-kind r)))
+    (case result-kind
+      ((pass)
+       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
+      ((fail)
+       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
+      ((xpass)
+       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
+      ((xfail)
+       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
+      (else
+       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
+    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
+    ((test-runner-on-test-end r) r)))
+
+(cond-expand
+ (guile
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (catch #t
+         (lambda () test-expression)
+         (lambda (key . args)
+           (test-result-set! (test-runner-current) 'actual-error
+                             (cons key args))
+           #f))))))
+ (kawa
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (try-catch test-expression
+		  (ex <java.lang.Throwable>
+		      (test-result-set! (test-runner-current) 'actual-error ex)
+		      #f))))))
+ (srfi-34
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (guard (err (else #f)) test-expression)))))
+ (chicken
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (condition-case test-expression (ex () #f))))))
+ (else
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       test-expression)))))
+	    
+(cond-expand
+ ((or kawa mzscheme)
+  (cond-expand
+   (mzscheme
+    (define-for-syntax (%test-syntax-file form)
+      (let ((source (syntax-source form)))
+	(cond ((string? source) file)
+				((path? source) (path->string source))
+				(else #f)))))
+   (kawa
+    (define (%test-syntax-file form)
+      (syntax-source form))))
+  (define (%test-source-line2 form)
+    (let* ((line (syntax-line form))
+	   (file (%test-syntax-file form))
+	   (line-pair (if line (list (cons 'source-line line)) '())))
+      (cons (cons 'source-form (syntax-object->datum form))
+	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
+ (guile-2
+  (define (%test-source-line2 form)
+    (let* ((src-props (syntax-source form))
+           (file (and src-props (assq-ref src-props 'filename)))
+           (line (and src-props (assq-ref src-props 'line)))
+           (file-alist (if file
+                           `((source-file . ,file))
+                           '()))
+           (line-alist (if line
+                           `((source-line . ,(+ line 1)))
+                           '())))
+      (datum->syntax (syntax here)
+                     `((source-form . ,(syntax->datum form))
+                       ,@file-alist
+                       ,@line-alist)))))
+ (else
+  (define (%test-source-line2 form)
+    '())))
+
+(define (%test-on-test-begin r)
+  (%test-should-execute r)
+  ((test-runner-on-test-begin r) r)
+  (not (eq? 'skip (test-result-ref r 'result-kind))))
+
+(define (%test-on-test-end r result)
+    (test-result-set! r 'result-kind
+		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
+			  (if result 'xpass 'xfail)
+			  (if result 'pass 'fail))))
+
+(define (test-runner-test-name runner)
+  (test-result-ref runner 'test-name ""))
+
+(define-syntax %test-comp2body
+  (syntax-rules ()
+		((%test-comp2body r comp expected expr)
+		 (let ()
+		   (if (%test-on-test-begin r)
+		       (let ((exp expected))
+			 (test-result-set! r 'expected-value exp)
+			 (let ((res (%test-evaluate-with-catch expr)))
+			   (test-result-set! r 'actual-value res)
+			   (%test-on-test-end r (comp exp res)))))
+		   (%test-report-result)))))
+
+(define (%test-approximate= error)
+  (lambda (value expected)
+    (let ((rval (real-part value))
+          (ival (imag-part value))
+          (rexp (real-part expected))
+          (iexp (imag-part expected)))
+      (and (>= rval (- rexp error))
+           (>= ival (- iexp error))
+           (<= rval (+ rexp error))
+           (<= ival (+ iexp error))))))
+
+(define-syntax %test-comp1body
+  (syntax-rules ()
+    ((%test-comp1body r expr)
+     (let ()
+       (if (%test-on-test-begin r)
+	   (let ()
+	     (let ((res (%test-evaluate-with-catch expr)))
+	       (test-result-set! r 'actual-value res)
+	       (%test-on-test-end r res))))
+       (%test-report-result)))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+  ;; Should be made to work for any Scheme with syntax-case
+  ;; However, I haven't gotten the quoting working.  FIXME.
+  (define-syntax test-end
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac suite-name) line)
+	 (syntax
+	  (%test-end suite-name line)))
+	(((mac) line)
+	 (syntax
+	  (%test-end #f line))))))
+  (define-syntax test-assert
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac tname expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get))
+		 (name tname))
+	    (test-result-alist! r (cons (cons 'test-name tname) line))
+	    (%test-comp1body r expr))))
+	(((mac expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-comp1body r expr)))))))
+  (define (%test-comp2 comp x)
+    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
+      (((mac tname expected expr) line comp)
+       (syntax
+	(let* ((r (test-runner-get))
+	       (name tname))
+	  (test-result-alist! r (cons (cons 'test-name tname) line))
+	  (%test-comp2body r comp expected expr))))
+      (((mac expected expr) line comp)
+       (syntax
+	(let* ((r (test-runner-get)))
+	  (test-result-alist! r line)
+	  (%test-comp2body r comp expected expr))))))
+  (define-syntax test-eqv
+    (lambda (x) (%test-comp2 (syntax eqv?) x)))
+  (define-syntax test-eq
+    (lambda (x) (%test-comp2 (syntax eq?) x)))
+  (define-syntax test-equal
+    (lambda (x) (%test-comp2 (syntax equal?) x)))
+  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+      (((mac tname expected expr error) line)
+       (syntax
+	(let* ((r (test-runner-get))
+	       (name tname))
+	  (test-result-alist! r (cons (cons 'test-name tname) line))
+	  (%test-comp2body r (%test-approximate= error) expected expr))))
+      (((mac expected expr error) line)
+       (syntax
+	(let* ((r (test-runner-get)))
+	  (test-result-alist! r line)
+	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
+ (else
+  (define-syntax test-end
+    (syntax-rules ()
+      ((test-end)
+       (%test-end #f '()))
+      ((test-end suite-name)
+       (%test-end suite-name '()))))
+  (define-syntax test-assert
+    (syntax-rules ()
+      ((test-assert tname test-expression)
+       (let* ((r (test-runner-get))
+	      (name tname))
+	 (test-result-alist! r '((test-name . tname)))
+	 (%test-comp1body r test-expression)))
+      ((test-assert test-expression)
+       (let* ((r (test-runner-get)))
+	 (test-result-alist! r '())
+	 (%test-comp1body r test-expression)))))
+  (define-syntax %test-comp2
+    (syntax-rules ()
+      ((%test-comp2 comp tname expected expr)
+       (let* ((r (test-runner-get))
+	      (name tname))
+	 (test-result-alist! r (list (cons 'test-name tname)))
+	 (%test-comp2body r comp expected expr)))
+      ((%test-comp2 comp expected expr)
+       (let* ((r (test-runner-get)))
+	 (test-result-alist! r '())
+	 (%test-comp2body r comp expected expr)))))
+  (define-syntax test-equal
+    (syntax-rules ()
+      ((test-equal . rest)
+       (%test-comp2 equal? . rest))))
+  (define-syntax test-eqv
+    (syntax-rules ()
+      ((test-eqv . rest)
+       (%test-comp2 eqv? . rest))))
+  (define-syntax test-eq
+    (syntax-rules ()
+      ((test-eq . rest)
+       (%test-comp2 eq? . rest))))
+  (define-syntax test-approximate
+    (syntax-rules ()
+      ((test-approximate tname expected expr error)
+       (%test-comp2 (%test-approximate= error) tname expected expr))
+      ((test-approximate expected expr error)
+       (%test-comp2 (%test-approximate= error) expected expr))))))
+
+(cond-expand
+ (guile
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (cond ((%test-on-test-begin r)
+              (let ((et etype))
+                (test-result-set! r 'expected-error et)
+                (%test-on-test-end r
+                                   (catch #t
+                                     (lambda ()
+                                       (test-result-set! r 'actual-value expr)
+                                       #f)
+                                     (lambda (key . args)
+                                       ;; TODO: decide how to specify expected
+                                       ;; error types for Guile.
+                                       (test-result-set! r 'actual-error
+                                                         (cons key args))
+                                       #t)))
+                (%test-report-result))))))))
+ (mzscheme
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
+					 (let ()
+					   (test-result-set! r 'actual-value expr)
+					   #f)))))))
+ (chicken
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+        (%test-comp1body r (condition-case expr (ex () #t)))))))
+ (kawa
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r #t expr)
+       (cond ((%test-on-test-begin r)
+	      (test-result-set! r 'expected-error #t)
+	      (%test-on-test-end r
+				 (try-catch
+				  (let ()
+				    (test-result-set! r 'actual-value expr)
+				    #f)
+				  (ex <java.lang.Throwable>
+				      (test-result-set! r 'actual-error ex)
+				      #t)))
+	      (%test-report-result))))
+      ((%test-error r etype expr)
+       (if (%test-on-test-begin r)
+	   (let ((et etype))
+	     (test-result-set! r 'expected-error et)
+	     (%test-on-test-end r
+				(try-catch
+				 (let ()
+				   (test-result-set! r 'actual-value expr)
+				   #f)
+				 (ex <java.lang.Throwable>
+				     (test-result-set! r 'actual-error ex)
+				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
+						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
+					    (instance? ex et))
+					   (else #t)))))
+	     (%test-report-result)))))))
+ ((and srfi-34 srfi-35)
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (guard (ex ((condition-type? etype)
+		   (and (condition? ex) (condition-has-type? ex etype)))
+		  ((procedure? etype)
+		   (etype ex))
+		  ((equal? etype #t)
+		   #t)
+		  (else #t))
+	      expr #f))))))
+ (srfi-34
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
+ (else
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (begin
+	 ((test-runner-on-test-begin r) r)
+	 (test-result-set! r 'result-kind 'skip)
+	 (%test-report-result)))))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+
+  (define-syntax test-error
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac tname etype expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get))
+		 (name tname))
+	    (test-result-alist! r (cons (cons 'test-name tname) line))
+	    (%test-error r etype expr))))
+	(((mac etype expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-error r etype expr))))
+	(((mac expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-error r #t expr))))))))
+ (else
+  (define-syntax test-error
+    (syntax-rules ()
+      ((test-error name etype expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r `((test-name . ,name)))
+         (%test-error r etype expr)))
+      ((test-error etype expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r etype expr)))
+      ((test-error expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r #t expr)))))))
+
+(define (test-apply first . rest)
+  (if (test-runner? first)
+      (test-with-runner first (apply test-apply rest))
+      (let ((r (test-runner-current)))
+	(if r
+	    (let ((run-list (%test-runner-run-list r)))
+	      (cond ((null? rest)
+		     (%test-runner-run-list! r (reverse run-list))
+		     (first)) ;; actually apply procedure thunk
+		    (else
+		     (%test-runner-run-list!
+		      r
+		      (if (eq? run-list #t) (list first) (cons first run-list)))
+		     (apply test-apply rest)
+		     (%test-runner-run-list! r run-list))))
+	    (let ((r (test-runner-create)))
+	      (test-with-runner r (apply test-apply first rest))
+	      ((test-runner-on-final r) r))))))
+
+(define-syntax test-with-runner
+  (syntax-rules ()
+    ((test-with-runner runner form ...)
+     (let ((saved-runner (test-runner-current)))
+       (dynamic-wind
+           (lambda () (test-runner-current runner))
+           (lambda () form ...)
+           (lambda () (test-runner-current saved-runner)))))))
+
+;;; Predicates
+
+(define (%test-match-nth n count)
+  (let ((i 0))
+    (lambda (runner)
+      (set! i (+ i 1))
+      (and (>= i n) (< i (+ n count))))))
+
+(define-syntax test-match-nth
+  (syntax-rules ()
+    ((test-match-nth n)
+     (test-match-nth n 1))
+    ((test-match-nth n count)
+     (%test-match-nth n count))))
+
+(define (%test-match-all . pred-list)
+  (lambda (runner)
+    (let ((result #t))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if (not ((car l) runner))
+		  (set! result #f))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-all
+  (syntax-rules ()
+    ((test-match-all pred ...)
+     (%test-match-all (%test-as-specifier pred) ...))))
+
+(define (%test-match-any . pred-list)
+  (lambda (runner)
+    (let ((result #f))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if ((car l) runner)
+		  (set! result #t))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-any
+  (syntax-rules ()
+    ((test-match-any pred ...)
+     (%test-match-any (%test-as-specifier pred) ...))))
+
+;; Coerce to a predicate function:
+(define (%test-as-specifier specifier)
+  (cond ((procedure? specifier) specifier)
+	((integer? specifier) (test-match-nth 1 specifier))
+	((string? specifier) (test-match-name specifier))
+	(else
+	 (error "not a valid test specifier"))))
+
+(define-syntax test-skip
+  (syntax-rules ()
+    ((test-skip pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-skip-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-skip-list runner)))))))
+
+(define-syntax test-expect-fail
+  (syntax-rules ()
+    ((test-expect-fail pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-fail-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-fail-list runner)))))))
+
+(define (test-match-name name)
+  (lambda (runner)
+    (equal? name (test-runner-test-name runner))))
+
+(define (test-read-eval-string string)
+  (let* ((port (open-input-string string))
+	 (form (read port)))
+    (if (eof-object? (read-char port))
+	(cond-expand
+	 (guile (eval form (current-module)))
+	 (else (eval form)))
+	(cond-expand
+	 (srfi-23 (error "(not at eof)"))
+	 (else "error")))))
+
+(define-library (srfi 67)
+  (export
+   </<=?
+   </<?
+   <=/<=?
+   <=/<?
+   <=?
+   <?
+   =?
+   >/>=?
+   >/>?
+   >=/>=?
+   >=/>?
+   >=?
+   >?
+   boolean-compare
+   chain<=?
+   chain<?
+   chain=?
+   chain>=?
+   chain>?
+   char-compare
+   char-compare-ci
+   compare-by<
+   compare-by<=
+   compare-by=/<
+   compare-by=/>
+   compare-by>
+   compare-by>=
+   complex-compare
+   cond-compare
+   debug-compare
+   default-compare
+   if-not=?
+   if3
+   if<=?
+   if<?
+   if=?
+   if>=?
+   if>?
+   integer-compare
+   kth-largest
+   list-compare
+   list-compare-as-vector
+   max-compare
+   min-compare
+   not=?
+   number-compare
+   pair-compare
+   pair-compare-car
+   pair-compare-cdr
+   pairwise-not=?
+   rational-compare
+   real-compare
+   refine-compare
+   select-compare
+   symbol-compare
+   vector-compare
+   vector-compare-as-list
+   bytevector-compare
+   bytevector-compare-as-list
+   )
+  (import
+   (scheme base)
+   (scheme case-lambda)
+   (scheme char)
+   (scheme complex)
+   (srfi 27))
+  (include "67.upstream.scm")
+  (begin
+    
+    (define (bytevector-compare bv1 bv2)
+      (let ((len1 (bytevector-length bv1))
+            (len2 (bytevector-length bv2)))
+        (cond
+         ((< len1 len2) -1)
+         ((> len1 len2) +1)
+         (else
+          (let lp ((i 0))
+            (if (= i len1)
+                0
+                (let ((b1 (bytevector-u8-ref bv1 i))
+                      (b2 (bytevector-u8-ref bv2 i)))
+                  (cond
+                   ((< b1 b2) -1)
+                   ((> b1 b2) +1)
+                   (else
+                    (lp (+ 1 i)))))))))))
+
+    (define (bytevector-compare-as-list bv1 bv2)
+      (let ((len1 (bytevector-length bv1))
+            (len2 (bytevector-length bv2)))
+        (let lp ((i 0))
+          (cond
+           ((or (= i len1) (= i len2))
+            (cond ((< len1 len2) -1)
+                  ((> len1 len2) +1)
+                  (else 0)))
+           (else
+            (let ((b1 (bytevector-u8-ref bv1 i))
+                  (b2 (bytevector-u8-ref bv2 i)))
+              (cond
+               ((< b1 b2) -1)
+               ((> b1 b2) +1)
+               (else
+                (lp (+ 1 i))))))))))
+
+    ))
+; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
+; 
+; 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.
+; 
+; -----------------------------------------------------------------------
+; 
+; Compare procedures SRFI (reference implementation)
+; Sebastian.Egner@philips.com, Jensaxel@soegaard.net
+; history of this file:
+;   SE, 14-Oct-2004: first version
+;   SE, 18-Oct-2004: 1st redesign: axioms for 'compare function'
+;   SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite
+;   SE,  2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's
+;   SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare
+;   SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added
+;   SE, 12-Jan-2005: pair-compare-cdr
+;   SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=?
+;   SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc.
+;   JS, 24-Feb-2005: selection-compare added
+;   SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc.
+;   JS, 28-Feb-2005: kth-largest modified - is "stable" now
+;   SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged
+;   SE, 07-Apr-2005: compare-based type checks made explicit
+;   SE, 18-Apr-2005: added (rel? compare) and eq?-test
+;   SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y
+
+; =============================================================================
+
+; Reference Implementation
+; ========================
+;
+; in R5RS (including hygienic macros)
+;  + SRFI-16 (case-lambda) 
+;  + SRFI-23 (error) 
+;  + SRFI-27 (random-integer)
+
+; Implementation remarks:
+;   * In general, the emphasis of this implementation is on correctness
+;     and portability, not on efficiency.
+;   * Variable arity procedures are expressed in terms of case-lambda
+;     in the hope that this will produce efficient code for the case
+;     where the arity is statically known at the call site.
+;   * In procedures that are required to type-check their arguments,
+;     we use (compare x x) for executing extra checks. This relies on
+;     the assumption that eq? is used to catch this case quickly.
+;   * Care has been taken to reference comparison procedures of R5RS
+;     only at the time the operations here are being defined. This
+;     makes it possible to redefine these operations, if need be.
+;   * For the sake of efficiency, some inlining has been done by hand.
+;     This is mainly expressed by macros producing defines.
+;   * Identifiers of the form compare:<something> are private.
+;
+; Hints for low-level implementation:
+;   * The basis of this SRFI are the atomic compare procedures, 
+;     i.e. boolean-compare, char-compare, etc. and the conditionals
+;     if3, if=?, if<? etc., and default-compare. These should make
+;     optimal use of the available type information.
+;   * For the sake of speed, the reference implementation does not
+;     use a LET to save the comparison value c for the ERROR call.
+;     This can be fixed in a low-level implementation at no cost.
+;   * Type-checks based on (compare x x) are made explicit by the
+;     expression (compare:check result compare x ...).
+;   * Eq? should  can used to speed up built-in compare procedures,
+;     but it can only be used after type-checking at least one of
+;     the arguments.
+
+(define (compare:checked result compare . args)
+  (for-each (lambda (x) (compare x x)) args)
+  result)
+
+
+; 3-sided conditional
+
+(define-syntax if3
+  (syntax-rules ()
+    ((if3 c less equal greater)
+     (case c
+       ((-1) less)
+       (( 0) equal)
+       (( 1) greater)
+       (else (error "comparison value not in {-1,0,1}"))))))
+
+
+; 2-sided conditionals for comparisons
+
+(define-syntax compare:if-rel?
+  (syntax-rules ()
+    ((compare:if-rel? c-cases a-cases c consequence)
+     (compare:if-rel? c-cases a-cases c consequence (if #f #f)))
+    ((compare:if-rel? c-cases a-cases c consequence alternate)
+     (case c
+       (c-cases consequence)
+       (a-cases alternate)
+       (else    (error "comparison value not in {-1,0,1}"))))))
+
+(define-syntax if=?
+  (syntax-rules ()
+    ((if=? arg ...)
+     (compare:if-rel? (0) (-1 1) arg ...))))
+
+(define-syntax if<?
+  (syntax-rules ()
+    ((if<? arg ...)
+     (compare:if-rel? (-1) (0 1) arg ...))))
+
+(define-syntax if>?
+  (syntax-rules ()
+    ((if>? arg ...)
+     (compare:if-rel? (1) (-1 0) arg ...))))
+
+(define-syntax if<=?
+  (syntax-rules ()
+    ((if<=? arg ...)
+     (compare:if-rel? (-1 0) (1) arg ...))))
+
+(define-syntax if>=?
+  (syntax-rules ()
+    ((if>=? arg ...)
+     (compare:if-rel? (0 1) (-1) arg ...))))
+
+(define-syntax if-not=?
+  (syntax-rules ()
+    ((if-not=? arg ...)
+     (compare:if-rel? (-1 1) (0) arg ...))))
+
+
+; predicates from compare procedures
+
+(define-syntax compare:define-rel?
+  (syntax-rules ()
+    ((compare:define-rel? rel? if-rel?)
+     (define rel?
+       (case-lambda
+	(()        (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+	((compare) (lambda (x y) (if-rel? (compare         x y) #t #f)))
+	((x y)                   (if-rel? (default-compare x y) #t #f))
+	((compare x y)
+	 (if (procedure? compare)
+	     (if-rel? (compare x y) #t #f)
+	     (error "not a procedure (Did you mean rel/rel??): " compare))))))))
+
+(compare:define-rel? =?    if=?)
+(compare:define-rel? <?    if<?)
+(compare:define-rel? >?    if>?)
+(compare:define-rel? <=?   if<=?)
+(compare:define-rel? >=?   if>=?)
+(compare:define-rel? not=? if-not=?)
+
+
+; chains of length 3
+
+(define-syntax compare:define-rel1/rel2?
+  (syntax-rules ()
+    ((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
+     (define rel1/rel2?
+       (case-lambda
+	(()
+	 (lambda (x y z)
+	   (if-rel1? (default-compare x y)
+		     (if-rel2? (default-compare y z) #t #f)
+		     (compare:checked #f default-compare z))))
+	((compare)
+	 (lambda (x y z)
+	   (if-rel1? (compare x y)
+		(if-rel2? (compare y z) #t #f)
+		(compare:checked #f compare z))))
+	((x y z)
+	 (if-rel1? (default-compare x y)
+	       (if-rel2? (default-compare y z) #t #f)
+	       (compare:checked #f default-compare z)))
+	((compare x y z)
+	 (if-rel1? (compare x y)
+	       (if-rel2? (compare y z) #t #f)
+	       (compare:checked #f compare z))))))))
+
+(compare:define-rel1/rel2? </<?   if<?  if<?)
+(compare:define-rel1/rel2? </<=?  if<?  if<=?)
+(compare:define-rel1/rel2? <=/<?  if<=? if<?)
+(compare:define-rel1/rel2? <=/<=? if<=? if<=?)
+(compare:define-rel1/rel2? >/>?   if>?  if>?)
+(compare:define-rel1/rel2? >/>=?  if>?  if>=?)
+(compare:define-rel1/rel2? >=/>?  if>=? if>?)
+(compare:define-rel1/rel2? >=/>=? if>=? if>=?)
+
+
+; chains of arbitrary length
+
+(define-syntax compare:define-chain-rel?
+  (syntax-rules ()
+    ((compare:define-chain-rel? chain-rel? if-rel?)
+     (define chain-rel?
+       (case-lambda
+	((compare)
+	 #t)
+	((compare x1)
+	 (compare:checked #t compare x1))
+	((compare x1 x2)
+	 (if-rel? (compare x1 x2) #t #f))
+	((compare x1 x2 x3)
+	 (if-rel? (compare x1 x2)
+		  (if-rel? (compare x2 x3) #t #f)
+		  (compare:checked #f compare x3)))
+	((compare x1 x2 . x3+)
+	 (if-rel? (compare x1 x2)
+		  (let chain? ((head x2) (tail x3+))
+		    (if (null? tail)
+			#t
+			(if-rel? (compare head (car tail))
+				 (chain? (car tail) (cdr tail))
+				 (apply compare:checked #f 
+					compare (cdr tail)))))
+		  (apply compare:checked #f compare x3+))))))))
+
+(compare:define-chain-rel? chain=?  if=?)
+(compare:define-chain-rel? chain<?  if<?)
+(compare:define-chain-rel? chain>?  if>?)
+(compare:define-chain-rel? chain<=? if<=?)
+(compare:define-chain-rel? chain>=? if>=?)
+
+
+; pairwise inequality
+
+(define pairwise-not=?
+  (let ((= =) (<= <=))
+    (case-lambda
+      ((compare)
+       #t)
+      ((compare x1)
+       (compare:checked #t compare x1))
+      ((compare x1 x2)
+       (if-not=? (compare x1 x2) #t #f))
+      ((compare x1 x2 x3)
+       (if-not=? (compare x1 x2)
+                 (if-not=? (compare x2 x3)
+                           (if-not=? (compare x1 x3) #t #f)
+                           #f)
+		 (compare:checked #f compare x3)))
+      ((compare . x1+)
+       (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t))
+         (if (< n 2)
+	     (if (and unchecked? (= n 1))
+		 (compare:checked #t compare (car x))
+		 #t)
+             (let* ((i-pivot (random-integer n))
+                    (x-pivot (list-ref x i-pivot)))
+               (let split ((i 0) (x x) (x< '()) (x> '()))
+                 (if (null? x)
+                     (and (unequal? x< (length x<) #f)
+                          (unequal? x> (length x>) #f))
+                     (if (= i i-pivot)
+                         (split (+ i 1) (cdr x) x< x>)
+                         (if3 (compare (car x) x-pivot)
+                              (split (+ i 1) (cdr x) (cons (car x) x<) x>)
+			      (if unchecked?
+				  (apply compare:checked #f compare (cdr x))
+				  #f)
+                              (split (+ i 1) (cdr x) x< (cons (car x) x>)))))))))))))
+
+
+; min/max
+
+(define min-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if<=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3) x1 x3)
+            (if<=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3)
+                   (if<=? (compare x1 x4) x1 x4)
+                   (if<=? (compare x3 x4) x3 x4))
+            (if<=? (compare x2 x3)
+                   (if<=? (compare x2 x4) x2 x4)
+                   (if<=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmin
+           (min (if<=? (compare xmin (car xs)) xmin (car xs))
+                (cdr xs)))))))
+
+(define max-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if>=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3) x1 x3)
+            (if>=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3)
+                   (if>=? (compare x1 x4) x1 x4)
+                   (if>=? (compare x3 x4) x3 x4))
+            (if>=? (compare x2 x3)
+                   (if>=? (compare x2 x4) x2 x4)
+                   (if>=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmax
+           (max (if>=? (compare xmax (car xs)) xmax (car xs))
+                (cdr xs)))))))
+
+
+; kth-largest
+
+(define kth-largest
+  (let ((= =) (< <))
+    (case-lambda
+      ((compare k x0)
+       (case (modulo k 1)
+         ((0)  (compare:checked x0 compare x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1)
+       (case (modulo k 2)
+         ((0) (if<=? (compare x0 x1) x0 x1))
+         ((1) (if<=? (compare x0 x1) x1 x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1 x2)
+       (case (modulo k 3)
+         ((0) (if<=? (compare x0 x1)
+                     (if<=? (compare x0 x2) x0 x2)
+                     (if<=? (compare x1 x2) x1 x2)))
+         ((1) (if3 (compare x0 x1)
+                   (if<=? (compare x1 x2)
+                          x1
+                          (if<=? (compare x0 x2) x2 x0))
+                   (if<=? (compare x0 x2) x1 x0)
+                   (if<=? (compare x0 x2)
+                          x0
+                          (if<=? (compare x1 x2) x2 x1))))
+         ((2) (if<=? (compare x0 x1)
+                     (if<=? (compare x1 x2) x2 x1)
+                     (if<=? (compare x0 x2) x2 x0)))
+         (else (error "bad index" k))))
+      ((compare k x0 . x1+) ; |x1+| >= 1
+       (if (not (and (integer? k) (exact? k)))
+           (error "bad index" k))
+       (let ((n (+ 1 (length x1+))))
+         (let kth ((k   (modulo k n))
+                   (n   n)  ; = |x|
+                   (rev #t) ; are x<, x=, x> reversed?
+                   (x   (cons x0 x1+)))
+           (let ((pivot (list-ref x (random-integer n))))
+             (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0))
+               (if (null? x)
+                   (cond
+                     ((< k n<)
+                      (kth k n< (not rev) x<))
+                     ((< k (+ n< n=))
+                      (if rev
+                          (list-ref x= (- (- n= 1) (- k n<)))
+                          (list-ref x= (- k n<))))
+                     (else
+                      (kth (- k (+ n< n=)) n> (not rev) x>)))
+                   (if3 (compare (car x) pivot)
+                        (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>)
+                        (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>)
+                        (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1))))))))))))
+
+
+; compare functions from predicates
+
+(define compare-by<
+  (case-lambda
+   ((lt)     (lambda (x y) (if (lt x y) -1 (if (lt y x)  1 0))))
+   ((lt x y)               (if (lt x y) -1 (if (lt y x)  1 0)))))
+
+(define compare-by>
+  (case-lambda
+   ((gt)     (lambda (x y) (if (gt x y) 1 (if (gt y x)  -1 0))))
+   ((gt x y)               (if (gt x y) 1 (if (gt y x)  -1 0)))))
+
+(define compare-by<=
+  (case-lambda
+   ((le)     (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1)))
+   ((le x y)               (if (le x y) (if (le y x) 0 -1) 1))))
+
+(define compare-by>=
+  (case-lambda
+   ((ge)     (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1)))
+   ((ge x y)               (if (ge x y) (if (ge y x) 0 1) -1))))
+
+(define compare-by=/<
+  (case-lambda
+   ((eq lt)     (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1))))
+   ((eq lt x y)               (if (eq x y) 0 (if (lt x y) -1 1)))))
+
+(define compare-by=/>
+  (case-lambda
+   ((eq gt)     (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1))))
+   ((eq gt x y)               (if (eq x y) 0 (if (gt x y) 1 -1)))))
+
+; refine and extend construction
+
+(define-syntax refine-compare
+  (syntax-rules ()
+    ((refine-compare)
+     0)
+    ((refine-compare c1)
+     c1)
+    ((refine-compare c1 c2 cs ...)
+     (if3 c1 -1 (refine-compare c2 cs ...) 1))))
+
+(define-syntax select-compare
+  (syntax-rules (else)
+    ((select-compare x y clause ...)
+     (let ((x-val x) (y-val y))
+       (select-compare (x-val y-val clause ...))))
+    ; used internally: (select-compare (x y clause ...))
+    ((select-compare (x y))
+     0)
+    ((select-compare (x y (else c ...)))
+     (refine-compare c ...))
+    ((select-compare (x y (t? c ...) clause ...))
+     (let ((t?-val t?))
+       (let ((tx (t?-val x)) (ty (t?-val y)))
+         (if tx
+             (if ty (refine-compare c ...) -1)
+             (if ty 1 (select-compare (x y clause ...)))))))))
+
+(define-syntax cond-compare
+  (syntax-rules (else)
+    ((cond-compare)
+     0)
+    ((cond-compare (else cs ...))
+     (refine-compare cs ...))
+    ((cond-compare ((tx ty) cs ...) clause ...)
+     (let ((tx-val tx) (ty-val ty))
+       (if tx-val
+           (if ty-val (refine-compare cs ...) -1)
+           (if ty-val 1 (cond-compare clause ...)))))))
+
+
+; R5RS atomic types
+
+(define-syntax compare:type-check
+  (syntax-rules ()
+    ((compare:type-check type? type-name x)
+     (if (not (type? x))
+         (error (string-append "not " type-name ":") x)))
+    ((compare:type-check type? type-name x y)
+     (begin (compare:type-check type? type-name x)
+            (compare:type-check type? type-name y)))))
+
+(define-syntax compare:define-by=/<
+  (syntax-rules ()
+    ((compare:define-by=/< compare = < type? type-name)
+     (define compare
+       (let ((= =) (< <))
+	 (lambda (x y)
+	   (if (type? x)
+	       (if (eq? x y)
+		   0
+		   (if (type? y)
+		       (if (= x y) 0 (if (< x y) -1 1))
+		       (error (string-append "not " type-name ":") y)))
+	       (error (string-append "not " type-name ":") x))))))))
+
+(define (boolean-compare x y)
+  (compare:type-check boolean? "boolean" x y)
+  (if x (if y 0 1) (if y -1 0)))
+
+(compare:define-by=/< char-compare char=? char<? char? "char")
+
+(compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char")
+
+(compare:define-by=/< string-compare string=? string<? string? "string")
+
+(compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string")
+
+(define (symbol-compare x y)
+  (compare:type-check symbol? "symbol" x y)
+  (string-compare (symbol->string x) (symbol->string y)))
+
+(compare:define-by=/< integer-compare = < integer? "integer")
+
+(compare:define-by=/< rational-compare = < rational? "rational")
+
+(compare:define-by=/< real-compare = < real? "real")
+
+(define (complex-compare x y)
+  (compare:type-check complex? "complex" x y)
+  (if (and (real? x) (real? y))
+      (real-compare x y)
+      (refine-compare (real-compare (real-part x) (real-part y))
+                      (real-compare (imag-part x) (imag-part y)))))
+
+(define (number-compare x y)
+  (compare:type-check number? "number" x y)
+  (complex-compare x y))
+
+
+; R5RS compound data structures: dotted pair, list, vector
+
+(define (pair-compare-car compare)
+  (lambda (x y)
+    (compare (car x) (car y))))
+
+(define (pair-compare-cdr compare)
+  (lambda (x y)
+    (compare (cdr x) (cdr y))))
+
+(define pair-compare
+  (case-lambda
+    
+    ; dotted pair
+    ((pair-compare-car pair-compare-cdr x y)
+     (refine-compare (pair-compare-car (car x) (car y))
+                     (pair-compare-cdr (cdr x) (cdr y))))
+    
+    ; possibly improper lists
+    ((compare x y)
+     (cond-compare 
+      (((null? x) (null? y)) 0)
+      (((pair? x) (pair? y)) (compare              (car x) (car y))
+                             (pair-compare compare (cdr x) (cdr y)))
+      (else                  (compare x y))))
+    
+    ; for convenience
+    ((x y)
+     (pair-compare default-compare x y))))
+
+(define list-compare
+  (case-lambda
+    ((compare x y empty? head tail)
+     (cond-compare
+      (((empty? x) (empty? y)) 0)
+      (else (compare              (head x) (head y))
+            (list-compare compare (tail x) (tail y) empty? head tail))))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare compare         x y null? car   cdr))
+    ((        x y              )
+     (list-compare default-compare x y null? car   cdr))))
+
+(define list-compare-as-vector
+  (case-lambda
+    ((compare x y empty? head tail)
+     (refine-compare
+      (let compare-length ((x x) (y y))
+        (cond-compare
+         (((empty? x) (empty? y)) 0)
+         (else (compare-length (tail x) (tail y)))))
+      (list-compare compare x y empty? head tail)))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare-as-vector default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare-as-vector compare         x y null?  car  cdr))
+    ((        x y              )
+     (list-compare-as-vector default-compare x y null?  car  cdr))))
+
+(define vector-compare
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((n (size x)) (m (size y)))
+         (refine-compare 
+          (integer-compare n m)
+          (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+            (if (= i n)
+                0
+                (refine-compare (compare (ref x i) (ref y i))
+                                (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare default-compare x y vector-length vector-ref)))))
+
+(define vector-compare-as-list
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((nx (size x)) (ny (size y)))
+         (let ((n (min nx ny)))
+           (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+             (if (= i n)
+                 (integer-compare nx ny)
+                 (refine-compare (compare (ref x i) (ref y i))
+                                 (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare-as-list default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare-as-list compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare-as-list default-compare x y vector-length vector-ref)))))
+
+
+; default compare
+
+(define (default-compare x y)
+  (select-compare 
+   x y
+   (null?    0)
+   (pair?    (default-compare (car x) (car y))
+	     (default-compare (cdr x) (cdr y)))
+   (boolean? (boolean-compare x y))
+   (char?    (char-compare    x y))
+   (string?  (string-compare  x y))
+   (symbol?  (symbol-compare  x y))
+   (number?  (number-compare  x y))
+   (vector?  (vector-compare default-compare x y))
+   (else (error "unrecognized type in default-compare" x y))))
+
+; Note that we pass default-compare to compare-{pair,vector} explictly.
+; This makes sure recursion proceeds with this default-compare, which 
+; need not be the one in the lexical scope of compare-{pair,vector}.
+
+
+; debug compare
+
+(define (debug-compare c)
+  
+  (define (checked-value c x y)
+    (let ((c-xy (c x y)))
+      (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1))
+          c-xy
+          (error "compare value not in {-1,0,1}" c-xy (list c x y)))))
+  
+  (define (random-boolean)
+    (zero? (random-integer 2)))
+  
+  (define q ; (u v w) such that u <= v, v <= w, and not u <= w
+    '#(
+       ;x < y   x = y   x > y   [x < z]
+       0       0       0    ; y < z
+               0    (z y x) (z y x) ; y = z
+               0    (z y x) (z y x) ; y > z
+               
+               ;x < y   x = y   x > y   [x = z]
+               (y z x) (z x y)    0    ; y < z
+               (y z x)    0    (x z y) ; y = z
+               0    (y x z) (x z y) ; y > z
+               
+               ;x < y   x = y   x > y   [x > z]
+               (x y z) (x y z)    0    ; y < z
+               (x y z) (x y z)    0    ; y = z
+               0       0       0    ; y > z
+               ))
+  
+  (let ((z? #f) (z #f)) ; stored element from previous call
+    (lambda (x y)
+      (let ((c-xx (checked-value c x x))
+	    (c-yy (checked-value c y y))
+	    (c-xy (checked-value c x y))
+	    (c-yx (checked-value c y x)))
+	(if (not (zero? c-xx))
+	    (error "compare error: not reflexive" c x))
+	(if (not (zero? c-yy))
+	    (error "compare error: not reflexive" c y))
+	(if (not (zero? (+ c-xy c-yx)))
+	    (error "compare error: not anti-symmetric" c x y))
+	(if z?
+	    (let ((c-xz (checked-value c x z))
+		  (c-zx (checked-value c z x))
+		  (c-yz (checked-value c y z))
+		  (c-zy (checked-value c z y)))
+	      (if (not (zero? (+ c-xz c-zx)))
+		  (error "compare error: not anti-symmetric" c x z))
+	      (if (not (zero? (+ c-yz c-zy)))
+		  (error "compare error: not anti-symmetric" c y z))
+	      (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13))))
+		(if (list? ijk)
+		    (apply error
+			   "compare error: not transitive"
+			   c 
+			   (map (lambda (i) (case i ((x) x) ((y) y) ((z) z)))
+				ijk)))))
+	    (set! z? #t))
+	(set! z (if (random-boolean) x y)) ; randomized testing
+	c-xy))))
+;;; Copyright © Panu Kalliokoski (2005). All Rights Reserved.
+
+;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright © 2014.
+
+;;; 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 default-bound (make-parameter (- (expt 2 29) 3)))
+
+(define (%string-hash s ch-conv bound)
+  (let ((hash 31)
+	(len (string-length s)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hash bound))
+      (set! hash (modulo (+ (* 37 hash)
+			    (char->integer (ch-conv (string-ref s index))))
+			 (default-bound))))))
+
+(define string-hash
+  (case-lambda
+    ((s) (string-hash s (default-bound)))
+    ((s bound)
+     (%string-hash s (lambda (x) x) bound))))
+
+(define string-ci-hash
+  (case-lambda
+    ((s) (string-ci-hash s (default-bound)))
+    ((s bound)
+     (%string-hash s char-downcase bound))))
+
+(define symbol-hash
+  (case-lambda
+    ((s) (symbol-hash s (default-bound)))
+    ((s bound)
+     (%string-hash (symbol->string s) (lambda (x) x) bound))))
+
+(define hash
+  (case-lambda
+    ((obj) (hash obj (default-bound)))
+    ((obj bound)
+     (cond ((integer? obj) (modulo obj bound))
+           ((string? obj) (string-hash obj bound))
+           ((symbol? obj) (symbol-hash obj bound))
+           ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
+           ((number? obj)
+            (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
+                    bound))
+           ((char? obj) (modulo (char->integer obj) bound))
+           ((vector? obj) (vector-hash obj bound))
+           ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
+                                bound))
+           ((null? obj) 0)
+           ((not obj) 0)
+           ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
+           (else 1)))))
+
+(define hash-by-identity hash)
+
+(define (vector-hash v bound)
+  (let ((hashvalue 571)
+	(len (vector-length v)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hashvalue bound))
+      (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
+			      (default-bound))))))
+
+(define %make-hash-node cons)
+(define %hash-node-set-value! set-cdr!)
+(define %hash-node-key car)
+(define %hash-node-value cdr)
+
+(define-record-type <srfi-hash-table>
+  (%make-hash-table size hash compare associate entries)
+  hash-table?
+  (size hash-table-size hash-table-set-size!)
+  (hash hash-table-hash-function)
+  (compare hash-table-equivalence-function)
+  (associate hash-table-association-function)
+  (entries hash-table-entries hash-table-set-entries!))
+
+(define default-table-size (make-parameter 64))
+
+(define (appropriate-hash-function-for comparison)
+  (or (and (eq? comparison eq?) hash-by-identity)
+      (and (eq? comparison string=?) string-hash)
+      (and (eq? comparison string-ci=?) string-ci-hash)
+      hash))
+
+(define make-hash-table
+  (case-lambda
+    (()
+     (make-hash-table equal?
+                      (appropriate-hash-function-for equal?)
+                      (default-table-size)))
+    ((comparison)
+     (make-hash-table comparison
+                      (appropriate-hash-function-for comparison)
+                      (default-table-size)))
+    ((comparison hash)
+     (make-hash-table comparison
+                      hash
+                      (default-table-size)))
+    ((comparison hash size)
+     (let ((association (or (and (eq? comparison eq?) assq)
+                            (and (eq? comparison eqv?) assv)
+                            (and (eq? comparison equal?) assoc)
+                            (rec (associate val alist)
+                              (cond
+                               ((null? alist) #f)
+                               ((comparison val (caar alist)) (car alist))
+                               (else (associate val (cdr alist))))))))
+       (%make-hash-table
+        0 hash comparison association (make-vector size '()))))))
+
+(define (make-hash-table-maker comp hash)
+  (lambda args (apply make-hash-table (cons comp (cons hash args)))))
+(define make-symbol-hash-table
+  (make-hash-table-maker eq? symbol-hash))
+(define make-string-hash-table
+  (make-hash-table-maker string=? string-hash))
+(define make-string-ci-hash-table
+  (make-hash-table-maker string-ci=? string-ci-hash))
+(define make-integer-hash-table
+  (make-hash-table-maker = modulo))
+
+(define (%hash-table-hash hash-table key)
+  ((hash-table-hash-function hash-table)
+     key (vector-length (hash-table-entries hash-table))))
+
+(define (%hash-table-find entries associate hash key)
+  (associate key (vector-ref entries hash)))
+
+(define (%hash-table-add! entries hash key value)
+  (vector-set! entries hash
+	       (cons (%make-hash-node key value)
+		     (vector-ref entries hash))))
+
+(define (%hash-table-delete! entries compare hash key)
+  (let ((entrylist (vector-ref entries hash)))
+    (cond ((null? entrylist) #f)
+	  ((compare key (caar entrylist))
+	   (vector-set! entries hash (cdr entrylist)) #t)
+	  (else
+	    (let loop ((current (cdr entrylist)) (previous entrylist))
+	      (cond ((null? current) #f)
+		    ((compare key (caar current))
+		     (set-cdr! previous (cdr current)) #t)
+		    (else (loop (cdr current) current))))))))
+
+(define (%hash-table-walk proc entries)
+  (do ((index (- (vector-length entries) 1) (- index 1)))
+    ((< index 0)) (for-each proc (vector-ref entries index))))
+
+(define (%hash-table-maybe-resize! hash-table)
+  (let* ((old-entries (hash-table-entries hash-table))
+	 (hash-length (vector-length old-entries)))
+    (if (> (hash-table-size hash-table) hash-length)
+      (let* ((new-length (* 2 hash-length))
+	     (new-entries (make-vector new-length '()))
+	     (hash (hash-table-hash-function hash-table)))
+	(%hash-table-walk
+	  (lambda (node)
+	    (%hash-table-add! new-entries
+			      (hash (%hash-node-key node) new-length)
+			      (%hash-node-key node) (%hash-node-value node)))
+	  old-entries)
+	(hash-table-set-entries! hash-table new-entries)))))
+
+(define (not-found-error key)
+  (lambda ()
+    (error "No value associated with key:" key)))
+
+(define hash-table-ref
+  (case-lambda
+    ((hash-table key) (hash-table-ref hash-table key (not-found-error key)))
+    ((hash-table key default-thunk)
+     (cond ((%hash-table-find (hash-table-entries hash-table)
+                              (hash-table-association-function hash-table)
+                              (%hash-table-hash hash-table key) key)
+            => %hash-node-value)
+           (else (default-thunk))))))
+
+(define (hash-table-ref/default hash-table key default)
+  (hash-table-ref hash-table key (lambda () default)))
+
+(define (hash-table-set! hash-table key value)
+  (let ((hash (%hash-table-hash hash-table key))
+	(entries (hash-table-entries hash-table)))
+    (cond ((%hash-table-find entries
+			     (hash-table-association-function hash-table)
+			     hash key)
+	   => (lambda (node) (%hash-node-set-value! node value)))
+	  (else (%hash-table-add! entries hash key value)
+		(hash-table-set-size! hash-table
+				       (+ 1 (hash-table-size hash-table)))
+		(%hash-table-maybe-resize! hash-table)))))
+
+(define hash-table-update!
+  (case-lambda
+    ((hash-table key function)
+     (hash-table-update! hash-table key function (not-found-error key)))
+    ((hash-table key function default-thunk)
+     (let ((hash (%hash-table-hash hash-table key))
+           (entries (hash-table-entries hash-table)))
+       (cond ((%hash-table-find entries
+                                (hash-table-association-function hash-table)
+                                hash key)
+              => (lambda (node)
+                   (%hash-node-set-value!
+                    node (function (%hash-node-value node)))))
+             (else (%hash-table-add! entries hash key
+                                     (function (default-thunk)))
+                   (hash-table-set-size! hash-table
+                                         (+ 1 (hash-table-size hash-table)))
+                   (%hash-table-maybe-resize! hash-table)))))))
+
+(define (hash-table-update!/default hash-table key function default)
+  (hash-table-update! hash-table key function (lambda () default)))
+
+(define (hash-table-delete! hash-table key)
+  (if (%hash-table-delete! (hash-table-entries hash-table)
+			   (hash-table-equivalence-function hash-table)
+			   (%hash-table-hash hash-table key) key)
+    (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1))))
+
+(define (hash-table-exists? hash-table key)
+  (and (%hash-table-find (hash-table-entries hash-table)
+			 (hash-table-association-function hash-table)
+			 (%hash-table-hash hash-table key) key) #t))
+
+(define (hash-table-walk hash-table proc)
+  (%hash-table-walk
+    (lambda (node) (proc (%hash-node-key node) (%hash-node-value node)))
+    (hash-table-entries hash-table)))
+
+(define (hash-table-fold hash-table f acc)
+  (hash-table-walk hash-table 
+		       (lambda (key value) (set! acc (f key value acc))))
+  acc)
+
+(define (appropriate-size-for-alist alist)
+  (max (default-table-size) (* 2 (length alist))))
+
+(define alist->hash-table
+  (case-lambda
+    ((alist)
+     (alist->hash-table alist
+                        equal?
+                        (appropriate-hash-function-for equal?)
+                        (appropriate-size-for-alist alist)))
+    ((alist comparison)
+     (alist->hash-table alist
+                        comparison
+                        (appropriate-hash-function-for comparison)
+                        (appropriate-size-for-alist alist)))
+    ((alist comparison hash)
+     (alist->hash-table alist
+                        comparison
+                        hash
+                        (appropriate-size-for-alist alist)))
+    ((alist comparison hash size)
+     (let ((hash-table (make-hash-table comparison hash size)))
+       (for-each
+        (lambda (elem)
+          (hash-table-update!/default
+           hash-table (car elem) (lambda (x) x) (cdr elem)))
+        alist)
+       hash-table))))
+
+(define (hash-table->alist hash-table)
+  (hash-table-fold hash-table
+		   (lambda (key val acc) (cons (cons key val) acc)) '()))
+
+(define (hash-table-copy hash-table)
+  (let ((new (make-hash-table (hash-table-equivalence-function hash-table)
+  			      (hash-table-hash-function hash-table)
+			      (max (default-table-size)
+				   (* 2 (hash-table-size hash-table))))))
+    (hash-table-walk hash-table
+		     (lambda (key value) (hash-table-set! new key value)))
+    new))
+
+(define (hash-table-merge! hash-table1 hash-table2)
+  (hash-table-walk
+    hash-table2
+    (lambda (key value) (hash-table-set! hash-table1 key value)))
+  hash-table1)
+
+(define (hash-table-keys hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
+
+(define (hash-table-values hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
+(define-library (srfi 69)
+  (export
+   ;; Type constructors and predicate
+   make-hash-table hash-table? alist->hash-table 
+   ;; Reflective queries
+   hash-table-equivalence-function hash-table-hash-function 
+   ;; Dealing with single elements
+   hash-table-ref hash-table-ref/default hash-table-set! hash-table-delete!
+   hash-table-exists? hash-table-update! hash-table-update!/default 
+   ;; Dealing with the whole contents
+   hash-table-size hash-table-keys hash-table-values hash-table-walk
+   hash-table-fold hash-table->alist hash-table-copy hash-table-merge! 
+   ;; Hashing
+   hash string-hash string-ci-hash hash-by-identity
+   )
+  (import 
+   (scheme base)
+   (scheme case-lambda)
+   (scheme char)
+   (scheme complex)
+   (scheme cxr)
+   (srfi 1)
+   (srfi 31))
+  (include "69.body.scm"))
+;;; Copyright © Panu Kalliokoski (2005). All Rights Reserved.
+
+;;; 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 *default-bound* (- (expt 2 29) 3))
+
+(define (%string-hash s ch-conv bound)
+  (let ((hash 31)
+	(len (string-length s)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hash bound))
+      (set! hash (modulo (+ (* 37 hash)
+			    (char->integer (ch-conv (string-ref s index))))
+			 *default-bound*)))))
+
+(define (string-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash s (lambda (x) x) bound)))
+
+(define (string-ci-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash s char-downcase bound)))
+
+(define (symbol-hash s . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (%string-hash (symbol->string s) (lambda (x) x) bound)))
+
+(define (hash obj . maybe-bound)
+  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
+    (cond ((integer? obj) (modulo obj bound))
+	  ((string? obj) (string-hash obj bound))
+	  ((symbol? obj) (symbol-hash obj bound))
+	  ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
+	  ((number? obj)
+	   (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
+		   bound))
+	  ((char? obj) (modulo (char->integer obj) bound))
+	  ((vector? obj) (vector-hash obj bound))
+	  ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
+			       bound))
+	  ((null? obj) 0)
+	  ((not obj) 0)
+	  ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
+	  (else 1))))
+
+(define hash-by-identity hash)
+
+(define (vector-hash v bound)
+  (let ((hashvalue 571)
+	(len (vector-length v)))
+    (do ((index 0 (+ index 1)))
+      ((>= index len) (modulo hashvalue bound))
+      (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
+			      *default-bound*)))))
+
+(define %make-hash-node cons)
+(define %hash-node-set-value! set-cdr!)
+(define %hash-node-key car)
+(define %hash-node-value cdr)
+
+(define-record-type <srfi-hash-table>
+  (%make-hash-table size hash compare associate entries)
+  hash-table?
+  (size hash-table-size hash-table-set-size!)
+  (hash hash-table-hash-function)
+  (compare hash-table-equivalence-function)
+  (associate hash-table-association-function)
+  (entries hash-table-entries hash-table-set-entries!))
+
+(define *default-table-size* 64)
+
+(define (appropriate-hash-function-for comparison)
+  (or (and (eq? comparison eq?) hash-by-identity)
+      (and (eq? comparison string=?) string-hash)
+      (and (eq? comparison string-ci=?) string-ci-hash)
+      hash))
+
+(define (make-hash-table . args)
+  (let* ((comparison (if (null? args) equal? (car args)))
+	 (hash
+	   (if (or (null? args) (null? (cdr args)))
+	     (appropriate-hash-function-for comparison) (cadr args)))
+	 (size
+	   (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+	     *default-table-size* (caddr args)))
+	 (association
+	   (or (and (eq? comparison eq?) assq)
+	       (and (eq? comparison eqv?) assv)
+	       (and (eq? comparison equal?) assoc)
+	       (letrec
+		 ((associate
+		    (lambda (val alist)
+		      (cond ((null? alist) #f)
+			    ((comparison val (caar alist)) (car alist))
+			    (else (associate val (cdr alist)))))))
+		 associate))))
+    (%make-hash-table 0 hash comparison association (make-vector size '()))))
+
+(define (make-hash-table-maker comp hash)
+  (lambda args (apply make-hash-table (cons comp (cons hash args)))))
+(define make-symbol-hash-table
+  (make-hash-table-maker eq? symbol-hash))
+(define make-string-hash-table
+  (make-hash-table-maker string=? string-hash))
+(define make-string-ci-hash-table
+  (make-hash-table-maker string-ci=? string-ci-hash))
+(define make-integer-hash-table
+  (make-hash-table-maker = modulo))
+
+(define (%hash-table-hash hash-table key)
+  ((hash-table-hash-function hash-table)
+     key (vector-length (hash-table-entries hash-table))))
+
+(define (%hash-table-find entries associate hash key)
+  (associate key (vector-ref entries hash)))
+
+(define (%hash-table-add! entries hash key value)
+  (vector-set! entries hash
+	       (cons (%make-hash-node key value)
+		     (vector-ref entries hash))))
+
+(define (%hash-table-delete! entries compare hash key)
+  (let ((entrylist (vector-ref entries hash)))
+    (cond ((null? entrylist) #f)
+	  ((compare key (caar entrylist))
+	   (vector-set! entries hash (cdr entrylist)) #t)
+	  (else
+	    (let loop ((current (cdr entrylist)) (previous entrylist))
+	      (cond ((null? current) #f)
+		    ((compare key (caar current))
+		     (set-cdr! previous (cdr current)) #t)
+		    (else (loop (cdr current) current))))))))
+
+(define (%hash-table-walk proc entries)
+  (do ((index (- (vector-length entries) 1) (- index 1)))
+    ((< index 0)) (for-each proc (vector-ref entries index))))
+
+(define (%hash-table-maybe-resize! hash-table)
+  (let* ((old-entries (hash-table-entries hash-table))
+	 (hash-length (vector-length old-entries)))
+    (if (> (hash-table-size hash-table) hash-length)
+      (let* ((new-length (* 2 hash-length))
+	     (new-entries (make-vector new-length '()))
+	     (hash (hash-table-hash-function hash-table)))
+	(%hash-table-walk
+	  (lambda (node)
+	    (%hash-table-add! new-entries
+			      (hash (%hash-node-key node) new-length)
+			      (%hash-node-key node) (%hash-node-value node)))
+	  old-entries)
+	(hash-table-set-entries! hash-table new-entries)))))
+
+(define (hash-table-ref hash-table key . maybe-default)
+  (cond ((%hash-table-find (hash-table-entries hash-table)
+			   (hash-table-association-function hash-table)
+			   (%hash-table-hash hash-table key) key)
+	 => %hash-node-value)
+	((null? maybe-default)
+	 (error "hash-table-ref: no value associated with" key))
+	(else ((car maybe-default)))))
+
+(define (hash-table-ref/default hash-table key default)
+  (hash-table-ref hash-table key (lambda () default)))
+
+(define (hash-table-set! hash-table key value)
+  (let ((hash (%hash-table-hash hash-table key))
+	(entries (hash-table-entries hash-table)))
+    (cond ((%hash-table-find entries
+			     (hash-table-association-function hash-table)
+			     hash key)
+	   => (lambda (node) (%hash-node-set-value! node value)))
+	  (else (%hash-table-add! entries hash key value)
+		(hash-table-set-size! hash-table
+				       (+ 1 (hash-table-size hash-table)))
+		(%hash-table-maybe-resize! hash-table)))))
+
+(define (hash-table-update! hash-table key function . maybe-default)
+  (let ((hash (%hash-table-hash hash-table key))
+	(entries (hash-table-entries hash-table)))
+    (cond ((%hash-table-find entries
+			     (hash-table-association-function hash-table)
+			     hash key)
+	   => (lambda (node)
+	        (%hash-node-set-value!
+		  node (function (%hash-node-value node)))))
+	  ((null? maybe-default)
+	   (error "hash-table-update!: no value exists for key" key))
+	  (else (%hash-table-add! entries hash key
+				  (function ((car maybe-default))))
+		(hash-table-set-size! hash-table
+				       (+ 1 (hash-table-size hash-table)))
+		(%hash-table-maybe-resize! hash-table)))))
+
+(define (hash-table-update!/default hash-table key function default)
+  (hash-table-update! hash-table key function (lambda () default)))
+
+(define (hash-table-delete! hash-table key)
+  (if (%hash-table-delete! (hash-table-entries hash-table)
+			   (hash-table-equivalence-function hash-table)
+			   (%hash-table-hash hash-table key) key)
+    (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1))))
+
+(define (hash-table-exists? hash-table key)
+  (and (%hash-table-find (hash-table-entries hash-table)
+			 (hash-table-association-function hash-table)
+			 (%hash-table-hash hash-table key) key) #t))
+
+(define (hash-table-walk hash-table proc)
+  (%hash-table-walk
+    (lambda (node) (proc (%hash-node-key node) (%hash-node-value node)))
+    (hash-table-entries hash-table)))
+
+(define (hash-table-fold hash-table f acc)
+  (hash-table-walk hash-table 
+		       (lambda (key value) (set! acc (f key value acc))))
+  acc)
+
+(define (alist->hash-table alist . args)
+  (let* ((comparison (if (null? args) equal? (car args)))
+	 (hash
+	   (if (or (null? args) (null? (cdr args)))
+	     (appropriate-hash-function-for comparison) (cadr args)))
+	 (size
+	   (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
+	     (max *default-table-size* (* 2 (length alist))) (caddr args)))
+	 (hash-table (make-hash-table comparison hash size)))
+    (for-each
+      (lambda (elem)
+	(hash-table-update!/default
+	  hash-table (car elem) (lambda (x) x) (cdr elem)))
+      alist)
+    hash-table))
+
+(define (hash-table->alist hash-table)
+  (hash-table-fold hash-table
+		   (lambda (key val acc) (cons (cons key val) acc)) '()))
+
+(define (hash-table-copy hash-table)
+  (let ((new (make-hash-table (hash-table-equivalence-function hash-table)
+  			      (hash-table-hash-function hash-table)
+			      (max *default-table-size*
+				   (* 2 (hash-table-size hash-table))))))
+    (hash-table-walk hash-table
+		     (lambda (key value) (hash-table-set! new key value)))
+    new))
+
+(define (hash-table-merge! hash-table1 hash-table2)
+  (hash-table-walk
+    hash-table2
+    (lambda (key value) (hash-table-set! hash-table1 key value)))
+  hash-table1)
+
+(define (hash-table-keys hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
+
+(define (hash-table-values hash-table)
+  (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
+(define-library (srfi 71)
+  (export
+   (rename srfi-letrec* letrec*)
+   (rename srfi-letrec letrec)
+   (rename srfi-let* let*)
+   (rename srfi-let let)
+   uncons
+   uncons-2
+   uncons-3
+   uncons-4
+   uncons-cons
+   unlist
+   unvector
+   )
+  (import
+   (rename (scheme base)
+           (let r5rs-let)
+           (letrec r5rs-letrec))
+   (scheme cxr))
+  (include "71.upstream.scm"))
+;;; Copyright (c) 2005 Sebastian Egner.
+
+;;; 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.
+
+; Reference implementation of SRFI-71 (generic part)
+; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
+;
+; In order to avoid conflicts with the existing let etc.
+; the macros defined here are called srfi-let etc.,
+; and they are defined in terms of r5rs-let etc.
+; It is up to the actual implementation to save let/*/rec
+; in r5rs-let/*/rec first and redefine let/*/rec
+; by srfi-let/*/rec then.
+;
+; There is also a srfi-letrec* being defined (in view of R6RS.)
+;
+; Macros used internally are named i:<something>.
+;
+; Abbreviations for macro arguments:
+;   bs  - <binding spec>
+;   b   - component of a binding spec (values, <variable>, or <expression>)
+;   v   - <variable>
+;   vr  - <variable> for rest list
+;   x   - <expression>
+;   t   - newly introduced temporary variable
+;   vx  - (<variable> <expression>)
+;   rec - flag if letrec is produced (and not let)
+;   cwv - call-with-value skeleton of the form (x formals)
+;         (call-with-values (lambda () x) (lambda formals /payload/))
+;         where /payload/ is of the form (let (vx ...) body1 body ...).
+;
+; Remark (*):
+;   We bind the variables of a letrec to i:undefined since there is
+;   no portable (R5RS) way of binding a variable to a values that
+;   raises an error when read uninitialized.
+
+(define i:undefined 'undefined)
+
+(define-syntax srfi-letrec* ; -> srfi-letrec
+  (syntax-rules ()
+    ((srfi-letrec* () body1 body ...)
+     (srfi-letrec () body1 body ...))
+    ((srfi-letrec* (bs) body1 body ...)
+     (srfi-letrec (bs) body1 body ...))
+    ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
+     (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
+
+(define-syntax srfi-letrec ; -> i:let
+  (syntax-rules ()
+    ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
+     (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
+
+(define-syntax srfi-let* ; -> srfi-let
+  (syntax-rules ()
+    ((srfi-let* () body1 body ...)
+     (srfi-let () body1 body ...))
+    ((srfi-let* (bs) body1 body ...)
+     (srfi-let (bs) body1 body ...))
+    ((srfi-let* (bs1 bs2 bs ...) body1 body ...)
+     (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
+
+(define-syntax srfi-let ; -> i:let or i:named-let
+  (syntax-rules ()
+    ((srfi-let ((b1 b2 b ...) ...) body1 body ...)
+     (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
+    ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
+     (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
+
+(define-syntax i:let
+  (syntax-rules (values)
+
+; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
+;   processes the binding specs bs ... by adding call-with-values
+;   skeletons to cwv ... and bindings to vx ..., and afterwards
+;   wrapping the skeletons around the payload (let (vx ...) . body).
+
+    ; no more bs to process -> wrap call-with-values skeletons
+    ((i:let "bs" rec (cwv ...) vxs body ())
+     (i:let "wrap" rec vxs body cwv ...))
+
+    ; recognize form1 without variable -> dummy binding for side-effects
+    ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...))
+     (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...)))
+
+    ; recognize form1 with single variable -> just extend vx ...
+    ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...))
+     (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
+
+    ; recognize form1 without rest arg -> generate cwv
+    ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))
+     (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...)))
+
+    ; recognize form1 with rest arg -> generate cwv
+    ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...))
+     (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs)))
+
+    ; recognize form2 with single variable -> just extend vx ...
+    ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...))
+     (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
+
+    ; recognize form2 with >=2 variables -> transform to form1
+    ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...))
+     (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...)))
+
+; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...))
+;   processes the variables in v1 v2 v ... adding them to (t ...)
+;   and producing a cwv when finished. There is not rest argument.
+
+    ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values))
+     (i:let "bs" rec (cwv ... (x ts)) vxs body bss))
+    ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...))
+     (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...)))
+
+; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr))
+;   processes the variables in v ... . vr adding them to (t ...)
+;   and producing a cwv when finished. The rest arg is vr.
+
+    ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs))
+     (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs)))
+    ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr))
+     (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss))
+    ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr))
+     (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss))
+
+; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x))
+;   processes the binding items (b ... x) from form2 as in
+;   (v ... b ... x) into ((values v ... b ...) x), i.e. form1.
+;   Then call "bs" recursively.
+
+    ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x))
+     (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)))
+    ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...))
+     (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...)))
+
+; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...)
+;   wraps cwv ... around the payload generating the actual code.
+;   For letrec this is of course different than for let.
+
+    ((i:let "wrap" #f vxs body)
+     (r5rs-let vxs . body))
+    ((i:let "wrap" #f vxs body (x formals) cwv ...)
+     (call-with-values
+       (lambda () x)
+       (lambda formals (i:let "wrap" #f vxs body cwv ...))))
+
+    ((i:let "wrap" #t vxs body)
+     (r5rs-letrec vxs . body))
+    ((i:let "wrap" #t ((v t) ...) body cwv ...)
+     (r5rs-let ((v i:undefined) ...) ; (*)
+       (i:let "wraprec" ((v t) ...) body cwv ...)))
+    
+; (i:let "wraprec" ((v t) ...) body cwv ...)
+;   generate the inner code for a letrec. The variables v ...
+;   are the user-visible variables (bound outside), and t ... 
+;   are the temporary variables bound by the cwv consumers.
+
+    ((i:let "wraprec" ((v t) ...) (body ...))
+     (begin (set! v t) ... (r5rs-let () body ...)))
+    ((i:let "wraprec" vxs body (x formals) cwv ...)
+     (call-with-values
+       (lambda () x)
+       (lambda formals (i:let "wraprec" vxs body cwv ...))))
+
+    ))
+
+(define-syntax i:named-let
+  (syntax-rules (values)
+
+; (i:named-let tag (vx ...) body (bs ...))
+;   processes the binding specs bs ... by extracting the variable
+;   and expression, adding them to vx and turning the result into
+;   an ordinary named let.
+
+    ((i:named-let tag vxs body ())
+     (r5rs-let tag vxs . body))    
+    ((i:named-let tag (vx ...) body (((values v) x) bs ...))
+     (i:named-let tag (vx ... (v x)) body (bs ...)))
+    ((i:named-let tag (vx ...) body ((v x) bs ...))
+     (i:named-let tag (vx ... (v x)) body (bs ...)))))
+
+; --- standard procedures ---
+
+(define (uncons pair)
+  (values (car pair) (cdr pair)))
+
+(define (uncons-2 list)
+  (values (car list) (cadr list) (cddr list)))
+
+(define (uncons-3 list)
+  (values (car list) (cadr list) (caddr list) (cdddr list)))
+
+(define (uncons-4 list)
+  (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
+
+(define (uncons-cons alist)
+  (values (caar alist) (cdar alist) (cdr alist)))
+
+(define (unlist list)
+  (apply values list))
+
+(define (unvector vector)
+  (apply values (vector->list vector)))
+
+; --- standard macros ---
+
+(define-syntax values->list
+  (syntax-rules ()
+    ((values->list x)
+     (call-with-values (lambda () x) list))))
+
+(define-syntax values->vector
+  (syntax-rules ()
+    ((values->vector x)
+     (call-with-values (lambda () x) vector))))
+(define-library (srfi 78)
+  (export
+   check
+   check-ec
+   check-report
+   check-set-mode!
+   check-reset!
+   check-passed?
+   )
+  (import
+   (scheme base)
+   (scheme cxr)
+   (scheme write)
+   (srfi 42))
+  (include "78.upstream.scm"))
+; <PLAINTEXT>
+; Copyright (c) 2005-2006 Sebastian Egner.
+; 
+; 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.
+; 
+; -----------------------------------------------------------------------
+; 
+; Lightweight testing (reference implementation)
+; ==============================================
+;
+; Sebastian.Egner@philips.com
+; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions)
+;
+; history of this file:
+;   SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67
+;   SE, 19-Jan-2006: (arg ...) made optional in check-ec
+;
+; Naming convention "check:<identifier>" is used only internally.
+
+; -- portability --
+
+; PLT:      (require (lib "23.ss" "srfi") (lib "42.ss" "srfi"))
+; Scheme48: ,open srfi-23 srfi-42 
+
+; -- utilities --
+
+(define check:write write)
+
+; You can also use a pretty printer if you have one.
+; However, the output might not improve for most cases
+; because the pretty printers usually output a trailing
+; newline.
+
+; PLT:      (require (lib "pretty.ss")) (define check:write pretty-print)
+; Scheme48: ,open pp (define check:write p)
+
+; -- mode --
+
+(define check:mode #f)
+
+(define (check-set-mode! mode)
+  (set! check:mode
+        (case mode
+          ((off)           0)
+          ((summary)       1)
+          ((report-failed) 10)
+          ((report)        100)
+          (else (error "unrecognized mode" mode)))))
+
+(check-set-mode! 'report)
+
+; -- state --
+
+(define check:correct #f)
+(define check:failed   #f)
+
+(define (check-reset!)
+  (set! check:correct 0)
+  (set! check:failed   '()))
+
+(define (check:add-correct!)
+  (set! check:correct (+ check:correct 1)))
+
+(define (check:add-failed! expression actual-result expected-result)
+  (set! check:failed
+        (cons (list expression actual-result expected-result)
+              check:failed)))
+
+(check-reset!)
+
+; -- reporting --
+
+(define (check:report-expression expression)
+  (newline)
+  (check:write expression)
+  (display " => "))
+
+(define (check:report-actual-result actual-result)
+  (check:write actual-result)
+  (display " ; "))
+
+(define (check:report-correct cases)
+  (display "correct")
+  (if (not (= cases 1))
+      (begin (display " (")
+             (display cases)
+             (display " cases checked)")))
+  (newline))
+
+(define (check:report-failed expected-result)
+  (display "*** failed ***")
+  (newline)
+  (display " ; expected result: ")
+  (check:write expected-result)
+  (newline))
+
+(define (check-report)
+  (if (>= check:mode 1)
+      (begin
+        (newline)
+        (display "; *** checks *** : ")
+        (display check:correct)
+        (display " correct, ")
+        (display (length check:failed))
+        (display " failed.")
+        (if (or (null? check:failed) (<= check:mode 1))
+            (newline)
+            (let* ((w (car (reverse check:failed)))
+                   (expression (car w))
+                   (actual-result (cadr w))
+                   (expected-result (caddr w)))                  
+              (display " First failed example:")
+              (newline)
+              (check:report-expression expression)
+              (check:report-actual-result actual-result)
+              (check:report-failed expected-result))))))
+
+(define (check-passed? expected-total-count)
+  (and (= (length check:failed) 0)
+       (= check:correct expected-total-count)))
+       
+; -- simple checks --
+
+(define (check:proc expression thunk equal expected-result)
+  (case check:mode
+    ((0) #f)
+    ((1)
+     (let ((actual-result (thunk)))
+       (if (equal actual-result expected-result)
+           (check:add-correct!)
+           (check:add-failed! expression actual-result expected-result))))
+    ((10)
+     (let ((actual-result (thunk)))
+       (if (equal actual-result expected-result)
+           (check:add-correct!)
+           (begin
+             (check:report-expression expression)
+             (check:report-actual-result actual-result)
+             (check:report-failed expected-result)
+             (check:add-failed! expression actual-result expected-result)))))
+    ((100)
+     (check:report-expression expression)
+     (let ((actual-result (thunk)))
+       (check:report-actual-result actual-result)
+       (if (equal actual-result expected-result)
+           (begin (check:report-correct 1)
+                  (check:add-correct!))
+           (begin (check:report-failed expected-result)
+                  (check:add-failed! expression 
+				     actual-result 
+				     expected-result)))))
+    (else (error "unrecognized check:mode" check:mode)))
+  (if #f #f))
+
+(define-syntax check
+  (syntax-rules (=>)
+    ((check expr => expected)
+     (check expr (=> equal?) expected))
+    ((check expr (=> equal) expected)
+     (if (>= check:mode 1)
+	 (check:proc 'expr (lambda () expr) equal expected)))))
+
+; -- parametric checks --
+
+(define (check:proc-ec w)
+  (let ((correct? (car w))
+        (expression (cadr w))
+        (actual-result (caddr w))
+        (expected-result (cadddr w))
+	(cases (car (cddddr w))))
+    (if correct?
+        (begin (if (>= check:mode 100)
+                   (begin (check:report-expression expression)
+                          (check:report-actual-result actual-result)
+                          (check:report-correct cases)))
+               (check:add-correct!))
+        (begin (if (>= check:mode 10)
+                   (begin (check:report-expression expression)
+                          (check:report-actual-result actual-result)
+                          (check:report-failed expected-result)))
+               (check:add-failed! expression 
+				  actual-result 
+				  expected-result)))))
+
+(define-syntax check-ec:make
+  (syntax-rules (=>)
+    ((check-ec:make qualifiers expr (=> equal) expected (arg ...))
+     (if (>= check:mode 1)
+         (check:proc-ec
+	  (let ((cases 0))
+	    (let ((w (first-ec 
+		      #f
+		      qualifiers
+		      (\:let equal-pred equal)
+		      (\:let expected-result expected)
+		      (\:let actual-result
+                            (let ((arg arg) ...) ; (*)
+                              expr))
+		      (begin (set! cases (+ cases 1)))
+		      (if (not (equal-pred actual-result expected-result)))
+		      (list (list 'let (list (list 'arg arg) ...) 'expr)
+			    actual-result
+			    expected-result
+			    cases))))
+	      (if w
+		  (cons #f w)
+		  (list #t 
+			'(check-ec qualifiers 
+				   expr (=> equal) 
+				   expected (arg ...))
+			(if #f #f)
+		        (if #f #f)
+			cases)))))))))
+
+; (*) is a compile-time check that (arg ...) is a list
+; of pairwise disjoint bound variables at this point.
+
+(define-syntax check-ec
+  (syntax-rules (nested =>)
+    ((check-ec expr => expected)
+     (check-ec:make (nested) expr (=> equal?) expected ()))
+    ((check-ec expr (=> equal) expected)
+     (check-ec:make (nested) expr (=> equal) expected ()))
+    ((check-ec expr => expected (arg ...))
+     (check-ec:make (nested) expr (=> equal?) expected (arg ...)))
+    ((check-ec expr (=> equal) expected (arg ...))
+     (check-ec:make (nested) expr (=> equal) expected (arg ...)))
+
+    ((check-ec qualifiers expr => expected)
+     (check-ec:make qualifiers expr (=> equal?) expected ()))
+    ((check-ec qualifiers expr (=> equal) expected)
+     (check-ec:make qualifiers expr (=> equal) expected ()))
+    ((check-ec qualifiers expr => expected (arg ...))
+     (check-ec:make qualifiers expr (=> equal?) expected (arg ...)))
+    ((check-ec qualifiers expr (=> equal) expected (arg ...))
+     (check-ec:make qualifiers expr (=> equal) expected (arg ...)))
+
+    ((check-ec (nested q1 ...) q etc ...)
+     (check-ec (nested q1 ... q) etc ...))
+    ((check-ec q1 q2             etc ...)
+     (check-ec (nested q1 q2)    etc ...))))
+(import (scheme base)
+        (scheme eval)
+        (scheme file)
+        (srfi 1)
+        (srfi 48)
+        (srfi 64))
+
+(test-runner-current (test-runner-simple "tests.log"))
+
+(test-begin "SRFI")
+
+(for-each
+ (lambda (n)
+   (let ((srfi-n (string->symbol (format #f "srfi-~s" n)))
+         (file-name (format #f "srfi-tests/srfi-~s.sld" n))
+         (test-name (format #f "SRFI-~s" n)))
+    (when (file-exists? file-name)
+      (test-assert test-name
+        (guard (err (else #f))
+          (eval '(run-tests) (environment `(srfi-tests ,srfi-n))))))))
+ (iota 200))
+
+(test-end "SRFI")
+
+(test-exit)
+;;; SRFI 13 string library reference implementation		-*- Scheme -*-
+;;; Olin Shivers 7/2000
+;;;
+;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
+;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
+;;;   The details of the copyrights appear at the end of the file. Short
+;;;   summary: BSD-style open source.
+
+;;; Exports:
+;;; string-map string-map!
+;;; string-fold       string-unfold
+;;; string-fold-right string-unfold-right 
+;;; string-tabulate string-for-each string-for-each-index
+;;; string-every string-any
+;;; string-hash string-hash-ci
+;;; string-compare string-compare-ci
+;;; string=    string<    string>    string<=    string>=    string<>
+;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> 
+;;; string-downcase  string-upcase  string-titlecase  
+;;; string-downcase! string-upcase! string-titlecase! 
+;;; string-take string-take-right
+;;; string-drop string-drop-right
+;;; string-pad string-pad-right
+;;; string-trim string-trim-right string-trim-both
+;;; string-filter string-delete
+;;; string-index string-index-right 
+;;; string-skip  string-skip-right
+;;; string-count
+;;; string-prefix-length string-prefix-length-ci
+;;; string-suffix-length string-suffix-length-ci
+;;; string-prefix? string-prefix-ci?
+;;; string-suffix? string-suffix-ci?
+;;; string-contains string-contains-ci
+;;; string-copy! substring/shared
+;;; string-reverse string-reverse! reverse-list->string
+;;; string-concatenate string-concatenate/shared string-concatenate-reverse
+;;; string-append/shared
+;;; xsubstring string-xcopy!
+;;; string-null?
+;;; string-join
+;;; string-tokenize
+;;; string-replace
+;;; 
+;;; R5RS extended:
+;;; string->list string-copy string-fill! 
+;;;
+;;; R5RS re-exports:
+;;; string? make-string string-length string-ref string-set! 
+;;;
+;;; R5RS re-exports (also defined here but commented-out):
+;;; string string-append list->string
+;;;
+;;; Low-level routines:
+;;; make-kmp-restart-vector string-kmp-partial-search kmp-step
+;;; string-parse-start+end
+;;; string-parse-final-start+end
+;;; let-string-start+end
+;;; check-substring-spec
+;;; substring-spec-ok?
+
+;;; Imports
+;;; This is a fairly large library. While it was written for portability, you
+;;; must be aware of its dependencies in order to run it in a given scheme
+;;; implementation. Here is a complete list of the dependencies it has and the
+;;; assumptions it makes beyond stock R5RS Scheme:
+;;;
+;;; This code has the following non-R5RS dependencies:
+;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro;
+;;;
+;;; - Various imports from the char-set library for the routines that can
+;;;   take char-set arguments;
+;;;   
+;;; - An n-ary ERROR procedure;
+;;;   
+;;; - BITWISE-AND for the hash functions;
+;;;   
+;;; - A simple CHECK-ARG procedure for checking parameter values; it is 
+;;;   (lambda (pred val proc) 
+;;;     (if (pred val) val (error "Bad arg" val pred proc)))
+;;;   
+;;; - #\:OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting & 
+;;;   type-checking optional parameters from a rest argument;
+;;;   
+;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE & 
+;;;   STRING-TITLECASE! procedures. The former returns true iff a character is
+;;;   one that has case distinctions; in ASCII it returns true on a-z and A-Z.
+;;;   CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII &
+;;;   Latin-1, it is the same as CHAR-UPCASE.
+;;;
+;;; The code depends upon a small set of core string primitives from R5RS:
+;;;     MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING 
+;;; (Actually, SUBSTRING is not a primitive, but we assume that an 
+;;; implementation's native version is probably faster than one we could
+;;; define, so we import it from R5RS.)
+;;;
+;;; The code depends upon a small set of R5RS character primitives:
+;;;   char? char=? char-ci=? char<? char-ci<?
+;;;   char-upcase char-downcase
+;;;   char->integer (for the hash functions)
+;;;   
+;;; We assume the following:
+;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE
+;;; - CHAR-CI=? is equivalent to
+;;;     (lambda (c1 c2) (char=? (char-downcase (char-upcase c1))
+;;;                             (char-downcase (char-upcase c2))))
+;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive
+;;;   and consistent with Unicode's 1-1 char-mapping spec.
+;;; These things are typically true, but if not, you would need to modify
+;;; the case-mapping and case-insensitive routines.
+
+;;; Enough introductory blather. On to the source code. (But see the end of
+;;; the file for further notes on porting & performance tuning.)
+
+
+;;; Support for START/END substring specs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This macro parses optional start/end arguments from arg lists, defaulting
+;;; them to 0/(string-length s), and checks them for correctness.
+
+(define-syntax let-string-start+end
+  (syntax-rules ()
+    ((let-string-start+end (start end) proc s-exp args-exp body ...)
+     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
+       body ...))
+    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
+     (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
+       body ...))))
+
+;;; This one parses out a *pair* of final start/end indices. 
+;;; Not exported; for internal use.
+(define-syntax let-string-start+end2
+  (syntax-rules ()
+    ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
+     (let ((procv proc)) ; Make sure PROC is only evaluated once.
+       (let-string-start+end (start1 end1 rest) procv s1 args
+         (let-string-start+end (start2 end2) procv s2 rest
+           body ...))))))
+
+
+;;; Returns three values: rest start end
+
+(define (string-parse-start+end proc s args)
+  (if (not (string? s)) (error "Non-string value" proc s))
+  (let ((slen (string-length s)))
+    (if (pair? args)
+
+	(let ((start (car args))
+	      (args (cdr args)))
+	  (if (and (integer? start) (exact? start) (>= start 0))
+	      (receive (end args)
+		  (if (pair? args)
+		      (let ((end (car args))
+			    (args (cdr args)))
+			(if (and (integer? end) (exact? end) (<= end slen))
+			    (values end args)
+			    (error "Illegal substring END spec" proc end s)))
+		      (values slen args))
+		(if (<= start end) (values args start end)
+		    (error "Illegal substring START/END spec"
+			   proc start end s)))
+	      (error "Illegal substring START spec" proc start s)))
+
+	(values '() 0 slen))))
+
+(define (string-parse-final-start+end proc s args)
+  (receive (rest start end) (string-parse-start+end proc s args)
+    (if (pair? rest) (error "Extra arguments to procedure" proc rest)
+	(values start end))))
+
+(define (substring-spec-ok? s start end)
+  (and (string? s)
+       (integer? start)
+       (exact? start)
+       (integer? end)
+       (exact? end)
+       (<= 0 start)
+       (<= start end)
+       (<= end (string-length s))))
+
+(define (check-substring-spec proc s start end)
+  (if (not (substring-spec-ok? s start end))
+      (error "Illegal substring spec." proc s start end)))
+
+
+;;; Defined by R5RS, so commented out here.
+;(define (string . chars)
+;  (let* ((len (length chars))
+;         (ans (make-string len)))
+;    (do ((i 0 (+ i 1))
+;	 (chars chars (cdr chars)))
+;	((>= i len))
+;      (string-set! ans i (car chars)))
+;    ans))
+;
+;(define (string . chars) (string-unfold null? car cdr chars))
+
+
+
+;;; substring/shared S START [END] 
+;;; string-copy      S [START END]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; All this goop is just arg parsing & checking surrounding a call to the
+;;; actual primitive, %SUBSTRING/SHARED.
+
+(define (substring/shared s start . maybe-end)
+  (check-arg string? s substring/shared)
+  (let ((slen (string-length s)))
+    (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
+	       start substring/shared)
+    (%substring/shared s start
+		       (#\:optional maybe-end slen
+				  (lambda (end) (and (integer? end)
+						     (exact? end)
+						     (<= start end)
+						     (<= end slen)))))))
+
+;;; Split out so that other routines in this library can avoid arg-parsing
+;;; overhead for END parameter.
+(define (%substring/shared s start end)
+  (if (and (zero? start) (= end (string-length s))) s
+      (substring s start end)))
+
+(define (string-copy s . maybe-start+end)
+  (let-string-start+end (start end) string-copy s maybe-start+end
+    (substring s start end)))
+
+;This library uses the R5RS SUBSTRING, but doesn't export it.
+;Here is a definition, just for completeness.
+;(define (substring s start end)
+;  (check-substring-spec substring s start end)
+;  (let* ((slen (- end start))
+;         (ans (make-string slen)))
+;    (do ((i 0 (+ i 1))
+;         (j start (+ j 1)))
+;        ((>= i slen) ans)
+;      (string-set! ans i (string-ref s j)))))
+
+;;; Basic iterators and other higher-order abstractions
+;;; (string-map proc s [start end])
+;;; (string-map! proc s [start end])
+;;; (string-fold kons knil s [start end])
+;;; (string-fold-right kons knil s [start end])
+;;; (string-unfold       p f g seed [base make-final])
+;;; (string-unfold-right p f g seed [base make-final])
+;;; (string-for-each       proc s [start end])
+;;; (string-for-each-index proc s [start end])
+;;; (string-every char-set/char/pred s [start end])
+;;; (string-any   char-set/char/pred s [start end])
+;;; (string-tabulate proc len)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; You want compiler support for high-level transforms on fold and unfold ops.
+;;; You'd at least like a lot of inlining for clients of these procedures.
+;;; Don't hold your breath.
+
+(define (string-map proc s . maybe-start+end)
+  (check-arg procedure? proc string-map)
+  (let-string-start+end (start end) string-map s maybe-start+end
+    (%string-map proc s start end)))
+
+(define (%string-map proc s start end)	; Internal utility
+  (let* ((len (- end start))
+	 (ans (make-string len)))
+    (do ((i (- end 1) (- i 1))
+	 (j (- len 1) (- j 1)))
+	((< j 0))
+      (string-set! ans j (proc (string-ref s i))))
+    ans))
+
+(define (string-map! proc s . maybe-start+end)
+  (check-arg procedure? proc string-map!)
+  (let-string-start+end (start end) string-map! s maybe-start+end
+    (%string-map! proc s start end)))
+
+(define (%string-map! proc s start end)
+  (do ((i (- end 1) (- i 1)))
+      ((< i start))
+    (string-set! s i (proc (string-ref s i)))))
+
+(define (string-fold kons knil s . maybe-start+end)
+  (check-arg procedure? kons string-fold)
+  (let-string-start+end (start end) string-fold s maybe-start+end
+    (let lp ((v knil) (i start))
+      (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
+	  v))))
+
+(define (string-fold-right kons knil s . maybe-start+end)
+  (check-arg procedure? kons string-fold-right)
+  (let-string-start+end (start end) string-fold-right s maybe-start+end
+    (let lp ((v knil) (i (- end 1)))
+      (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
+	  v))))
+
+;;; (string-unfold p f g seed [base make-final])
+;;; This is the fundamental constructor for strings. 
+;;; - G is used to generate a series of "seed" values from the initial seed:
+;;;     SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
+;;; - P tells us when to stop -- when it returns true when applied to one 
+;;;   of these seed values.
+;;; - F maps each seed value to the corresponding character 
+;;;   in the result string. These chars are assembled into the
+;;;   string in a left-to-right order.
+;;; - BASE is the optional initial/leftmost portion of the constructed string;
+;;;   it defaults to the empty string "".
+;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
+;;;   true) to produce the final/rightmost portion of the constructed string.
+;;;   It defaults to (LAMBDA (X) "").
+;;;
+;;; In other words, the following (simple, inefficient) definition holds:
+;;; (define (string-unfold p f g seed base make-final)
+;;;   (string-append base
+;;;                  (let recur ((seed seed))
+;;;                    (if (p seed) (make-final seed)
+;;;                        (string-append (string (f seed))
+;;;                                       (recur (g seed)))))))
+;;; 
+;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
+;;; reverse a string, copy a string, convert a list to a string, read
+;;; a port into a string, and so forth. Examples:
+;;; (port->string port) =
+;;;   (string-unfold (compose eof-object? peek-char)
+;;;                  read-char values port)
+;;;
+;;; (list->string lis) = (string-unfold null? car cdr lis)
+;;; 
+;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)
+
+;;; A problem with the following simple formulation is that it pushes one
+;;; stack frame for every char in the result string -- an issue if you are
+;;; using it to read a 100kchar string. So we don't use it -- but I include
+;;; it to give a clear, straightforward description of what the function
+;;; does.
+
+;(define (string-unfold p f g seed base make-final)
+;  (let ((ans (let recur ((seed seed) (i (string-length base)))
+;               (if (p seed)
+;                   (let* ((final (make-final seed))
+;                          (ans (make-string (+ i (string-length final)))))
+;                     (string-copy! ans i final)
+;                     ans)
+;
+;                   (let* ((c (f seed))
+;                          (s (recur (g seed) (+ i 1))))
+;                     (string-set! s i c)
+;                     s)))))
+;    (string-copy! ans 0 base)
+;    ans))
+
+;;; The strategy is to allocate a series of chunks into which we stash the
+;;; chars as we generate them. Chunk size goes up in powers of two starting
+;;; with 40 and levelling out at 4k, i.e.
+;;;     40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
+;;; This should work pretty well for short strings, 1-line (80 char) strings,
+;;; and longer ones. When done, we allocate an answer string and copy the
+;;; chars over from the chunk buffers.
+
+(define (string-unfold p f g seed . base+make-final)
+  (check-arg procedure? p string-unfold)
+  (check-arg procedure? f string-unfold)
+  (check-arg procedure? g string-unfold)
+  (let-optionals* base+make-final
+                  ((base       ""              (string? base))
+		   (make-final (lambda (x) "") (procedure? make-final)))
+    (let lp ((chunks '())		; Previously filled chunks
+	     (nchars 0)			; Number of chars in CHUNKS
+	     (chunk (make-string 40))	; Current chunk into which we write
+	     (chunk-len 40)
+	     (i 0)			; Number of chars written into CHUNK
+	     (seed seed))
+      (let lp2 ((i i) (seed seed))
+	(if (not (p seed))
+	    (let ((c (f seed))
+		  (seed (g seed)))
+	      (if (< i chunk-len)
+		  (begin (string-set! chunk i c)
+			 (lp2 (+ i 1) seed))
+
+		  (let* ((nchars2 (+ chunk-len nchars))
+			 (chunk-len2 (min 4096 nchars2))
+			 (new-chunk (make-string chunk-len2)))
+		    (string-set! new-chunk 0 c)
+		    (lp (cons chunk chunks) (+ nchars chunk-len)
+			new-chunk chunk-len2 1 seed))))
+
+	    ;; We're done. Make the answer string & install the bits.
+	    (let* ((final (make-final seed))
+		   (flen (string-length final))
+		   (base-len (string-length base))
+		   (j (+ base-len nchars i))
+		   (ans (make-string (+ j flen))))
+	      (%string-copy! ans j final 0 flen)	; Install FINAL.
+	      (let ((j (- j i)))
+		(%string-copy! ans j chunk 0 i)		; Install CHUNK[0,I).
+		(let lp ((j j) (chunks chunks))		; Install CHUNKS.
+		  (if (pair? chunks)
+		      (let* ((chunk  (car chunks))
+			     (chunks (cdr chunks))
+			     (chunk-len (string-length chunk))
+			     (j (- j chunk-len)))
+			(%string-copy! ans j chunk 0 chunk-len)
+			(lp j chunks)))))
+	      (%string-copy! ans 0 base 0 base-len)	; Install BASE.
+	      ans))))))
+
+(define (string-unfold-right p f g seed . base+make-final)
+  (let-optionals* base+make-final
+                  ((base       ""              (string? base))
+		   (make-final (lambda (x) "") (procedure? make-final)))
+    (let lp ((chunks '())		; Previously filled chunks
+	     (nchars 0)			; Number of chars in CHUNKS
+	     (chunk (make-string 40))	; Current chunk into which we write
+	     (chunk-len 40)
+	     (i 40)			; Number of chars available in CHUNK
+	     (seed seed))
+      (let lp2 ((i i) (seed seed))	; Fill up CHUNK from right
+	(if (not (p seed))		; to left.
+	    (let ((c (f seed))
+		  (seed (g seed)))
+	      (if (> i 0)
+		  (let ((i (- i 1)))
+		    (string-set! chunk i c)
+		    (lp2 i seed))
+
+		  (let* ((nchars2 (+ chunk-len nchars))
+			 (chunk-len2 (min 4096 nchars2))
+			 (new-chunk (make-string chunk-len2))
+			 (i (- chunk-len2 1)))
+		    (string-set! new-chunk i c)
+		    (lp (cons chunk chunks) (+ nchars chunk-len)
+			new-chunk chunk-len2 i seed))))
+
+	    ;; We're done. Make the answer string & install the bits.
+	    (let* ((final (make-final seed))
+		   (flen (string-length final))
+		   (base-len (string-length base))
+		   (chunk-used (- chunk-len i))
+		   (j (+ base-len nchars chunk-used))
+		   (ans (make-string (+ j flen))))
+	      (%string-copy! ans 0 final 0 flen)	; Install FINAL.
+	      (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,).
+	      (let lp ((j (+ flen chunk-used))		; Install CHUNKS.
+		       (chunks chunks))		
+		  (if (pair? chunks)
+		      (let* ((chunk  (car chunks))
+			     (chunks (cdr chunks))
+			     (chunk-len (string-length chunk)))
+			(%string-copy! ans j chunk 0 chunk-len)
+			(lp (+ j chunk-len) chunks))
+		      (%string-copy! ans j base 0 base-len))); Install BASE.
+	      ans))))))
+
+
+(define (string-for-each proc s . maybe-start+end)
+  (check-arg procedure? proc string-for-each)
+  (let-string-start+end (start end) string-for-each s maybe-start+end
+    (let lp ((i start))
+      (if (< i end)
+	  (begin (proc (string-ref s i)) 
+		 (lp (+ i 1)))))))
+
+(define (string-for-each-index proc s . maybe-start+end)
+  (check-arg procedure? proc string-for-each-index)
+  (let-string-start+end (start end) string-for-each-index s maybe-start+end
+    (let lp ((i start))
+      (if (< i end) (begin (proc i) (lp (+ i 1)))))))
+
+(define (string-every criterion s . maybe-start+end)
+  (let-string-start+end (start end) string-every s maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i start))
+	     (or (>= i end)
+		 (and (char=? criterion (string-ref s i))
+		      (lp (+ i 1))))))
+
+	  ((char-set? criterion)
+	   (let lp ((i start))
+	     (or (>= i end)
+		 (and (char-set-contains? criterion (string-ref s i))
+		      (lp (+ i 1))))))
+
+	  ((procedure? criterion)		; Slightly funky loop so that
+	   (or (= start end)			; final (PRED S[END-1]) call
+	       (let lp ((i start))		; is a tail call.
+		 (let ((c (string-ref s i))
+		       (i1 (+ i 1)))
+		   (if (= i1 end) (criterion c)	; Tail call.
+		       (and (criterion c) (lp i1)))))))
+
+	  (else (error "Second param is neither char-set, char, or predicate procedure."
+		       string-every criterion)))))
+
+
+(define (string-any criterion s . maybe-start+end)
+  (let-string-start+end (start end) string-any s maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (or (char=? criterion (string-ref s i))
+		      (lp (+ i 1))))))
+
+	  ((char-set? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (or (char-set-contains? criterion (string-ref s i))
+		      (lp (+ i 1))))))
+
+	  ((procedure? criterion)		; Slightly funky loop so that
+	   (and (< start end)			; final (PRED S[END-1]) call
+		(let lp ((i start))		; is a tail call.
+		  (let ((c (string-ref s i))
+			(i1 (+ i 1)))
+		    (if (= i1 end) (criterion c)	; Tail call
+			(or (criterion c) (lp i1)))))))
+
+	  (else (error "Second param is neither char-set, char, or predicate procedure."
+		       string-any criterion)))))
+
+
+(define (string-tabulate proc len)
+  (check-arg procedure? proc string-tabulate)
+  (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
+	     len string-tabulate)
+  (let ((s (make-string len)))
+    (do ((i (- len 1) (- i 1)))
+	((< i 0))
+      (string-set! s i (proc i)))
+    s))
+
+
+
+;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
+;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Find the length of the common prefix/suffix.
+;;; It is not required that the two substrings passed be of equal length.
+;;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
+;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
+;;; so should be as tense as possible.
+
+(define (%string-prefix-length s1 start1 end1 s2 start2 end2)
+  (let* ((delta (min (- end1 start1) (- end2 start2)))
+	 (end1 (+ start1 delta)))
+
+    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
+	delta
+
+	(let lp ((i start1) (j start2))		; Regular path
+	  (if (or (>= i end1)
+		  (not (char=? (string-ref s1 i)
+			       (string-ref s2 j))))
+	      (- i start1)
+	      (lp (+ i 1) (+ j 1)))))))
+
+(define (%string-suffix-length s1 start1 end1 s2 start2 end2)
+  (let* ((delta (min (- end1 start1) (- end2 start2)))
+	 (start1 (- end1 delta)))
+
+    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
+	delta
+
+	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
+	  (if (or (< i start1)
+		  (not (char=? (string-ref s1 i)
+			       (string-ref s2 j))))
+	      (- (- end1 i) 1)
+	      (lp (- i 1) (- j 1)))))))
+
+(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
+  (let* ((delta (min (- end1 start1) (- end2 start2)))
+	 (end1 (+ start1 delta)))
+
+    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
+	delta
+
+	(let lp ((i start1) (j start2))		; Regular path
+	  (if (or (>= i end1)
+		  (not (char-ci=? (string-ref s1 i)
+				  (string-ref s2 j))))
+	      (- i start1)
+	      (lp (+ i 1) (+ j 1)))))))
+
+(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
+  (let* ((delta (min (- end1 start1) (- end2 start2)))
+	 (start1 (- end1 delta)))
+
+    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
+	delta
+
+	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
+	  (if (or (< i start1)
+		  (not (char-ci=? (string-ref s1 i)
+				  (string-ref s2 j))))
+	      (- (- end1 i) 1)
+	      (lp (- i 1) (- j 1)))))))
+
+
+(define (string-prefix-length s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-prefix-length s1 s2 maybe-starts+ends
+    (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-length s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-suffix-length s1 s2 maybe-starts+ends
+    (%string-suffix-length s1 start1 end1 s2 start2 end2)))
+
+(define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-prefix-length-ci s1 s2 maybe-starts+ends
+    (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-suffix-length-ci s1 s2 maybe-starts+ends
+    (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))
+
+
+;;; string-prefix?    s1 s2 [start1 end1 start2 end2]
+;;; string-suffix?    s1 s2 [start1 end1 start2 end2]
+;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2]
+;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These are all simple derivatives of the previous counting funs.
+
+(define (string-prefix? s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-prefix? s1 s2 maybe-starts+ends
+    (%string-prefix? s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix? s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-suffix? s1 s2 maybe-starts+ends
+    (%string-suffix? s1 start1 end1 s2 start2 end2)))
+
+(define (string-prefix-ci? s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-prefix-ci? s1 s2 maybe-starts+ends
+    (%string-prefix-ci? s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-ci? s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-suffix-ci? s1 s2 maybe-starts+ends
+    (%string-suffix-ci? s1 start1 end1 s2 start2 end2)))
+
+
+;;; Here are the internal routines that do the real work.
+
+(define (%string-prefix? s1 start1 end1 s2 start2 end2)
+  (let ((len1 (- end1 start1)))
+    (and (<= len1 (- end2 start2))	; Quick check
+	 (= (%string-prefix-length s1 start1 end1
+				   s2 start2 end2)
+	    len1))))
+
+(define (%string-suffix? s1 start1 end1 s2 start2 end2)
+  (let ((len1 (- end1 start1)))
+    (and (<= len1 (- end2 start2))	; Quick check
+	 (= len1 (%string-suffix-length s1 start1 end1
+					s2 start2 end2)))))
+
+(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
+  (let ((len1 (- end1 start1)))
+    (and (<= len1 (- end2 start2))	; Quick check
+	 (= len1 (%string-prefix-length-ci s1 start1 end1
+					   s2 start2 end2)))))
+
+(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
+  (let ((len1 (- end1 start1)))
+    (and (<= len1 (- end2 start2))	; Quick check
+	 (= len1 (%string-suffix-length-ci s1 start1 end1
+					   s2 start2 end2)))))
+
+
+;;; string-compare    s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Primitive string-comparison functions.
+;;; Continuation order is different from MIT Scheme.
+;;; Continuations are applied to s1's mismatch index;
+;;; in the case of equality, this is END1.
+
+(define (%string-compare s1 start1 end1 s2 start2 end2
+			   proc< proc= proc>)
+  (let ((size1 (- end1 start1))
+	(size2 (- end2 start2)))
+    (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+      (if (= match size1)
+	  ((if (= match size2) proc= proc<) end1)
+	  ((if (= match size2)
+	       proc>
+	       (if (char<? (string-ref s1 (+ start1 match))
+			   (string-ref s2 (+ start2 match)))
+		   proc< proc>))
+	   (+ match start1))))))
+
+(define (%string-compare-ci s1 start1 end1 s2 start2 end2
+			      proc< proc= proc>)
+  (let ((size1 (- end1 start1))
+	(size2 (- end2 start2)))
+    (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+      (if (= match size1)
+	  ((if (= match size2) proc= proc<) end1)
+	  ((if (= match size2) proc>
+	       (if (char-ci<? (string-ref s1 (+ start1 match))
+			      (string-ref s2 (+ start2 match)))
+		   proc< proc>))
+	   (+ start1 match))))))
+
+(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
+  (check-arg procedure? proc< string-compare)
+  (check-arg procedure? proc= string-compare)
+  (check-arg procedure? proc> string-compare)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-compare s1 s2 maybe-starts+ends
+    (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
+  (check-arg procedure? proc< string-compare-ci)
+  (check-arg procedure? proc= string-compare-ci)
+  (check-arg procedure? proc> string-compare-ci)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-compare-ci s1 s2 maybe-starts+ends
+    (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+
+
+;;; string=          string<>		string-ci=          string-ci<>
+;;; string<          string>		string-ci<          string-ci>
+;;; string<=         string>=		string-ci<=         string-ci>=
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Simple definitions in terms of the previous comparison funs.
+;;; I sure hope the %STRING-COMPARE calls get integrated.
+
+(define (string= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string= s1 s2 maybe-starts+ends
+    (and (= (- end1 start1) (- end2 start2))			; Quick filter
+	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
+	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
+			      (lambda (i) #f)
+			      values
+			      (lambda (i) #f))))))
+
+(define (string<> s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string<> s1 s2 maybe-starts+ends
+    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
+	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
+	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
+			      values
+			      (lambda (i) #f)
+			      values)))))
+
+(define (string< s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string< s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(< end1 end2)
+
+	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
+			 values
+			 (lambda (i) #f)
+			 (lambda (i) #f)))))
+
+(define (string> s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string> s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(> end1 end2)
+
+	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
+			 (lambda (i) #f)
+			 (lambda (i) #f)
+			 values))))
+
+(define (string<= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string<= s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(<= end1 end2)
+
+	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
+			 values
+			 values
+			 (lambda (i) #f)))))
+
+(define (string>= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string>= s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(>= end1 end2)
+
+	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
+			 (lambda (i) #f)
+			 values
+			 values))))
+
+(define (string-ci= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci= s1 s2 maybe-starts+ends
+    (and (= (- end1 start1) (- end2 start2))			; Quick filter
+	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
+	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+				 (lambda (i) #f)
+				 values
+				 (lambda (i) #f))))))
+
+(define (string-ci<> s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci<> s1 s2 maybe-starts+ends
+    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
+	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
+	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+				 values
+				 (lambda (i) #f)
+				 values)))))
+
+(define (string-ci< s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci< s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(< end1 end2)
+
+	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+			    values
+			    (lambda (i) #f)
+			    (lambda (i) #f)))))
+
+(define (string-ci> s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci> s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(> end1 end2)
+
+	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+			    (lambda (i) #f)
+			    (lambda (i) #f)
+			    values))))
+
+(define (string-ci<= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci<= s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(<= end1 end2)
+
+	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+			    values
+			    values
+			    (lambda (i) #f)))))
+
+(define (string-ci>= s1 s2 . maybe-starts+ends)
+  (let-string-start+end2 (start1 end1 start2 end2) 
+			 string-ci>= s1 s2 maybe-starts+ends
+    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
+	(>= end1 end2)
+
+	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
+			    (lambda (i) #f)
+			    values
+			    values))))
+
+
+;;; Hash
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
+;;; to keep the intermediate values small. (We do the calculation with just
+;;; enough bits to represent BOUND, masking off high bits at each step in
+;;; calculation. If this screws up any important properties of the hash
+;;; function I'd like to hear about it. -Olin)
+;;;
+;;; If you keep BOUND small enough, the intermediate calculations will 
+;;; always be fixnums. How small is dependent on the underlying Scheme system; 
+;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
+;;; Schemes that give you at least 29 signed bits for fixnums. The core 
+;;; calculation that you don't want to overflow is, worst case,
+;;;     (+ 65535 (* 37 (- bound 1)))
+;;; where 65535 is the max character code. Choose the default BOUND to be the
+;;; biggest power of two that won't cause this expression to fixnum overflow, 
+;;; and everything will be copacetic.
+
+(define (%string-hash s char->int bound start end)
+  (let ((iref (lambda (s i) (char->int (string-ref s i))))
+	;; Compute a 111...1 mask that will cover BOUND-1:
+	(mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
+		(if (>= i bound) (- i 1) (lp (+ i i))))))
+    (let lp ((i start) (ans 0))
+      (if (>= i end) (modulo ans bound)
+	  (lp (+ i 1) (bitwise-and mask (+ (* 37 ans) (iref s i))))))))
+
+(define (string-hash s . maybe-bound+start+end)
+  (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound)
+							     (exact? bound)
+							     (<= 0 bound)))
+					 rest)
+    (let ((bound (if (zero? bound) 4194304 bound)))	; 0 means default.
+      (let-string-start+end (start end) string-hash s rest
+        (%string-hash s char->integer bound start end)))))
+
+(define (string-hash-ci s . maybe-bound+start+end)
+  (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound)
+							     (exact? bound)
+							     (<= 0 bound)))
+					 rest)
+    (let ((bound (if (zero? bound) 4194304 bound)))	; 0 means default.
+      (let-string-start+end (start end) string-hash-ci s rest
+        (%string-hash s (lambda (c) (char->integer (char-downcase c)))
+		      bound start end)))))
+
+;;; Case hacking
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-upcase  s [start end]
+;;; string-upcase! s [start end]
+;;; string-downcase  s [start end]
+;;; string-downcase! s [start end]
+;;;
+;;; string-titlecase  s [start end]
+;;; string-titlecase! s [start end]
+;;;   Capitalize every contiguous alpha sequence: capitalise
+;;;   first char, lowercase rest.
+
+(define (string-upcase  s . maybe-start+end)
+  (let-string-start+end (start end) string-upcase s maybe-start+end
+    (%string-map char-upcase s start end)))
+
+(define (string-upcase! s . maybe-start+end)
+  (let-string-start+end (start end) string-upcase! s maybe-start+end
+    (%string-map! char-upcase s start end)))
+
+(define (string-downcase  s . maybe-start+end)
+  (let-string-start+end (start end) string-downcase s maybe-start+end
+    (%string-map char-downcase s start end)))
+
+(define (string-downcase! s . maybe-start+end)
+  (let-string-start+end (start end) string-downcase! s maybe-start+end
+    (%string-map! char-downcase s start end)))
+
+(define (%string-titlecase! s start end)
+  (let lp ((i start))
+    (cond ((string-index s char-cased? i end) =>
+           (lambda (i)
+	     (string-set! s i (char-titlecase (string-ref s i)))
+	     (let ((i1 (+ i 1)))
+	       (cond ((string-skip s char-cased? i1 end) =>
+		      (lambda (j)
+			(string-downcase! s i1 j)
+			(lp (+ j 1))))
+		     (else (string-downcase! s i1 end)))))))))
+
+(define (string-titlecase! s . maybe-start+end)
+  (let-string-start+end (start end) string-titlecase! s maybe-start+end
+    (%string-titlecase! s start end)))
+
+(define (string-titlecase s . maybe-start+end)
+  (let-string-start+end (start end) string-titlecase! s maybe-start+end
+    (let ((ans (substring s start end)))
+      (%string-titlecase! ans 0 (- end start))
+      ans)))
+
+
+;;; Cutting & pasting strings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-take string nchars
+;;; string-drop string nchars
+;;;
+;;; string-take-right string nchars
+;;; string-drop-right string nchars
+;;;
+;;; string-pad string k [char start end] 
+;;; string-pad-right string k [char start end] 
+;;; 
+;;; string-trim       string [char/char-set/pred start end] 
+;;; string-trim-right string [char/char-set/pred start end] 
+;;; string-trim-both  string [char/char-set/pred start end] 
+;;;
+;;; These trimmers invert the char-set meaning from MIT Scheme -- you
+;;; say what you want to trim.
+
+(define (string-take s n)
+  (check-arg string? s string-take)
+  (check-arg (lambda (val) (and (integer? n) (exact? n)
+				(<= 0 n (string-length s))))
+	     n string-take)
+  (%substring/shared s 0 n))
+
+(define (string-take-right s n)
+  (check-arg string? s string-take-right)
+  (let ((len (string-length s)))
+    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+	       n string-take-right)
+    (%substring/shared s (- len n) len)))
+
+(define (string-drop s n)
+  (check-arg string? s string-drop)
+  (let ((len (string-length s)))
+    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+	       n string-drop)
+  (%substring/shared s n len)))
+
+(define (string-drop-right s n)
+  (check-arg string? s string-drop-right)
+  (let ((len (string-length s)))
+    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+	       n string-drop-right)
+    (%substring/shared s 0 (- len n))))
+
+
+(define (string-trim s . criterion+start+end)
+  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
+    (let-string-start+end (start end) string-trim s rest
+      (cond ((string-skip s criterion start end) =>
+	     (lambda (i) (%substring/shared s i end)))
+	    (else "")))))
+
+(define (string-trim-right s . criterion+start+end)
+  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
+    (let-string-start+end (start end) string-trim-right s rest
+      (cond ((string-skip-right s criterion start end) =>
+	     (lambda (i) (%substring/shared s start (+ 1 i))))
+	    (else "")))))
+
+(define (string-trim-both s . criterion+start+end)
+  (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest)
+    (let-string-start+end (start end) string-trim-both s rest
+      (cond ((string-skip s criterion start end) =>
+	     (lambda (i)
+	       (%substring/shared s i (+ 1 (string-skip-right s criterion i end)))))
+	    (else "")))))
+
+
+(define (string-pad-right s n . char+start+end)
+  (let-optionals* char+start+end ((char #\space (char? char)) rest)
+    (let-string-start+end (start end) string-pad-right s rest
+      (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
+		 n string-pad-right)
+      (let ((len (- end start)))
+	(if (<= n len)
+	    (%substring/shared s start (+ start n))
+	    (let ((ans (make-string n char)))
+	      (%string-copy! ans 0 s start end)
+	      ans))))))
+
+(define (string-pad s n . char+start+end)
+  (let-optionals* char+start+end ((char #\space (char? char)) rest)
+    (let-string-start+end (start end) string-pad s rest
+      (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))
+		 n string-pad)
+      (let ((len (- end start)))
+	(if (<= n len)
+	    (%substring/shared s (- end n) end)
+	    (let ((ans (make-string n char)))
+	      (%string-copy! ans (- n len) s start end)
+	      ans))))))
+
+
+
+;;; Filtering strings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-delete char/char-set/pred string [start end]
+;;; string-filter char/char-set/pred string [start end]
+;;;
+;;; If the criterion is a char or char-set, we scan the string twice with
+;;;   string-fold -- once to determine the length of the result string, 
+;;;   and once to do the filtered copy.
+;;; If the criterion is a predicate, we don't do this double-scan strategy, 
+;;;   because the predicate might have side-effects or be very expensive to
+;;;   compute. So we preallocate a temp buffer pessimistically, and only do
+;;;   one scan over S. This is likely to be faster and more space-efficient
+;;;   than consing a list.
+
+(define (string-delete criterion s . maybe-start+end)
+  (let-string-start+end (start end) string-delete s maybe-start+end
+    (if (procedure? criterion)
+	(let* ((slen (- end start))
+	       (temp (make-string slen))
+	       (ans-len (string-fold (lambda (c i)
+				       (if (criterion c) i
+					   (begin (string-set! temp i c)
+						  (+ i 1))))
+				     0 s start end)))
+	  (if (= ans-len slen) temp (substring temp 0 ans-len)))
+
+	(let* ((cset (cond ((char-set? criterion) criterion)
+			   ((char? criterion) (char-set criterion))
+			   (else (error "string-delete criterion not predicate, char or char-set" criterion))))
+	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+						   i
+						   (+ i 1)))
+				 0 s start end))
+	       (ans (make-string len)))
+	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
+					 i
+					 (begin (string-set! ans i c)
+						(+ i 1))))
+		       0 s start end)
+	  ans))))
+
+(define (string-filter criterion s . maybe-start+end)
+  (let-string-start+end (start end) string-filter s maybe-start+end
+    (if (procedure? criterion)
+	(let* ((slen (- end start))
+	       (temp (make-string slen))
+	       (ans-len (string-fold (lambda (c i)
+				       (if (criterion c)
+					   (begin (string-set! temp i c)
+						  (+ i 1))
+					   i))
+				     0 s start end)))
+	  (if (= ans-len slen) temp (substring temp 0 ans-len)))
+
+	(let* ((cset (cond ((char-set? criterion) criterion)
+			   ((char? criterion) (char-set criterion))
+			   (else (error "string-delete criterion not predicate, char or char-set" criterion))))
+
+	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+						   (+ i 1)
+						   i))
+				 0 s start end))
+	       (ans (make-string len)))
+	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
+					 (begin (string-set! ans i c)
+						(+ i 1))
+					 i))
+		       0 s start end)
+	  ans))))
+
+
+;;; String search
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-index       string char/char-set/pred [start end]
+;;; string-index-right string char/char-set/pred [start end]
+;;; string-skip        string char/char-set/pred [start end]
+;;; string-skip-right  string char/char-set/pred [start end]
+;;; string-count       string char/char-set/pred [start end]
+;;;     There's a lot of replicated code here for efficiency.
+;;;     For example, the char/char-set/pred discrimination has
+;;;     been lifted above the inner loop of each proc.
+
+(define (string-index str criterion . maybe-start+end)
+  (let-string-start+end (start end) string-index str maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (char=? criterion (string-ref str i)) i
+		      (lp (+ i 1))))))
+	  ((char-set? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (char-set-contains? criterion (string-ref str i)) i
+		      (lp (+ i 1))))))
+	  ((procedure? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (criterion (string-ref str i)) i
+		      (lp (+ i 1))))))
+	  (else (error "Second param is neither char-set, char, or predicate procedure."
+		       string-index criterion)))))
+
+(define (string-index-right str criterion . maybe-start+end)
+  (let-string-start+end (start end) string-index-right str maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (char=? criterion (string-ref str i)) i
+		      (lp (- i 1))))))
+	  ((char-set? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (char-set-contains? criterion (string-ref str i)) i
+		      (lp (- i 1))))))
+	  ((procedure? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (criterion (string-ref str i)) i
+		      (lp (- i 1))))))
+	  (else (error "Second param is neither char-set, char, or predicate procedure."
+		       string-index-right criterion)))))
+
+(define (string-skip str criterion . maybe-start+end)
+  (let-string-start+end (start end) string-skip str maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (char=? criterion (string-ref str i))
+		      (lp (+ i 1))
+		      i))))
+	  ((char-set? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (char-set-contains? criterion (string-ref str i))
+		      (lp (+ i 1))
+		      i))))
+	  ((procedure? criterion)
+	   (let lp ((i start))
+	     (and (< i end)
+		  (if (criterion (string-ref str i)) (lp (+ i 1))
+		      i))))
+	  (else (error "Second param is neither char-set, char, or predicate procedure."
+		       string-skip criterion)))))
+
+(define (string-skip-right str criterion . maybe-start+end)
+  (let-string-start+end (start end) string-skip-right str maybe-start+end
+    (cond ((char? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (char=? criterion (string-ref str i))
+		      (lp (- i 1))
+		      i))))
+	  ((char-set? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (char-set-contains? criterion (string-ref str i))
+		      (lp (- i 1))
+		      i))))
+	  ((procedure? criterion)
+	   (let lp ((i (- end 1)))
+	     (and (>= i start)
+		  (if (criterion (string-ref str i)) (lp (- i 1))
+		      i))))
+	  (else (error "CRITERION param is neither char-set or char."
+		       string-skip-right criterion)))))
+
+
+(define (string-count s criterion . maybe-start+end)
+  (let-string-start+end (start end) string-count s maybe-start+end
+    (cond ((char? criterion)
+	   (do ((i start (+ i 1))
+		(count 0 (if (char=? criterion (string-ref s i))
+			     (+ count 1)
+			     count)))
+	       ((>= i end) count)))
+
+	  ((char-set? criterion)
+	   (do ((i start (+ i 1))
+		(count 0 (if (char-set-contains? criterion (string-ref s i))
+			     (+ count 1)
+			     count)))
+	       ((>= i end) count)))
+
+	  ((procedure? criterion)
+	   (do ((i start (+ i 1))
+		(count 0 (if (criterion (string-ref s i)) (+ count 1) count)))
+	       ((>= i end) count)))
+
+	  (else (error "CRITERION param is neither char-set or char."
+		       string-count criterion)))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-fill! string char [start end]
+;;; 
+;;; string-copy! to tstart from [fstart fend]
+;;; 	Guaranteed to work, even if s1 eq s2.
+
+(define (string-fill! s char . maybe-start+end)
+  (check-arg char? char string-fill!)
+  (let-string-start+end (start end) string-fill! s maybe-start+end
+    (do ((i (- end 1) (- i 1)))
+	((< i start))
+      (string-set! s i char))))
+
+(define (string-copy! to tstart from . maybe-fstart+fend)
+  (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
+    (check-arg integer? tstart string-copy!)
+    (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
+    (%string-copy! to tstart from fstart fend)))
+
+;;; Library-internal routine
+(define (%string-copy! to tstart from fstart fend)
+  (if (> fstart tstart)
+      (do ((i fstart (+ i 1))
+	   (j tstart (+ j 1)))
+	  ((>= i fend))
+	(string-set! to j (string-ref from i)))
+
+      (do ((i (- fend 1)                    (- i 1))
+	   (j (+ -1 tstart (- fend fstart)) (- j 1)))
+	  ((< i fstart))
+	(string-set! to j (string-ref from i)))))
+
+
+
+;;; Returns starting-position in STRING or #f if not true.
+;;; This implementation is slow & simple. It is useful as a "spec" or for
+;;; comparison testing with fancier implementations.
+;;; See below for fast KMP version.
+
+;(define (string-contains string substring . maybe-starts+ends)
+;  (let-string-start+end2 (start1 end1 start2 end2) 
+;                         string-contains string substring maybe-starts+ends
+;    (let* ((len (- end2 start2))
+;	   (i-bound (- end1 len)))
+;      (let lp ((i start1))
+;	(and (< i i-bound)
+;	     (if (string= string substring i (+ i len) start2 end2)
+;		 i
+;		 (lp (+ i 1))))))))
+
+
+;;; Searching for an occurrence of a substring
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-contains text pattern . maybe-starts+ends)
+  (let-string-start+end2 (t-start t-end p-start p-end)
+                         string-contains text pattern maybe-starts+ends
+    (%kmp-search pattern text char=? p-start p-end t-start t-end)))
+
+(define (string-contains-ci text pattern . maybe-starts+ends)
+  (let-string-start+end2 (t-start t-end p-start p-end)
+                         string-contains-ci text pattern maybe-starts+ends
+    (%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))
+
+
+;;; Knuth-Morris-Pratt string searching
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See
+;;;     "Fast pattern matching in strings"
+;;;     SIAM J. Computing 6(2):323-350 1977
+;;;     D. E. Knuth, J. H. Morris and V. R. Pratt
+;;; also described in
+;;;     "Pattern matching in strings"
+;;;     Alfred V. Aho
+;;;     Formal Language Theory - Perspectives and Open Problems
+;;;     Ronald V. Brook (editor)
+;;; This algorithm is O(m + n) where m and n are the 
+;;; lengths of the pattern and string respectively
+
+;;; KMP search source[start,end) for PATTERN. Return starting index of
+;;; leftmost match or #f.
+
+(define (%kmp-search pattern text c= p-start p-end t-start t-end)
+  (let ((plen (- p-end p-start))
+	(rv (make-kmp-restart-vector pattern c= p-start p-end)))
+
+    ;; The search loop. TJ & PJ are redundant state.
+    (let lp ((ti t-start) (pi 0)
+	     (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left.
+	     (pj plen))		 ; (- plen pi) -- how many chars left.
+
+      (if (= pi plen)
+	  (- ti plen)			; Win.
+	  (and (<= pj tj)		; Lose.
+	       (if (c= (string-ref text ti) ; Search.
+		       (string-ref pattern (+ p-start pi)))
+		   (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance.
+		   
+		   (let ((pi (vector-ref rv pi))) ; Retreat.
+		     (if (= pi -1)
+			 (lp (+ ti 1) 0  (- tj 1) plen) ; Punt.
+			 (lp ti       pi tj       (- plen pi))))))))))
+
+;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute the KMP restart vector RV for string PATTERN.  If
+;;; we have matched chars 0..i-1 of PATTERN against a search string S, and
+;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to
+;;; match S[k].  If RV[i] = -1, then punt S[k] completely, and move on to
+;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k].
+;;;
+;;; In other words, if you have matched the first i chars of PATTERN, but
+;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest
+;;; prefix of PATTERN is that you have matched.
+;;;
+;;; - C= (default CHAR=?) is used to compare characters for equality.
+;;;   Pass in CHAR-CI=? for case-folded string search.
+;;;
+;;; - START & END restrict the pattern to the indicated substring; the
+;;;   returned vector will be of length END - START. The numbers stored
+;;;   in the vector will be values in the range [0,END-START) -- that is,
+;;;   they are valid indices into the restart vector; you have to add START
+;;;   to them to use them as indices into PATTERN.
+;;;
+;;; I've split this out as a separate function in case other constant-string
+;;; searchers might want to use it.
+;;;
+;;; E.g.:
+;;;    a b d  a b x
+;;; #(-1 0 0 -1 1 2)
+
+(define (make-kmp-restart-vector pattern . maybe-c=+start+end)
+  (let-optionals* maybe-c=+start+end
+                  ((c= char=? (procedure? c=))
+		   ((start end) (lambda (args)
+				  (string-parse-start+end make-kmp-restart-vector
+							  pattern args))))
+    (let* ((rvlen (- end start))
+	   (rv (make-vector rvlen -1)))
+      (if (> rvlen 0)
+	  (let ((rvlen-1 (- rvlen 1))
+		(c0 (string-ref pattern start)))
+
+	    ;; Here's the main loop. We have set rv[0] ... rv[i].
+	    ;; K = I + START -- it is the corresponding index into PATTERN.
+	    (let lp1 ((i 0) (j -1) (k start))	
+	      (if (< i rvlen-1)
+		  ;; lp2 invariant:
+		  ;;   pat[(k-j) .. k-1] matches pat[start .. start+j-1]
+		  ;;   or j = -1.
+		  (let lp2 ((j j))
+		    (cond ((= j -1)
+			   (let ((i1 (+ 1 i)))
+			     (if (not (c= (string-ref pattern (+ k 1)) c0))
+				 (vector-set! rv i1 0))
+			     (lp1 i1 0 (+ k 1))))
+			  ;; pat[(k-j) .. k] matches pat[start..start+j].
+			  ((c= (string-ref pattern k) (string-ref pattern (+ j start)))
+			   (let* ((i1 (+ 1 i))
+				  (j1 (+ 1 j)))
+			     (vector-set! rv i1 j1)
+			     (lp1 i1 j1 (+ k 1))))
+
+			  (else (lp2 (vector-ref rv j)))))))))
+      rv)))
+
+
+;;; We've matched I chars from PAT. C is the next char from the search string.
+;;; Return the new I after handling C. 
+;;;
+;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START
+;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched
+;;; are 
+;;;     PAT[PAT-START .. PAT-START + I].
+;;;
+;;; It's *not* an oversight that there is no friendly error checking or
+;;; defaulting of arguments. This is a low-level, inner-loop procedure
+;;; that we want integrated/inlined into the point of call.
+
+(define (kmp-step pat rv c i c= p-start)
+  (let lp ((i i))
+    (if (c= c (string-ref pat (+ i p-start)))	; Match =>
+	(+ i 1)					;   Done.
+	(let ((i (vector-ref rv i)))		; Back up in PAT.
+	  (if (= i -1) 0			; Can't back up further.
+	      (lp i))))))			; Keep trying for match.
+
+;;; Zip through S[start,end), looking for a match of PAT. Assume we've
+;;; already matched the first I chars of PAT when we commence at S[start].
+;;; - <0:  If we find a match *ending* at index J, return -J.
+;;; - >=0: If we get to the end of the S[start,end) span without finding
+;;;   a complete match, return the number of chars from PAT we'd matched
+;;;   when we ran off the end.
+;;;
+;;; This is useful for searching *across* buffers -- that is, when your
+;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop
+;;; for speed.
+
+(define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end)
+  (check-arg vector? rv string-kmp-partial-search)
+  (let-optionals* c=+p-start+s-start+s-end
+		  ((c=      char=? (procedure? c=))
+		   (p-start 0 (and (integer? p-start) (exact? p-start) (<= 0 p-start)))
+		   ((s-start s-end) (lambda (args)
+				      (string-parse-start+end string-kmp-partial-search
+							      s args))))
+    (let ((patlen (vector-length rv)))
+      (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i) (< i patlen)))
+		 i string-kmp-partial-search)
+
+      ;; Enough prelude. Here's the actual code.
+      (let lp ((si s-start)		; An index into S.
+	       (vi i))			; An index into RV.
+	(cond ((= vi patlen) (- si))	; Win.
+	      ((= si s-end) vi)		; Ran off the end.
+	      (else			; Match s[si] & loop.
+	       (let ((c (string-ref s si)))
+		 (lp (+ si 1)	
+		     (let lp2 ((vi vi))	; This is just KMP-STEP.
+		       (if (c= c (string-ref pat (+ vi p-start)))
+			   (+ vi 1)
+			   (let ((vi (vector-ref rv vi)))
+			     (if (= vi -1) 0
+				 (lp2 vi)))))))))))))
+
+
+;;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; (string-null? s)
+;;; (string-reverse  s [start end])
+;;; (string-reverse! s [start end])
+;;; (reverse-list->string clist)
+;;; (string->list s [start end])
+
+(define (string-null? s) (zero? (string-length s)))
+
+(define (string-reverse s . maybe-start+end)
+  (let-string-start+end (start end) string-reverse s maybe-start+end
+    (let* ((len (- end start))
+	   (ans (make-string len)))
+      (do ((i start (+ i 1))
+	   (j (- len 1) (- j 1)))
+	  ((< j 0))
+	(string-set! ans j (string-ref s i)))
+      ans)))
+
+(define (string-reverse! s . maybe-start+end)
+  (let-string-start+end (start end) string-reverse! s maybe-start+end
+    (do ((i (- end 1) (- i 1))
+	 (j start (+ j 1)))
+	((<= i j))
+      (let ((ci (string-ref s i)))
+	(string-set! s i (string-ref s j))
+	(string-set! s j ci)))))
+
+
+(define (reverse-list->string clist)
+  (let* ((len (length clist))
+	 (s (make-string len)))
+    (do ((i (- len 1) (- i 1))   (clist clist (cdr clist)))
+	((not (pair? clist)))
+      (string-set! s i (car clist)))
+    s))
+
+
+;(define (string->list s . maybe-start+end)
+;  (apply string-fold-right cons '() s maybe-start+end))
+
+(define (string->list s . maybe-start+end)
+  (let-string-start+end (start end) string->list s maybe-start+end
+    (do ((i (- end 1) (- i 1))
+	 (ans '() (cons (string-ref s i) ans)))
+	((< i start) ans))))
+
+;;; Defined by R5RS, so commented out here.
+;(define (list->string lis) (string-unfold null? car cdr lis))
+
+
+;;; string-concatenate        string-list -> string
+;;; string-concatenate/shared string-list -> string
+;;; string-append/shared s ... -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; STRING-APPEND/SHARED has license to return a string that shares storage
+;;; with any of its arguments. In particular, if there is only one non-empty
+;;; string amongst its parameters, it is permitted to return that string as
+;;; its result. STRING-APPEND, by contrast, always allocates new storage.
+;;;
+;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
+;;; strings, which they concatenate into a result string. STRING-CONCATENATE
+;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
+;;; not) return a result that shares storage with any of its arguments. In
+;;; particular, if it is applied to a singleton list, it is permitted to
+;;; return the car of that list as its value.
+
+(define (string-append/shared . strings) (string-concatenate/shared strings))
+
+(define (string-concatenate/shared strings)
+  (let lp ((strings strings) (nchars 0) (first #f))
+    (cond ((pair? strings)			; Scan the args, add up total
+	   (let* ((string  (car strings))	; length, remember 1st 
+		  (tail (cdr strings))		; non-empty string.
+		  (slen (string-length string)))
+	     (if (zero? slen)
+		 (lp tail nchars first)
+		 (lp tail (+ nchars slen) (or first strings)))))
+
+	  ((zero? nchars) "")
+
+	  ;; Just one non-empty string! Return it.
+	  ((= nchars (string-length (car first))) (car first))
+
+	  (else (let ((ans (make-string nchars)))
+		  (let lp ((strings first) (i 0))
+		    (if (pair? strings)
+			(let* ((s (car strings))
+			       (slen (string-length s)))
+			  (%string-copy! ans i s 0 slen)
+			  (lp (cdr strings) (+ i slen)))))
+		  ans)))))
+			
+
+; Alas, Scheme 48's APPLY blows up if you have many, many arguments.
+;(define (string-concatenate strings) (apply string-append strings))
+
+;;; Here it is written out. I avoid using REDUCE to add up string lengths
+;;; to avoid non-R5RS dependencies.
+(define (string-concatenate strings)
+  (let* ((total (do ((strings strings (cdr strings))
+		     (i 0 (+ i (string-length (car strings)))))
+		    ((not (pair? strings)) i)))
+	 (ans (make-string total)))
+    (let lp ((i 0) (strings strings))
+      (if (pair? strings)
+	  (let* ((s (car strings))
+		 (slen (string-length s)))
+	    (%string-copy! ans i s 0 slen)
+	    (lp (+ i slen) (cdr strings)))))
+    ans))
+	  
+
+;;; Defined by R5RS, so commented out here.
+;(define (string-append . strings) (string-concatenate strings))
+
+;;; string-concatenate-reverse        string-list [final-string end] -> string
+;;; string-concatenate-reverse/shared string-list [final-string end] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Return
+;;;   (string-concatenate 
+;;;     (reverse
+;;;       (cons (substring final-string 0 end) string-list)))
+
+(define (string-concatenate-reverse string-list . maybe-final+end)
+  (let-optionals* maybe-final+end ((final "" (string? final))
+				   (end (string-length final)
+					(and (integer? end)
+					     (exact? end)
+					     (<= 0 end (string-length final)))))
+    (let ((len (let lp ((sum 0) (lis string-list))
+		 (if (pair? lis)
+		     (lp (+ sum (string-length (car lis))) (cdr lis))
+		     sum))))
+
+      (%finish-string-concatenate-reverse len string-list final end))))
+
+(define (string-concatenate-reverse/shared string-list . maybe-final+end)
+  (let-optionals* maybe-final+end ((final "" (string? final))
+				   (end (string-length final)
+					(and (integer? end)
+					     (exact? end)
+					     (<= 0 end (string-length final)))))
+    ;; Add up the lengths of all the strings in STRING-LIST; also get a
+    ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length
+    ;; string starts.
+    (let lp ((len 0) (nzlist #f) (lis string-list))
+      (if (pair? lis)
+	  (let ((slen (string-length (car lis))))
+	    (lp (+ len slen)
+		(if (or nzlist (zero? slen)) nzlist lis)
+		(cdr lis)))
+
+	  (cond ((zero? len) (substring/shared final 0 end))
+
+		;; LEN > 0, so NZLIST is non-empty.
+
+		((and (zero? end) (= len (string-length (car nzlist))))
+		 (car nzlist))
+
+		(else (%finish-string-concatenate-reverse len nzlist final end)))))))
+
+(define (%finish-string-concatenate-reverse len string-list final end)
+  (let ((ans (make-string (+ end len))))
+    (%string-copy! ans len final 0 end)
+    (let lp ((i len) (lis string-list))
+      (if (pair? lis)
+	  (let* ((s   (car lis))
+		 (lis (cdr lis))
+		 (slen (string-length s))
+		 (i (- i slen)))
+	    (%string-copy! ans i s 0 slen)
+	    (lp i lis))))
+    ans))
+
+
+
+
+;;; string-replace s1 s2 start1 end1 [start2 end2] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Replace S1[START1,END1) with S2[START2,END2).
+
+(define (string-replace s1 s2 start1 end1 . maybe-start+end)
+  (check-substring-spec string-replace s1 start1 end1)
+  (let-string-start+end (start2 end2) string-replace s2 maybe-start+end
+    (let* ((slen1 (string-length s1))
+	   (sublen2 (- end2 start2))
+	   (alen (+ (- slen1 (- end1 start1)) sublen2))
+	   (ans (make-string alen)))
+      (%string-copy! ans 0 s1 0 start1)
+      (%string-copy! ans start1 s2 start2 end2)
+      (%string-copy! ans (+ start1 sublen2) s1 end1 slen1)
+      ans)))
+
+
+;;; string-tokenize s [token-set start end] -> list
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Break S up into a list of token strings, where a token is a maximal
+;;; non-empty contiguous sequence of chars belonging to TOKEN-SET.
+;;; (string-tokenize "hello, world") => ("hello," "world")
+
+(define (string-tokenize s . token-chars+start+end)
+  (let-optionals* token-chars+start+end
+                  ((token-chars char-set:graphic (char-set? token-chars)) rest)
+    (let-string-start+end (start end) string-tokenize s rest
+      (let lp ((i end) (ans '()))
+	(cond ((and (< start i) (string-index-right s token-chars start i)) =>
+	       (lambda (tend-1)
+		 (let ((tend (+ 1 tend-1)))
+		   (cond ((string-skip-right s token-chars start tend-1) =>
+			  (lambda (tstart-1)
+			    (lp tstart-1
+				(cons (substring s (+ 1 tstart-1) tend)
+				      ans))))
+			 (else (cons (substring s start tend) ans))))))
+	      (else ans))))))
+
+
+;;; xsubstring s from [to start end] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; S is a string; START and END are optional arguments that demarcate
+;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole
+;;; string). Replicate this substring up and down index space, in both the
+;;  positive and negative directions. For example, if S = "abcdefg", START=3, 
+;;; and END=6, then we have the conceptual bidirectionally-infinite string
+;;;     ...  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f  d  e  f ...
+;;;     ... -9 -8 -7 -6 -5 -4 -3 -2 -1  0  1  2  3  4  5  6  7  8  9 ...
+;;; XSUBSTRING returns the substring of this string beginning at index FROM,
+;;; and ending at TO (which defaults to FROM+(END-START)).
+;;; 
+;;; You can use XSUBSTRING in many ways:
+;;; - To rotate a string left:  (xsubstring "abcdef" 2)  => "cdefab"
+;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd"
+;;; - To replicate a string:    (xsubstring "abc" 0 7) => "abcabca"
+;;;
+;;; Note that 
+;;;   - The FROM/TO indices give a half-open range -- the characters from
+;;;     index FROM up to, but not including index TO.
+;;;   - The FROM/TO indices are not in terms of the index space for string S.
+;;;     They are in terms of the replicated index space of the substring
+;;;     defined by S, START, and END.
+;;;
+;;; It is an error if START=END -- although this is allowed by special
+;;; dispensation when FROM=TO.
+
+(define (xsubstring s from . maybe-to+start+end)
+  (check-arg (lambda (val) (and (integer? val) (exact? val)))
+	     from xsubstring)
+  (receive (to start end)
+           (if (pair? maybe-to+start+end)
+	       (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end)
+		 (let ((to (car maybe-to+start+end)))
+		   (check-arg (lambda (val) (and (integer? val)
+						 (exact? val)
+						 (<= from val)))
+			      to xsubstring)
+		   (values to start end)))
+	       (let ((slen (string-length (check-arg string? s xsubstring))))
+		 (values (+ from slen) 0 slen)))
+    (let ((slen   (- end start))
+	  (anslen (- to  from)))
+      (cond ((zero? anslen) "")
+	    ((zero? slen) (error "Cannot replicate empty (sub)string"
+				  xsubstring s from to start end))
+
+	    ((= 1 slen)		; Fast path for 1-char replication.
+	     (make-string anslen (string-ref s start)))
+
+	    ;; Selected text falls entirely within one span.
+	    ((= (floor (/ from slen)) (floor (/ to slen)))
+	     (substring s (+ start (modulo from slen))
+			  (+ start (modulo to   slen))))
+
+	    ;; Selected text requires multiple spans.
+	    (else (let ((ans (make-string anslen)))
+		    (%multispan-repcopy! ans 0 s from to start end)
+		    ans))))))
+
+
+;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Exactly the same as xsubstring, but the extracted text is written
+;;; into the string TARGET starting at index TSTART.
+;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy
+;;; a string on top of itself.
+
+(define (string-xcopy! target tstart s sfrom . maybe-sto+start+end)
+  (check-arg (lambda (val) (and (integer? val) (exact? val)))
+	     sfrom string-xcopy!)
+  (receive (sto start end)
+           (if (pair? maybe-sto+start+end)
+	       (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end)
+		 (let ((sto (car maybe-sto+start+end)))
+		   (check-arg (lambda (val) (and (integer? val) (exact? val)))
+			      sto string-xcopy!)
+		   (values sto start end)))
+	       (let ((slen (string-length s)))
+		 (values (+ sfrom slen) 0 slen)))
+
+    (let* ((tocopy (- sto sfrom))
+	   (tend (+ tstart tocopy))
+	   (slen (- end start)))
+      (check-substring-spec string-xcopy! target tstart tend)
+      (cond ((zero? tocopy))
+	    ((zero? slen) (error "Cannot replicate empty (sub)string"
+				 string-xcopy!
+				 target tstart s sfrom sto start end))
+
+	    ((= 1 slen)			; Fast path for 1-char replication.
+	     (string-fill! target (string-ref s start) tstart tend))
+
+	    ;; Selected text falls entirely within one span.
+	    ((= (floor (/ sfrom slen)) (floor (/ sto slen)))
+	     (%string-copy! target tstart s 
+			    (+ start (modulo sfrom slen))
+			    (+ start (modulo sto   slen))))
+
+	    ;; Multi-span copy.
+	    (else (%multispan-repcopy! target tstart s sfrom sto start end))))))
+
+;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY!
+;;; Internal -- not exported, no careful arg checking.
+(define (%multispan-repcopy! target tstart s sfrom sto start end)
+  (let* ((slen (- end start))
+	 (i0 (+ start (modulo sfrom slen)))
+	 (total-chars (- sto sfrom)))
+
+    ;; Copy the partial span @ the beginning
+    (%string-copy! target tstart s i0 end)
+		    
+    (let* ((ncopied (- end i0))			; We've copied this many.
+	   (nleft (- total-chars ncopied))	; # chars left to copy.
+	   (nspans (quotient nleft slen)))	; # whole spans to copy
+			   
+      ;; Copy the whole spans in the middle.
+      (do ((i (+ tstart ncopied) (+ i slen))	; Current target index.
+	   (nspans nspans (- nspans 1)))	; # spans to copy
+	  ((zero? nspans)
+	   ;; Copy the partial-span @ the end & we're done.
+	   (%string-copy! target i s start (+ start (- total-chars (- i tstart)))))
+
+	(%string-copy! target i s start end))))); Copy a whole span.
+
+
+
+;;; (string-join string-list [delimiter grammar]) => string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Paste strings together using the delimiter string.
+;;;
+;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
+;;;
+;;; DELIMITER defaults to a single space " "
+;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} 
+;;; and defaults to 'infix.
+;;;
+;;; I could rewrite this more efficiently -- precompute the length of the
+;;; answer string, then allocate & fill it in iteratively. Using 
+;;; STRING-CONCATENATE is less efficient.
+
+(define (string-join strings . delim+grammar)
+  (let-optionals* delim+grammar ((delim " " (string? delim))
+				 (grammar 'infix))
+    (let ((buildit (lambda (lis final)
+		     (let recur ((lis lis))
+		       (if (pair? lis)
+			   (cons delim (cons (car lis) (recur (cdr lis))))
+			   final)))))
+
+      (cond ((pair? strings)
+	     (string-concatenate
+	      (case grammar
+
+		((infix strict-infix)
+		 (cons (car strings) (buildit (cdr strings) '())))
+
+		((prefix) (buildit strings '()))
+
+		((suffix)
+		 (cons (car strings) (buildit (cdr strings) (list delim))))
+
+		(else (error "Illegal join grammar"
+			     grammar string-join)))))
+
+	     ((not (null? strings))
+	      (error "STRINGS parameter not list." strings string-join))
+
+	     ;; STRINGS is ()
+
+	     ((eq? grammar 'strict-infix)
+	      (error "Empty list cannot be joined with STRICT-INFIX grammar."
+		     string-join))
+
+	     (else "")))))		; Special-cased for infix grammar.
+
+
+;;; Porting & performance-tuning notes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See the section at the beginning of this file on external dependencies.
+;;;
+;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro.
+;;; There are many, many optional arguments in this library; the complexity
+;;; of parsing, defaulting & type-testing these parameters is handled with the
+;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can
+;;; rewrite the uses, port the hairy macro definition (which is implemented
+;;; using a Clinger-Rees low-level explicit-renaming macro system), or port
+;;; the simple, high-level definition, which is less efficient.
+;;;
+;;; There is a fair amount of argument checking. This is, strictly speaking,
+;;; unnecessary -- the actual body of the procedures will blow up if, say, a
+;;; START/END index is improper. However, the error message will not be as
+;;; good as if the error were caught at the "higher level." Also, a very, very
+;;; smart Scheme compiler may be able to exploit having the type checks done
+;;; early, so that the actual body of the procedures can assume proper values.
+;;; This isn't likely; this kind of compiler technology isn't common any 
+;;; longer.
+;;; 
+;;; The overhead of optional-argument parsing is irritating. The optional
+;;; arguments must be consed into a rest list on entry, and then parsed out.
+;;; Function call should be a matter of a few register moves and a jump; it
+;;; should not involve heap allocation! Your Scheme system may have a superior
+;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
+;;; then this is a prime candidate for optimising these procedures,
+;;; *especially* the many optional START/END index parameters.
+;;;
+;;; Note that optional arguments are also a barrier to procedure integration.
+;;; If your Scheme system permits you to specify alternate entry points
+;;; for a call when the number of optional arguments is known in a manner
+;;; that enables inlining/integration, this can provide performance 
+;;; improvements.
+;;;
+;;; There is enough *explicit* error checking that *all* string-index
+;;; operations should *never* produce a bounds error. Period. Feel like
+;;; living dangerously? *Big* performance win to be had by replacing
+;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops. 
+;;; Similarly, fixnum-specific operators can speed up the arithmetic done on 
+;;; the index values in the inner loops. The only arguments that are not
+;;; completely error checked are
+;;;   - string lists (complete checking requires time proportional to the
+;;;     length of the list)
+;;;   - procedure arguments, such as char->char maps & predicates.
+;;;     There is no way to check the range & domain of procedures in Scheme.
+;;; Procedures that take these parameters cannot fully check their
+;;; arguments. But all other types to all other procedures are fully
+;;; checked.
+;;;
+;;; This does open up the alternate possibility of simply *removing* these 
+;;; checks, and letting the safe primitives raise the errors. On a dumb
+;;; Scheme system, this would provide speed (by eliminating the redundant
+;;; error checks) at the cost of error-message clarity.
+;;;
+;;; See the comments preceding the hash function code for notes on tuning
+;;; the default bound so that the code never overflows your implementation's
+;;; fixnum size into bignum calculation.
+;;;
+;;; In an interpreted Scheme, some of these procedures, or the internal
+;;; routines with % prefixes, are excellent candidates for being rewritten
+;;; in C. Consider STRING-HASH, %STRING-COMPARE, the 
+;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX &
+;;; STRING-SKIP (char-set & char cases), SUBSTRING and SUBSTRING/SHARED,
+;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!.
+;;;
+;;; It would also be nice to have the ability to mark some of these
+;;; routines as candidates for inlining/integration.
+;;; 
+;;; All the %-prefixed routines in this source code are written
+;;; to be called internally to this library. They do *not* perform
+;;; friendly error checks on the inputs; they assume everything is
+;;; proper. They also do not take optional arguments. These two properties
+;;; save calling overhead and enable procedure integration -- but they
+;;; are not appropriate for exported routines.
+
+
+;;; Copyright details
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The prefix/suffix and comparison routines in this code had (extremely
+;;; distant) origins in MIT Scheme's string lib, and was substantially
+;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is
+;;; covered by MIT Scheme's open source copyright. See below for details.
+;;; 
+;;; The KMP string-search code was influenced by implementations written
+;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
+;;; version was written from scratch by myself.
+;;;
+;;; The remainder of this code was written from scratch by myself for scsh.
+;;; The scsh copyright is a BSD-style open source copyright. See below for
+;;; details.
+;;;     -Olin Shivers
+
+;;; MIT Scheme copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This material was developed by the Scheme project at the Massachusetts
+;;; Institute of Technology, Department of Electrical Engineering and
+;;; Computer Science.  Permission to copy and modify this software, to
+;;; redistribute either the original software or a modified version, and
+;;; to use this software for any purpose is granted, subject to the
+;;; following restrictions and understandings.
+;;; 
+;;; 1. Any copy made of this software must include this copyright notice
+;;; in full.
+;;; 
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions that
+;;; they make, so that these may be included in future releases; and (b)
+;;; to inform MIT of noteworthy uses of this software.
+;;; 
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the usual
+;;; standards of acknowledging credit in academic research.
+;;; 
+;;; 4. MIT has made no warrantee or representation that the operation of
+;;; this software will be error-free, and MIT is under no obligation to
+;;; provide any services, by way of maintenance, update, or otherwise.
+;;; 
+;;; 5. In conjunction with products arising from the use of this material,
+;;; there shall be no use of the name of the Massachusetts Institute of
+;;; Technology nor of any adaptation thereof in any advertising,
+;;; promotional, or sales literature without prior written consent from
+;;; MIT in each case.
+
+;;; Scsh copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; All rights reserved.
+;;; 
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;;    derived from this software without specific prior written permission.
+;;; 
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+(define-library (srfi 14)
+  (export
+   ;; Predicates & comparison
+   char-set? char-set= char-set<= char-set-hash
+
+   ;; Iterating over character sets
+   char-set-cursor char-set-ref char-set-cursor-next end-of-char-set? 
+   char-set-fold char-set-unfold char-set-unfold!
+   char-set-for-each char-set-map
+
+   ;; Creating character sets
+   char-set-copy char-set
+
+   list->char-set  string->char-set
+   list->char-set! string->char-set!
+        
+   char-set-filter  ucs-range->char-set 
+   char-set-filter! ucs-range->char-set!
+
+   ->char-set
+
+   ;; Querying character sets
+   char-set->list char-set->string
+   char-set-size char-set-count char-set-contains?
+   char-set-every char-set-any
+
+   ;; Character-set algebra
+   char-set-adjoin  char-set-delete
+   char-set-adjoin! char-set-delete!
+
+   char-set-complement  char-set-union  char-set-intersection
+   char-set-complement! char-set-union! char-set-intersection!
+
+   char-set-difference  char-set-xor  char-set-diff+intersection
+   char-set-difference! char-set-xor! char-set-diff+intersection!
+
+   ;; Standard character sets
+   char-set:lower-case  char-set:upper-case  char-set:title-case
+   char-set:letter      char-set:digit       char-set:letter+digit
+   char-set:graphic     char-set:printing    char-set:whitespace
+   char-set:iso-control char-set:punctuation char-set:symbol
+   char-set:hex-digit   char-set:blank       char-set:ascii
+   char-set:empty       char-set:full
+   )
+  (import
+   (scheme base)
+   (srfi 60)
+   (srfi aux))
+  (include "14.upstream.scm"))
+;;; SRFI-14 character-sets library				-*- Scheme -*-
+;;;
+;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom.
+;;; - Massively rehacked & extended by Olin Shivers 6/98.
+;;; - Massively redesigned and rehacked 5/2000 during SRFI process.
+;;; At this point, the code bears the following relationship to the
+;;; MIT Scheme code: "This is my grandfather's axe. My father replaced
+;;; the head, and I have replaced the handle." Nonetheless, we preserve
+;;; the MIT Scheme copyright:
+;;;     Copyright (c) 1988-1995 Massachusetts Institute of Technology
+;;; The MIT Scheme license is a "free software" license. See the end of
+;;; this file for the tedious details. 
+
+;;; Exports:
+;;; char-set? char-set= char-set<=
+;;; char-set-hash 
+;;; char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
+;;; char-set-fold char-set-unfold char-set-unfold!
+;;; char-set-for-each char-set-map
+;;; char-set-copy char-set
+;;;
+;;; list->char-set  string->char-set 
+;;; list->char-set! string->char-set! 
+;;;
+;;; filterchar-set  ucs-range->char-set  ->char-set
+;;; filterchar-set! ucs-range->char-set!
+;;;
+;;; char-set->list char-set->string
+;;;
+;;; char-set-size char-set-count char-set-contains?
+;;; char-set-every char-set-any
+;;;
+;;; char-set-adjoin  char-set-delete 
+;;; char-set-adjoin! char-set-delete!
+;;; 
+
+;;; char-set-complement  char-set-union  char-set-intersection  
+;;; char-set-complement! char-set-union! char-set-intersection! 
+;;;
+;;; char-set-difference  char-set-xor  char-set-diff+intersection
+;;; char-set-difference! char-set-xor! char-set-diff+intersection!
+;;;
+;;; char-set:lower-case		char-set:upper-case	char-set:title-case
+;;; char-set:letter		char-set:digit		char-set:letter+digit
+;;; char-set:graphic		char-set:printing	char-set:whitespace
+;;; char-set:iso-control	char-set:punctuation	char-set:symbol
+;;; char-set:hex-digit		char-set:blank		char-set:ascii
+;;; char-set:empty		char-set:full
+
+;;; Imports
+;;; This code has the following non-R5RS dependencies:
+;;; - ERROR
+;;; - %LATIN1->CHAR %CHAR->LATIN1
+;;; - LET-OPTIONALS* and #\:OPTIONAL macros for parsing, checking & defaulting
+;;;   optional arguments from rest lists.
+;;; - BITWISE-AND for CHAR-SET-HASH
+;;; - The SRFI-19 DEFINE-RECORD-TYPE record macro
+;;; - A simple CHECK-ARG procedure: 
+;;;   (lambda (pred val caller) (if (not (pred val)) (error val caller)))
+
+;;; This is simple code, not great code. Char sets are represented as 256-char
+;;; strings. If char I is ASCII/Latin-1 0, then it isn't in the set; if char I
+;;; is ASCII/Latin-1 1, then it is in the set.
+;;; - Should be rewritten to use bit strings or byte vecs.
+;;; - Is Latin-1 specific. Would certainly have to be rewritten for Unicode.
+
+;;; See the end of the file for porting and performance-tuning notes.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type \:char-set
+  (make-char-set s)
+  char-set?
+  (s char-set:s))
+
+
+(define (%string-copy s) (substring s 0 (string-length s)))
+
+;;; Parse, type-check & default a final optional BASE-CS parameter from
+;;; a rest argument. Return a *fresh copy* of the underlying string.
+;;; The default is the empty set. The PROC argument is to help us
+;;; generate informative error exceptions.
+
+(define (%default-base maybe-base proc)
+  (if (pair? maybe-base)
+      (let ((bcs  (car maybe-base))
+	    (tail (cdr maybe-base)))
+	(if (null? tail)
+	    (if (char-set? bcs) (%string-copy (char-set:s bcs))
+		(error "BASE-CS parameter not a char-set" proc bcs))
+	    (error "Expected final base char set -- too many parameters"
+		   proc maybe-base)))
+      (make-string 256 (%latin1->char 0))))
+
+;;; If CS is really a char-set, do CHAR-SET:S, otw report an error msg on
+;;; behalf of our caller, PROC. This procedure exists basically to provide
+;;; explicit error-checking & reporting.
+
+(define (%char-set:s/check cs proc)
+  (let lp ((cs cs))
+    (if (char-set? cs) (char-set:s cs)
+	(lp (error "Not a char-set" cs proc)))))
+
+
+
+;;; These internal functions hide a lot of the dependency on the
+;;; underlying string representation of char sets. They should be
+;;; inlined if possible.
+
+(define (si=0? s i) (zero? (%char->latin1 (string-ref s i))))
+(define (si=1? s i) (not (si=0? s i)))
+(define c0 (%latin1->char 0))
+(define c1 (%latin1->char 1))
+(define (si s i) (%char->latin1 (string-ref s i)))
+(define (%set0! s i) (string-set! s i c0))
+(define (%set1! s i) (string-set! s i c1))
+
+;;; These do various "s[i] := s[i] op val" operations -- see 
+;;; %CHAR-SET-ALGEBRA. They are used to implement the various
+;;; set-algebra procedures.
+(define (setv!   s i v) (string-set! s i (%latin1->char v))) ; SET to a Value.
+(define (%not!   s i v) (setv! s i (- 1 v)))
+(define (%and!   s i v) (if (zero? v) (%set0! s i)))
+(define (%or!    s i v) (if (not (zero? v)) (%set1! s i)))
+(define (%minus! s i v) (if (not (zero? v)) (%set0! s i)))
+(define (%xor!   s i v) (if (not (zero? v)) (setv! s i (- 1 (si s i)))))
+
+
+(define (char-set-copy cs)
+  (make-char-set (%string-copy (%char-set:s/check cs char-set-copy))))
+
+(define (char-set= . rest)
+  (or (null? rest)
+      (let* ((cs1  (car rest))
+	     (rest (cdr rest))
+	     (s1 (%char-set:s/check cs1 char-set=)))
+	(let lp ((rest rest))
+	  (or (not (pair? rest))
+	      (and (string=? s1 (%char-set:s/check (car rest) char-set=))
+		   (lp (cdr rest))))))))
+
+(define (char-set<= . rest)
+  (or (null? rest)
+      (let ((cs1  (car rest))
+	    (rest (cdr rest)))
+	(let lp ((s1 (%char-set:s/check cs1 char-set<=))  (rest rest))
+	  (or (not (pair? rest))
+	      (let ((s2 (%char-set:s/check (car rest) char-set<=))
+		    (rest (cdr rest)))
+		(if (eq? s1 s2) (lp s2 rest)	; Fast path
+		    (let lp2 ((i 255))		; Real test
+		      (if (< i 0) (lp s2 rest)
+			  (and (<= (si s1 i) (si s2 i))
+			       (lp2 (- i 1))))))))))))
+
+;;; Hash
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
+;;; to keep the intermediate values small. (We do the calculation with just
+;;; enough bits to represent BOUND, masking off high bits at each step in
+;;; calculation. If this screws up any important properties of the hash
+;;; function I'd like to hear about it. -Olin)
+;;;
+;;; If you keep BOUND small enough, the intermediate calculations will 
+;;; always be fixnums. How small is dependent on the underlying Scheme system; 
+;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
+;;; Schemes that give you at least 29 signed bits for fixnums. The core 
+;;; calculation that you don't want to overflow is, worst case,
+;;;     (+ 65535 (* 37 (- bound 1)))
+;;; where 65535 is the max character code. Choose the default BOUND to be the
+;;; biggest power of two that won't cause this expression to fixnum overflow, 
+;;; and everything will be copacetic.
+
+(define (char-set-hash cs . maybe-bound)
+  (let* ((bound (#\:optional maybe-bound 4194304 (lambda (n) (and (integer? n)
+								(exact? n)
+								(<= 0 n)))))
+	 (bound (if (zero? bound) 4194304 bound))	; 0 means default.
+	 (s (%char-set:s/check cs char-set-hash))
+	 ;; Compute a 111...1 mask that will cover BOUND-1:
+	 (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
+		 (if (>= i bound) (- i 1) (lp (+ i i))))))
+
+      (let lp ((i 255) (ans 0))
+	(if (< i 0) (modulo ans bound)
+	    (lp (- i 1)
+		(if (si=0? s i) ans
+		    (bitwise-and mask (+ (* 37 ans) i))))))))
+
+
+(define (char-set-contains? cs char)
+  (si=1? (%char-set:s/check cs char-set-contains?)
+	 (%char->latin1 (check-arg char? char char-set-contains?))))
+
+(define (char-set-size cs)
+  (let ((s (%char-set:s/check cs char-set-size)))
+    (let lp ((i 255) (size 0))
+      (if (< i 0) size
+	  (lp (- i 1) (+ size (si s i)))))))
+
+(define (char-set-count pred cset)
+  (check-arg procedure? pred char-set-count)
+  (let ((s (%char-set:s/check cset char-set-count)))
+    (let lp ((i 255) (count 0))
+      (if (< i 0) count
+	  (lp (- i 1)
+	      (if (and (si=1? s i) (pred (%latin1->char i)))
+		  (+ count 1)
+		  count))))))
+
+
+;;; -- Adjoin & delete
+
+(define (%set-char-set set proc cs chars)
+  (let ((s (%string-copy (%char-set:s/check cs proc))))
+    (for-each (lambda (c) (set s (%char->latin1 c)))
+	      chars)
+    (make-char-set s)))
+
+(define (%set-char-set! set proc cs chars)
+  (let ((s (%char-set:s/check cs proc)))
+    (for-each (lambda (c) (set s (%char->latin1 c)))
+	      chars))
+  cs)
+
+(define (char-set-adjoin cs . chars)
+  (%set-char-set  %set1! char-set-adjoin cs chars))
+(define (char-set-adjoin! cs . chars)
+  (%set-char-set! %set1! char-set-adjoin! cs chars))
+(define (char-set-delete cs . chars)
+  (%set-char-set  %set0! char-set-delete cs chars))
+(define (char-set-delete! cs . chars)
+  (%set-char-set! %set0! char-set-delete! cs chars))
+
+
+;;; Cursors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Simple implementation. A cursors is an integer index into the
+;;; mark vector, and -1 for the end-of-char-set cursor.
+;;;
+;;; If we represented char sets as a bit set, we could do the following
+;;; trick to pick the lowest bit out of the set: 
+;;;   (count-bits (xor (- cset 1) cset))
+;;; (But first mask out the bits already scanned by the cursor first.)
+
+(define (char-set-cursor cset)
+  (%char-set-cursor-next cset 256 char-set-cursor))
+  
+(define (end-of-char-set? cursor) (< cursor 0))
+
+(define (char-set-ref cset cursor) (%latin1->char cursor))
+
+(define (char-set-cursor-next cset cursor)
+  (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i 255))) cursor
+	     char-set-cursor-next)
+  (%char-set-cursor-next cset cursor char-set-cursor-next))
+
+(define (%char-set-cursor-next cset cursor proc)	; Internal
+  (let ((s (%char-set:s/check cset proc)))
+    (let lp ((cur cursor))
+      (let ((cur (- cur 1)))
+	(if (or (< cur 0) (si=1? s cur)) cur
+	    (lp cur))))))
+
+
+;;; -- for-each map fold unfold every any
+
+(define (char-set-for-each proc cs)
+  (check-arg procedure? proc char-set-for-each)
+  (let ((s (%char-set:s/check cs char-set-for-each)))
+    (let lp ((i 255))
+      (cond ((>= i 0)
+	     (if (si=1? s i) (proc (%latin1->char i)))
+	     (lp (- i 1)))))))
+
+(define (char-set-map proc cs)
+  (check-arg procedure? proc char-set-map)
+  (let ((s (%char-set:s/check cs char-set-map))
+	(ans (make-string 256 c0)))
+    (let lp ((i 255))
+      (cond ((>= i 0)
+	     (if (si=1? s i)
+		 (%set1! ans (%char->latin1 (proc (%latin1->char i)))))
+	     (lp (- i 1)))))
+    (make-char-set ans)))
+
+(define (char-set-fold kons knil cs)
+  (check-arg procedure? kons char-set-fold)
+  (let ((s (%char-set:s/check cs char-set-fold)))
+    (let lp ((i 255) (ans knil))
+      (if (< i 0) ans
+	  (lp (- i 1)
+	      (if (si=0? s i) ans
+		  (kons (%latin1->char i) ans)))))))
+
+(define (char-set-every pred cs)
+  (check-arg procedure? pred char-set-every)
+  (let ((s (%char-set:s/check cs char-set-every)))
+    (let lp ((i 255))
+      (or (< i 0)
+	  (and (or (si=0? s i) (pred (%latin1->char i)))
+	       (lp (- i 1)))))))
+
+(define (char-set-any pred cs)
+  (check-arg procedure? pred char-set-any)
+  (let ((s (%char-set:s/check cs char-set-any)))
+    (let lp ((i 255))
+      (and (>= i 0)
+	   (or (and (si=1? s i) (pred (%latin1->char i)))
+	       (lp (- i 1)))))))
+
+
+(define (%char-set-unfold! proc p f g s seed)
+  (check-arg procedure? p proc)
+  (check-arg procedure? f proc)
+  (check-arg procedure? g proc)
+  (let lp ((seed seed))
+    (cond ((not (p seed))			; P says we are done.
+	   (%set1! s (%char->latin1 (f seed)))	; Add (F SEED) to set.
+	   (lp (g seed))))))			; Loop on (G SEED).
+
+(define (char-set-unfold p f g seed . maybe-base)
+  (let ((bs (%default-base maybe-base char-set-unfold)))
+    (%char-set-unfold! char-set-unfold p f g bs seed)
+    (make-char-set bs)))
+
+(define (char-set-unfold! p f g seed base-cset)
+  (%char-set-unfold! char-set-unfold! p f g
+		     (%char-set:s/check base-cset char-set-unfold!)
+		     seed)
+  base-cset)
+
+
+
+;;; list <--> char-set
+
+(define (%list->char-set! chars s)
+  (for-each (lambda (char) (%set1! s (%char->latin1 char)))
+	    chars))
+
+(define (char-set . chars)
+  (let ((s (make-string 256 c0)))
+    (%list->char-set! chars s)
+    (make-char-set s)))
+
+(define (list->char-set chars . maybe-base)
+  (let ((bs (%default-base maybe-base list->char-set)))
+    (%list->char-set! chars bs)
+    (make-char-set bs)))
+
+(define (list->char-set! chars base-cs)
+  (%list->char-set! chars (%char-set:s/check base-cs list->char-set!))
+  base-cs)
+
+
+(define (char-set->list cs)
+  (let ((s (%char-set:s/check cs char-set->list)))
+    (let lp ((i 255) (ans '()))
+      (if (< i 0) ans
+	  (lp (- i 1)
+	      (if (si=0? s i) ans
+		  (cons (%latin1->char i) ans)))))))
+
+
+
+;;; string <--> char-set
+
+(define (%string->char-set! str bs proc)
+  (check-arg string? str proc)
+  (do ((i (- (string-length str) 1) (- i 1)))
+      ((< i 0))
+    (%set1! bs (%char->latin1 (string-ref str i)))))
+
+(define (string->char-set str . maybe-base)
+  (let ((bs (%default-base maybe-base string->char-set)))
+    (%string->char-set! str bs string->char-set)
+    (make-char-set bs)))
+
+(define (string->char-set! str base-cs)
+  (%string->char-set! str (%char-set:s/check base-cs string->char-set!)
+		      string->char-set!)
+  base-cs)
+
+
+(define (char-set->string cs)
+  (let* ((s (%char-set:s/check cs char-set->string))
+	 (ans (make-string (char-set-size cs))))
+    (let lp ((i 255) (j 0))
+      (if (< i 0) ans
+	  (let ((j (if (si=0? s i) j
+		       (begin (string-set! ans j (%latin1->char i))
+			      (+ j 1)))))
+	    (lp (- i 1) j))))))
+
+
+;;; -- UCS-range -> char-set
+
+(define (%ucs-range->char-set! lower upper error? bs proc)
+  (check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) lower proc)
+  (check-arg (lambda (x) (and (integer? x) (exact? x) (<= lower x))) upper proc)
+
+  (if (and (< lower upper) (< 256 upper) error?)
+      (error "Requested UCS range contains unavailable characters -- this implementation only supports Latin-1"
+	     proc lower upper))
+
+  (let lp ((i (- (min upper 256) 1)))
+    (cond ((<= lower i) (%set1! bs i) (lp (- i 1))))))
+
+(define (ucs-range->char-set lower upper . rest)
+  (let-optionals* rest ((error? #f) rest)
+    (let ((bs (%default-base rest ucs-range->char-set)))
+      (%ucs-range->char-set! lower upper error? bs ucs-range->char-set)
+      (make-char-set bs))))
+
+(define (ucs-range->char-set! lower upper error? base-cs)
+  (%ucs-range->char-set! lower upper error?
+			 (%char-set:s/check base-cs ucs-range->char-set!)
+			 ucs-range->char-set)
+  base-cs)
+
+
+;;; -- predicate -> char-set
+
+(define (%char-set-filter! pred ds bs proc)
+  (check-arg procedure? pred proc)
+  (let lp ((i 255))
+    (cond ((>= i 0)
+	   (if (and (si=1? ds i) (pred (%latin1->char i)))
+	       (%set1! bs i))
+	   (lp (- i 1))))))
+
+(define (char-set-filter predicate domain . maybe-base)
+  (let ((bs (%default-base maybe-base char-set-filter)))
+    (%char-set-filter! predicate
+		       (%char-set:s/check domain char-set-filter!)
+		       bs
+		       char-set-filter)
+    (make-char-set bs)))
+
+(define (char-set-filter! predicate domain base-cs)
+  (%char-set-filter! predicate
+		     (%char-set:s/check domain char-set-filter!)
+		     (%char-set:s/check base-cs char-set-filter!)
+		     char-set-filter!)
+  base-cs)
+
+
+;;; {string, char, char-set, char predicate} -> char-set
+
+(define (->char-set x)
+  (cond ((char-set? x) x)
+	((string? x) (string->char-set x))
+	((char? x) (char-set x))
+	(else (error "->char-set: Not a charset, string or char." x))))
+
+
+
+;;; Set algebra
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The exported ! procs are "linear update" -- allowed, but not required, to
+;;; side-effect their first argument when computing their result. In other
+;;; words, you must use them as if they were completely functional, just like
+;;; their non-! counterparts, and you must additionally ensure that their
+;;; first arguments are "dead" at the point of call. In return, we promise a
+;;; more efficient result, plus allowing you to always assume char-sets are
+;;; unchangeable values.
+
+;;; Apply P to each index and its char code in S: (P I VAL).
+;;; Used by the set-algebra ops.
+
+(define (%string-iter p s)
+  (let lp ((i (- (string-length s) 1)))
+    (cond ((>= i 0)
+	   (p i (%char->latin1 (string-ref s i)))
+	   (lp (- i 1))))))
+
+;;; String S represents some initial char-set. (OP s i val) does some
+;;; kind of s[i] := s[i] op val update. Do
+;;;     S := S OP CSETi
+;;; for all the char-sets in the list CSETS. The n-ary set-algebra ops
+;;; all use this internal proc.
+
+(define (%char-set-algebra s csets op proc)
+  (for-each (lambda (cset)
+	      (let ((s2 (%char-set:s/check cset proc)))
+		(let lp ((i 255))
+		  (cond ((>= i 0)
+			 (op s i (si s2 i))
+			 (lp (- i 1)))))))
+	    csets))
+
+
+;;; -- Complement
+
+(define (char-set-complement cs)
+  (let ((s (%char-set:s/check cs char-set-complement))
+	(ans (make-string 256)))
+    (%string-iter (lambda (i v) (%not! ans i v)) s)
+    (make-char-set ans)))
+
+(define (char-set-complement! cset)
+  (let ((s (%char-set:s/check cset char-set-complement!)))
+    (%string-iter (lambda (i v) (%not! s i v)) s))
+  cset)
+
+
+;;; -- Union
+
+(define (char-set-union! cset1 . csets)
+  (%char-set-algebra (%char-set:s/check cset1 char-set-union!)
+		     csets %or! char-set-union!)
+  cset1)
+
+(define (char-set-union . csets)
+  (if (pair? csets)
+      (let ((s (%string-copy (%char-set:s/check (car csets) char-set-union))))
+	(%char-set-algebra s (cdr csets) %or! char-set-union)
+	(make-char-set s))
+      (char-set-copy char-set:empty)))
+
+
+;;; -- Intersection
+
+(define (char-set-intersection! cset1 . csets)
+  (%char-set-algebra (%char-set:s/check cset1 char-set-intersection!)
+		     csets %and! char-set-intersection!)
+  cset1)
+
+(define (char-set-intersection . csets)
+  (if (pair? csets)
+      (let ((s (%string-copy (%char-set:s/check (car csets) char-set-intersection))))
+	(%char-set-algebra s (cdr csets) %and! char-set-intersection)
+	(make-char-set s))
+      (char-set-copy char-set:full)))
+
+
+;;; -- Difference
+
+(define (char-set-difference! cset1 . csets)
+  (%char-set-algebra (%char-set:s/check cset1 char-set-difference!)
+		     csets %minus! char-set-difference!)
+  cset1)
+
+(define (char-set-difference cs1 . csets)
+  (if (pair? csets)
+      (let ((s (%string-copy (%char-set:s/check cs1 char-set-difference))))
+	(%char-set-algebra s csets %minus! char-set-difference)
+	(make-char-set s))
+      (char-set-copy cs1)))
+
+
+;;; -- Xor
+
+(define (char-set-xor! cset1 . csets)
+  (%char-set-algebra (%char-set:s/check cset1 char-set-xor!)
+		      csets %xor! char-set-xor!)
+  cset1)
+
+(define (char-set-xor . csets)
+  (if (pair? csets)
+      (let ((s (%string-copy (%char-set:s/check (car csets) char-set-xor))))
+	(%char-set-algebra s (cdr csets) %xor! char-set-xor)
+	(make-char-set s))
+      (char-set-copy char-set:empty)))
+
+
+;;; -- Difference & intersection
+
+(define (%char-set-diff+intersection! diff int csets proc)
+  (for-each (lambda (cs)
+	      (%string-iter (lambda (i v)
+			      (if (not (zero? v))
+				  (cond ((si=1? diff i)
+					 (%set0! diff i)
+					 (%set1! int  i)))))
+			    (%char-set:s/check cs proc)))
+	    csets))
+
+(define (char-set-diff+intersection! cs1 cs2 . csets)
+  (let ((s1 (%char-set:s/check cs1 char-set-diff+intersection!))
+	(s2 (%char-set:s/check cs2 char-set-diff+intersection!)))
+    (%string-iter (lambda (i v) (if (zero? v)
+				    (%set0! s2 i)
+				    (if (si=1? s2 i) (%set0! s1 i))))
+		  s1)
+    (%char-set-diff+intersection! s1 s2 csets char-set-diff+intersection!))
+  (values cs1 cs2))
+
+(define (char-set-diff+intersection cs1 . csets)
+  (let ((diff (string-copy (%char-set:s/check cs1 char-set-diff+intersection)))
+	(int  (make-string 256 c0)))
+    (%char-set-diff+intersection! diff int csets char-set-diff+intersection)
+    (values (make-char-set diff) (make-char-set int))))
+
+
+;;;; System character sets
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These definitions are for Latin-1.
+;;;
+;;; If your Scheme implementation allows you to mark the underlying strings
+;;; as immutable, you should do so -- it would be very, very bad if a client's
+;;; buggy code corrupted these constants.
+
+(define char-set:empty (char-set))
+(define char-set:full (char-set-complement char-set:empty))
+
+(define char-set:lower-case
+  (let* ((a-z (ucs-range->char-set #x61 #x7B))
+	 (latin1 (ucs-range->char-set! #xdf #xf7  #t a-z))
+	 (latin2 (ucs-range->char-set! #xf8 #x100 #t latin1)))
+    (char-set-adjoin! latin2 (%latin1->char #xb5))))
+
+(define char-set:upper-case
+  (let ((A-Z (ucs-range->char-set #x41 #x5B)))
+    ;; Add in the Latin-1 upper-case chars.
+    (ucs-range->char-set! #xd8 #xdf #t
+			  (ucs-range->char-set! #xc0 #xd7 #t A-Z))))
+
+(define char-set:title-case char-set:empty)
+
+(define char-set:letter
+  (let ((u/l (char-set-union char-set:upper-case char-set:lower-case)))
+    (char-set-adjoin! u/l
+		      (%latin1->char #xaa)	; FEMININE ORDINAL INDICATOR
+		      (%latin1->char #xba))))	; MASCULINE ORDINAL INDICATOR
+
+(define char-set:digit     (string->char-set "0123456789"))
+(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
+
+(define char-set:letter+digit
+  (char-set-union char-set:letter char-set:digit))
+
+(define char-set:punctuation
+  (let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
+	(latin-1-chars (map %latin1->char '(#xA1 ; INVERTED EXCLAMATION MARK
+					    #xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+					    #xAD ; SOFT HYPHEN
+					    #xB7 ; MIDDLE DOT
+					    #xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+					    #xBF)))) ; INVERTED QUESTION MARK
+    (list->char-set! latin-1-chars ascii)))
+
+(define char-set:symbol
+  (let ((ascii (string->char-set "$+<=>^`|~"))
+	(latin-1-chars (map %latin1->char '(#x00A2 ; CENT SIGN
+					    #x00A3 ; POUND SIGN
+					    #x00A4 ; CURRENCY SIGN
+					    #x00A5 ; YEN SIGN
+					    #x00A6 ; BROKEN BAR
+					    #x00A7 ; SECTION SIGN
+					    #x00A8 ; DIAERESIS
+					    #x00A9 ; COPYRIGHT SIGN
+					    #x00AC ; NOT SIGN
+					    #x00AE ; REGISTERED SIGN
+					    #x00AF ; MACRON
+					    #x00B0 ; DEGREE SIGN
+					    #x00B1 ; PLUS-MINUS SIGN
+					    #x00B4 ; ACUTE ACCENT
+					    #x00B6 ; PILCROW SIGN
+					    #x00B8 ; CEDILLA
+					    #x00D7 ; MULTIPLICATION SIGN
+					    #x00F7)))) ; DIVISION SIGN
+    (list->char-set! latin-1-chars ascii)))
+  
+
+(define char-set:graphic
+  (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
+
+(define char-set:whitespace
+  (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
+				       #x0A ; LINE FEED		
+				       #x0B ; VERTICAL TABULATION
+				       #x0C ; FORM FEED
+				       #x0D ; CARRIAGE RETURN
+				       #x20 ; SPACE
+				       #xA0))))
+
+(define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) ; NO-BREAK SPACE
+
+(define char-set:blank
+  (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
+				       #x20 ; SPACE
+				       #xA0)))) ; NO-BREAK SPACE
+
+
+(define char-set:iso-control
+  (ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32)))
+
+(define char-set:ascii (ucs-range->char-set 0 128))
+
+
+;;; Porting & performance-tuning notes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See the section at the beginning of this file on external dependencies.
+;;;
+;;; First and foremost, rewrite this code to use bit vectors of some sort.
+;;; This will give big speedup and memory savings.
+;;;
+;;; - LET-OPTIONALS* macro.
+;;; This is only used once. You can rewrite the use, port the hairy macro
+;;; definition (which is implemented using a Clinger-Rees low-level
+;;; explicit-renaming macro system), or port the simple, high-level
+;;; definition, which is less efficient.
+;;;
+;;; - #\:OPTIONAL macro
+;;; Very simply defined using an R5RS high-level macro.
+;;;
+;;; Implementations that can arrange for the base char sets to be immutable
+;;; should do so. (E.g., Scheme 48 allows one to mark a string as immutable,
+;;; which can be used to protect the underlying strings.) It would be very,
+;;; very bad if a client's buggy code corrupted these constants.
+;;;
+;;; There is a fair amount of argument checking. This is, strictly speaking,
+;;; unnecessary -- the actual body of the procedures will blow up if an
+;;; illegal value is passed in. However, the error message will not be as good
+;;; as if the error were caught at the "higher level." Also, a very, very
+;;; smart Scheme compiler may be able to exploit having the type checks done
+;;; early, so that the actual body of the procedures can assume proper values.
+;;; This isn't likely; this kind of compiler technology isn't common any
+;;; longer.
+;;; 
+;;; The overhead of optional-argument parsing is irritating. The optional
+;;; arguments must be consed into a rest list on entry, and then parsed out.
+;;; Function call should be a matter of a few register moves and a jump; it
+;;; should not involve heap allocation! Your Scheme system may have a superior
+;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
+;;; then this is a prime candidate for optimising these procedures,
+;;; *especially* the many optional BASE-CS parameters.
+;;;
+;;; Note that optional arguments are also a barrier to procedure integration.
+;;; If your Scheme system permits you to specify alternate entry points
+;;; for a call when the number of optional arguments is known in a manner
+;;; that enables inlining/integration, this can provide performance 
+;;; improvements.
+;;;
+;;; There is enough *explicit* error checking that *all* internal operations
+;;; should *never* produce a type or index-range error. Period. Feel like
+;;; living dangerously? *Big* performance win to be had by replacing string
+;;; and record-field accessors and setters with unsafe equivalents in the
+;;; code. Similarly, fixnum-specific operators can speed up the arithmetic
+;;; done on the index values in the inner loops. The only arguments that are
+;;; not completely error checked are
+;;;   - string lists (complete checking requires time proportional to the
+;;;     length of the list)
+;;;   - procedure arguments, such as char->char maps & predicates.
+;;;     There is no way to check the range & domain of procedures in Scheme.
+;;; Procedures that take these parameters cannot fully check their
+;;; arguments. But all other types to all other procedures are fully
+;;; checked.
+;;;
+;;; This does open up the alternate possibility of simply *removing* these 
+;;; checks, and letting the safe primitives raise the errors. On a dumb
+;;; Scheme system, this would provide speed (by eliminating the redundant
+;;; error checks) at the cost of error-message clarity.
+;;;
+;;; In an interpreted Scheme, some of these procedures, or the internal
+;;; routines with % prefixes, are excellent candidates for being rewritten
+;;; in C.
+;;;
+;;; It would also be nice to have the ability to mark some of these
+;;; routines as candidates for inlining/integration.
+;;; 
+;;; See the comments preceding the hash function code for notes on tuning
+;;; the default bound so that the code never overflows your implementation's
+;;; fixnum size into bignum calculation.
+;;;
+;;; All the %-prefixed routines in this source code are written
+;;; to be called internally to this library. They do *not* perform
+;;; friendly error checks on the inputs; they assume everything is
+;;; proper. They also do not take optional arguments. These two properties
+;;; save calling overhead and enable procedure integration -- but they
+;;; are not appropriate for exported routines.
+
+;;; Copyright notice
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
+;;; 
+;;; This material was developed by the Scheme project at the Massachusetts
+;;; Institute of Technology, Department of Electrical Engineering and
+;;; Computer Science.  Permission to copy and modify this software, to
+;;; redistribute either the original software or a modified version, and
+;;; to use this software for any purpose is granted, subject to the
+;;; following restrictions and understandings.
+;;; 
+;;; 1. Any copy made of this software must include this copyright notice
+;;; in full.
+;;; 
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions that
+;;; they make, so that these may be included in future releases; and (b)
+;;; to inform MIT of noteworthy uses of this software.
+;;; 
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the usual
+;;; standards of acknowledging credit in academic research.
+;;; 
+;;; 4. MIT has made no warrantee or representation that the operation of
+;;; this software will be error-free, and MIT is under no obligation to
+;;; provide any services, by way of maintenance, update, or otherwise.
+;;; 
+;;; 5. In conjunction with products arising from the use of this material,
+;;; there shall be no use of the name of the Massachusetts Institute of
+;;; Technology nor of any adaptation thereof in any advertising,
+;;; promotional, or sales literature without prior written consent from
+;;; MIT in each case.
+(define-library (srfi test)             ; -*- scheme -*-
+  (import (except (scheme base) cond)
+          (scheme write)
+          (srfi 61))
+  (begin
+    (display (cond
+              ((values 0 1) (lambda (x y) #t)
+               => list)))
+    (newline)))
+(use-modules (srfi srfi-11))
+
+(define (assert bool explanation)
+  (unless bool
+    (error explanation)))
+
+(define (id= x y)
+  (and (identifier? x)
+       (identifier? y)
+       (free-identifier=? x y)))
+
+(define-syntax uq
+  (syntax-rules ()
+    ((uq . x) (syntax-error "Unquote used outside quasiquote."))))
+
+(define-syntax uq-s
+  (syntax-rules ()
+    ((uq-s . x) (syntax-error "Unquote-splicing used outside quasiquote."))))
+
+(define-syntax qq
+  (lambda (stx)
+    (define (handle-node node level splicable?)
+      (if (zero? level)
+          (values 'one node)
+          (let ((node (syntax->datum node)))
+            (if (pair? node)
+                (handle-pair node level splicable?)
+                (handle-atom node level)))))
+    (define (handle-pair pair level splicable?)
+      (let ((car (datum->syntax stx (car pair)))
+            (cdr (datum->syntax stx (cdr pair))))
+        (cond
+         ((id= car #'qq)
+          (handle-qq pair level))
+         ((id= car #'uq)
+          (handle-uq pair level))
+         ((and splicable? (id= car #'uq-s))
+          (handle-uq-s pair level))
+         (else
+          (let-values (((type car) (handle-node car level #t))
+                       ((_    cdr) (handle-node cdr level #f)))
+            (case type
+              ((one)
+               (values 'one #`(cons #,car #,cdr)))
+              ((many)
+               (values 'one #`(append #,car #,cdr)))))))))
+    (define (handle-qq qq-form level)
+      (assert (and (list? qq-form) (= 2 (length qq-form)))
+              "Quasiquote expects exactly one operand.")
+      (let ((operand (datum->syntax stx (cadr qq-form))))
+        (let-values (((_ val) (handle-node operand (+ level 1) #f)))
+          (values 'one #`(list 'qq #,val)))))
+    (define (handle-uq uq-form level)
+      (assert (and (list? uq-form) (= 2 (length uq-form)))
+              "Unquote expects exactly one operand.")
+      (let ((operand (datum->syntax stx (cadr uq-form))))
+        (let-values (((type val) (handle-node operand (- level 1) #t)))
+          (if (= level 1)
+              (values type val)
+              (case type
+                ((one)
+                 (values 'one #`(list 'uq #,val)))
+                ((many)
+                 (values 'one #`(apply list 'uq #,val))))))))
+    (define (handle-uq-s uq-s-form level)
+      (assert (and (list? uq-s-form) (= 2 (length uq-s-form)))
+              "Unquote-splicing expects exactly one operand.")
+      (let ((operand (datum->syntax stx (cadr uq-s-form))))
+        (let-values (((type val) (handle-node operand (- level 1) #t)))
+         (if (= 1 level)
+             (values 'many val)
+             (values 'one #`(list 'uq-s #,val))))))
+    (define (handle-atom atom level)
+      (let ((atom (datum->syntax stx atom)))
+        (values 'one #`(quote #,atom))))
+    (syntax-case stx ()
+      ((qq operand)
+       (let-values (((_ val) (handle-node #'operand 1 #f)))
+         val))
+      ((qq . x)
+       (error "Quasiquote expects exactly one operand.")))))
+;;;; benchmark-suite/lib.scm --- generic support for benchmarking
+;;;; Copyright (C) 2002, 2006, 2011, 2012 Free Software Foundation, Inc.
+;;;;
+;;;; This program 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, or (at your option) any later version.
+;;;;
+;;;; This program 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 software; see the file COPYING.LESSER.
+;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
+;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmark-suite lib)
+  #\use-module (srfi srfi-9)
+  #\export (;; Controlling the execution.
+            iteration-factor
+            scale-iterations
+
+            ;; Running benchmarks.
+            run-benchmark
+            benchmark
+
+            ;; Naming groups of benchmarks in a regular fashion.
+            with-benchmark-prefix with-benchmark-prefix*
+            current-benchmark-prefix format-benchmark-name
+
+            ;; <benchmark-result> accessors
+            benchmark-result:name
+            benchmark-result:iterations
+            benchmark-result:real-time
+            benchmark-result:run-time
+            benchmark-result:gc-time
+            benchmark-result:core-time
+
+            ;; Reporting results in various ways.
+            report current-reporter
+            register-reporter unregister-reporter reporter-registered?
+            make-log-reporter
+            full-reporter
+            user-reporter))
+
+
+;;;; If you're using Emacs's Scheme mode:
+;;;;   (put 'with-benchmark-prefix 'scheme-indent-function 1)
+;;;;   (put 'benchmark 'scheme-indent-function 1)
+
+
+;;;; CORE FUNCTIONS
+;;;;
+;;;; The function (run-benchmark name iterations thunk) is the heart of the
+;;;; benchmarking environment.  The first parameter NAME is a unique name for
+;;;; the benchmark to be executed (for an explanation of this parameter see
+;;;; below under ;;;; NAMES.  The second parameter ITERATIONS is a positive
+;;;; integer value that indicates how often the thunk shall be executed (for
+;;;; an explanation of how iteration counts should be used, see below under
+;;;; ;;;; ITERATION COUNTS).  For example:
+;;;;
+;;;;    (run-benchmark "small integer addition" 100000 (lambda () (+ 1 1)))
+;;;;
+;;;; This will run the function (lambda () (+ 1 1)) a 100000 times (the
+;;;; iteration count can, however be scaled.  See below for details).  Some
+;;;; different time data for running the thunk for the given number of
+;;;; iterations is measured and reported.
+;;;;
+;;;; Convenience macro
+;;;;
+;;;; * (benchmark name iterations body) is a short form for
+;;;;   (run-benchmark name iterations (lambda () body))
+
+
+;;;; NAMES
+;;;;
+;;;; Every benchmark in the benchmark suite has a unique name to be able to
+;;;; compare the results of individual benchmarks across several runs of the
+;;;; benchmark suite.
+;;;;
+;;;; A benchmark name is a list of printable objects.  For example:
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Benchmark names may contain arbitrary objects, but they always have
+;;;; the following properties:
+;;;; - Benchmark names can be compared with EQUAL?.
+;;;; - Benchmark names can be reliably stored and retrieved with the standard
+;;;;   WRITE and READ procedures; doing so preserves their identity.
+;;;;
+;;;; For example:
+;;;;
+;;;;    (benchmark "simple addition" 100000 (+ 2 2))
+;;;;
+;;;; In that case, the benchmark name is the list ("simple addition").
+;;;;
+;;;; The WITH-BENCHMARK-PREFIX syntax and WITH-BENCHMARK-PREFIX* procedure
+;;;; establish a prefix for the names of all benchmarks whose results are
+;;;; reported within their dynamic scope.  For example:
+;;;;
+;;;; (begin
+;;;;   (with-benchmark-prefix "basic arithmetic"
+;;;;     (benchmark "addition" 100000 (+ 2 2))
+;;;;     (benchmark "subtraction" 100000 (- 4 2)))
+;;;;   (benchmark "multiplication" 100000 (* 2 2))))
+;;;;
+;;;; In that example, the three benchmark names are:
+;;;;   ("basic arithmetic" "addition"),
+;;;;   ("basic arithmetic" "subtraction"), and
+;;;;   ("multiplication").
+;;;;
+;;;; WITH-BENCHMARK-PREFIX can be nested.  Each WITH-BENCHMARK-PREFIX
+;;;; appends a new element to the current prefix:
+;;;;
+;;;; (with-benchmark-prefix "arithmetic"
+;;;;   (with-benchmark-prefix "addition"
+;;;;     (benchmark "integer" 100000 (+ 2 2))
+;;;;     (benchmark "complex" 100000 (+ 2+3i 4+5i)))
+;;;;   (with-benchmark-prefix "subtraction"
+;;;;     (benchmark "integer" 100000 (- 2 2))
+;;;;     (benchmark "complex" 100000 (- 2+3i 1+2i))))
+;;;;
+;;;; The four benchmark names here are:
+;;;;   ("arithmetic" "addition" "integer")
+;;;;   ("arithmetic" "addition" "complex")
+;;;;   ("arithmetic" "subtraction" "integer")
+;;;;   ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by ": ".  So, the last set of benchmark names would be
+;;;; reported as:
+;;;;
+;;;;   arithmetic: addition: integer
+;;;;   arithmetic: addition: complex
+;;;;   arithmetic: subtraction: integer
+;;;;   arithmetic: subtraction: complex
+;;;;
+;;;; The Guile benchmarks use with-benchmark-prefix to include the name of
+;;;; the source file containing the benchmark in the benchmark name, to
+;;;; provide each file with its own namespace.
+
+
+;;;; ITERATION COUNTS
+;;;;
+;;;; Every benchmark has to be given an iteration count that indicates how
+;;;; often it should be executed.  The reason is, that in most cases a single
+;;;; execution of the benchmark code would not deliver usable timing results:
+;;;; The resolution of the system time is not arbitrarily fine.  Thus, some
+;;;; benchmarks would be executed too quickly to be measured at all.  A rule
+;;;; of thumb is, that the longer a benchmark runs, the more exact is the
+;;;; information about the execution time.
+;;;;
+;;;; However, execution time depends on several influences:  First, the
+;;;; machine you are running the benchmark on.  Second, the compiler you use.
+;;;; Third, which compiler options you use.  Fourth, which version of guile
+;;;; you are using.  Fifth, which guile options you are using (for example if
+;;;; you are using the debugging evaluator or not).  There are even more
+;;;; influences.
+;;;;
+;;;; For this reason, the same number of iterations for a single benchmark may
+;;;; lead to completely different execution times in different
+;;;; constellations.  For someone working on a slow machine, the default
+;;;; execution counts may lead to an inacceptable execution time of the
+;;;; benchmark suite.  For someone on a very fast machine, however, it may be
+;;;; desireable to increase the number of iterations in order to increase the
+;;;; accuracy of the time data.
+;;;;
+;;;; For this reason, the benchmark suite allows to scale the number of
+;;;; executions by a global factor, stored in the exported variable
+;;;; iteration-factor.  The default for iteration-factor is 1.  A number of 2
+;;;; means, that all benchmarks are executed twice as often, which will also
+;;;; roughly double the execution time for the benchmark suite.  Similarly, if
+;;;; iteration-factor holds a value of 0.5, only about half the execution time
+;;;; will be required.
+;;;;
+;;;; It is probably a good idea to choose the iteration count for each
+;;;; benchmark such that all benchmarks will take about the same time, for
+;;;; example one second.  To achieve this, the benchmark suite holds an empty
+;;;; benchmark in the file 0-reference.bm named "reference benchmark for
+;;;; iteration counts".  It's iteration count is calibrated to make the
+;;;; benchmark run about one second on Dirk's laptop :-)  If you are adding
+;;;; benchmarks to the suite, it would be nice if you could calibrate the
+;;;; number of iterations such that each of your added benchmarks takes about
+;;;; as long to run as the reference benchmark.  But:  Don't be too accurate
+;;;; to figure out the correct iteration count.
+
+
+;;;; REPORTERS
+;;;;
+;;;; A reporter is a function which we apply to each benchmark outcome.
+;;;; Reporters can log results, print interesting results to the standard
+;;;; output, collect statistics, etc.
+;;;;
+;;;; A reporter function takes the following arguments:  NAME ITERATIONS
+;;;; BEFORE AFTER GC-TIME.  The argument NAME holds the name of the benchmark,
+;;;; ITERATIONS holds the actual number of iterations that were performed.
+;;;; BEFORE holds the result of the function (times) at the very beginning of
+;;;; the excution of the benchmark, AFTER holds the result of the function
+;;;; (times) after the execution of the benchmark.  GC-TIME, finally, holds
+;;;; the difference of calls to (gc-run-time) before and after the execution
+;;;; of the benchmark.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, (FIXME: and
+;;;; collecting totals).
+;;;;
+;;;; You can use the REGISTER-REPORTER function and friends to add whatever
+;;;; reporting functions you like.  See under ;;;; TIMING DATA to see how the
+;;;; library helps you to extract relevant timing information from the values
+;;;; ITERATIONS, BEFORE, AFTER and GC-TIME.  If you don't register any
+;;;; reporters, the library uses USER-REPORTER, which writes the most
+;;;; interesting results to the standard output.
+
+
+;;;; TIME CALCULATION
+;;;;
+;;;; The library uses the guile functions `get-internal-run-time',
+;;;; `get-internal-real-time', and `gc-run-time' to determine the
+;;;; execution time for a single benchmark.  Based on these functions,
+;;;; Guile makes a <benchmark-result>, a record containing the elapsed
+;;;; run time, real time, gc time, and possibly other metrics.  These
+;;;; times include the time needed to executed the benchmark code
+;;;; itself, but also the surrounding code that implements the loop to
+;;;; run the benchmark code for the given number of times.  This is
+;;;; undesirable, since one would prefer to only get the timing data for
+;;;; the benchmarking code.
+;;;;
+;;;; To cope with this, the benchmarking framework uses a trick:  During
+;;;; initialization of the library, the time for executing an empty
+;;;; benchmark is measured and stored.  This is an estimate for the time
+;;;; needed by the benchmarking framework itself.  For later benchmarks,
+;;;; this time can then be subtracted from the measured execution times.
+;;;; Note that for very short benchmarks, this may result in a negative
+;;;; number.
+;;;;
+;;;; The benchmarking framework provides the following accessors for
+;;;; <benchmark-result> values.  Note that all time values are in
+;;;; internal time units; divide by internal-time-units-per-second to
+;;;; get seconds.
+;;;;
+;;;; benchmark-result:name : Return the name of the benchmark.
+;;;;
+;;;; benchmark-result:iterations : Return the number of iterations that
+;;;;     this benchmark ran for.
+;;;;
+;;;; benchmark-result:real-time : Return the clock time elapsed while
+;;;;     this benchmark executed.
+;;;;
+;;;; benchmark-result:run-time : Return the CPU time elapsed while this
+;;;;     benchmark executed, both in user and kernel space.
+;;;;
+;;;; benchmark-result:gc-time : Return the approximate amount of time
+;;;;     spent in garbage collection while this benchmark executed, both
+;;;;     in user and kernel space.
+;;;;
+;;;; benchmark-result:core-time : Like benchmark-result:run-time, but
+;;;;     also estimates the time spent by the framework for the number
+;;;;     of iterations, and subtracts off that time from the result.
+;;;;
+
+;;;; This module is used when benchmarking different Guiles, and so it
+;;;; should run on all the Guiles of interest.  Currently this set
+;;;; includes Guile 1.8, so be careful with introducing features that
+;;;; only Guile 2.0 supports.
+
+
+;;;; MISCELLANEOUS
+;;;;
+
+(define-record-type <benchmark-result>
+  (make-benchmark-result name iterations real-time run-time gc-time)
+  benchmark-result?
+  (name benchmark-result:name)
+  (iterations benchmark-result:iterations)
+  (real-time benchmark-result:real-time)
+  (run-time benchmark-result:run-time)
+  (gc-time benchmark-result:gc-time))
+
+;;; Perform a division and convert the result to inexact.
+(define (->seconds time)
+  (/ time 1.0 internal-time-units-per-second))
+
+;;; Scale the number of iterations according to the given scaling factor.
+(define iteration-factor 1)
+(define (scale-iterations iterations)
+  (let* ((i (inexact->exact (round (* iterations iteration-factor)))))
+    (if (< i 1) 1 i)))
+
+;;; Parameters.
+(cond-expand
+ (srfi-39 #t)
+ (else (use-modules (srfi srfi-39))))
+
+;;;; CORE FUNCTIONS
+;;;;
+
+;;; The central routine for executing benchmarks.
+;;; The idea is taken from Greg, the GNUstep regression test environment.
+(define benchmark-running? (make-parameter #f))
+(define (run-benchmark name iterations thunk)
+  (if (benchmark-running?)
+      (error "Nested calls to run-benchmark are not permitted."))
+  (if (not (and (integer? iterations) (exact? iterations)))
+      (error "Expected exact integral number of iterations"))
+  (parameterize ((benchmark-running? #t))
+    ;; Warm up the benchmark first.  This will resolve any toplevel-ref
+    ;; forms.
+    (thunk)
+    (gc)
+    (let* ((before-gc-time (gc-run-time))
+           (before-real-time (get-internal-real-time))
+           (before-run-time (get-internal-run-time)))
+      (do ((i iterations (1- i)))
+          ((zero? i))
+        (thunk))
+      (let ((after-run-time (get-internal-run-time))
+            (after-real-time (get-internal-real-time))
+            (after-gc-time (gc-run-time)))
+        (report (make-benchmark-result (full-name name) iterations
+                                       (- after-real-time before-real-time)
+                                       (- after-run-time before-run-time)
+                                       (- after-gc-time before-gc-time)))))))
+
+;;; A short form for benchmarks.
+(cond-expand
+ (guile-2
+  (define-syntax-rule (benchmark name iterations body body* ...)
+    (run-benchmark name iterations (lambda () body body* ...))))
+ (else
+  (defmacro benchmark (name iterations body . rest)
+    `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))))
+
+
+;;;; BENCHMARK NAMES
+;;;;
+
+;;;; Turn a benchmark name into a nice human-readable string.
+(define (format-benchmark-name name)
+  (string-join name ": "))
+
+;;;; For a given benchmark-name, deliver the full name including all prefixes.
+(define (full-name name)
+  (append (current-benchmark-prefix) (list name)))
+
+;;; A parameter containing the current benchmark prefix, as a list.
+(define current-benchmark-prefix
+  (make-parameter '()))
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-benchmark-prefix*.  Return the value returned by THUNK.
+(define (with-benchmark-prefix* prefix thunk)
+  (parameterize ((current-benchmark-prefix (full-name prefix)))
+    (thunk)))
+
+;;; (with-benchmark-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-benchmark-prefix expression.  Return the value returned by the last
+;;; BODY expression.
+(cond-expand
+ (guile-2
+  (define-syntax-rule (with-benchmark-prefix prefix body body* ...)
+    (with-benchmark-prefix* prefix (lambda () body body* ...))))
+ (else
+  (defmacro with-benchmark-prefix (prefix . body)
+    `(with-benchmark-prefix* ,prefix (lambda () ,@body)))))
+
+
+;;;; Benchmark results
+;;;;
+
+(define *calibration-result*
+  "<will be set during initialization>")
+
+(define (benchmark-overhead iterations accessor)
+  (* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*))
+     (accessor *calibration-result*)))
+
+(define (benchmark-result:core-time result)
+  (- (benchmark-result:run-time result)
+     (benchmark-overhead (benchmark-result:iterations result)
+                         benchmark-result:run-time)))
+
+
+;;;; REPORTERS
+;;;;
+
+;;; The global set of reporters.
+(define report-hook (make-hook 1))
+
+(define (default-reporter result)
+  (if (hook-empty? report-hook)
+      (user-reporter result)
+      (run-hook report-hook result)))
+
+(define current-reporter
+  (make-parameter default-reporter))
+
+(define (register-reporter reporter)
+  (add-hook! report-hook reporter))
+
+(define (unregister-reporter reporter)
+  (remove-hook! report-hook reporter))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+  (if (memq reporter (hook->list report-hook)) #t #f))
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report result)
+  ((current-reporter) result))
+
+
+;;;; Some useful standard reporters:
+;;;; Log reporters write all benchmark results to a given log file.
+;;;; Full reporters write all benchmark results to the standard output.
+;;;; User reporters write some interesting results to the standard output.
+
+;;; Display a single benchmark result to the given port
+(define (print-result port result)
+  (let ((name (format-benchmark-name (benchmark-result:name result)))
+        (iterations (benchmark-result:iterations result))
+        (real-time (benchmark-result:real-time result))
+        (run-time (benchmark-result:run-time result))
+        (gc-time (benchmark-result:gc-time result))
+        (core-time (benchmark-result:core-time result)))
+    (write (list name iterations
+		 'total (->seconds real-time)
+		 'user (->seconds run-time)
+		 'system 0
+                 'frame (->seconds (- run-time core-time))
+		 'benchmark (->seconds core-time)
+		 'user/interp (->seconds (- run-time gc-time))
+		 'bench/interp (->seconds (- core-time gc-time))
+		 'gc (->seconds gc-time))
+	   port)
+    (newline port)))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form.  FILE may be a filename, or a port.
+(define (make-log-reporter file)
+  (let ((port (if (output-port? file) file
+		  (open-output-file file))))
+    (lambda (result)
+      (print-result port result)
+      (force-output port))))
+
+;;; A reporter that reports all results to the user.
+(define (full-reporter result)
+  (print-result (current-output-port) result))
+
+;;; Display interesting results of a single benchmark to the given port
+(define (print-user-result port result)
+  (let ((name (format-benchmark-name (benchmark-result:name result)))
+        (iterations (benchmark-result:iterations result))
+        (real-time (benchmark-result:real-time result))
+        (run-time (benchmark-result:run-time result))
+        (gc-time (benchmark-result:gc-time result))
+        (core-time (benchmark-result:core-time result)))
+    (write (list name iterations
+                 'real (->seconds real-time)
+		 'real/iteration (->seconds (/ real-time iterations))
+		 'run/iteration (->seconds (/ run-time iterations))
+		 'core/iteration (->seconds (/ core-time iterations))
+		 'gc (->seconds gc-time))
+	   port)
+    (newline port)))
+
+;;; A reporter that reports interesting results to the user.
+(define (user-reporter result)
+  (print-user-result (current-output-port) result))
+
+
+;;;; Initialize the benchmarking system:
+;;;;
+
+(define (calibrate-benchmark-framework)
+  (display ";; running guile version ")
+  (display (version))
+  (newline)
+  (display ";; calibrating the benchmarking framework...")
+  (newline)
+  (parameterize ((current-reporter
+                  (lambda (result)
+                    (set! *calibration-result* result)
+                    (display ";; calibration: ")
+                    (print-user-result (current-output-port) result))))
+    (benchmark "empty initialization benchmark" 10000000 #t)))
+
+(calibrate-benchmark-framework)
+;; -*- Scheme -*-
+;;
+;; A library of dumb functions that may be used to benchmark Guile-VM.
+
+
+;; The comments are from Ludovic, a while ago. The speedups now are much
+;; more significant (all over 2x, sometimes 8x).
+
+(define (fibo x)
+  (if (or (= x 1) (= x 2))
+      1
+      (+ (fibo (- x 1))
+	 (fibo (- x 2)))))
+
+(define (g-c-d x y)
+  (if (= x y)
+      x
+      (if (< x y)
+	  (g-c-d x (- y x))
+	  (g-c-d (- x y) y))))
+
+(define (loop n)
+  ;; This one shows that procedure calls are no faster than within the
+  ;; interpreter: the VM yields no performance improvement.
+  (if (= 0 n)
+      0
+      (loop (1- n))))
+
+;; Disassembly of `loop'
+;;
+;; Disassembly of #<objcode b79bdf28>:
+
+;; nlocs = 0  nexts = 0
+
+;;    0    (make-int8 64)                  ;; 64
+;;    2    (load-symbol "guile-user")      ;; guile-user
+;;   14    (list 0 1)                      ;; 1 element
+;;   17    (load-symbol "loop")            ;; loop
+;;   23    (link-later)
+;;   24    (vector 0 1)                    ;; 1 element
+;;   27    (make-int8 0)                   ;; 0
+;;   29    (load-symbol "n")               ;; n
+;;   32    (make-false)                    ;; #f
+;;   33    (make-int8 0)                   ;; 0
+;;   35    (list 0 3)                      ;; 3 elements
+;;   38    (list 0 2)                      ;; 2 elements
+;;   41    (list 0 1)                      ;; 1 element
+;;   44    (make-int8 5)                   ;; 5
+;;   46    (make-false)                    ;; #f
+;;   47    (cons)
+;;   48    (make-int8 18)                  ;; 18
+;;   50    (make-false)                    ;; #f
+;;   51    (cons)
+;;   52    (make-int8 20)                  ;; 20
+;;   54    (make-false)                    ;; #f
+;;   55    (cons)
+;;   56    (list 0 4)                      ;; 4 elements
+;;   59    (load-program ##{66}#)
+;;   81    (define "loop")
+;;   87    (variable-set)
+;;   88    (void)
+;;   89    (return)
+
+;; Bytecode ##{66}#\
+
+;;    0    (make-int8 0)                   ;; 0
+;;    2    (local-ref 0)
+;;    4    (ee?)
+;;    5    (br-if-not 0 3)                 ;; -> 11
+;;    8    (make-int8 0)                   ;; 0
+;;   10    (return)
+;;   11    (toplevel-ref 0)
+;;   13    (local-ref 0)
+;;   15    (make-int8 1)                   ;; 1
+;;   17    (sub)
+;;   18    (tail-call 1)
+
+(define (loopi n)
+  ;; Same as `loop'.
+  (let loopi ((n n))
+    (if (= 0 n)
+	0
+	(loopi (1- n)))))
+
+(define (do-loop n)
+  ;; Same as `loop' using `do'.
+  (do ((i n (1- i)))
+      ((= 0 i))
+    ;; do nothing
+    ))
+
+
+(define (do-cons x)
+  ;; This one shows that the built-in `cons' instruction yields a significant
+  ;; improvement (speedup: 1.5).
+  (let loop ((x x)
+	     (result '()))
+    (if (<= x 0)
+	result
+	(loop (1- x) (cons x result)))))
+
+(define big-list (iota 500000))
+
+(define (copy-list lst)
+  ;; Speedup: 5.9.
+  (let loop ((lst lst)
+	     (result '()))
+    (if (null? lst)
+	result
+	(loop (cdr lst)
+	      (cons (car lst) result)))))
+
+;; A simple interpreter vs. VM performance comparison tool
+;;
+
+(define-module (measure)
+  \:export (measure)
+  \:use-module (system vm vm)
+  \:use-module (system base compile)
+  \:use-module (system base language))
+
+
+(define (time-for-eval sexp eval)
+  (let ((before (tms:utime (times))))
+    (eval sexp)
+    (let ((elapsed (- (tms:utime (times)) before)))
+      (format #t "elapsed time: ~a~%" elapsed)
+      elapsed)))
+
+(define *scheme* (lookup-language 'scheme))
+
+
+(define (measure . args)
+  (if (< (length args) 2)
+      (begin
+	(format #t "Usage: measure SEXP FILE-TO-LOAD...~%")
+	(format #t "~%")
+	(format #t "Example: measure '(loop 23424)' lib.scm~%~%")
+	(exit 1)))
+  (for-each load (cdr args))
+  (let* ((sexp (with-input-from-string (car args)
+		 (lambda ()
+		   (read))))
+	 (eval-here (lambda (sexp) (eval sexp (current-module))))
+	 (proc-name (car sexp))
+	 (proc-source (procedure-source (eval proc-name (current-module))))
+	 (% (format #t "proc: ~a~%source: ~a~%" proc-name proc-source))
+	 (time-interpreted (time-for-eval sexp eval-here))
+	 (& (if (defined? proc-name)
+		(eval `(set! ,proc-name #f) (current-module))
+		(format #t "unbound~%")))
+	 (the-program (compile proc-source))
+
+	 (time-compiled (time-for-eval `(,proc-name ,@(cdr sexp))
+				       (lambda (sexp)
+					 (eval `(begin
+						  (define ,proc-name
+						    ,the-program)
+						  ,sexp)
+					       (current-module))))))
+
+    (format #t "proc:        ~a => ~a~%"
+	    proc-name (eval proc-name (current-module)))
+    (format #t "interpreted: ~a~%" time-interpreted)
+    (format #t "compiled:    ~a~%" time-compiled)
+    (format #t "speedup:     ~a~%"
+	    (exact->inexact (/ time-interpreted time-compiled)))
+    0))
+
+(define main measure)
+;;; guile-emacs.scm --- Guile Emacs interface
+
+;; Copyright (C) 2001, 2010 Keisuke Nishida <kxn30@po.cwru.edu>
+
+;;;; 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., 59 Temple Place, Suite 330, Boston, MA
+;;;; 02111-1307 USA
+
+;;; Code:
+
+(use-modules (ice-9 regex))
+(use-modules (ice-9 channel))
+(use-modules (ice-9 session))
+(use-modules (ice-9 documentation))
+
+
+;;;
+;;; Emacs Lisp channel
+;;;
+
+(define (emacs-lisp-channel)
+
+  (define (native-type? x)
+    (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))
+
+  (define (emacs-lisp-print ch val)
+    (cond
+      ((unspecified? val))
+      ((eq? val #t) (channel-print-value ch 't))
+      ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
+      ((native-type? val) (channel-print-value ch val))
+      (else (channel-print-token ch val))))
+
+  (channel-open (make-object-channel emacs-lisp-print)))
+
+
+;;;
+;;; Scheme channel
+;;;
+
+(define (emacs-scheme-channel)
+  (define (print ch val) (channel-print-value ch (object->string val)))
+  (channel-open (make-object-channel print)))
+
+
+;;;
+;;; for guile-import and guile-import-module
+;;;
+
+(define (guile-emacs-export-procedure name proc docs)
+  (define (procedure-args proc)
+    (let ((source (procedure-source proc)))
+      (if source
+	;; formals -> emacs args
+	(let loop ((formals (cadr source)))
+	  (cond
+	    ((null? formals) '())
+	    ((symbol? formals) `(&rest ,formals))
+	    (else (cons (car formals) (loop (cdr formals))))))
+	;; arity -> emacs args
+	(let* ((arity (procedure-minimum-arity proc))
+	       (nreqs (car arity))
+	       (nopts (cadr arity))
+	       (restp (caddr arity)))
+	  (define (nsyms n)
+	    (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
+	  (append! (nsyms nreqs)
+		   (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
+		   (if restp (cons '&rest (nsyms 1)) '()))))))
+
+  (define (procedure-call name args)
+    (let ((restp (memq '&rest args))
+	  (args (delq '&rest (delq '&optional args))))
+      (if restp
+	`('apply ',name ,@args)
+	`(',name ,@args))))
+
+  (let ((args (procedure-args proc))
+	(docs (and docs (object-documentation proc))))
+    `(defun ,name ,args
+       ,@(if docs (list docs) '())
+       (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
+
+(define (guile-emacs-export proc-name func-name docs)
+  (let ((proc (module-ref (current-module) proc-name)))
+    (guile-emacs-export-procedure func-name proc docs)))
+
+(define (guile-emacs-export-procedures module-name docs)
+  (define (module-public-procedures name)
+    (hash-fold (lambda (s v d)
+		 (let ((val (variable-ref v)))
+		   (if (procedure? val) (acons s val d) d)))
+	       '() (module-obarray (resolve-interface name))))
+  `(progn ,@(map (lambda (n+p)
+		   (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
+		 (module-public-procedures module-name))))
+
+
+;;;
+;;; for guile-scheme-complete-symbol
+;;;
+
+(define (guile-emacs-complete-alist str)
+  (sort! (apropos-fold (lambda (module name val data)
+			 (cons (list (symbol->string name)
+				     (cond ((procedure? val) " <p>")
+					   ((macro? val)     " <m>")
+					   (else "")))
+			       data))
+		       '() (string-append "^" (regexp-quote str))
+		       apropos-fold-all)
+	 (lambda (p1 p2) (string<? (car p1) (car p2)))))
+
+
+;;;
+;;; for guile-scheme-apropos
+;;;
+
+(define (guile-emacs-apropos regexp)
+  (with-output-to-string (lambda () (apropos regexp))))
+
+
+;;;
+;;; for guile-scheme-describe
+;;;
+
+(define (guile-emacs-describe sym)
+  (object-documentation (eval sym (current-module))))
+
+
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define object->string
+  (if (defined? 'object->string)
+    object->string
+    (lambda (x) (format #f "~S" x))))
+
+;;; guile-emacs.scm ends here
+;;; examples/box-dynamic-module/box-mixed.scm -- Scheme module using some
+;;;   functionality from the shared library libbox-module, but do not
+;;;   export procedures from the module.
+
+;;; Commentary:
+
+;;; This is the Scheme module box-mixed.  It uses some functionality
+;;; from the shared library libbox-module, but does not export it.
+
+;;; Code:
+
+;;; Author: Thomas Wawrzinek
+;;; Date: 2001-06-08
+;;; Changed: 2001-06-14 by martin, some commenting, cleanup and integration.
+
+(define-module (box-mixed))
+
+;; First, load the library.
+;;
+(load-extension "libbox-module" "scm_init_box")
+
+;; Create a list of boxes, each containing one element from ARGS.
+;;
+(define (make-box-list . args)
+  (map (lambda (el)
+	 (let ((b (make-box)))
+	   (box-set! b el) b))
+       args))
+
+;; Map the procedure FUNC over all elements of LST, which must be a
+;; list of boxes.  The result is a list of freshly allocated boxes,
+;; each containing the result of an application of FUNC.
+(define (box-map func lst)
+  (map (lambda (el)
+	 (let ((b (make-box)))
+	   (box-set! b (func (box-ref el)))
+	   b))
+       lst))
+
+;; Export the procedures, so that they can be used by others.
+;;
+(export make-box-list box-map)
+
+;;; End of file.
+;;; examples/box-dynamic-module/box-module.scm -- Scheme module exporting
+;;;   some functionality from the shared library libbox-module.
+
+;;; Commentary:
+
+;;; This is the Scheme part of the dynamic library module (box-module).
+;;; When you do a (use-modules (box-module)) in this directory,
+;;; this file gets loaded and will load the compiled extension.
+
+;;; Code:
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-06-06
+
+(define-module (box-module))
+
+;; First, load the library.
+;;
+(load-extension "libbox-module" "scm_init_box")
+
+;; Then export the procedures which should be visible to module users.
+;;
+(export make-box box-ref box-set!)
+
+;;; End of file.
+;;; examples/modules/module-0.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 0 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-0))
+
+(export foo bar)
+
+(define (foo)
+  (display "module-0 foo")
+  (newline))
+
+(define (bar)
+  (display "module-0 bar")
+  (newline))
+
+;;; End of file.
+;;; examples/modules/module-1.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 1 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-1))
+
+(export foo bar)
+
+(define (foo)
+  (display "module-1 foo")
+  (newline))
+
+(define (bar)
+  (display "module-1 bar")
+  (newline))
+
+;;; End of file.
+;;; examples/modules/module-2.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 2 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-2))
+
+(export foo bar braz)
+
+(define (foo)
+  (display "module-2 foo")
+  (newline))
+
+(define (bar)
+  (display "module-2 bar")
+  (newline))
+
+(define (braz)
+  (display "module-2 braz")
+  (newline))
+
+;;; End of file.
+;;; examples/safe/evil.scm -- Evil Scheme file to be run in a safe
+;;; environment.
+
+;;; Commentary:
+
+;;; This is an example file to be evaluated by the `safe' program in
+;;; this directory.  This program, unlike the `untrusted.scm' (which
+;;; is untrusted, but a really nice fellow though), tries to do evil
+;;; things and will thus break in a safe environment.
+;;;
+;;; *Note* that the files in this directory are only suitable for
+;;; demonstration purposes, if you have to implement safe evaluation
+;;; mechanisms in important environments, you will have to do more
+;;; than shown here -- for example disabling input/output operations.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-30
+
+;;; Code:
+
+(define passwd (open-input-file "/etc/passwd"))
+
+(let lp ((ch (read-char passwd)))
+  (if (not (eof-object? ch))
+    (lp (read-char passwd))))
+
+;;; End of file.
+;;; examples/safe/untrusted.scm -- Scheme file to be run in a safe
+;;; environment.
+
+;;; Commentary:
+
+;;; This is an example file to be evaluated by the `safe' program in
+;;; this directory.
+;;;
+;;; *Note* that the files in this directory are only suitable for
+;;; demonstration purposes, if you have to implement safe evaluation
+;;; mechanisms in important environments, you will have to do more
+;;; than shown here -- for example disabling input/output operations.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-30
+
+;;; Code:
+
+;; fact -- the everlasting factorial function...
+;;
+(define (fact n)
+  (if (< n 2)
+    1
+    (* n (fact (- n 1)))))
+
+;; Display the factorial of 0..9 to the terminal.
+;;
+(do ((x 0 (+ x 1)))
+    ((= x 11))
+  (display (fact x))
+  (newline))
+
+;;; End of file.
+;;; Commentary:
+
+;;; This is the famous Hello-World-program, written for Guile.  
+;;;
+;;; For an advanced version, see the script `hello' in the same
+;;; directory.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(display "Hello, World!")
+(newline)
+
+;;; End of file.
+;;; Commentary:
+
+;;; A simple debugging server that responds to all responses with a
+;;; table containing the headers given in the request.
+;;;
+;;; As a novelty, this server uses a little micro-framework to build up
+;;; the response as SXML. Instead of a string, the `respond' helper
+;;; returns a procedure for the body, which allows the `(web server)'
+;;; machinery to collect the output as a bytevector in the desired
+;;; encoding, instead of building an intermediate output string.
+;;;
+;;; In the future this will also allow for chunked transfer-encoding,
+;;; for HTTP/1.1 clients.
+
+;;; Code:
+
+(use-modules (web server)
+             (web request)
+             (web response)
+             (sxml simple))
+
+(define html5-doctype "<!DOCTYPE html>\n")
+(define default-title "Hello hello!")
+
+(define* (templatize #\key (title "No title") (body '((p "No body"))))
+  `(html (head (title ,title))
+         (body ,@body)))
+
+(define* (respond #\optional body #\key
+                  (status 200)
+                  (title default-title)
+                  (doctype html5-doctype)
+                  (content-type-params '((charset . "utf-8")))
+                  (content-type 'text/html)
+                  (extra-headers '())
+                  (sxml (and body (templatize #\title title #\body body))))
+  (values (build-response
+           #\code status
+           #\headers `((content-type . (,content-type ,@content-type-params))
+                       ,@extra-headers))
+          (lambda (port)
+            (if sxml
+                (begin
+                  (if doctype (display doctype port))
+                  (sxml->xml sxml port))))))
+
+(define (debug-page request body)
+  (respond `((h1 "hello world!")
+             (table
+              (tr (th "header") (th "value"))
+              ,@(map (lambda (pair)
+                       `(tr (td (tt ,(with-output-to-string
+                                       (lambda () (display (car pair))))))
+                            (td (tt ,(with-output-to-string
+                                       (lambda ()
+                                         (write (cdr pair))))))))
+                     (request-headers request))))))
+
+(run-server debug-page)
+;;; Commentary:
+
+;;; A simple web server that responds to all requests with the eponymous
+;;; string. Visit http://localhost:8080 to test.
+
+;;; Code:
+
+(use-modules (web server))
+
+;; A handler receives two values as arguments: the request object, and
+;; the request body.  It returns two values also: the response object,
+;; and the response body.
+;;
+;; In this simple example we don't actually access the request object,
+;; but if we wanted to, we would use the procedures from the `(web
+;; request)' module.  If there is no body given in the request, the body
+;; argument will be false.
+;;
+;; To create a response object, use the `build-response' procedure from
+;; `(web response)'.  Here we take advantage of a shortcut, in which we
+;; return an alist of headers for the response instead of returning a
+;; proper response object. In this case, a response object will be made
+;; for us with a 200 OK status.
+;;
+(define (handler request body)
+  (values '((content-type . (text/plain)))
+          "Hello, World!"))
+
+(run-server handler)
+;;; Copyright (C) 2008, 2011 Free Software Foundation, Inc.
+;;;
+;;; This program 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, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(use-modules (ice-9 format)
+             (ice-9 rdelim)
+             (ice-9 regex)
+             (srfi srfi-1)
+             (srfi srfi-37)
+             (srfi srfi-39))
+
+
+;;;
+;;; Memory usage.
+;;;
+
+(define (memory-mappings pid)
+  "Return an list of alists, each of which contains information about a
+memory mapping of process @var{pid}.  This information is obtained by reading
+@file{/proc/PID/smaps} on Linux.  See `procs(5)' for details."
+
+  (define mapping-line-rx
+    ;; As of Linux 2.6.32.28, an `smaps' line looks like this:
+    ;; "00400000-00401000 r-xp 00000000 fe:00 108264 /home/ludo/soft/bin/guile"
+    (make-regexp
+     "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [[:xdigit:]]{2}:[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$"))
+
+  (define rss-line-rx
+    (make-regexp
+     "^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
+
+  (if (not (string-contains %host-type "-linux-"))
+      (error "this procedure only works on Linux-based systems" %host-type))
+
+  (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
+    (lambda ()
+      (let loop ((line   (read-line))
+                 (result '()))
+        (if (eof-object? line)
+            (reverse result)
+            (cond ((regexp-exec mapping-line-rx line)
+                   =>
+                   (lambda (match)
+                     (let ((mapping-start (string->number
+                                           (match:substring match 1)
+                                           16))
+                           (mapping-end   (string->number
+                                           (match:substring match 2)
+                                           16))
+                           (access-bits   (match:substring match 3))
+                           (name          (match:substring match 5)))
+                       (loop (read-line)
+                             (cons `((mapping-start . ,mapping-start)
+                                     (mapping-end   . ,mapping-end)
+                                     (access-bits   . ,access-bits)
+                                     (name          . ,(if (string=? name "")
+                                                           #f
+                                                           name)))
+                                   result)))))
+                  ((regexp-exec rss-line-rx line)
+                   =>
+                   (lambda (match)
+                     (let ((section+ (cons (cons 'rss
+                                                 (string->number
+                                                  (match:substring match 1)))
+                                           (car result))))
+                       (loop (read-line)
+                             (cons section+ (cdr result))))))
+                  (else
+                   (loop (read-line) result))))))))
+
+(define (total-heap-size pid)
+  "Return a pair representing the total and RSS heap size of PID."
+
+  (define heap-or-anon-rx
+    (make-regexp "\\[(heap|anon)\\]"))
+
+  (define private-mapping-rx
+    (make-regexp "^[r-][w-][x-]p$"))
+
+  (fold (lambda (heap total+rss)
+          (let ((name (assoc-ref heap 'name))
+                (perm (assoc-ref heap 'access-bits)))
+            ;; Include anonymous private mappings.
+            (if (or (and (not name)
+                         (regexp-exec private-mapping-rx perm))
+                    (and name
+                         (regexp-exec heap-or-anon-rx name)))
+                (let ((start (assoc-ref heap 'mapping-start))
+                      (end   (assoc-ref heap 'mapping-end))
+                      (rss   (assoc-ref heap 'rss)))
+                  (cons (+ (car total+rss) (- end start))
+                        (+ (cdr total+rss) rss)))
+                total+rss)))
+        '(0 . 0)
+        (memory-mappings pid)))
+
+
+(define (display-stats start end)
+  (define (->usecs sec+usecs)
+    (+ (* 1000000 (car sec+usecs))
+       (cdr sec+usecs)))
+
+  (let ((usecs        (- (->usecs end) (->usecs start)))
+        (heap-size    (total-heap-size (getpid)))
+        (gc-heap-size (assoc-ref (gc-stats) 'heap-size)))
+
+    (format #t "execution time:              ~6,3f seconds~%"
+            (/ usecs 1000000.0))
+
+    (and gc-heap-size
+         (format #t "GC-reported heap size: ~8d B   (~1,2f MiB)~%"
+                 gc-heap-size
+                 (/ gc-heap-size 1024.0 1024.0)))
+
+    (format #t "heap size:             ~8d B   (~1,2f MiB)~%"
+            (car heap-size)
+            (/ (car heap-size) 1024.0 1024.0))
+    (format #t "heap RSS:              ~8d KiB (~1,2f MiB)~%"
+            (cdr heap-size)
+            (/ (cdr heap-size) 1024.0))
+;;     (system (format #f "cat /proc/~a/smaps" (getpid)))
+;;     (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
+    ))
+
+
+;;;
+;;; Larceny/Twobit benchmarking compability layer.
+;;;
+
+(define *iteration-count*
+  (make-parameter #f))
+
+(define (run-benchmark name . args)
+  "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking
+framework.  See
+@url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for
+details."
+
+  (define %concise-invocation?
+    ;; This procedure can be called with only two arguments, NAME and
+    ;; RUN-MAKER.
+    (procedure? (car args)))
+
+  (let ((count     (or (*iteration-count*)
+                       (if %concise-invocation? 0 (car args))))
+        (run-maker (if %concise-invocation? (car args) (cadr args)))
+        (ok?       (if %concise-invocation?
+                       (lambda (result) #t)
+                       (caddr args)))
+        (args      (if %concise-invocation? '() (cdddr args))))
+    (let loop ((i 0))
+      (and (< i count)
+           (let ((result (apply run-maker args)))
+             (if (not (ok? result))
+                 (begin
+                   (format (current-output-port) "invalid result for `~A'~%"
+                           name)
+                   (exit 1)))
+             (loop (1+ i)))))))
+
+(define (save-directory-excursion directory thunk)
+  (let ((previous-dir (getcwd)))
+    (dynamic-wind
+      (lambda ()
+        (chdir directory))
+      thunk
+      (lambda ()
+        (chdir previous-dir)))))
+
+(define (load-larceny-benchmark file)
+  "Load the Larceny benchmark from @var{file}."
+  (let ((name   (let ((base (basename file)))
+                  (substring base 0 (or (string-rindex base #\.)
+                                        (string-length base)))))
+        (module (let ((m (make-module)))
+                  (beautify-user-module! m)
+                  (module-use! m (resolve-interface '(ice-9 syncase)))
+                  m)))
+    (save-directory-excursion (dirname file)
+     (lambda ()
+       (save-module-excursion
+        (lambda ()
+          (set-current-module module)
+          (module-define! module 'run-benchmark run-benchmark)
+          (load (basename file))
+
+          ;; Invoke the benchmark's entry point.
+          (let ((entry (module-ref (current-module)
+                                   (symbol-append (string->symbol name)
+                                                  '-benchmark))))
+            (entry))))))))
+
+
+
+;;;
+;;; Option processing.
+;;;
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\l "larceny") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'larceny? #t result)))
+        (option '(#\i "iterations") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'iterations (string->number arg) result)))))
+
+(define (show-help)
+  (format #t "Usage: gc-profile [OPTIONS] FILE.SCM
+Load FILE.SCM, a Guile Scheme source file, and report its execution time and
+final heap usage.
+
+  -h, --help      Show this help message
+
+  -l, --larceny   Provide mechanisms compatible with the Larceny/Twobit
+                  GC benchmark suite.
+  -i, --iterations=COUNT
+                  Run the given benchmark COUNT times, regardless of the
+                  iteration count passed to `run-benchmark' (for Larceny
+                  benchmarks).
+
+Report bugs to <bug-guile@gnu.org>.~%"))
+
+(define (parse-args args)
+  (define (leave fmt . args)
+    (apply format (current-error-port) (string-append fmt "~%") args)
+    (exit 1))
+
+  (args-fold args %options
+             (lambda (opt name arg result)
+               (leave "~A: unrecognized option" opt))
+             (lambda (file result)
+               (if (pair? (assoc 'input result))
+                   (leave "~a: only one input file at a time" file)
+                   (alist-cons 'input file result)))
+             '()))
+
+
+;;;
+;;; Main program.
+;;;
+
+(define (main . args)
+  (let* ((options (parse-args args))
+         (prog    (assoc-ref options 'input))
+         (load    (if (assoc-ref options 'larceny?)
+                      load-larceny-benchmark
+                      load)))
+
+    (parameterize ((*iteration-count* (assoc-ref options 'iterations)))
+      (format #t "running `~a' with Guile ~a...~%" prog (version))
+
+      (let ((start (gettimeofday)))
+        (dynamic-wind
+          (lambda ()
+            #t)
+          (lambda ()
+            (set! quit (lambda args args))
+            (load prog))
+          (lambda ()
+            (let ((end (gettimeofday)))
+              (format #t "done~%")
+              (display-stats start end))))))))
+;  This is adapted from a benchmark written by John Ellis and Pete Kovac
+;  of Post Communications.
+;  It was modified by Hans Boehm of Silicon Graphics.
+;  It was translated into Scheme by William D Clinger of Northeastern Univ;
+;    the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
+;  Last modified 30 May 1997.
+; 
+;       This is no substitute for real applications.  No actual application
+;       is likely to behave in exactly this way.  However, this benchmark was
+;       designed to be more representative of real applications than other
+;       Java GC benchmarks of which we are aware.
+;       It attempts to model those properties of allocation requests that
+;       are important to current GC techniques.
+;       It is designed to be used either to obtain a single overall performance
+;       number, or to give a more detailed estimate of how collector
+;       performance varies with object lifetimes.  It prints the time
+;       required to allocate and collect balanced binary trees of various
+;       sizes.  Smaller trees result in shorter object lifetimes.  Each cycle
+;       allocates roughly the same amount of memory.
+;       Two data structures are kept around during the entire process, so
+;       that the measured performance is representative of applications
+;       that maintain some live in-memory data.  One of these is a tree
+;       containing many pointers.  The other is a large array containing
+;       double precision floating point numbers.  Both should be of comparable
+;       size.
+; 
+;       The results are only really meaningful together with a specification
+;       of how much memory was used.  It is possible to trade memory for
+;       better time performance.  This benchmark should be run in a 32 MB
+;       heap, though we don't currently know how to enforce that uniformly.
+
+; In the Java version, this routine prints the heap size and the amount
+; of free memory.  There is no portable way to do this in Scheme; each
+; implementation needs its own version.
+
+(use-modules (ice-9 syncase))
+
+(define (PrintDiagnostics)
+  (display " Total memory available= ???????? bytes")
+  (display "  Free memory= ???????? bytes")
+  (newline))
+
+
+
+(define (run-benchmark str thu)
+	(display str)
+  (thu))
+; Should we implement a Java class as procedures or hygienic macros?
+; Take your pick.
+
+(define-syntax let-class
+  (syntax-rules
+   ()
+
+   ;; Put this rule first to implement a class using procedures.
+   ((let-class (((method . args) . method-body) ...) . body)
+    (let () (define (method . args) . method-body) ... . body))
+
+   
+   ;; Put this rule first to implement a class using hygienic macros.
+   ((let-class (((method . args) . method-body) ...) . body)
+    (letrec-syntax ((method (syntax-rules () ((method . args) (begin .  method-body))))
+                    ...)
+      . body))
+
+   
+   ))
+                          
+
+(define (gcbench kStretchTreeDepth)
+  
+  ;  Nodes used by a tree of a given size
+  (define (TreeSize i)
+    (- (expt 2 (+ i 1)) 1))
+  
+  ;  Number of iterations to use for a given tree depth
+  (define (NumIters i)
+    (quotient (* 2 (TreeSize kStretchTreeDepth))
+              (TreeSize i)))
+  
+  ;  Parameters are determined by kStretchTreeDepth.
+  ;  In Boehm's version the parameters were fixed as follows:
+  ;    public static final int kStretchTreeDepth    = 18;  // about 16Mb
+  ;    public static final int kLongLivedTreeDepth  = 16;  // about 4Mb
+  ;    public static final int kArraySize  = 500000;       // about 4Mb
+  ;    public static final int kMinTreeDepth = 4;
+  ;    public static final int kMaxTreeDepth = 16;
+  ;  In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
+  
+  (let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
+         (kArraySize          (* 4 (TreeSize kLongLivedTreeDepth)))
+         (kMinTreeDepth       4)
+         (kMaxTreeDepth       kLongLivedTreeDepth))
+    
+    ; Elements 3 and 4 of the allocated vectors are useless.
+    
+    (let-class (((make-node l r)
+                 (let ((v (make-empty-node)))
+                   (vector-set! v 0 l)
+                   (vector-set! v 1 r)
+                   v))
+                ((make-empty-node) (make-vector 4 0))
+                ((node.left node) (vector-ref node 0))
+                ((node.right node) (vector-ref node 1))
+                ((node.left-set! node x) (vector-set! node 0 x))
+                ((node.right-set! node x) (vector-set! node 1 x)))
+      
+      ;  Build tree top down, assigning to older objects.
+      (define (Populate iDepth thisNode)
+        (if (<= iDepth 0)
+            #f
+            (let ((iDepth (- iDepth 1)))
+              (node.left-set! thisNode (make-empty-node))
+              (node.right-set! thisNode (make-empty-node))
+              (Populate iDepth (node.left thisNode))
+              (Populate iDepth (node.right thisNode)))))
+      
+      ;  Build tree bottom-up
+      (define (MakeTree iDepth)
+        (if (<= iDepth 0)
+            (make-empty-node)
+            (make-node (MakeTree (- iDepth 1))
+                       (MakeTree (- iDepth 1)))))
+      
+      (define (TimeConstruction depth)
+        (let ((iNumIters (NumIters depth)))
+          (display (string-append "Creating "
+                                  (number->string iNumIters)
+                                  " trees of depth "
+                                  (number->string depth)))
+          (newline)
+          (run-benchmark "GCBench: Top down construction"
+                         (lambda ()
+                           (do ((i 0 (+ i 1)))
+                               ((>= i iNumIters))
+                               (Populate depth (make-empty-node)))))
+          (run-benchmark "GCBench: Bottom up construction"
+                         (lambda ()
+                           (do ((i 0 (+ i 1)))
+                               ((>= i iNumIters))
+                               (MakeTree depth))))))
+      
+      (define (main)
+        (display "Garbage Collector Test")
+        (newline)
+        (display (string-append
+                  " Stretching memory with a binary tree of depth "
+                  (number->string kStretchTreeDepth)))
+        (newline)
+        (run-benchmark "GCBench: Main"
+                       (lambda ()
+                         ;  Stretch the memory space quickly
+                         (MakeTree kStretchTreeDepth)
+                         
+                         ;  Create a long lived object
+                         (display (string-append
+                                   " Creating a long-lived binary tree of depth "
+                                   (number->string kLongLivedTreeDepth)))
+                         (newline)
+                         (let ((longLivedTree (make-empty-node)))
+                           (Populate kLongLivedTreeDepth longLivedTree)
+                           
+                           ;  Create long-lived array, filling half of it
+                           (display (string-append
+                                     " Creating a long-lived array of "
+                                     (number->string kArraySize)
+                                     " inexact reals"))
+                           (newline)
+                           (let ((array (make-vector kArraySize 0.0)))
+                             (do ((i 0 (+ i 1)))
+                                 ((>= i (quotient kArraySize 2)))
+                                 (vector-set! array i (/ 1.0 (exact->inexact i))))
+                             (PrintDiagnostics)
+                             
+                             (do ((d kMinTreeDepth (+ d 2)))
+                                 ((> d kMaxTreeDepth))
+                                 (TimeConstruction d))
+                             
+                             (if (or (eq? longLivedTree '())
+                                     (let ((n (min 1000
+                                                   (- (quotient (vector-length array)
+                                                                2)
+                                                      1))))
+                                       (not (= (vector-ref array n)
+                                               (/ 1.0 (exact->inexact
+n))))))
+                                 (begin (display "Failed") (newline)))
+                             ;  fake reference to LongLivedTree
+                             ;  and array
+                             ;  to keep them from being optimized away
+                             ))))
+        (PrintDiagnostics))
+      
+      (main))))
+
+(define (gc-benchmark . rest)
+  (let ((k (if (null? rest) 18 (car rest))))
+    (display "The garbage collector should touch about ")
+    (display (expt 2 (- k 13)))
+    (display " megabytes of heap storage.")
+    (newline)
+    (display "The use of more or less memory will skew the results.")
+    (newline)
+    (run-benchmark (string-append "GCBench" (number->string k))
+                   (lambda () (gcbench k)))))
+
+
+
+(gc-benchmark )
+(display (gc-stats))
+(set! %load-path (cons (string-append (getenv "HOME") "/src/guile")
+                       %load-path))
+
+(load "../test-suite/guile-test")
+
+(main `("guile-test"
+        "--test-suite" ,(string-append (getenv "HOME")
+                                       "/src/guile/test-suite/tests")
+        "--log-file" ",,test-suite.log"))
+;
+;  GCOld.sch x.x 00/08/03
+;  translated from GCOld.java 2.0a 00/08/23
+; 
+; Copyright 2000 Sun Microsystems, Inc. All rights reserved.
+; 
+;
+
+; Should be good enough for this benchmark.
+
+(define (newRandom)
+  (letrec ((random14
+            (lambda (n)
+              (set! x (remainder (+ (* a x) c) m))
+              (remainder (quotient x 8) n)))
+           (a 701)
+           (x 1)
+           (c 743483)
+           (m 524288)
+           (loop
+            (lambda (q r n)
+              (if (zero? q)
+                  (remainder r n)
+                  (loop (quotient q 16384)
+                        (+ (* 16384 r) (random14 16384))
+                        n)))))
+    (lambda (n)
+      (if (and (exact? n) (integer? n) (< n 16384))
+          (random14 n)
+          (loop n (random14 16384) n)))))
+
+; A TreeNode is a record with three fields: left, right, val.
+; The left and right fields contain a TreeNode or 0, and the
+; val field will contain the integer height of the tree.
+
+(define-syntax newTreeNode
+  (syntax-rules ()
+    ((newTreeNode left right val)
+     (vector left right val))
+    ((newTreeNode)
+     (vector 0 0 0))))
+
+(define-syntax TreeNode.left
+  (syntax-rules ()
+    ((TreeNode.left node)
+     (vector-ref node 0))))
+
+(define-syntax TreeNode.right
+  (syntax-rules ()
+    ((TreeNode.right node)
+     (vector-ref node 1))))
+
+(define-syntax TreeNode.val
+  (syntax-rules ()
+    ((TreeNode.val node)
+     (vector-ref node 2))))
+
+(define-syntax setf
+  (syntax-rules (TreeNode.left TreeNode.right TreeNode.val)
+    ((setf (TreeNode.left node) x)
+     (vector-set! node 0 x))
+    ((setf (TreeNode.right node) x)
+     (vector-set! node 1 x))
+    ((setf (TreeNode.val node) x)
+     (vector-set! node 2 x))))
+
+;  Args:
+;  live-data-size: in megabytes.
+;  work: units of mutator non-allocation work per byte allocated,
+;    (in unspecified units.  This will affect the promotion rate
+;     printed at the end of the run: more mutator work per step implies
+;     fewer steps per second implies fewer bytes promoted per second.)
+;  short/long ratio: ratio of short-lived bytes allocated to long-lived
+;     bytes allocated.
+;  pointer mutation rate: number of pointer mutations per step.
+;  steps: number of steps to do.
+;
+
+(define (GCOld size workUnits promoteRate ptrMutRate steps)
+
+  (define (println . args)
+    (for-each display args)
+    (newline))
+
+  ; Rounds an inexact real to two decimal places.
+
+  (define (round2 x)
+    (/ (round (* 100.0 x)) 100.0))
+
+  ; Returns the height of the given tree.
+
+  (define (height t)
+    (if (eqv? t 0)
+        0
+        (+ 1 (max (height (TreeNode.left t))
+                  (height (TreeNode.right t))))))
+
+  ; Returns the length of the shortest path in the given tree.
+
+  (define (shortestPath t)
+    (if (eqv? t 0)
+        0
+        (+ 1 (min (shortestPath (TreeNode.left t))
+                  (shortestPath (TreeNode.right t))))))
+
+  ; Returns the number of nodes in a balanced tree of the given height.
+
+  (define (heightToNodes h)
+    (- (expt 2 h) 1))
+
+  ; Returns the height of the largest balanced tree
+  ; that has no more than the given number of nodes.
+
+  (define (nodesToHeight nodes)
+    (do ((h 1 (+ h 1))
+         (n 1 (+ n n)))
+        ((> (+ n n -1) nodes)
+         (- h 1))))
+
+  (let* (
+
+         ; Constants.
+
+         (null 0)            ; Java's null
+         (pathBits 65536)    ; to generate 16 random bits
+
+         (MEG 1000000)
+         (INSIGNIFICANT 999) ; this many bytes don't matter
+         (bytes/word 4)
+         (bytes/node 20)     ; bytes per tree node in typical JVM
+         (words/dead 100)    ; size of young garbage objects
+
+         ; Returns the number of bytes in a balanced tree of the given height.
+
+         (heightToBytes
+           (lambda (h)
+             (* bytes/node (heightToNodes h))))
+
+         ; Returns the height of the largest balanced tree
+         ; that occupies no more than the given number of bytes.
+
+         (bytesToHeight
+           (lambda (bytes)
+             (nodesToHeight (/ bytes bytes/node))))
+
+         (treeHeight 14)
+         (treeSize (heightToBytes treeHeight))
+
+         (msg1 "Usage: java GCOld <size> <work> <ratio> <mutation> <steps>")
+         (msg2 "  where <size> is the live storage in megabytes")
+         (msg3 "        <work> is the mutator work per step (arbitrary units)")
+         (msg4 "        <ratio> is the ratio of short-lived to long-lived allocation")
+         (msg5 "        <mutation> is the mutations per step")
+         (msg6 "        <steps> is the number of steps")
+
+         ; Counters (and global variables that discourage optimization).
+
+         (youngBytes 0)
+         (nodes 0)
+         (actuallyMut 0)
+         (mutatorSum 0)
+         (aexport '#())
+
+         ; Global variables.
+
+         (trees '#())
+         (where 0)
+         (rnd (newRandom))
+
+         )
+
+    ; Returns a newly allocated balanced binary tree of height h.
+
+    (define (makeTree h)
+      (if (zero? h)
+          null
+          (let ((res (newTreeNode)))
+            (set! nodes (+ nodes 1))
+            (setf (TreeNode.left res) (makeTree (- h 1)))
+            (setf (TreeNode.right res) (makeTree (- h 1)))
+            (setf (TreeNode.val res) h)
+            res)))
+
+    ; Allocates approximately size megabytes of trees and stores
+    ; them into a global array.
+
+    (define (init)
+      ; Each tree will be about a megabyte.
+      (let ((ntrees (quotient (* size MEG) treeSize)))
+	(set! trees (make-vector ntrees null))
+	(println "Allocating " ntrees " trees.")
+        (println "  (" (* ntrees treeSize) " bytes)")
+	(do ((i 0 (+ i 1)))
+	    ((>= i ntrees))
+	  (vector-set! trees i (makeTree treeHeight))
+	  (doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead))
+	(println "  (" nodes " nodes)")))
+
+    ; Confirms that all trees are balanced and have the correct height.
+
+    (define (checkTrees)
+      (let ((ntrees (vector-length trees)))
+        (do ((i 0 (+ i 1)))
+            ((>= i ntrees))
+          (let* ((t (vector-ref trees i))
+                 (h1 (height t))
+                 (h2 (shortestPath t)))
+            (if (or (not (= h1 treeHeight))
+                    (not (= h2 treeHeight)))
+                (println "*****BUG: " h1 " " h2))))))
+
+    ; Called only by replaceTree (below) and by itself.
+
+    (define (replaceTreeWork full partial dir)
+      (let ((canGoLeft (and (not (eq? (TreeNode.left full) null))
+			    (> (TreeNode.val (TreeNode.left full))
+			       (TreeNode.val partial))))
+	    (canGoRight (and (not (eq? (TreeNode.right full) null))
+			     (> (TreeNode.val (TreeNode.right full))
+			        (TreeNode.val partial)))))
+	(cond ((and canGoLeft canGoRight)
+	       (if dir
+		   (replaceTreeWork (TreeNode.left full)
+				    partial
+				    (not dir))
+		   (replaceTreeWork (TreeNode.right full)
+				    partial
+				    (not dir))))
+	      ((and (not canGoLeft) (not canGoRight))
+	       (if dir
+		   (setf (TreeNode.left full) partial)
+		   (setf (TreeNode.right full) partial)))
+	      ((not canGoLeft)
+	       (setf (TreeNode.left full) partial))
+	      (else
+	       (setf (TreeNode.right full) partial)))))
+
+    ; Given a balanced tree full and a smaller balanced tree partial,
+    ; replaces an appropriate subtree of full by partial, taking care
+    ; to preserve the shape of the full tree.
+
+    (define (replaceTree full partial)
+      (let ((dir (zero? (modulo (TreeNode.val partial) 2))))
+        (set! actuallyMut (+ actuallyMut 1))
+	(replaceTreeWork full partial dir)))
+
+    ; Allocates approximately n bytes of long-lived storage,
+    ; replacing oldest existing long-lived storage.
+
+    (define (oldGenAlloc n)
+      (let ((full (quotient n treeSize))
+	    (partial (modulo n treeSize)))
+	;(println "In oldGenAlloc, doing "
+	;         full
+	;         " full trees and one partial tree of size "
+	;         partial)
+	(do ((i 0 (+ i 1)))
+	    ((>= i full))
+	  (vector-set! trees where (makeTree treeHeight))
+	  (set! where
+                (modulo (+ where 1) (vector-length trees))))
+	(let loop ((partial partial))
+          (if (> partial INSIGNIFICANT)
+              (let* ((h (bytesToHeight partial))
+                     (newTree (makeTree h)))
+                (replaceTree (vector-ref trees where) newTree)
+                (set! where
+                      (modulo (+ where 1) (vector-length trees)))
+                (loop (- partial (heightToBytes h))))))))
+
+    ; Interchanges two randomly selected subtrees (of same size and depth).
+
+    (define (oldGenSwapSubtrees)
+      ; Randomly pick:
+      ;   * two tree indices 
+      ;   * A depth
+      ;   * A path to that depth.
+      (let* ((index1 (rnd (vector-length trees)))
+	     (index2 (rnd (vector-length trees)))
+	     (depth (rnd treeHeight))
+	     (path (rnd pathBits))
+	     (tn1 (vector-ref trees index1))
+	     (tn2 (vector-ref trees index2)))
+	(do ((i 0 (+ i 1)))
+	    ((>= i depth))
+	  (if (even? path)
+	      (begin (set! tn1 (TreeNode.left tn1))
+		     (set! tn2 (TreeNode.left tn2)))
+	      (begin (set! tn1 (TreeNode.right tn1))
+		     (set! tn2 (TreeNode.right tn2))))
+	  (set! path (quotient path 2)))
+	(if (even? path)
+	    (let ((tmp (TreeNode.left tn1)))
+	      (setf (TreeNode.left tn1) (TreeNode.left tn2))
+	      (setf (TreeNode.left tn2) tmp))
+	    (let ((tmp (TreeNode.right tn1)))
+	      (setf (TreeNode.right tn1) (TreeNode.right tn2))
+	      (setf (TreeNode.right tn2) tmp)))
+	(set! actuallyMut (+ actuallyMut 2))))
+
+    ; Update "n" old-generation pointers.
+
+    (define (oldGenMut n)
+      (do ((i 0 (+ i 1)))
+	  ((>= i (quotient n 2)))
+	(oldGenSwapSubtrees)))
+
+    ; Does the amount of mutator work appropriate for n bytes of young-gen
+    ; garbage allocation.
+
+    (define (doMutWork n)
+      (let ((limit (quotient (* workUnits n) 10)))
+	(do ((k 0 (+ k 1))
+	     (sum 0 (+ sum 1)))
+	    ((>= k limit)
+             ; We don't want dead code elimination to eliminate this loop.
+	     (set! mutatorSum (+ mutatorSum sum))))))
+
+    ; Allocate n bytes of young-gen garbage, in units of "nwords"
+    ; words.
+
+    (define (doYoungGenAlloc n nwords)
+      (let ((nbytes (* nwords bytes/word)))
+	(do ((allocated 0 (+ allocated nbytes)))
+	    ((>= allocated n)
+             (set! youngBytes (+ youngBytes allocated)))
+	  (set! aexport (make-vector nwords 0)))))
+
+    ; Allocate "n" bytes of young-gen data; and do the
+    ; corresponding amount of old-gen allocation and pointer
+    ; mutation.
+
+    ; oldGenAlloc may perform some mutations, so this code
+    ; takes those mutations into account.
+
+    (define (doStep n)
+      (let ((mutations actuallyMut))
+	(doYoungGenAlloc n words/dead)
+	(doMutWork n)
+	; Now do old-gen allocation
+	(oldGenAlloc (quotient n promoteRate))
+	(oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut)))))
+
+    (println size " megabytes")
+    (println workUnits " work units per step.")
+    (println "promotion ratio is 1:" promoteRate)
+    (println "pointer mutation rate is " ptrMutRate)
+    (println steps " steps")
+
+    (init)
+    (checkTrees)
+    (set! youngBytes 0)
+    (set! nodes 0)
+
+    (println "Initialization complete...")
+
+    (run-benchmark "GCOld"
+		   1
+		   (lambda ()
+                     (lambda ()
+                       (do ((step 0 (+ step 1)))
+                           ((>= step steps))
+                         (doStep MEG))))
+                   (lambda (result) #t))
+
+    (checkTrees)
+
+    (println "Allocated " steps " Mb of young gen garbage")
+    (println "    (actually allocated "
+             (round2 (/ youngBytes MEG))
+             " megabytes)")
+    (println "Promoted " (round2 (/ steps promoteRate)) " Mb")
+    (println "    (actually promoted "
+             (round2 (/ (* nodes bytes/node) MEG))
+             " megabytes)")
+    (if (not (zero? ptrMutRate))
+        (println "Mutated " actuallyMut " pointers"))
+
+    ; This output serves mainly to discourage optimization.
+
+    (+ mutatorSum (vector-length aexport))))
+
+(define (gcold-benchmark . args)
+  (define gcold-iters 1)
+
+  (GCOld 25 0 10 10 gcold-iters))
+(let loop ((i 10000000))
+  (and (> i 0)
+       (loop (1- i))))
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+;;;
+;;; This program 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, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(use-modules (ice-9 rdelim)
+             (ice-9 popen)
+             (ice-9 regex)
+             (ice-9 format)
+             (ice-9 pretty-print)
+             (srfi srfi-1)
+             (srfi srfi-37))
+
+
+;;;
+;;; Running Guile.
+;;;
+
+(define (run-reference-guile env bench-dir profile-opts bench)
+  "Run the ``mainstream'' Guile, i.e., Guile 1.9 with its own GC."
+  (open-input-pipe (string-append
+                    env " "
+                    bench-dir "/gc-profile.scm " profile-opts
+                    " \"" bench "\"")))
+
+(define (run-bdwgc-guile env bench-dir profile-opts options bench)
+  "Run the Guile port to the Boehm-Demers-Weiser GC (BDW-GC)."
+  (let ((fsd (assoc-ref options 'free-space-divisor)))
+    (open-input-pipe (string-append env " "
+                                    "GC_FREE_SPACE_DIVISOR="
+                                    (number->string fsd)
+
+                                    (if (or (assoc-ref options 'incremental?)
+                                            (assoc-ref options 'generational?))
+                                        " GC_ENABLE_INCREMENTAL=yes"
+                                        "")
+                                    (if (assoc-ref options 'generational?)
+                                        " GC_PAUSE_TIME_TARGET=999999"
+                                        "")
+                                    (if (assoc-ref options 'parallel?)
+                                        "" ;; let it choose the number of procs
+                                        " GC_MARKERS=1")
+                                    " "
+                                    bench-dir "/gc-profile.scm " profile-opts
+                                    " \"" bench "\""))))
+
+
+;;;
+;;; Extracting performance results.
+;;;
+
+(define (grep regexp input)
+  "Read line by line from the @var{input} port and return all matches for
+@var{regexp}."
+  (let ((regexp (if (string? regexp) (make-regexp regexp) regexp)))
+    (with-input-from-port input
+      (lambda ()
+        (let loop ((line   (read-line))
+                   (result '()))
+          (format #t "> ~A~%" line)
+          (if (eof-object? line)
+              (reverse result)
+              (cond ((regexp-exec regexp line)
+                     =>
+                     (lambda (match)
+                       (loop (read-line)
+                             (cons match result))))
+                    (else
+                     (loop (read-line) result)))))))))
+
+(define (parse-result benchmark-output)
+  (let ((result (grep "^(execution time|heap size):[[:blank:]]+([0-9.]+)"
+                      benchmark-output)))
+    (fold (lambda (match result)
+            (cond ((equal? (match:substring match 1) "execution time")
+                   (cons (cons 'execution-time
+                               (string->number (match:substring match 2)))
+                         result))
+                  ((equal? (match:substring match 1) "heap size")
+                   (cons (cons 'heap-size
+                               (string->number (match:substring match 2)))
+                         result))
+                  (else
+                   result)))
+          '()
+          result)))
+
+(define (pretty-print-result benchmark reference bdwgc)
+  (define ref-heap (assoc-ref reference 'heap-size))
+  (define ref-time (assoc-ref reference 'execution-time))
+
+  (define (distance x1 y1 x2 y2)
+    ;; Return the distance between (X1,Y1) and (X2,Y2).  Y is the heap size,
+    ;; in MiB and X is the execution time in seconds.
+    (let ((y1 (/ y1 (expt 2 20)))
+          (y2 (/ y2 (expt 2 20))))
+      (sqrt (+ (expt (- y1 y2) 2)
+               (expt (- x1 x2) 2)))))
+
+  (define (score time heap)
+    ;; Return a score lower than +1.0.  The score is positive if the
+    ;; distance to the origin of (TIME,HEAP) is smaller than that of
+    ;; (REF-TIME,REF-HEAP), negative otherwise.
+
+    ;; heap  ^         .
+    ;; size  |         .   worse
+    ;;       |         .    [-]
+    ;;       |         .
+    ;;       | . . . .ref. . . .
+    ;;       |         .
+    ;;       |  [+]    .
+    ;;       | better  .
+    ;;     0 +-------------------->
+    ;;                        exec. time
+
+    (let ((ref-dist (distance ref-time ref-heap 0 0))
+          (dist     (distance time heap 0 0)))
+      (/ (- ref-dist dist) ref-dist)))
+
+  (define (score-string time heap)
+    ;; Return a string denoting a bar to illustrate the score of (TIME,HEAP)
+    ;; relative to (REF-TIME,REF-HEAP).
+    (define %max-width 15)
+
+    (let ((s (score time heap)))
+      (make-string (inexact->exact (round (* (if (< s 0.0) (- s) s)
+                                             %max-width)))
+                   (if (< s 0.0)
+                       #\-
+                       #\+))))
+
+  (define (print-line name result ref?)
+    (let ((name (string-pad-right name 23))
+          (time (assoc-ref result 'execution-time))
+          (heap (assoc-ref result 'heap-size)))
+      (format #t "~a ~6,2f (~,2fx)    ~7,3f (~,2fx)~A~%"
+              name
+              (/ heap (expt 2.0 20)) (/ heap ref-heap 1.0)
+              time (/ time ref-time 1.0)
+              (if (not ref?)
+                  (string-append " "
+                                 (score-string time heap))
+                  ""))))
+
+  (format #t "benchmark: `~a'~%" benchmark)
+  (format #t "                       heap size (MiB)  execution time (s.)~%")
+  (print-line "Guile" reference #t)
+  (for-each (lambda (bdwgc)
+              (let ((name (format #f "BDW-GC, FSD=~a~a"
+                                  (assoc-ref bdwgc 'free-space-divisor)
+                                  (cond ((assoc-ref bdwgc 'incremental?)
+                                         " incr.")
+                                        ((assoc-ref bdwgc 'generational?)
+                                         " gene.")
+                                        ((assoc-ref bdwgc 'parallel?)
+                                         " paral.")
+                                        (else "")))))
+                (print-line name bdwgc #f)))
+            bdwgc))
+
+(define (print-raw-result benchmark reference bdwgc)
+  (pretty-print `(,benchmark
+                  (reference . ,reference)
+                  (bdw-gc    . ,bdwgc))))
+
+
+
+;;;
+;;; Option processing.
+;;;
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\r "reference") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'reference-environment arg
+                              (alist-delete 'reference-environment result
+                                            eq?))))
+        (option '(#\b "bdw-gc") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'bdwgc-environment arg
+                              (alist-delete 'bdwgc-environment result
+                                            eq?))))
+        (option '(#\d "benchmark-dir") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'benchmark-directory arg
+                              (alist-delete 'benchmark-directory result
+                                            eq?))))
+        (option '(#\p "profile-options") #t #f
+                (lambda (opt name arg result)
+                  (let ((opts (assoc-ref result 'profile-options)))
+                    (alist-cons 'profile-options
+                                (string-append opts " " arg)
+                                (alist-delete 'profile-options result
+                                              eq?)))))
+        (option '(#\l "log-file") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'log-port (open-output-file arg)
+                              (alist-delete 'log-port result
+                                            eq?))))
+        (option '("raw") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'printer print-raw-result
+                              (alist-delete 'printer result eq?))))
+        (option '("load-results") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'load-results? #t result)))))
+
+(define %default-options
+  `((reference-environment . "GUILE=guile")
+    (benchmark-directory   . "./gc-benchmarks")
+    (log-port              . ,(current-output-port))
+    (profile-options       . "")
+    (input                 . ())
+    (printer               . ,pretty-print-result)))
+
+(define (show-help)
+  (format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS...
+Run BENCHMARKS (a list of Scheme files) and display a performance
+comparison of standard Guile (1.9) and the BDW-GC-based Guile.
+
+  -h, --help      Show this help message
+
+  -r, --reference=ENV
+  -b, --bdw-gc=ENV
+                  Use ENV as the environment necessary to run the
+                  \"reference\" Guile (1.9) or the BDW-GC-based Guile,
+                  respectively.  At a minimum, ENV should define the
+                  `GUILE' environment variable.  For example:
+
+                    --reference='GUILE=/foo/bar/guile LD_LIBRARY_PATH=/foo'
+
+  -p, --profile-options=OPTS
+                  Pass OPTS as additional options for `gc-profile.scm'.
+  -l, --log-file=FILE
+                  Save output to FILE instead of the standard output.
+
+      --raw       Write benchmark results in raw (s-exp) format.
+      --load-results
+                  Load raw (s-exp) results instead of actually running
+                  the benchmarks.
+
+  -d, --benchmark-dir=DIR
+                  Use DIR as the GC benchmark directory where `gc-profile.scm'
+                  lives (it is automatically determined by default).
+
+Report bugs to <bug-guile@gnu.org>.~%"))
+
+(define (parse-args args)
+  (define (leave fmt . args)
+    (apply format (current-error-port) (string-append fmt "~%") args)
+    (exit 1))
+
+  (args-fold args %options
+             (lambda (opt name arg result)
+               (leave "~A: unrecognized option" opt))
+             (lambda (file result)
+               (let ((files (or (assoc-ref result 'input) '())))
+                 (alist-cons 'input (cons file files)
+                             (alist-delete 'input result eq?))))
+             %default-options))
+
+
+;;;
+;;; The main program.
+;;;
+
+(define (main . args)
+  (let* ((args            (parse-args args))
+         (benchmark-files (assoc-ref args 'input)))
+
+    (let* ((log       (assoc-ref args 'log-port))
+           (bench-dir (assoc-ref args 'benchmark-directory))
+           (ref-env   (assoc-ref args 'reference-environment))
+           (bdwgc-env (or (assoc-ref args 'bdwgc-environment)
+                          (string-append "GUILE=" bench-dir
+                                         "/../meta/guile")))
+           (prof-opts (assoc-ref args 'profile-options))
+           (print     (assoc-ref args 'printer)))
+      (define (run benchmark)
+        (let ((ref   (parse-result (run-reference-guile ref-env
+                                                        bench-dir
+                                                        prof-opts
+                                                        benchmark)))
+              (bdwgc (map (lambda (fsd incremental?
+                                       generational? parallel?)
+                            (let ((opts
+                                   (list
+                                    (cons 'free-space-divisor fsd)
+                                    (cons 'incremental? incremental?)
+                                    (cons 'generational? generational?)
+                                    (cons 'parallel? parallel?))))
+                              (append opts
+                                      (parse-result
+                                       (run-bdwgc-guile bdwgc-env
+                                                        bench-dir
+                                                        prof-opts
+                                                        opts
+                                                        benchmark)))))
+                          '( 3  6  9  3  3)
+                          '(#f #f #f #t #f)      ;; incremental
+                          '(#f #f #f #f #t)      ;; generational
+                          '(#f #f #f #f #f))))   ;; parallel
+          `(,benchmark
+            (reference . ,ref)
+            (bdw-gc    . ,bdwgc))))
+
+      (define (load-results file)
+        (with-input-from-file file
+          (lambda ()
+            (let loop ((results '()) (o (read)))
+              (if (eof-object? o)
+                  (reverse results)
+                  (loop (cons o results)
+                        (read)))))))
+
+      (for-each (lambda (result)
+                  (let ((benchmark (car result))
+                        (ref       (assoc-ref (cdr result) 'reference))
+                        (bdwgc     (assoc-ref (cdr result) 'bdw-gc)))
+                    (with-output-to-port log
+                      (lambda ()
+                        (print benchmark ref bdwgc)
+                        (newline)
+                        (force-output)))))
+                (if (assoc-ref args 'load-results?)
+                    (append-map load-results benchmark-files)
+                    (map run benchmark-files))))))
+;;; From from http://www.ccs.neu.edu/home/will/Twobit/KVW/string.txt .
+; string test
+; (try 100000)
+
+(define s "abcdef")
+
+(define (grow)
+	(set! s (string-append "123" s "456" s "789"))
+	(set! s (string-append
+		(substring s (quotient (string-length s) 2) (string-length s))
+		(substring s 0 (+ 1 (quotient (string-length s) 2)))))
+	s)
+
+(define (trial n)
+	(do ((i 0 (+ i 1)))
+		((> (string-length s) n) (string-length s))
+		(grow)))
+
+(define (try n)
+	(do ((i 0 (+ i 1)))
+		((>= i 10) (string-length s))
+		(set! s "abcdef")
+		(trial n)))
+
+(try 50000000);;;; readline.scm --- support functions for command-line editing
+;;;;
+;;;; 	Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 3, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program 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 General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+;;;; 
+;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
+;;;; Extensions based upon code by
+;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
+
+
+
+(define-module (ice-9 readline)
+  #\use-module (ice-9 session)
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 buffered-input)
+  #\no-backtrace
+  #\export (filename-completion-function
+	    add-history
+	    read-history
+	    write-history
+	    clear-history))
+
+
+
+;;; Dynamically link the glue code for accessing the readline library,
+;;; but only when it isn't already present.
+
+(if (not (provided? 'readline))
+    (load-extension "libguilereadline-v-18" "scm_init_readline"))
+
+(if (not (provided? 'readline))
+    (scm-error 'misc-error
+	       #f
+	       "readline is not provided in this Guile installation"
+	       '()
+	       '()))
+
+
+
+;;; Run-time options
+
+(export
+ readline-options
+ readline-enable
+ readline-disable)
+(export-syntax
+ readline-set!)
+
+(define-option-interface
+  (readline-options-interface
+   (readline-options readline-enable readline-disable)
+   (readline-set!)))
+
+
+
+;;; MDJ 980513 <djurfeldt@nada.kth.se>:
+;;; There should probably be low-level support instead of this code.
+
+;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed,
+;;; guile will enter an endless loop or crash.
+
+(define-once new-input-prompt "")
+(define-once continuation-prompt "")
+(define-once input-port (current-input-port))
+(define-once output-port (current-output-port))
+(define-once read-hook #f)
+
+(define (make-readline-port)
+  (let ((history-buffer #f))
+    (make-line-buffered-input-port (lambda (continuation?)
+                                     ;; When starting a new read, add
+                                     ;; the previously read expression
+                                     ;; to the history.
+                                     (if (and (not continuation?)
+                                              history-buffer)
+                                         (begin
+                                           (add-history history-buffer)
+                                           (set! history-buffer #f)))
+                                     ;; Set up prompts and read a line.
+                                     (let* ((prompt (if continuation?
+                                                        continuation-prompt
+                                                        new-input-prompt))
+                                            (str (%readline (if (string? prompt)
+                                                                prompt
+                                                                (prompt))
+                                                            input-port
+                                                            output-port
+                                                            read-hook)))
+                                       (or (eof-object? str)
+                                           (string=? str "")
+                                           (set! history-buffer
+                                                 (if history-buffer
+                                                     (string-append history-buffer
+                                                                    "\n"
+                                                                    str)
+                                                     str)))
+                                       str)))))
+
+;;; We only create one readline port.  There's no point in having
+;;; more, since they would all share the tty and history ---
+;;; everything except the prompt.  And don't forget the
+;;; compile/load/run phase distinctions.  Also, the readline library
+;;; isn't reentrant.
+(define-once the-readline-port #f)
+
+(define-once history-variable "GUILE_HISTORY")
+(define-once history-file
+  (string-append (or (getenv "HOME") ".") "/.guile_history"))
+
+(define-public readline-port
+  (let ((do (lambda (r/w)
+	      (if (memq 'history-file (readline-options-interface))
+		  (r/w (or (getenv history-variable)
+			   history-file))))))
+    (lambda ()
+      (if (not the-readline-port)
+	  (begin
+	    (do read-history) 
+	    (set! the-readline-port (make-readline-port))
+	    (add-hook! exit-hook (lambda () 
+				   (do write-history)
+				   (clear-history)))))
+      the-readline-port)))
+
+;;; The user might try to use readline in his programs.  It then
+;;; becomes very uncomfortable that the current-input-port is the
+;;; readline port...
+;;;
+;;; Here, we detect this situation and replace it with the
+;;; underlying port.
+;;;
+;;; %readline is the low-level readline procedure.
+
+(define-public (readline . args)
+  (let ((prompt new-input-prompt)
+	(inp input-port))
+    (cond ((not (null? args))
+	   (set! prompt (car args))
+	   (set! args (cdr args))
+	   (cond ((not (null? args))
+		  (set! inp (car args))
+		  (set! args (cdr args))))))
+    (apply %readline
+	   prompt
+	   (if (eq? inp the-readline-port)
+	       input-port
+	       inp)
+	   args)))
+
+(define-public (set-readline-prompt! p . rest)
+  (set! new-input-prompt p)
+  (if (not (null? rest))
+      (set! continuation-prompt (car rest))))
+
+(define-public (set-readline-input-port! p)
+  (cond ((or (not (file-port? p)) (not (input-port? p)))
+	 (scm-error 'wrong-type-arg "set-readline-input-port!"
+		    "Not a file input port: ~S" (list p) #f))
+	((port-closed? p)
+	 (scm-error 'misc-error "set-readline-input-port!"
+		    "Port not open: ~S" (list p) #f))
+	(else
+	 (set! input-port p))))
+
+(define-public (set-readline-output-port! p)
+  (cond ((or (not (file-port? p)) (not (output-port? p)))
+	 (scm-error 'wrong-type-arg "set-readline-input-port!"
+		    "Not a file output port: ~S" (list p) #f))
+	((port-closed? p)
+	 (scm-error 'misc-error "set-readline-output-port!"
+		    "Port not open: ~S" (list p) #f))
+	(else
+	 (set! output-port p))))
+
+(define-public (set-readline-read-hook! h)
+  (set! read-hook h))
+
+(define-public apropos-completion-function
+  (let ((completions '()))
+    (lambda (text cont?)
+      (if (not cont?)
+          (set! completions
+                (map symbol->string
+                     (apropos-internal
+                      (string-append "^" (regexp-quote text))))))
+      (if (null? completions)
+          #f
+          (let ((retval (car completions)))
+            (begin (set! completions (cdr completions))
+                   retval))))))
+
+(if (provided? 'regex)
+    (set! *readline-completion-function* apropos-completion-function))
+
+(define-public (with-readline-completion-function completer thunk)
+  "With @var{completer} as readline completion function, call @var{thunk}."
+  (let ((old-completer *readline-completion-function*))
+    (dynamic-wind
+	(lambda ()
+	  (set! *readline-completion-function* completer))
+	thunk
+	(lambda ()
+	  (set! *readline-completion-function* old-completer)))))
+
+(define-once readline-repl-reader
+  (let ((boot-9-repl-reader repl-reader))
+    (lambda* (repl-prompt #\optional (reader (fluid-ref current-reader)))
+      (let ((port (current-input-port)))
+        (if (eq? port (readline-port))
+            (let ((outer-new-input-prompt new-input-prompt)
+                  (outer-continuation-prompt continuation-prompt)
+                  (outer-read-hook read-hook))
+              (dynamic-wind
+                (lambda ()
+                  (set-buffered-input-continuation?! port #f)
+                  (set-readline-prompt! repl-prompt "... ")
+                  (set-readline-read-hook! (lambda ()
+                                             (run-hook before-read-hook))))
+                (lambda () ((or reader read) port))
+                (lambda ()
+                  (set-readline-prompt! outer-new-input-prompt
+                                        outer-continuation-prompt)
+                  (set-readline-read-hook! outer-read-hook))))
+            (boot-9-repl-reader repl-prompt reader))))))
+
+(define-public (activate-readline)
+  (if (isatty? (current-input-port))
+      (begin
+        (set-current-input-port (readline-port))
+        (set! repl-reader readline-repl-reader)
+        (set! (using-readline?) #t))))
+
+(define-public (make-completion-function strings)
+  "Construct and return a completion function for a list of strings.
+The returned function is suitable for passing to
+@code{with-readline-completion-function.  The argument @var{strings}
+should be a list of strings, where each string is one of the possible
+completions."
+  (letrec ((strs '())
+	   (regexp #f)
+	   (completer (lambda (text continue?)
+			(if continue?
+			    (if (null? strs)
+				#f
+				(let ((str (car strs)))
+				  (set! strs (cdr strs))
+				  (if (string-match regexp str)
+				      str
+				      (completer text #t))))
+			    (begin
+			      (set! strs strings)
+			      (set! regexp
+				    (string-append "^" (regexp-quote text)))
+			      (completer text #t))))))
+    completer))
+;;; GDB debugging support for Guile.
+;;;
+;;; Copyright 2014, 2015 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guile-gdb)
+  #\use-module (system base types)
+  #\use-module ((gdb) #\hide (symbol?))
+  #\use-module (gdb printing)
+  #\use-module (srfi srfi-11)
+  #\use-module (ice-9 match)
+  #\export (%gdb-memory-backend
+            display-vm-frames))
+
+;;; Commentary:
+;;;
+;;; This file defines GDB extensions to pretty-print 'SCM' objects, and
+;;; to walk Guile's virtual machine stack.
+;;;
+;;; This file is installed under a name that follows the convention that
+;;; allows GDB to auto-load it anytime the user is debugging libguile
+;;; (info "(gdb) objfile-gdbdotext file").
+;;;
+;;; Code:
+
+(define (type-name-from-descriptor descriptor-array type-number)
+  "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f
+if the information is not available."
+  (let ((descriptors (lookup-global-symbol descriptor-array)))
+    (and descriptors
+         (let ((code (type-code (symbol-type descriptors))))
+           (or (= TYPE_CODE_ARRAY code)
+               (= TYPE_CODE_PTR code)))
+         (let* ((type-descr (value-subscript (symbol-value descriptors)
+                                             type-number))
+                (name       (value-field type-descr "name")))
+           (value->string name)))))
+
+(define (scm-value->integer value)
+  "Return the integer value of VALUE, which is assumed to be a GDB value
+corresponding to an 'SCM' object."
+  (let ((type (type-strip-typedefs (value-type value))))
+    (cond ((= (type-code type) TYPE_CODE_UNION)
+           ;; SCM_DEBUG_TYPING_STRICTNESS = 2
+           (value->integer (value-field (value-field value "n")
+                                        "n")))
+          (else
+           ;; SCM_DEBUG_TYPING_STRICTNESS = 1
+           (value->integer value)))))
+
+(define %gdb-memory-backend
+  ;; The GDB back-end to access the inferior's memory.
+  (let ((void* (type-pointer (lookup-type "void"))))
+    (define (dereference-word address)
+      ;; Return the word at ADDRESS.
+      (value->integer
+       (value-dereference (value-cast (make-value address)
+                                      (type-pointer void*)))))
+
+    (define (open address size)
+      ;; Return a port to the SIZE bytes starting at ADDRESS.
+      (if size
+          (open-memory #\start address #\size size)
+          (open-memory #\start address)))
+
+    (define (type-name kind number)
+      ;; Return the type name of KIND type NUMBER.
+      (type-name-from-descriptor (case kind
+                                   ((smob) "scm_smobs")
+                                   ((port) "scm_ptobs"))
+                                 number))
+
+    (memory-backend dereference-word open type-name)))
+
+
+;;;
+;;; GDB pretty-printer registration.
+;;;
+
+(define (make-scm-pretty-printer-worker obj)
+  (define (list->iterator list)
+    (make-iterator list list
+                   (let ((n 0))
+                     (lambda (iter)
+                       (match (iterator-progress iter)
+                         (() (end-of-iteration))
+                         ((elt . list)
+                          (set-iterator-progress! iter list)
+                          (let ((name (format #f "[~a]" n)))
+                            (set! n (1+ n))
+                            (cons name (object->string elt)))))))))
+  (cond
+   ((string? obj)
+    (make-pretty-printer-worker
+     "string" ; display hint
+     (lambda (printer) obj)
+     #f))
+   ((and (array? obj)
+         (match (array-shape obj)
+           (((0 _)) #t)
+           (_ #f)))
+    (make-pretty-printer-worker
+     "array" ; display hint
+     (lambda (printer)
+       (let ((tag (array-type obj)))
+         (case tag
+           ((#t) "#<vector>")
+           ((b) "#<bitvector>")
+           (else (format #f "#<~avector>" tag)))))
+     (lambda (printer)
+       (list->iterator (array->list obj)))))
+   ((inferior-struct? obj)
+    (make-pretty-printer-worker
+     "array" ; display hint
+     (lambda (printer)
+       (format #f "#<struct ~a>" (inferior-struct-name obj)))
+     (lambda (printer)
+       (list->iterator (inferior-struct-fields obj)))))
+   (else
+    (make-pretty-printer-worker
+     #f                                 ; display hint
+     (lambda (printer)
+       (object->string obj))
+     #f))))
+
+(define %scm-pretty-printer
+  (make-pretty-printer
+   "SCM"
+   (lambda (pp value)
+     (let ((name (type-name (value-type value))))
+       (and (and name (string=? name "SCM"))
+            (make-scm-pretty-printer-worker
+             (scm->object (scm-value->integer value) %gdb-memory-backend)))))))
+
+(define* (register-pretty-printer #\optional objfile)
+  (prepend-pretty-printer! objfile %scm-pretty-printer))
+
+(register-pretty-printer)
+
+
+;;;
+;;; VM stack walking.
+;;;
+
+(define (find-vm-engine-frame)
+  "Return the bottom-most frame containing a call to the VM engine."
+  (define (vm-engine-frame? frame)
+    (let ((sym (frame-function frame)))
+      (and sym
+           (member (symbol-name sym)
+                   '("vm_debug_engine" "vm_regular_engine")))))
+
+  (let loop ((frame (newest-frame)))
+    (and frame
+         (if (vm-engine-frame? frame)
+             frame
+             (loop (frame-older frame))))))
+
+(define (vm-stack-pointer)
+  "Return the current value of the VM stack pointer or #f."
+  (let ((frame (find-vm-engine-frame)))
+    (and frame
+         (frame-read-var frame "sp"))))
+
+(define (vm-frame-pointer)
+  "Return the current value of the VM frame pointer or #f."
+  (let ((frame (find-vm-engine-frame)))
+    (and frame
+         (frame-read-var frame "fp"))))
+
+(define* (display-vm-frames #\optional (port (current-output-port)))
+  "Display the VM frames on PORT."
+  (define (display-objects start end)
+    ;; Display all the objects (arguments and local variables) located
+    ;; between START and END.
+    (let loop ((number  0)
+               (address start))
+      (when (and (> start 0) (<= address end))
+        (let ((object (dereference-word %gdb-memory-backend address)))
+          ;; TODO: Push onto GDB's value history.
+          (format port "  slot ~a -> ~s~%"
+                  number (scm->object object %gdb-memory-backend)))
+        (loop (+ 1 number) (+ address %word-size)))))
+
+  (let loop ((number 0)
+             (sp     (value->integer (vm-stack-pointer)))
+             (fp     (value->integer (vm-frame-pointer))))
+    (unless (zero? fp)
+      (let-values (((ra mvra link proc)
+                    (vm-frame fp %gdb-memory-backend)))
+        (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend))
+        (display-objects fp sp)
+        (loop (+ 1 number) (- fp (* 5 %word-size)) link)))))
+
+;; See libguile/frames.h.
+(define* (vm-frame fp #\optional (backend %gdb-memory-backend))
+  "Return the components of the stack frame at FP."
+  (let ((caller (dereference-word backend (- fp %word-size)))
+        (ra     (dereference-word backend (- fp (* 2 %word-size))))
+        (mvra   (dereference-word backend (- fp (* 3 %word-size))))
+        (link   (dereference-word backend (- fp (* 4 %word-size)))))
+    (values ra mvra link caller)))
+
+;;; libguile-2.0-gdb.scm ends here
+;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
+;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013,
+;;;;   2015 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 and-let-star)
+  \:export-syntax (and-let*))
+
+(define-syntax %and-let*
+  (lambda (form)
+    (syntax-case form ()
+
+      ;; Handle zero-clauses special-case.
+      ((_ orig-form () . body)
+       #'(begin #t . body))
+
+      ;; Reduce clauses down to one regardless of body.
+      ((_ orig-form ((var expr) rest . rest*) . body)
+       (identifier? #'var)
+       #'(let ((var expr))
+           (and var (%and-let* orig-form (rest . rest*) . body))))
+      ((_ orig-form ((expr) rest . rest*) . body)
+       #'(and expr (%and-let* orig-form (rest . rest*) . body)))
+      ((_ orig-form (var rest . rest*) . body)
+       (identifier? #'var)
+       #'(and var (%and-let* orig-form (rest . rest*) . body)))
+
+      ;; Handle 1-clause cases without a body.
+      ((_ orig-form ((var expr)))
+       (identifier? #'var)
+       #'expr)
+      ((_ orig-form ((expr)))
+       #'expr)
+      ((_ orig-form (var))
+       (identifier? #'var)
+       #'var)
+
+      ;; Handle 1-clause cases with a body.
+      ((_ orig-form ((var expr)) . body)
+       (identifier? #'var)
+       #'(let ((var expr))
+           (and var (begin . body))))
+      ((_ orig-form ((expr)) . body)
+       #'(and expr (begin . body)))
+      ((_ orig-form (var) . body)
+       (identifier? #'var)
+       #'(and var (begin . body)))
+
+      ;; Handle bad clauses.
+      ((_ orig-form (bad-clause . rest) . body)
+       (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
+
+(define-syntax and-let*
+  (lambda (form)
+    (syntax-case form ()
+      ((_ (c ...) body ...)
+       #`(%and-let* #,form (c ...) body ...)))))
+
+(cond-expand-provide (current-module) '(srfi-2))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2001, 2004, 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 (array-shape a)
+  (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+       (array-dimensions a)))
+;;;; binary-ports.scm --- Binary IO on ports
+
+;;;;	Copyright (C) 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module.  In many areas
+;;; it complements or refines Guile's own historical port API.  For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(define-module (ice-9 binary-ports)
+  #\use-module (rnrs bytevectors)
+  #\export (eof-object
+            open-bytevector-input-port
+            make-custom-binary-input-port
+            get-u8
+            lookahead-u8
+            get-bytevector-n
+            get-bytevector-n!
+            get-bytevector-some
+            get-bytevector-all
+            get-string-n!
+            put-u8
+            put-bytevector
+            unget-bytevector
+            open-bytevector-output-port
+            make-custom-binary-output-port))
+
+;; Note that this extension also defines %make-transcoded-port, which is
+;; not exported but is used by (rnrs io ports).
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_r6rs_ports")
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 1995-2014, 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:
+
+;;; This file is the first thing loaded into Guile.  It adds many mundane
+;;; definitions and a few that are interesting.
+;;;
+;;; The module system (hence the hierarchical namespace) are defined in this
+;;; file.
+;;;
+
+;;; Code:
+
+
+
+;; Before compiling, make sure any symbols are resolved in the (guile)
+;; module, the primary location of those symbols, rather than in
+;; (guile-user), the default module that we compile in.
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
+;; Prevent this file being loaded more than once in a session.  Just
+;; doesn't make sense!
+(if (current-module)
+    (error "re-loading ice-9/boot-9.scm not allowed"))
+
+
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define make-prompt-tag
+  (lambda* (#\optional (stem "prompt"))
+    (gensym stem)))
+
+(define default-prompt-tag
+  ;; not sure if we should expose this to the user as a fluid
+  (let ((%default-prompt-tag (make-prompt-tag)))
+    (lambda ()
+      %default-prompt-tag)))
+
+(define (call-with-prompt tag thunk handler)
+  (@prompt tag (thunk) handler))
+(define (abort-to-prompt tag . args)
+  (@abort tag args))
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(define with-throw-handler #f)
+(let ()
+  (define (default-exception-handler k . args)
+    (cond
+     ((eq? k 'quit)
+      (primitive-exit (cond
+                       ((not (pair? args)) 0)
+                       ((integer? (car args)) (car args))
+                       ((not (car args)) 1)
+                       (else 0))))
+     (else
+      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+      (primitive-exit 1))))
+
+  (define %running-exception-handlers (make-fluid '()))
+  (define %exception-handler (make-fluid default-exception-handler))
+
+  (define (default-throw-handler prompt-tag catch-k)
+    (let ((prev (fluid-ref %exception-handler)))
+      (lambda (thrown-k . args)
+        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+            (apply abort-to-prompt prompt-tag thrown-k args)
+            (apply prev thrown-k args)))))
+
+  (define (custom-throw-handler prompt-tag catch-k pre)
+    (let ((prev (fluid-ref %exception-handler)))
+      (lambda (thrown-k . args)
+        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+            (let ((running (fluid-ref %running-exception-handlers)))
+              (with-fluids ((%running-exception-handlers (cons pre running)))
+                (if (not (memq pre running))
+                    (apply pre thrown-k args))
+                ;; fall through
+                (if prompt-tag
+                    (apply abort-to-prompt prompt-tag thrown-k args)
+                    (apply prev thrown-k args))))
+            (apply prev thrown-k args)))))
+
+  (set! catch
+        (lambda* (k thunk handler #\optional pre-unwind-handler)
+          "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}.  If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments.  If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}.  @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}.  It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler.  If it exits
+non-locally, that exit determines the continuation."
+          (if (not (or (symbol? k) (eqv? k #t)))
+              (scm-error 'wrong-type-arg "catch"
+                         "Wrong type argument in position ~a: ~a"
+                         (list 1 k) (list k)))
+          (let ((tag (make-prompt-tag "catch")))
+            (call-with-prompt
+             tag
+             (lambda ()
+               (with-fluids
+                   ((%exception-handler
+                     (if pre-unwind-handler
+                         (custom-throw-handler tag k pre-unwind-handler)
+                         (default-throw-handler tag k))))
+                 (thunk)))
+             (lambda (cont k . args)
+               (apply handler k args))))))
+
+  (set! with-throw-handler
+        (lambda (k thunk pre-unwind-handler)
+          "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+          (if (not (or (symbol? k) (eqv? k #t)))
+              (scm-error 'wrong-type-arg "with-throw-handler"
+                         "Wrong type argument in position ~a: ~a"
+                         (list 1 k) (list k)))
+          (with-fluids ((%exception-handler
+                         (custom-throw-handler #f k pre-unwind-handler)))
+            (thunk))))
+
+  (set! throw
+        (lambda (key . args)
+          "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+          (if (not (symbol? key))
+              ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
+               "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+              (apply (fluid-ref %exception-handler) key args)))))
+
+
+
+;;; Boot versions of `map' and `for-each', enough to get the expander
+;;; running, and get the "map" used in eval.scm for with-fluids to work.
+;;;
+(define map
+  (case-lambda
+    ((f l)
+     (let map1 ((l l))
+       (if (null? l)
+           '()
+           (cons (f (car l)) (map1 (cdr l))))))
+    ((f l1 l2)
+     (let map2 ((l1 l1) (l2 l2))
+       (if (null? l1)
+           '()
+           (cons (f (car l1) (car l2))
+                 (map2 (cdr l1) (cdr l2))))))
+    ((f l1 . rest)
+     (let lp ((l1 l1) (rest rest))
+       (if (null? l1)
+           '()
+           (cons (apply f (car l1) (map car rest))
+                 (lp (cdr l1) (map cdr rest))))))))
+
+(define for-each
+  (case-lambda
+    ((f l)
+     (let for-each1 ((l l))
+       (if (pair? l)
+           (begin
+             (f (car l))
+             (for-each1 (cdr l))))))
+    ((f l1 l2)
+     (let for-each2 ((l1 l1) (l2 l2))
+       (if (pair? l1)
+           (begin
+             (f (car l1) (car l2))
+             (for-each2 (cdr l1) (cdr l2))))))
+    ((f l1 . rest)
+     (let lp ((l1 l1) (rest rest))
+       (if (pair? l1)
+           (begin
+             (apply f (car l1) (map car rest))
+             (lp (cdr l1) (map cdr rest))))))))
+
+
+
+;;; {R4RS compliance}
+;;;
+
+(primitive-load-path "ice-9/r4rs")
+
+
+
+;;; {Simple Debugging Tools}
+;;;
+
+;; peek takes any number of arguments, writes them to the
+;; current ouput port, and returns the last argument.
+;; It is handy to wrap around an expression to look at
+;; a value each time is evaluated, e.g.:
+;;
+;;      (+ 10 (troublesome-fn))
+;;      => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;;
+
+(define (peek . stuff)
+  (newline)
+  (display ";;; ")
+  (write stuff)
+  (newline)
+  (car (last-pair stuff)))
+
+(define pk peek)
+
+(define (warn . stuff)
+  (with-output-to-port (current-warning-port)
+    (lambda ()
+      (newline)
+      (display ";;; WARNING ")
+      (display stuff)
+      (newline)
+      (car (last-pair stuff)))))
+
+
+
+;;; {Features}
+;;;
+
+(define (provide sym)
+  (if (not (memq sym *features*))
+      (set! *features* (cons sym *features*))))
+
+;; Return #t iff FEATURE is available to this Guile interpreter.  In SLIB,
+;; provided? also checks to see if the module is available.  We should do that
+;; too, but don't.
+
+(define (provided? feature)
+  (and (memq feature *features*) #t))
+
+
+
+;;; {Structs}
+;;;
+
+(define (make-struct/no-tail vtable . args)
+  (apply make-struct vtable 0 args))
+
+
+
+;; Temporary definition used in the include-from-path expansion;
+;; replaced later.
+
+(define (absolute-file-name? file-name)
+  #t)
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f.  Otherwise, return the last value returned
+;; by f.  If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+  (let loop ((result #t)
+             (l lst))
+    (and result
+         (or (and (null? l)
+                  result)
+             (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+  (let loop ((result #f)
+             (l lst))
+    (or result
+        (and (not (null? l))
+             (loop (f (car l)) (cdr l))))))
+
+
+
+;; let format alias simple-format until the more complete version is loaded
+
+(define format simple-format)
+
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define string-any
+  (lambda* (char_pred s #\optional (start 0) (end (string-length s)))
+    (if (and (procedure? char_pred)
+             (> end start)
+             (<= end (string-length s))) ;; let c-code handle range error
+        (or (string-any-c-code char_pred s start (1- end))
+            (char_pred (string-ref s (1- end))))
+        (string-any-c-code char_pred s start end))))
+
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define string-every
+  (lambda* (char_pred s #\optional (start 0) (end (string-length s)))
+    (if (and (procedure? char_pred)
+             (> end start)
+             (<= end (string-length s))) ;; let c-code handle range error
+        (and (string-every-c-code char_pred s start (1- end))
+             (char_pred (string-ref s (1- end))))
+        (string-every-c-code char_pred s start end))))
+
+;; A variant of string-fill! that we keep for compatability
+;;
+(define (substring-fill! str start end fill)
+  (string-fill! str fill start end))
+
+
+
+;; Define a minimal stub of the module API for psyntax, before modules
+;; have booted.
+(define (module-name x)
+  '(guile))
+(define (module-add! module sym var)
+  (hashq-set! (%get-pre-modules-obarray) sym var))
+(define (module-define! module sym val)
+  (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
+    (if v
+        (variable-set! v val)
+        (module-add! (current-module) sym (make-variable val)))))
+(define (module-ref module sym)
+  (let ((v (module-variable module sym)))
+    (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
+(define module-generate-unique-id!
+  (let ((next-id 0))
+    (lambda (m)
+      (let ((i next-id))
+        (set! next-id (+ i 1))
+        i))))
+(define module-gensym gensym)
+(define (resolve-module . args)
+  #f)
+
+;; API provided by psyntax
+(define syntax-violation #f)
+(define datum->syntax #f)
+(define syntax->datum #f)
+(define syntax-source #f)
+(define identifier? #f)
+(define generate-temporaries #f)
+(define bound-identifier=? #f)
+(define free-identifier=? #f)
+
+;; $sc-dispatch is an implementation detail of psyntax. It is used by
+;; expanded macros, to dispatch an input against a set of patterns.
+(define $sc-dispatch #f)
+
+;; Load it up!
+(primitive-load-path "ice-9/psyntax-pp")
+;; The binding for `macroexpand' has now been overridden, making psyntax the
+;; expander now.
+
+(define-syntax and
+  (syntax-rules ()
+    ((_) #t)
+    ((_ x) x)
+    ;; Avoid ellipsis, which would lead to quadratic expansion time.
+    ((_ x . y) (if x (and . y) #f))))
+
+(define-syntax or
+  (syntax-rules ()
+    ((_) #f)
+    ((_ x) x)
+    ;; Avoid ellipsis, which would lead to quadratic expansion time.
+    ((_ x . y) (let ((t x)) (if t t (or . y))))))
+
+(include-from-path "ice-9/quasisyntax")
+
+(define-syntax-rule (when test stmt stmt* ...)
+  (if test (begin stmt stmt* ...)))
+
+(define-syntax-rule (unless test stmt stmt* ...)
+  (if (not test) (begin stmt stmt* ...)))
+
+(define-syntax cond
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (reverse-map f xs)
+      (fold (lambda (x seed) (cons (f x) seed))
+            '() xs))
+    (syntax-case whole-expr ()
+      ((_ clause clauses ...)
+       #`(begin
+           #,@(fold (lambda (clause-builder tail)
+                      (clause-builder tail))
+                    #'()
+                    (reverse-map
+                     (lambda (clause)
+                       (define* (bad-clause #\optional (msg "invalid clause"))
+                         (syntax-violation 'cond msg whole-expr clause))
+                       (syntax-case clause (=> else)
+                         ((else e e* ...)
+                          (lambda (tail)
+                            (if (null? tail)
+                                #'((begin e e* ...))
+                                (bad-clause "else must be the last clause"))))
+                         ((else . _) (bad-clause))
+                         ((test => receiver)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t
+                                     (receiver t)
+                                     #,@tail)))))
+                         ((test => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((generator guard => receiver)
+                          (lambda (tail)
+                            #`((call-with-values (lambda () generator)
+                                 (lambda vals
+                                   (if (apply guard vals)
+                                       (apply receiver vals)
+                                       #,@tail))))))
+                         ((generator guard => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((test)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t t #,@tail)))))
+                         ((test e e* ...)
+                          (lambda (tail)
+                            #`((if test
+                                   (begin e e* ...)
+                                   #,@tail))))
+                         (_ (bad-clause))))
+                     #'(clause clauses ...))))))))
+
+(define-syntax case
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (fold2 f a b xs)
+      (let loop ((xs xs) (a a) (b b))
+        (if (null? xs) (values a b)
+            (call-with-values
+                (lambda () (f (car xs) a b))
+              (lambda (a b)
+                (loop (cdr xs) a b))))))
+    (define (reverse-map-with-seed f seed xs)
+      (fold2 (lambda (x ys seed)
+               (call-with-values
+                   (lambda () (f x seed))
+                 (lambda (y seed)
+                   (values (cons y ys) seed))))
+             '() seed xs))
+    (syntax-case whole-expr ()
+      ((_ expr clause clauses ...)
+       (with-syntax ((key #'key))
+         #`(let ((key expr))
+             #,@(fold
+                 (lambda (clause-builder tail)
+                   (clause-builder tail))
+                 #'()
+                 (reverse-map-with-seed
+                  (lambda (clause seen)
+                    (define* (bad-clause #\optional (msg "invalid clause"))
+                      (syntax-violation 'case msg whole-expr clause))
+                    (syntax-case clause ()
+                      ((test . rest)
+                       (with-syntax
+                           ((clause-expr
+                             (syntax-case #'rest (=>)
+                               ((=> receiver) #'(receiver key))
+                               ((=> receiver ...)
+                                (bad-clause
+                                 "wrong number of receiver expressions"))
+                               ((e e* ...) #'(begin e e* ...))
+                               (_ (bad-clause)))))
+                         (syntax-case #'test (else)
+                           ((datums ...)
+                            (let ((seen
+                                   (fold
+                                    (lambda (datum seen)
+                                      (define (warn-datum type)
+                                        ((@ (system base message)
+                                            warning)
+                                         type
+                                         (append (source-properties datum)
+                                                 (source-properties
+                                                  (syntax->datum #'test)))
+                                         datum
+                                         (syntax->datum clause)
+                                         (syntax->datum whole-expr)))
+                                      (when (memv datum seen)
+                                        (warn-datum 'duplicate-case-datum))
+                                      (when (or (pair? datum) (array? datum))
+                                        (warn-datum 'bad-case-datum))
+                                      (cons datum seen))
+                                    seen
+                                    (map syntax->datum #'(datums ...)))))
+                              (values (lambda (tail)
+                                        #`((if (memv key '(datums ...))
+                                               clause-expr
+                                               #,@tail)))
+                                      seen)))
+                           (else (values (lambda (tail)
+                                           (if (null? tail)
+                                               #'(clause-expr)
+                                               (bad-clause
+                                                "else must be the last clause")))
+                                         seen))
+                           (_ (bad-clause)))))
+                      (_ (bad-clause))))
+                  '() #'(clause clauses ...)))))))))
+
+(define-syntax do
+  (syntax-rules ()
+    ((do ((var init step ...) ...)
+         (test expr ...)
+         command ...)
+     (letrec
+       ((loop
+         (lambda (var ...)
+           (if test
+               (begin
+                 (if #f #f)
+                 expr ...)
+               (begin
+                 command
+                 ...
+                 (loop (do "step" var step ...)
+                       ...))))))
+       (loop init ...)))
+    ((do "step" x)
+     x)
+    ((do "step" x y)
+     y)))
+
+;; XXX FIXME: When 'call-with-values' is fixed to no longer do automatic
+;;     truncation of values (in 2.2 ?), then this hack can be removed.
+(define (%define-values-arity-error)
+  (throw 'wrong-number-of-args
+         #f
+         "define-values: wrong number of return values returned by expression"
+         '()
+         #f))
+
+(define-syntax define-values
+  (lambda (orig-form)
+    (syntax-case orig-form ()
+      ((_ () expr)
+       ;; XXX Work around the lack of hygienic top-level identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(define dummy
+             (call-with-values (lambda () expr)
+               (case-lambda
+                 (() #f)
+                 (_ (%define-values-arity-error)))))))
+      ((_ (var) expr)
+       (identifier? #'var)
+       #`(define var
+           (call-with-values (lambda () expr)
+             (case-lambda
+               ((v) v)
+               (_ (%define-values-arity-error))))))
+      ((_ (var0 ... varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       ;; XXX Work around the lack of hygienic toplevel identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(begin
+             ;; Avoid mutating the user-visible variables
+             (define dummy
+               (call-with-values (lambda () expr)
+                 (case-lambda
+                   ((var0 ... varn)
+                    (list var0 ... varn))
+                   (_ (%define-values-arity-error)))))
+             (define var0
+               (let ((v (car dummy)))
+                 (set! dummy (cdr dummy))
+                 v))
+             ...
+             (define varn
+               (let ((v (car dummy)))
+                 (set! dummy #f)  ; blackhole dummy
+                 v)))))
+      ((_ var expr)
+       (identifier? #'var)
+       #'(define var
+           (call-with-values (lambda () expr)
+             list)))
+      ((_ (var0 ... . varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       ;; XXX Work around the lack of hygienic toplevel identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(begin
+             ;; Avoid mutating the user-visible variables
+             (define dummy
+               (call-with-values (lambda () expr)
+                 (case-lambda
+                   ((var0 ... . varn)
+                    (list var0 ... varn))
+                   (_ (%define-values-arity-error)))))
+             (define var0
+               (let ((v (car dummy)))
+                 (set! dummy (cdr dummy))
+                 v))
+             ...
+             (define varn
+               (let ((v (car dummy)))
+                 (set! dummy #f)  ; blackhole dummy
+                 v))))))))
+
+(define-syntax-rule (delay exp)
+  (make-promise (lambda () exp)))
+
+(define-syntax current-source-location
+  (lambda (x)
+    (syntax-case x ()
+      ((_)
+       (with-syntax ((s (datum->syntax x (syntax-source x))))
+         #''s)))))
+
+;; We provide this accessor out of convenience.  current-line and
+;; current-column aren't so interesting, because they distort what they
+;; are measuring; better to use syntax-source from a macro.
+;;
+(define-syntax current-filename
+  (lambda (x)
+    "A macro that expands to the current filename: the filename that
+the (current-filename) form appears in.  Expands to #f if this
+information is unavailable."
+    (false-if-exception
+     (canonicalize-path (assq-ref (syntax-source x) 'filename)))))
+
+(define-syntax-rule (define-once sym val)
+  (define sym
+    (if (module-locally-bound? (current-module) 'sym) sym val)))
+
+;;; The real versions of `map' and `for-each', with cycle detection, and
+;;; that use reverse! instead of recursion in the case of `map'.
+;;;
+(define map
+  (case-lambda
+    ((f l)
+     (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+       (if (pair? hare)
+           (if move?
+               (if (eq? tortoise hare)
+                   (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                              (list l) #f)
+                   (map1 (cdr hare) (cdr tortoise) #f
+                       (cons (f (car hare)) out)))
+               (map1 (cdr hare) tortoise #t
+                     (cons (f (car hare)) out)))
+           (if (null? hare)
+               (reverse! out)
+               (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                          (list l) #f)))))
+    
+    ((f l1 l2)
+     (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
+       (cond
+        ((pair? h1)
+         (cond
+          ((not (pair? h2))
+           (scm-error 'wrong-type-arg "map"
+                      (if (list? h2)
+                          "List of wrong length: ~S"
+                          "Not a list: ~S")
+                      (list l2) #f))
+          ((not move?)
+           (map2 (cdr h1) (cdr h2) t1 t2 #t
+                 (cons (f (car h1) (car h2)) out)))
+          ((eq? t1 h1)
+           (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                      (list l1) #f))
+          ((eq? t2 h2)
+           (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                      (list l2) #f))
+          (else
+           (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
+                 (cons (f (car h1) (car h2)) out)))))
+
+        ((and (null? h1) (null? h2))
+         (reverse! out))
+        
+        ((null? h1)
+         (scm-error 'wrong-type-arg "map"
+                    (if (list? h2)
+                        "List of wrong length: ~S"
+                        "Not a list: ~S")
+                    (list l2) #f))
+        (else
+         (scm-error 'wrong-type-arg "map"
+                    "Not a list: ~S"
+                    (list l1) #f)))))
+
+    ((f l1 . rest)
+     (let ((len (length l1)))
+       (let mapn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (mapn (cdr rest))
+                 (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+     (let mapn ((l1 l1) (rest rest) (out '()))
+       (if (null? l1)
+           (reverse! out)
+           (mapn (cdr l1) (map cdr rest)
+                 (cons (apply f (car l1) (map car rest)) out)))))))
+
+(define map-in-order map)
+
+(define for-each
+  (case-lambda
+    ((f l)
+     (let for-each1 ((hare l) (tortoise l))
+       (if (pair? hare)
+           (begin
+             (f (car hare))
+             (let ((hare (cdr hare)))
+               (if (pair? hare)
+                   (begin
+                     (when (eq? tortoise hare)
+                       (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                                  (list l) #f))
+                     (f (car hare))
+                     (for-each1 (cdr hare) (cdr tortoise))))))
+           (if (not (null? hare))
+               (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+                          (list l) #f)))))
+
+    ((f l1 l2)
+     (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
+       (cond
+        ((and (pair? h1) (pair? h2))
+         (cond
+          ((not move?)
+           (f (car h1) (car h2))
+           (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
+          ((eq? t1 h1)
+           (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                      (list l1) #f))
+          ((eq? t2 h2)
+           (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                      (list l2) #f))
+          (else
+           (f (car h1) (car h2))
+           (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
+
+        ((if (null? h1)
+             (or (null? h2) (pair? h2))
+             (and (pair? h1) (null? h2)))
+         (if #f #f))
+        
+        ((list? h1)
+         (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+                    (list h2) #f))
+        (else
+         (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+                    (list h1) #f)))))
+
+    ((f l1 . rest)
+     (let ((len (length l1)))
+       (let for-eachn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (for-eachn (cdr rest))
+                 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+     
+     (let for-eachn ((l1 l1) (rest rest))
+       (if (pair? l1)
+           (begin
+             (apply f (car l1) (map car rest))
+             (for-eachn (cdr l1) (map cdr rest))))))))
+
+
+
+
+;;;
+;;; Enhanced file opening procedures
+;;;
+
+(define* (open-input-file
+          file #\key (binary #f) (encoding #f) (guess-encoding #f))
+  "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file.  If the file
+cannot be opened, an error is signalled."
+  (open-file file (if binary "rb" "r")
+             #\encoding encoding
+             #\guess-encoding guess-encoding))
+
+(define* (open-output-file file #\key (binary #f) (encoding #f))
+  "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name.  If the file cannot be opened, an error is signalled.  If a
+file with the given name already exists, the effect is unspecified."
+  (open-file file (if binary "wb" "w")
+             #\encoding encoding))
+
+(define* (call-with-input-file
+          file proc #\key (binary #f) (encoding #f) (guess-encoding #f))
+  "PROC should be a procedure of one argument, and FILE should be a
+string naming a file.  The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output.  If the file cannot be opened, an error is
+signalled.  If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+  (let ((p (open-input-file file
+                            #\binary binary
+                            #\encoding encoding
+                            #\guess-encoding guess-encoding)))
+    (call-with-values
+      (lambda () (proc p))
+      (lambda vals
+        (close-input-port p)
+        (apply values vals)))))
+
+(define* (call-with-output-file file proc #\key (binary #f) (encoding #f))
+  "PROC should be a procedure of one argument, and FILE should be a
+string naming a file.  The behaviour is unspecified if the file
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output.  If the file cannot be opened, an error is
+signalled.  If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+  (let ((p (open-output-file file #\binary binary #\encoding encoding)))
+    (call-with-values
+      (lambda () (proc p))
+      (lambda vals
+        (close-output-port p)
+        (apply values vals)))))
+
+(define* (with-input-from-file
+          file thunk #\key (binary #f) (encoding #f) (guess-encoding #f))
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-input-file file
+   (lambda (p) (with-input-from-port p thunk))
+   #\binary binary
+   #\encoding encoding
+   #\guess-encoding guess-encoding))
+
+(define* (with-output-to-file file thunk #\key (binary #f) (encoding #f))
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-output-file file
+   (lambda (p) (with-output-to-port p thunk))
+   #\binary binary
+   #\encoding encoding))
+
+(define* (with-error-to-file file thunk #\key (binary #f) (encoding #f))
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-output-file file
+   (lambda (p) (with-error-to-port p thunk))
+   #\binary binary
+   #\encoding encoding))
+
+
+
+;;;
+;;; Extensible exception printing.
+;;;
+
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
+
+(let ((exception-printers '()))
+  (define (print-location frame port)
+    (let ((source (and=> frame frame-source)))
+      ;; source := (addr . (filename . (line . column)))
+      (if source
+          (let ((filename (or (cadr source) "<unnamed port>"))
+                (line (caddr source))
+                (col (cdddr source)))
+            (format port "~a:~a:~a: " filename (1+ line) col))
+          (format port "ERROR: "))))
+
+  (set! set-exception-printer!
+        (lambda (key proc)
+          (set! exception-printers (acons key proc exception-printers))))
+
+  (set! print-exception
+        (lambda (port frame key args)
+          (define (default-printer)
+            (format port "Throw to key `~a' with args `~s'." key args))
+
+          (if frame
+              (let ((proc (frame-procedure frame)))
+                (print-location frame port)
+                (format port "In procedure ~a:\n"
+                        (or (false-if-exception (procedure-name proc))
+                            proc))))
+
+          (print-location frame port)
+          (catch #t
+            (lambda ()
+              (let ((printer (assq-ref exception-printers key)))
+                (if printer
+                    (printer port key args default-printer)
+                    (default-printer))))
+            (lambda (k . args)
+              (format port "Error while printing exception.")))
+          (newline port)
+          (force-output port))))
+
+;;;
+;;; Printers for those keys thrown by Guile.
+;;;
+(let ()
+  (define (scm-error-printer port key args default-printer)
+    ;; Abuse case-lambda as a pattern matcher, given that we don't have
+    ;; ice-9 match at this point.
+    (apply (case-lambda
+             ((subr msg args . rest)
+              (if subr
+                  (format port "In procedure ~a: " subr))
+              (apply format port msg (or args '())))
+             (_ (default-printer)))
+           args))
+
+  (define (syntax-error-printer port key args default-printer)
+    (apply (case-lambda
+             ((who what where form subform . extra)
+              (format port "Syntax error:\n")
+              (if where
+                  (let ((file (or (assq-ref where 'filename) "unknown file"))
+                        (line (and=> (assq-ref where 'line) 1+))
+                        (col (assq-ref where 'column)))
+                    (format port "~a:~a:~a: " file line col))
+                  (format port "unknown location: "))
+              (if who
+                  (format port "~a: " who))
+              (format port "~a" what)
+              (if subform
+                  (format port " in subform ~s of ~s" subform form)
+                  (if form
+                      (format port " in form ~s" form))))
+             (_ (default-printer)))
+           args))
+
+  (define (keyword-error-printer port key args default-printer)
+    (let ((message (cadr args))
+          (faulty  (car (cadddr args)))) ; I won't do it again, I promise.
+      (format port "~a: ~s" message faulty)))
+
+  (define (getaddrinfo-error-printer port key args default-printer)
+    (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+
+  (set-exception-printer! 'goops-error scm-error-printer)
+  (set-exception-printer! 'host-not-found scm-error-printer)
+  (set-exception-printer! 'keyword-argument-error keyword-error-printer)
+  (set-exception-printer! 'misc-error scm-error-printer)
+  (set-exception-printer! 'no-data scm-error-printer)
+  (set-exception-printer! 'no-recovery scm-error-printer)
+  (set-exception-printer! 'null-pointer-error scm-error-printer)
+  (set-exception-printer! 'out-of-range scm-error-printer)
+  (set-exception-printer! 'program-error scm-error-printer)
+  (set-exception-printer! 'read-error scm-error-printer)
+  (set-exception-printer! 'regular-expression-syntax scm-error-printer)
+  (set-exception-printer! 'signal scm-error-printer)
+  (set-exception-printer! 'stack-overflow scm-error-printer)
+  (set-exception-printer! 'system-error scm-error-printer)
+  (set-exception-printer! 'try-again scm-error-printer)
+  (set-exception-printer! 'unbound-variable scm-error-printer)
+  (set-exception-printer! 'wrong-number-of-args scm-error-printer)
+  (set-exception-printer! 'wrong-type-arg scm-error-printer)
+
+  (set-exception-printer! 'syntax-error syntax-error-printer)
+
+  (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
+
+
+
+
+;;; {Defmacros}
+;;;
+
+(define-syntax define-macro
+  (lambda (x)
+    "Define a defmacro."
+    (syntax-case x ()
+      ((_ (macro . args) doc body1 body ...)
+       (string? (syntax->datum #'doc))
+       #'(define-macro macro doc (lambda args body1 body ...)))
+      ((_ (macro . args) body ...)
+       #'(define-macro macro #f (lambda args body ...)))
+      ((_ macro transformer)
+       #'(define-macro macro #f transformer))
+      ((_ macro doc transformer)
+       (or (string? (syntax->datum #'doc))
+           (not (syntax->datum #'doc)))
+       #'(define-syntax macro
+           (lambda (y)
+             doc
+             #((macro-type . defmacro)
+               (defmacro-args args))
+             (syntax-case y ()
+               ((_ . args)
+                (let ((v (syntax->datum #'args)))
+                  (datum->syntax y (apply transformer v)))))))))))
+
+(define-syntax defmacro
+  (lambda (x)
+    "Define a defmacro, with the old lispy defun syntax."
+    (syntax-case x ()
+      ((_ macro args doc body1 body ...)
+       (string? (syntax->datum #'doc))
+       #'(define-macro macro doc (lambda args body1 body ...)))
+      ((_ macro args body ...)
+       #'(define-macro macro #f (lambda args body ...))))))
+
+(provide 'defmacro)
+
+
+
+;;; {Deprecation}
+;;;
+
+(define-syntax begin-deprecated
+  (lambda (x)
+    (syntax-case x ()
+      ((_ form form* ...)
+       (if (include-deprecated-features)
+           #'(begin form form* ...)
+           #'(begin))))))
+
+
+
+;;; {Trivial Functions}
+;;;
+
+(define (identity x) x)
+
+(define (compose proc . rest)
+  "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+  (if (null? rest)
+      proc
+      (let ((g (apply compose rest)))
+        (lambda args
+          (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+  "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+  (lambda args
+    (not (apply proc args))))
+
+(define (const value)
+  "Return a procedure that accepts any number of arguments and returns
+VALUE."
+  (lambda _
+    value))
+
+(define (and=> value procedure)
+  "When VALUE is #f, return #f.  Otherwise, return (PROC VALUE)."
+  (and value (procedure value)))
+
+(define call/cc call-with-current-continuation)
+
+(define-syntax false-if-exception
+  (syntax-rules ()
+    ((false-if-exception expr)
+     (catch #t
+       (lambda () expr)
+       (lambda args #f)))
+    ((false-if-exception expr #\warning template arg ...)
+     (catch #t
+       (lambda () expr)
+       (lambda (key . args)
+         (for-each (lambda (s)
+                     (if (not (string-null? s))
+                         (format (current-warning-port) ";;; ~a\n" s)))
+                   (string-split
+                    (call-with-output-string
+                     (lambda (port)
+                       (format port template arg ...)
+                       (print-exception port #f key args)))
+                    #\newline))
+         #f)))))
+
+
+
+;;; {General Properties}
+;;;
+
+;; Properties are a lispy way to associate random info with random objects.
+;; Traditionally properties are implemented as an alist or a plist actually
+;; pertaining to the object in question.
+;;
+;; These "object properties" have the advantage that they can be associated with
+;; any object, even if the object has no plist. Object properties are good when
+;; you are extending pre-existing objects in unexpected ways. They also present
+;; a pleasing, uniform procedure-with-setter interface. But if you have a data
+;; type that always has properties, it's often still best to store those
+;; properties within the object itself.
+
+(define (make-object-property)
+  (define-syntax-rule (with-mutex lock exp)
+    (dynamic-wind (lambda () (lock-mutex lock))
+                  (lambda () exp)
+                  (lambda () (unlock-mutex lock))))
+  (let ((prop (make-weak-key-hash-table))
+        (lock (make-mutex)))
+    (make-procedure-with-setter
+     (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
+     (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+
+
+
+
+;;; {Symbol Properties}
+;;;
+
+;;; Symbol properties are something you see in old Lisp code. In most current
+;;; Guile code, symbols are not used as a data structure -- they are used as
+;;; keys into other data structures.
+
+(define (symbol-property sym prop)
+  (let ((pair (assoc prop (symbol-pref sym))))
+    (and pair (cdr pair))))
+
+(define (set-symbol-property! sym prop val)
+  (let ((pair (assoc prop (symbol-pref sym))))
+    (if pair
+        (set-cdr! pair val)
+        (symbol-pset! sym (acons prop val (symbol-pref sym))))))
+
+(define (symbol-property-remove! sym prop)
+  (let ((pair (assoc prop (symbol-pref sym))))
+    (if pair
+        (symbol-pset! sym (delq! pair (symbol-pref sym))))))
+
+
+
+;;; {Arrays}
+;;;
+
+(define (array-shape a)
+  (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+       (array-dimensions a)))
+
+
+
+;;; {Keywords}
+;;;
+
+;;; It's much better if you can use lambda* / define*, of course.
+
+(define (kw-arg-ref args kw)
+  (let ((rem (member kw args)))
+    (and rem (pair? (cdr rem)) (cadr rem))))
+
+
+
+;;; {Structs}
+;;;
+
+(define (struct-layout s)
+  (struct-ref (struct-vtable s) vtable-index-layout))
+
+
+
+;;; {Records}
+;;;
+
+;; Printing records: by default, records are printed as
+;;
+;;   #<type-name field1: val1 field2: val2 ...>
+;;
+;; You can change that by giving a custom printing function to
+;; MAKE-RECORD-TYPE (after the list of field symbols).  This function
+;; will be called like
+;;
+;;   (<printer> object port)
+;;
+;; It should print OBJECT to PORT.
+
+(define (inherit-print-state old-port new-port)
+  (if (get-print-state old-port)
+      (port-with-print-state new-port (get-print-state old-port))
+      new-port))
+
+;; 0: type-name, 1: fields, 2: constructor
+(define record-type-vtable
+  (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+                        (lambda (s p)
+                          (display "#<record-type " p)
+                          (display (record-type-name s) p)
+                          (display ">" p)))))
+    (set-struct-vtable-name! s 'record-type)
+    s))
+
+(define (record-type? obj)
+  (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
+
+(define* (make-record-type type-name fields #\optional printer)
+  ;; Pre-generate constructors for nfields < 20.
+  (define-syntax make-constructor
+    (lambda (x)
+      (define *max-static-argument-count* 20)
+      (define (make-formals n)
+        (let lp ((i 0))
+          (if (< i n)
+              (cons (datum->syntax
+                     x 
+                     (string->symbol
+                      (string (integer->char (+ (char->integer #\a) i)))))
+                    (lp (1+ i)))
+              '())))
+      (syntax-case x ()
+        ((_ rtd exp) (not (identifier? #'exp))
+         #'(let ((n exp))
+             (make-constructor rtd n)))
+        ((_ rtd nfields)
+         #`(case nfields
+             #,@(let lp ((n 0))
+                  (if (< n *max-static-argument-count*)
+                      (cons (with-syntax (((formal ...) (make-formals n))
+                                          (n n))
+                              #'((n)
+                                 (lambda (formal ...)
+                                   (make-struct rtd 0 formal ...))))
+                            (lp (1+ n)))
+                      '()))
+             (else
+              (lambda args
+                (if (= (length args) nfields)
+                    (apply make-struct rtd 0 args)
+                    (scm-error 'wrong-number-of-args
+                               (format #f "make-~a" type-name)
+                               "Wrong number of arguments" '() #f)))))))))
+
+  (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)
+        (display (struct-ref s off) p)
+        (loop (cdr fields) (+ 1 off)))))
+    (display ">" p))
+
+  (let ((rtd (make-struct record-type-vtable 0
+                          (make-struct-layout
+                           (apply string-append
+                                  (map (lambda (f) "pw") fields)))
+                          (or printer default-record-printer)
+                          type-name
+                          (copy-tree fields))))
+    (struct-set! rtd (+ vtable-offset-user 2)
+                 (make-constructor rtd (length fields)))
+    ;; Temporary solution: Associate a name to the record type descriptor
+    ;; so that the object system can create a wrapper class for it.
+    (set-struct-vtable-name! rtd (if (symbol? type-name)
+                                     type-name
+                                     (string->symbol type-name)))
+    rtd))
+
+(define (record-type-name obj)
+  (if (record-type? obj)
+      (struct-ref obj vtable-offset-user)
+      (error 'not-a-record-type obj)))
+
+(define (record-type-fields obj)
+  (if (record-type? obj)
+      (struct-ref obj (+ 1 vtable-offset-user))
+      (error 'not-a-record-type obj)))
+
+(define* (record-constructor rtd #\optional field-names)
+  (if (not field-names)
+      (struct-ref rtd (+ 2 vtable-offset-user))
+      (primitive-eval
+       `(lambda ,field-names
+          (make-struct ',rtd 0 ,@(map (lambda (f)
+                                        (if (memq f field-names)
+                                            f
+                                            #f))
+                                      (record-type-fields rtd)))))))
+          
+(define (record-predicate rtd)
+  (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+
+(define (%record-type-error rtd obj)  ;; private helper
+  (or (eq? rtd (record-type-descriptor obj))
+      (scm-error 'wrong-type-arg "%record-type-check"
+                 "Wrong type record (want `~S'): ~S"
+                 (list (record-type-name rtd) obj)
+                 #f)))
+
+(define (record-accessor rtd field-name)
+  (let ((pos (list-index (record-type-fields rtd) field-name)))
+    (if (not pos)
+        (error 'no-such-field field-name))
+    (lambda (obj)
+      (if (eq? (struct-vtable obj) rtd)
+          (struct-ref obj pos)
+          (%record-type-error rtd obj)))))
+
+(define (record-modifier rtd field-name)
+  (let ((pos (list-index (record-type-fields rtd) field-name)))
+    (if (not pos)
+        (error 'no-such-field field-name))
+    (lambda (obj val)
+      (if (eq? (struct-vtable obj) rtd)
+          (struct-set! obj pos val)
+          (%record-type-error rtd obj)))))
+
+(define (record? obj)
+  (and (struct? obj) (record-type? (struct-vtable obj))))
+
+(define (record-type-descriptor obj)
+  (if (struct? obj)
+      (struct-vtable obj)
+      (error 'not-a-record obj)))
+
+(provide 'record)
+
+
+
+;;; {Booleans}
+;;;
+
+(define (->bool x) (not (not x)))
+
+
+
+;;; {Symbols}
+;;;
+
+(define (symbol-append . args)
+  (string->symbol (apply string-append (map symbol->string args))))
+
+(define (list->symbol . args)
+  (string->symbol (apply list->string args)))
+
+(define (symbol . args)
+  (string->symbol (apply string args)))
+
+
+
+;;; {Lists}
+;;;
+
+(define (list-index l k)
+  (let loop ((n 0)
+             (l l))
+    (and (not (null? l))
+         (if (eq? (car l) k)
+             n
+             (loop (+ n 1) (cdr l))))))
+
+
+
+;; Load `posix.scm' even when not (provided? 'posix) so that we get the
+;; `stat' accessors.
+(primitive-load-path "ice-9/posix")
+
+(if (provided? 'socket)
+    (primitive-load-path "ice-9/networking"))
+
+;; For reference, Emacs file-exists-p uses stat in this same way.
+(define file-exists?
+  (if (provided? 'posix)
+      (lambda (str)
+        (->bool (stat str #f)))
+      (lambda (str)
+        (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+                           (lambda args #f))))
+          (if port (begin (close-port port) #t)
+              #f)))))
+
+(define file-is-directory?
+  (if (provided? 'posix)
+      (lambda (str)
+        (eq? (stat:type (stat str)) 'directory))
+      (lambda (str)
+        (let ((port (catch 'system-error
+                           (lambda () (open-file (string-append str "/.")
+                                                 OPEN_READ))
+                           (lambda args #f))))
+          (if port (begin (close-port port) #t)
+              #f)))))
+
+(define (system-error-errno args)
+  (if (eq? (car args) 'system-error)
+      (car (list-ref args 4))
+      #f))
+
+
+
+;;; {Error Handling}
+;;;
+
+(define error
+  (case-lambda
+    (()
+     (scm-error 'misc-error #f "?" #f #f))
+    ((message . args)
+     (let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
+       (scm-error 'misc-error #f msg (cons message args) #f)))))
+
+
+
+;;; {Time Structures}
+;;;
+
+(define (tm:sec obj) (vector-ref obj 0))
+(define (tm:min obj) (vector-ref obj 1))
+(define (tm:hour obj) (vector-ref obj 2))
+(define (tm:mday obj) (vector-ref obj 3))
+(define (tm:mon obj) (vector-ref obj 4))
+(define (tm:year obj) (vector-ref obj 5))
+(define (tm:wday obj) (vector-ref obj 6))
+(define (tm:yday obj) (vector-ref obj 7))
+(define (tm:isdst obj) (vector-ref obj 8))
+(define (tm:gmtoff obj) (vector-ref obj 9))
+(define (tm:zone obj) (vector-ref obj 10))
+
+(define (set-tm:sec obj val) (vector-set! obj 0 val))
+(define (set-tm:min obj val) (vector-set! obj 1 val))
+(define (set-tm:hour obj val) (vector-set! obj 2 val))
+(define (set-tm:mday obj val) (vector-set! obj 3 val))
+(define (set-tm:mon obj val) (vector-set! obj 4 val))
+(define (set-tm:year obj val) (vector-set! obj 5 val))
+(define (set-tm:wday obj val) (vector-set! obj 6 val))
+(define (set-tm:yday obj val) (vector-set! obj 7 val))
+(define (set-tm:isdst obj val) (vector-set! obj 8 val))
+(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
+(define (set-tm:zone obj val) (vector-set! obj 10 val))
+
+(define (tms:clock obj) (vector-ref obj 0))
+(define (tms:utime obj) (vector-ref obj 1))
+(define (tms:stime obj) (vector-ref obj 2))
+(define (tms:cutime obj) (vector-ref obj 3))
+(define (tms:cstime obj) (vector-ref obj 4))
+
+
+
+;;; {File Descriptors and Ports}
+;;;
+
+(define file-position ftell)
+(define* (file-set-position port offset #\optional (whence SEEK_SET))
+  (seek port offset whence))
+
+(define (move->fdes fd/port fd)
+  (cond ((integer? fd/port)
+         (dup->fdes fd/port fd)
+         (close fd/port)
+         fd)
+        (else
+         (primitive-move->fdes fd/port fd)
+         (set-port-revealed! fd/port 1)
+         fd/port)))
+
+(define (release-port-handle port)
+  (let ((revealed (port-revealed port)))
+    (if (> revealed 0)
+        (set-port-revealed! port (- revealed 1)))))
+
+(define dup->port
+  (case-lambda
+    ((port/fd mode)
+     (fdopen (dup->fdes port/fd) mode))
+    ((port/fd mode new-fd)
+     (let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
+       (set-port-revealed! port 1)
+       port))))
+
+(define dup->inport
+  (case-lambda
+    ((port/fd)
+     (dup->port port/fd "r"))
+    ((port/fd new-fd)
+     (dup->port port/fd "r" new-fd))))
+
+(define dup->outport
+  (case-lambda
+    ((port/fd)
+     (dup->port port/fd "w"))
+    ((port/fd new-fd)
+     (dup->port port/fd "w" new-fd))))
+
+(define dup
+  (case-lambda
+    ((port/fd)
+     (if (integer? port/fd)
+         (dup->fdes port/fd)
+         (dup->port port/fd (port-mode port/fd))))
+    ((port/fd new-fd)
+     (if (integer? port/fd)
+         (dup->fdes port/fd new-fd)
+         (dup->port port/fd (port-mode port/fd) new-fd)))))
+
+(define (duplicate-port port modes)
+  (dup->port port modes))
+
+(define (fdes->inport fdes)
+  (let loop ((rest-ports (fdes->ports fdes)))
+    (cond ((null? rest-ports)
+           (let ((result (fdopen fdes "r")))
+             (set-port-revealed! result 1)
+             result))
+          ((input-port? (car rest-ports))
+           (set-port-revealed! (car rest-ports)
+                               (+ (port-revealed (car rest-ports)) 1))
+           (car rest-ports))
+          (else
+           (loop (cdr rest-ports))))))
+
+(define (fdes->outport fdes)
+  (let loop ((rest-ports (fdes->ports fdes)))
+    (cond ((null? rest-ports)
+           (let ((result (fdopen fdes "w")))
+             (set-port-revealed! result 1)
+             result))
+          ((output-port? (car rest-ports))
+           (set-port-revealed! (car rest-ports)
+                               (+ (port-revealed (car rest-ports)) 1))
+           (car rest-ports))
+          (else
+           (loop (cdr rest-ports))))))
+
+(define (port->fdes port)
+  (set-port-revealed! port (+ (port-revealed port) 1))
+  (fileno port))
+
+(define (setenv name value)
+  (if value
+      (putenv (string-append name "=" value))
+      (putenv name)))
+
+(define (unsetenv name)
+  "Remove the entry for NAME from the environment."
+  (putenv name))
+
+
+
+;;; {Load Paths}
+;;;
+
+(let-syntax ((compile-time-case
+              (lambda (stx)
+                (syntax-case stx ()
+                  ((_ exp clauses ...)
+                   (let ((val (primitive-eval (syntax->datum #'exp))))
+                     (let next-clause ((clauses #'(clauses ...)))
+                       (syntax-case clauses (else)
+                         (()
+                          (syntax-violation 'compile-time-case
+                                            "all clauses failed to match" stx))
+                         (((else form ...))
+                          #'(begin form ...))
+                         ((((k ...) form ...) clauses ...)
+                          (if (memv val (syntax->datum #'(k ...)))
+                              #'(begin form ...)
+                              (next-clause #'(clauses ...))))))))))))
+  ;; emacs: (put 'compile-time-case 'scheme-indent-function 1)
+  (compile-time-case (system-file-name-convention)
+    ((posix)
+     (define (file-name-separator? c)
+       (char=? c #\/))
+
+     (define file-name-separator-string "/")
+
+     (define (absolute-file-name? file-name)
+       (string-prefix? "/" file-name)))
+
+    ((windows)
+     (define (file-name-separator? c)
+       (or (char=? c #\/)
+           (char=? c #\\)))
+
+     (define file-name-separator-string "/")
+
+     (define (absolute-file-name? file-name)
+       (define (file-name-separator-at-index? idx)
+         (and (> (string-length file-name) idx)
+              (file-name-separator? (string-ref file-name idx))))
+       (define (unc-file-name?)
+         ;; Universal Naming Convention (UNC) file-names start with \\,
+         ;; and are always absolute.  See:
+         ;;   http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#fully_qualified_vs._relative_paths
+         (and (file-name-separator-at-index? 0)
+              (file-name-separator-at-index? 1)))
+       (define (has-drive-specifier?)
+         (and (>= (string-length file-name) 2)
+              (let ((drive (string-ref file-name 0)))
+                (or (char<=? #\a drive #\z)
+                    (char<=? #\A drive #\Z)))
+              (eqv? (string-ref file-name 1) #\:)))
+       (or (unc-file-name?)
+           (if (has-drive-specifier?)
+               (file-name-separator-at-index? 2)
+               (file-name-separator-at-index? 0)))))))
+
+(define (in-vicinity vicinity file)
+  (let ((tail (let ((len (string-length vicinity)))
+                (if (zero? len)
+                    #f
+                    (string-ref vicinity (- len 1))))))
+    (string-append vicinity
+                   (if (or (not tail) (file-name-separator? tail))
+                       ""
+                       file-name-separator-string)
+                   file)))
+
+
+
+;;; {Help for scm_shell}
+;;;
+;;; The argument-processing code used by Guile-based shells generates
+;;; Scheme code based on the argument list.  This page contains help
+;;; functions for the code it generates.
+;;;
+
+(define (command-line) (program-arguments))
+
+;; This is mostly for the internal use of the code generated by
+;; scm_compile_shell_switches.
+
+(define (load-user-init)
+  (let* ((home (or (getenv "HOME")
+                   (false-if-exception (passwd:dir (getpwuid (getuid))))
+                   file-name-separator-string))  ;; fallback for cygwin etc.
+         (init-file (in-vicinity home ".guile")))
+    (if (file-exists? init-file)
+        (primitive-load init-file))))
+
+
+
+;;; {The interpreter stack}
+;;;
+
+;; %stacks defined in stacks.c
+(define (%start-stack tag thunk)
+  (let ((prompt-tag (make-prompt-tag "start-stack")))
+    (call-with-prompt
+     prompt-tag
+     (lambda ()
+       (with-fluids ((%stacks (acons tag prompt-tag
+                                     (or (fluid-ref %stacks) '()))))
+         (thunk)))
+     (lambda (k . args)
+       (%start-stack tag (lambda () (apply k args)))))))
+
+(define-syntax-rule (start-stack tag exp)
+  (%start-stack tag (lambda () exp)))
+
+
+
+;;; {Loading by paths}
+;;;
+
+;;; Load a Scheme source file named NAME, searching for it in the
+;;; directories listed in %load-path, and applying each of the file
+;;; name extensions listed in %load-extensions.
+(define (load-from-path name)
+  (start-stack 'load-stack
+               (primitive-load-path name)))
+
+(define-syntax-rule (add-to-load-path elt)
+  "Add ELT to Guile's load path, at compile-time and at run-time."
+  (eval-when (expand load eval)
+    (set! %load-path (cons elt (delete elt %load-path)))))
+
+(define %load-verbosely #f)
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+  (if %load-verbosely
+      (with-output-to-port (current-warning-port)
+        (lambda ()
+          (display ";;; ")
+          (display "loading ")
+          (display file)
+          (newline)
+          (force-output)))))
+
+(set! %load-hook %load-announce)
+
+
+
+;;; {Reader Extensions}
+;;;
+;;; Reader code for various "#c" forms.
+;;;
+
+(define read-eval? (make-fluid #f))
+(read-hash-extend #\.
+                  (lambda (c port)
+                    (if (fluid-ref read-eval?)
+                        (eval (read port) (interaction-environment))
+                        (error
+                         "#. read expansion found and read-eval? is #f."))))
+
+
+
+;;; {Low Level Modules}
+;;;
+;;; These are the low level data structures for modules.
+;;;
+;;; Every module object is of the type 'module-type', which is a record
+;;; consisting of the following members:
+;;;
+;;; - eval-closure: A deprecated field, to be removed in Guile 2.2.
+;;;
+;;; - obarray: a hash table that maps symbols to variable objects.  In this
+;;;   hash table, the definitions are found that are local to the module (that
+;;;   is, not imported from other modules).  When looking up bindings in the
+;;;   module, this hash table is searched first.
+;;;
+;;; - binder: either #f or a function taking a module and a symbol argument.
+;;;   If it is a function it is called after the obarray has been
+;;;   unsuccessfully searched for a binding.  It then can provide bindings
+;;;   that would otherwise not be found locally in the module.
+;;;
+;;; - uses: a list of modules from which non-local bindings can be inherited.
+;;;   These modules are the third place queried for bindings after the obarray
+;;;   has been unsuccessfully searched and the binder function did not deliver
+;;;   a result either.
+;;;
+;;; - transformer: either #f or a function taking a scheme expression as
+;;;   delivered by read.  If it is a function, it will be called to perform
+;;;   syntax transformations (e. g. makro expansion) on the given scheme
+;;;   expression. The output of the transformer function will then be passed
+;;;   to Guile's internal memoizer.  This means that the output must be valid
+;;;   scheme code.  The only exception is, that the output may make use of the
+;;;   syntax extensions provided to identify the modules that a binding
+;;;   belongs to.
+;;;
+;;; - name: the name of the module.  This is used for all kinds of printing
+;;;   outputs.  In certain places the module name also serves as a way of
+;;;   identification.  When adding a module to the uses list of another
+;;;   module, it is made sure that the new uses list will not contain two
+;;;   modules of the same name.
+;;;
+;;; - kind: classification of the kind of module.  The value is (currently?)
+;;;   only used for printing.  It has no influence on how a module is treated.
+;;;   Currently the following values are used when setting the module kind:
+;;;   'module, 'directory, 'interface, 'custom-interface.  If no explicit kind
+;;;   is set, it defaults to 'module.
+;;;
+;;; - duplicates-handlers: a list of procedures that get called to make a
+;;;   choice between two duplicate bindings when name clashes occur.  See the
+;;;   `duplicate-handlers' global variable below.
+;;;
+;;; - observers: a list of procedures that get called when the module is
+;;;   modified.
+;;;
+;;; - weak-observers: a weak-key hash table of procedures that get called
+;;;   when the module is modified.  See `module-observe-weak' for details.
+;;;
+;;; In addition, the module may (must?) contain a binding for
+;;; `%module-public-interface'.  This variable should be bound to a module
+;;; representing the exported interface of a module.  See the
+;;; `module-public-interface' and `module-export!' procedures.
+;;;
+;;; !!! warning: The interface to lazy binder procedures is going
+;;; to be changed in an incompatible way to permit all the basic
+;;; module ops to be virtualized.
+;;;
+;;; (make-module size use-list lazy-binding-proc) => module
+;;; module-{obarray,uses,binder}[|-set!]
+;;; (module? obj) => [#t|#f]
+;;; (module-locally-bound? module symbol) => [#t|#f]
+;;; (module-bound? module symbol) => [#t|#f]
+;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
+;;; (module-symbol-interned? module symbol) => [#t|#f]
+;;; (module-local-variable module symbol) => [#<variable ...> | #f]
+;;; (module-variable module symbol) => [#<variable ...> | #f]
+;;; (module-symbol-binding module symbol opt-value)
+;;;             => [ <obj> | opt-value | an error occurs ]
+;;; (module-make-local-var! module symbol) => #<variable...>
+;;; (module-add! module symbol var) => unspecified
+;;; (module-remove! module symbol) =>  unspecified
+;;; (module-for-each proc module) => unspecified
+;;; (make-scm-module) => module ; a lazy copy of the symhash module
+;;; (set-current-module module) => unspecified
+;;; (current-module) => #<module...>
+;;;
+;;;
+
+
+
+;;; {Printing Modules}
+;;;
+
+;; This is how modules are printed.  You can re-define it.
+(define (%print-module mod port)
+  (display "#<" port)
+  (display (or (module-kind mod) "module") port)
+  (display " " port)
+  (display (module-name mod) port)
+  (display " " port)
+  (display (number->string (object-address mod) 16) port)
+  (display ">" port))
+
+(letrec-syntax
+     ;; Locally extend the syntax to allow record accessors to be defined at
+     ;; compile-time. Cache the rtd locally to the constructor, the getters and
+     ;; the setters, in order to allow for redefinition of the record type; not
+     ;; relevant in the case of modules, but perhaps if we make this public, it
+     ;; could matter.
+
+    ((define-record-type
+       (lambda (x)
+         (define (make-id scope . fragments)
+           (datum->syntax #'scope
+                          (apply symbol-append
+                                 (map (lambda (x)
+                                        (if (symbol? x) x (syntax->datum x)))
+                                      fragments))))
+         
+         (define (getter rtd type-name field slot)
+           #`(define #,(make-id rtd type-name '- field)
+               (let ((rtd #,rtd))
+                 (lambda (#,type-name)
+                   (if (eq? (struct-vtable #,type-name) rtd)
+                       (struct-ref #,type-name #,slot)
+                       (%record-type-error rtd #,type-name))))))
+
+         (define (setter rtd type-name field slot)
+           #`(define #,(make-id rtd 'set- type-name '- field '!)
+               (let ((rtd #,rtd))
+                 (lambda (#,type-name val)
+                   (if (eq? (struct-vtable #,type-name) rtd)
+                       (struct-set! #,type-name #,slot val)
+                       (%record-type-error rtd #,type-name))))))
+
+         (define (accessors rtd type-name fields n exp)
+           (syntax-case fields ()
+             (() exp)
+             (((field #\no-accessors) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         exp))
+             (((field #\no-setter) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(getter rtd type-name #'field n))))
+             (((field #\no-getter) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(setter rtd type-name #'field n))))
+             ((field field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(getter rtd type-name #'field n)
+                                  #,(setter rtd type-name #'field n))))))
+
+         (define (predicate rtd type-name fields exp)
+           (accessors
+            rtd type-name fields 0
+            #`(begin
+                #,exp
+                (define (#,(make-id rtd type-name '?) obj)
+                  (and (struct? obj) (eq? (struct-vtable obj) #,rtd))))))
+
+         (define (field-list fields)
+           (syntax-case fields ()
+             (() '())
+             (((f . opts) . rest) (identifier? #'f)
+              (cons #'f (field-list #'rest)))
+             ((f . rest) (identifier? #'f)
+              (cons #'f (field-list #'rest)))))
+
+         (define (constructor rtd type-name fields exp)
+           (let ((ctor (make-id rtd type-name '-constructor))
+                 (args (field-list fields)))
+             (predicate rtd type-name fields
+                        #`(begin #,exp
+                                 (define #,ctor
+                                   (let ((rtd #,rtd))
+                                     (lambda #,args
+                                       (make-struct rtd 0 #,@args))))
+                                 (struct-set! #,rtd (+ vtable-offset-user 2)
+                                              #,ctor)))))
+
+         (define (type type-name printer fields)
+           (define (make-layout)
+             (let lp ((fields fields) (slots '()))
+               (syntax-case fields ()
+                 (() (datum->syntax #'here
+                                    (make-struct-layout
+                                     (apply string-append slots))))
+                 ((_ . rest) (lp #'rest (cons "pw" slots))))))
+
+           (let ((rtd (make-id type-name type-name '-type)))
+             (constructor rtd type-name fields
+                          #`(begin
+                              (define #,rtd
+                                (make-struct record-type-vtable 0
+                                             '#,(make-layout)
+                                             #,printer
+                                             '#,type-name
+                                             '#,(field-list fields)))
+                              (set-struct-vtable-name! #,rtd '#,type-name)))))
+
+         (syntax-case x ()
+           ((_ type-name printer (field ...))
+            (type #'type-name #'printer #'(field ...)))))))
+
+  ;; module-type
+  ;;
+  ;; A module is characterized by an obarray in which local symbols
+  ;; are interned, a list of modules, "uses", from which non-local
+  ;; bindings can be inherited, and an optional lazy-binder which
+  ;; is a (CLOSURE module symbol) which, as a last resort, can provide
+  ;; bindings that would otherwise not be found locally in the module.
+  ;;
+  ;; NOTE: If you change the set of fields or their order, you also need to
+  ;; change the constants in libguile/modules.h.
+  ;;
+  ;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
+  ;; NOTE: The getter `module-name' is defined later, due to boot reasons.
+  ;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
+  ;;
+  (define-record-type module
+    (lambda (obj port) (%print-module obj port))
+    (obarray
+     uses
+     binder
+     eval-closure
+     (transformer #\no-getter)
+     (name #\no-getter)
+     kind
+     duplicates-handlers
+     (import-obarray #\no-setter)
+     observers
+     (weak-observers #\no-setter)
+     version
+     submodules
+     submodule-binder
+     public-interface
+     filename
+     next-unique-id)))
+
+
+;; make-module &opt size uses binder
+;;
+;; Create a new module, perhaps with a particular size of obarray,
+;; initial uses list, or binding procedure.
+;;
+(define* (make-module #\optional (size 31) (uses '()) (binder #f))
+  (define %default-import-size
+    ;; Typical number of imported bindings actually used by a module.
+    600)
+
+  (if (not (integer? size))
+      (error "Illegal size to make-module." size))
+  (if (not (and (list? uses)
+                (and-map module? uses)))
+      (error "Incorrect use list." uses))
+  (if (and binder (not (procedure? binder)))
+      (error
+       "Lazy-binder expected to be a procedure or #f." binder))
+
+  (module-constructor (make-hash-table size)
+                      uses binder #f macroexpand
+                      #f #f #f
+                      (make-hash-table %default-import-size)
+                      '()
+                      (make-weak-key-hash-table 31) #f
+                      (make-hash-table 7) #f #f #f 0))
+
+
+
+
+;;; {Observer protocol}
+;;;
+
+(define (module-observe module proc)
+  (set-module-observers! module (cons proc (module-observers module)))
+  (cons module proc))
+
+(define* (module-observe-weak module observer-id #\optional (proc observer-id))
+  ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
+  ;; be any Scheme object).  PROC is invoked and passed MODULE any time
+  ;; MODULE is modified.  PROC gets unregistered when OBSERVER-ID gets GC'd
+  ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value,
+  ;; for instance).
+
+  ;; The two-argument version is kept for backward compatibility: when called
+  ;; with two arguments, the observer gets unregistered when closure PROC
+  ;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
+  (hashq-set! (module-weak-observers module) observer-id proc))
+
+(define (module-unobserve token)
+  (let ((module (car token))
+        (id (cdr token)))
+    (if (integer? id)
+        (hash-remove! (module-weak-observers module) id)
+        (set-module-observers! module (delq1! id (module-observers module)))))
+  *unspecified*)
+
+(define module-defer-observers #f)
+(define module-defer-observers-mutex (make-mutex 'recursive))
+(define module-defer-observers-table (make-hash-table))
+
+(define (module-modified m)
+  (if module-defer-observers
+      (hash-set! module-defer-observers-table m #t)
+      (module-call-observers m)))
+
+;;; This function can be used to delay calls to observers so that they
+;;; can be called once only in the face of massive updating of modules.
+;;;
+(define (call-with-deferred-observers thunk)
+  (dynamic-wind
+      (lambda ()
+        (lock-mutex module-defer-observers-mutex)
+        (set! module-defer-observers #t))
+      thunk
+      (lambda ()
+        (set! module-defer-observers #f)
+        (hash-for-each (lambda (m dummy)
+                         (module-call-observers m))
+                       module-defer-observers-table)
+        (hash-clear! module-defer-observers-table)
+        (unlock-mutex module-defer-observers-mutex))))
+
+(define (module-call-observers m)
+  (for-each (lambda (proc) (proc m)) (module-observers m))
+
+  ;; We assume that weak observers don't (un)register themselves as they are
+  ;; called since this would preclude proper iteration over the hash table
+  ;; elements.
+  (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m)))
+
+
+
+;;; {Module Searching in General}
+;;;
+;;; We sometimes want to look for properties of a symbol
+;;; just within the obarray of one module.  If the property
+;;; holds, then it is said to hold ``locally'' as in, ``The symbol
+;;; DISPLAY is locally rebound in the module `safe-guile'.''
+;;;
+;;;
+;;; Other times, we want to test for a symbol property in the obarray
+;;; of M and, if it is not found there, try each of the modules in the
+;;; uses list of M.  This is the normal way of testing for some
+;;; property, so we state these properties without qualification as
+;;; in: ``The symbol 'fnord is interned in module M because it is
+;;; interned locally in module M2 which is a member of the uses list
+;;; of M.''
+;;;
+
+;; module-search fn m
+;;
+;; return the first non-#f result of FN applied to M and then to
+;; the modules in the uses of m, and so on recursively.  If all applications
+;; return #f, then so does this function.
+;;
+(define (module-search fn m v)
+  (define (loop pos)
+    (and (pair? pos)
+         (or (module-search fn (car pos) v)
+             (loop (cdr pos)))))
+  (or (fn m v)
+      (loop (module-uses m))))
+
+
+;;; {Is a symbol bound in a module?}
+;;;
+;;; Symbol S in Module M is bound if S is interned in M and if the binding
+;;; of S in M has been set to some well-defined value.
+;;;
+
+;; module-locally-bound? module symbol
+;;
+;; Is a symbol bound (interned and defined) locally in a given module?
+;;
+(define (module-locally-bound? m v)
+  (let ((var (module-local-variable m v)))
+    (and var
+         (variable-bound? var))))
+
+;; module-bound? module symbol
+;;
+;; Is a symbol bound (interned and defined) anywhere in a given module
+;; or its uses?
+;;
+(define (module-bound? m v)
+  (let ((var (module-variable m v)))
+    (and var
+         (variable-bound? var))))
+
+;;; {Is a symbol interned in a module?}
+;;;
+;;; Symbol S in Module M is interned if S occurs in
+;;; of S in M has been set to some well-defined value.
+;;;
+;;; It is possible to intern a symbol in a module without providing
+;;; an initial binding for the corresponding variable.  This is done
+;;; with:
+;;;       (module-add! module symbol (make-undefined-variable))
+;;;
+;;; In that case, the symbol is interned in the module, but not
+;;; bound there.  The unbound symbol shadows any binding for that
+;;; symbol that might otherwise be inherited from a member of the uses list.
+;;;
+
+(define (module-obarray-get-handle ob key)
+  ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
+
+(define (module-obarray-ref ob key)
+  ((if (symbol? key) hashq-ref hash-ref) ob key))
+
+(define (module-obarray-set! ob key val)
+  ((if (symbol? key) hashq-set! hash-set!) ob key val))
+
+(define (module-obarray-remove! ob key)
+  ((if (symbol? key) hashq-remove! hash-remove!) ob key))
+
+;; module-symbol-locally-interned? module symbol
+;;
+;; is a symbol interned (not neccessarily defined) locally in a given module
+;; or its uses?  Interned symbols shadow inherited bindings even if
+;; they are not themselves bound to a defined value.
+;;
+(define (module-symbol-locally-interned? m v)
+  (not (not (module-obarray-get-handle (module-obarray m) v))))
+
+;; module-symbol-interned? module symbol
+;;
+;; is a symbol interned (not neccessarily defined) anywhere in a given module
+;; or its uses?  Interned symbols shadow inherited bindings even if
+;; they are not themselves bound to a defined value.
+;;
+(define (module-symbol-interned? m v)
+  (module-search module-symbol-locally-interned? m v))
+
+
+;;; {Mapping modules x symbols --> variables}
+;;;
+
+;; module-local-variable module symbol
+;; return the local variable associated with a MODULE and SYMBOL.
+;;
+;;; This function is very important. It is the only function that can
+;;; return a variable from a module other than the mutators that store
+;;; new variables in modules.  Therefore, this function is the location
+;;; of the "lazy binder" hack.
+;;;
+;;; If symbol is defined in MODULE, and if the definition binds symbol
+;;; to a variable, return that variable object.
+;;;
+;;; If the symbols is not found at first, but the module has a lazy binder,
+;;; then try the binder.
+;;;
+;;; If the symbol is not found at all, return #f.
+;;;
+;;; (This is now written in C, see `modules.c'.)
+;;;
+
+;;; {Mapping modules x symbols --> bindings}
+;;;
+;;; These are similar to the mapping to variables, except that the
+;;; variable is dereferenced.
+;;;
+
+;; module-symbol-binding module symbol opt-value
+;;
+;; return the binding of a variable specified by name within
+;; a given module, signalling an error if the variable is unbound.
+;; If the OPT-VALUE is passed, then instead of signalling an error,
+;; return OPT-VALUE.
+;;
+(define (module-symbol-local-binding m v . opt-val)
+  (let ((var (module-local-variable m v)))
+    (if (and var (variable-bound? var))
+        (variable-ref var)
+        (if (not (null? opt-val))
+            (car opt-val)
+            (error "Locally unbound variable." v)))))
+
+;; module-symbol-binding module symbol opt-value
+;;
+;; return the binding of a variable specified by name within
+;; a given module, signalling an error if the variable is unbound.
+;; If the OPT-VALUE is passed, then instead of signalling an error,
+;; return OPT-VALUE.
+;;
+(define (module-symbol-binding m v . opt-val)
+  (let ((var (module-variable m v)))
+    (if (and var (variable-bound? var))
+        (variable-ref var)
+        (if (not (null? opt-val))
+            (car opt-val)
+            (error "Unbound variable." v)))))
+
+
+
+
+;;; {Adding Variables to Modules}
+;;;
+
+;; module-make-local-var! module symbol
+;;
+;; ensure a variable for V in the local namespace of M.
+;; If no variable was already there, then create a new and uninitialzied
+;; variable.
+;;
+;; This function is used in modules.c.
+;;
+(define (module-make-local-var! m v)
+  (or (let ((b (module-obarray-ref (module-obarray m) v)))
+        (and (variable? b)
+             (begin
+               ;; Mark as modified since this function is called when
+               ;; the standard eval closure defines a binding
+               (module-modified m)
+               b)))
+
+      ;; Create a new local variable.
+      (let ((local-var (make-undefined-variable)))
+        (module-add! m v local-var)
+        local-var)))
+
+;; module-ensure-local-variable! module symbol
+;;
+;; Ensure that there is a local variable in MODULE for SYMBOL.  If
+;; there is no binding for SYMBOL, create a new uninitialized
+;; variable.  Return the local variable.
+;;
+(define (module-ensure-local-variable! module symbol)
+  (or (module-local-variable module symbol)
+      (let ((var (make-undefined-variable)))
+        (module-add! module symbol var)
+        var)))
+
+;; module-add! module symbol var
+;;
+;; ensure a particular variable for V in the local namespace of M.
+;;
+(define (module-add! m v var)
+  (if (not (variable? var))
+      (error "Bad variable to module-add!" var))
+  (if (not (symbol? v))
+      (error "Bad symbol to module-add!" v))
+  (module-obarray-set! (module-obarray m) v var)
+  (module-modified m))
+
+;; module-remove!
+;;
+;; make sure that a symbol is undefined in the local namespace of M.
+;;
+(define (module-remove! m v)
+  (module-obarray-remove! (module-obarray m) v)
+  (module-modified m))
+
+(define (module-clear! m)
+  (hash-clear! (module-obarray m))
+  (module-modified m))
+
+;; MODULE-FOR-EACH -- exported
+;;
+;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
+;;
+(define (module-for-each proc module)
+  (hash-for-each proc (module-obarray module)))
+
+(define (module-map proc module)
+  (hash-map->list proc (module-obarray module)))
+
+;; Submodules
+;;
+;; Modules exist in a separate namespace from values, because you generally do
+;; not want the name of a submodule, which you might not even use, to collide
+;; with local variables that happen to be named the same as the submodule.
+;;
+(define (module-ref-submodule module name)
+  (or (hashq-ref (module-submodules module) name)
+      (and (module-submodule-binder module)
+           ((module-submodule-binder module) module name))))
+
+(define (module-define-submodule! module name submodule)
+  (hashq-set! (module-submodules module) name submodule))
+
+;; It used to be, however, that module names were also present in the
+;; value namespace. When we enable deprecated code, we preserve this
+;; legacy behavior.
+;;
+;; These shims are defined here instead of in deprecated.scm because we
+;; need their definitions before loading other modules.
+;;
+(begin-deprecated
+ (define (module-ref-submodule module name)
+   (or (hashq-ref (module-submodules module) name)
+       (and (module-submodule-binder module)
+            ((module-submodule-binder module) module name))
+       (let ((var (module-local-variable module name)))
+         (and var (variable-bound? var) (module? (variable-ref var))
+              (begin
+                (warn "module" module "not in submodules table")
+                (variable-ref var))))))
+
+ (define (module-define-submodule! module name submodule)
+   (let ((var (module-local-variable module name)))
+     (if (and var
+              (or (not (variable-bound? var))
+                  (not (module? (variable-ref var)))))
+         (warn "defining module" module ": not overriding local definition" var)
+         (module-define! module name submodule)))
+   (hashq-set! (module-submodules module) name submodule)))
+
+
+
+;;; {Module-based Loading}
+;;;
+
+(define (save-module-excursion thunk)
+  (let ((inner-module (current-module))
+        (outer-module #f))
+    (dynamic-wind (lambda ()
+                    (set! outer-module (current-module))
+                    (set-current-module inner-module)
+                    (set! inner-module #f))
+                  thunk
+                  (lambda ()
+                    (set! inner-module (current-module))
+                    (set-current-module outer-module)
+                    (set! outer-module #f)))))
+
+
+
+;;; {MODULE-REF -- exported}
+;;;
+
+;; Returns the value of a variable called NAME in MODULE or any of its
+;; used modules.  If there is no such variable, then if the optional third
+;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
+;;
+(define (module-ref module name . rest)
+  (let ((variable (module-variable module name)))
+    (if (and variable (variable-bound? variable))
+        (variable-ref variable)
+        (if (null? rest)
+            (error "No variable named" name 'in module)
+            (car rest)                  ; default value
+            ))))
+
+;; MODULE-SET! -- exported
+;;
+;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
+;; to VALUE; if there is no such variable, an error is signaled.
+;;
+(define (module-set! module name value)
+  (let ((variable (module-variable module name)))
+    (if variable
+        (variable-set! variable value)
+        (error "No variable named" name 'in module))))
+
+;; MODULE-DEFINE! -- exported
+;;
+;; Sets the variable called NAME in MODULE to VALUE; if there is no such
+;; variable, it is added first.
+;;
+(define (module-define! module name value)
+  (let ((variable (module-local-variable module name)))
+    (if variable
+        (begin
+          (variable-set! variable value)
+          (module-modified module))
+        (let ((variable (make-variable value)))
+          (module-add! module name variable)))))
+
+;; MODULE-DEFINED? -- exported
+;;
+;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
+;; uses)
+;;
+(define (module-defined? module name)
+  (let ((variable (module-variable module name)))
+    (and variable (variable-bound? variable))))
+
+;; MODULE-USE! module interface
+;;
+;; Add INTERFACE to the list of interfaces used by MODULE.
+;;
+(define (module-use! module interface)
+  (if (not (or (eq? module interface)
+               (memq interface (module-uses module))))
+      (begin
+        ;; Newly used modules must be appended rather than consed, so that
+        ;; `module-variable' traverses the use list starting from the first
+        ;; used module.
+        (set-module-uses! module (append (module-uses module)
+                                         (list interface)))
+        (hash-clear! (module-import-obarray module))
+        (module-modified module))))
+
+;; MODULE-USE-INTERFACES! module interfaces
+;;
+;; Same as MODULE-USE!, but only notifies module observers after all
+;; interfaces are added to the inports list.
+;;
+(define (module-use-interfaces! module interfaces)
+  (let* ((cur (module-uses module))
+         (new (let lp ((in interfaces) (out '()))
+                (if (null? in)
+                    (reverse out)
+                    (lp (cdr in)
+                        (let ((iface (car in)))
+                          (if (or (memq iface cur) (memq iface out))
+                              out
+                              (cons iface out))))))))
+    (set-module-uses! module (append cur new))
+    (hash-clear! (module-import-obarray module))
+    (module-modified module)))
+
+
+
+;;; {Recursive Namespaces}
+;;;
+;;; A hierarchical namespace emerges if we consider some module to be
+;;; root, and submodules of that module to be nested namespaces.
+;;;
+;;; The routines here manage variable names in hierarchical namespace.
+;;; Each variable name is a list of elements, looked up in successively nested
+;;; modules.
+;;;
+;;;             (nested-ref some-root-module '(foo bar baz))
+;;;             => <value of a variable named baz in the submodule bar of
+;;;                 the submodule foo of some-root-module>
+;;;
+;;;
+;;; There are:
+;;;
+;;;     ;; a-root is a module
+;;;     ;; name is a list of symbols
+;;;
+;;;     nested-ref a-root name
+;;;     nested-set! a-root name val
+;;;     nested-define! a-root name val
+;;;     nested-remove! a-root name
+;;;
+;;; These functions manipulate values in namespaces. For referencing the
+;;; namespaces themselves, use the following:
+;;;
+;;;     nested-ref-module a-root name
+;;;     nested-define-module! a-root name mod
+;;;
+;;; (current-module) is a natural choice for a root so for convenience there are
+;;; also:
+;;;
+;;;     local-ref name                ==  nested-ref (current-module) name
+;;;     local-set! name val           ==  nested-set! (current-module) name val
+;;;     local-define name val         ==  nested-define! (current-module) name val
+;;;     local-remove name             ==  nested-remove! (current-module) name
+;;;     local-ref-module name         ==  nested-ref-module (current-module) name
+;;;     local-define-module! name m   ==  nested-define-module! (current-module) name m
+;;;
+
+
+(define (nested-ref root names)
+  (if (null? names)
+      root
+      (let loop ((cur root)
+                 (head (car names))
+                 (tail (cdr names)))
+        (if (null? tail)
+            (module-ref cur head #f)
+            (let ((cur (module-ref-submodule cur head)))
+              (and cur
+                   (loop cur (car tail) (cdr tail))))))))
+
+(define (nested-set! root names val)
+  (let loop ((cur root)
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-set! cur head val)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
+
+(define (nested-define! root names val)
+  (let loop ((cur root)
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-define! cur head val)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
+
+(define (nested-remove! root names)
+  (let loop ((cur root)
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-remove! cur head)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
+
+
+(define (nested-ref-module root names)
+  (let loop ((cur root)
+             (names names))
+    (if (null? names)
+        cur
+        (let ((cur (module-ref-submodule cur (car names))))
+          (and cur
+               (loop cur (cdr names)))))))
+
+(define (nested-define-module! root names module)
+  (if (null? names)
+      (error "can't redefine root module" root module)
+      (let loop ((cur root)
+                 (head (car names))
+                 (tail (cdr names)))
+        (if (null? tail)
+            (module-define-submodule! cur head module)
+            (let ((cur (or (module-ref-submodule cur head)
+                           (let ((m (make-module 31)))
+                             (set-module-kind! m 'directory)
+                             (set-module-name! m (append (module-name cur)
+                                                         (list head)))
+                             (module-define-submodule! cur head m)
+                             m))))
+              (loop cur (car tail) (cdr tail)))))))
+
+
+(define (local-ref names)
+  (nested-ref (current-module) names))
+
+(define (local-set! names val)
+  (nested-set! (current-module) names val))
+
+(define (local-define names val)
+  (nested-define! (current-module) names val))
+
+(define (local-remove names)
+  (nested-remove! (current-module) names))
+
+(define (local-ref-module names)
+  (nested-ref-module (current-module) names))
+
+(define (local-define-module names mod)
+  (nested-define-module! (current-module) names mod))
+
+
+
+
+
+;;; {The (guile) module}
+;;;
+;;; The standard module, which has the core Guile bindings. Also called the
+;;; "root module", as it is imported by many other modules, but it is not
+;;; necessarily the root of anything; and indeed, the module named '() might be
+;;; better thought of as a root.
+;;;
+
+;; The root module uses the pre-modules-obarray as its obarray.  This
+;; special obarray accumulates all bindings that have been established
+;; before the module system is fully booted.
+;;
+;; (The obarray continues to be used by code that has been closed over
+;;  before the module system has been booted.)
+;;
+(define the-root-module
+  (let ((m (make-module 0)))
+    (set-module-obarray! m (%get-pre-modules-obarray))
+    (set-module-name! m '(guile))
+
+    ;; Inherit next-unique-id from preliminary stub of
+    ;; %module-get-next-unique-id! defined above.
+    (set-module-next-unique-id! m (module-generate-unique-id! #f))
+
+    m))
+
+;; The root interface is a module that uses the same obarray as the
+;; root module.  It does not allow new definitions, tho.
+;;
+(define the-scm-module
+  (let ((m (make-module 0)))
+    (set-module-obarray! m (%get-pre-modules-obarray))
+    (set-module-name! m '(guile))
+    (set-module-kind! m 'interface)
+
+    ;; In Guile 1.8 and earlier M was its own public interface.
+    (set-module-public-interface! m m)
+
+    m))
+
+(set-module-public-interface! the-root-module the-scm-module)
+
+
+
+;; Now that we have a root module, even though modules aren't fully booted,
+;; expand the definition of resolve-module.
+;;
+(define (resolve-module name . args)
+  (if (equal? name '(guile))
+      the-root-module
+      (error "unexpected module to resolve during module boot" name)))
+
+(define (module-generate-unique-id! m)
+  (let ((i (module-next-unique-id m)))
+    (set-module-next-unique-id! m (+ i 1))
+    i))
+
+;; Cheat.  These bindings are needed by modules.c, but we don't want
+;; to move their real definition here because that would be unnatural.
+;;
+(define define-module* #f)
+(define process-use-modules #f)
+(define module-export! #f)
+(define default-duplicate-binding-procedures #f)
+
+;; This boots the module system.  All bindings needed by modules.c
+;; must have been defined by now.
+;;
+(set-current-module the-root-module)
+
+
+
+
+;; Now that modules are booted, give module-name its final definition.
+;;
+(define module-name
+  (let ((accessor (record-accessor module-type 'name)))
+    (lambda (mod)
+      (or (accessor mod)
+          (let ((name (list (gensym))))
+            ;; Name MOD and bind it in the module root so that it's visible to
+            ;; `resolve-module'. This is important as `psyntax' stores module
+            ;; names and relies on being able to `resolve-module' them.
+            (set-module-name! mod name)
+            (nested-define-module! (resolve-module '() #f) name mod)
+            (accessor mod))))))
+
+(define* (module-gensym #\optional (id " mg") (m (current-module)))
+  "Return a fresh symbol in the context of module M, based on ID (a
+string or symbol).  As long as M is a valid module, this procedure is
+deterministic."
+  (define (->string number)
+    (number->string number 16))
+
+  (if m
+      (string->symbol
+       (string-append id "-"
+                      (->string (hash (module-name m) most-positive-fixnum))
+                      "-"
+                      (->string (module-generate-unique-id! m))))
+      (gensym id)))
+
+(define (make-modules-in module name)
+  (or (nested-ref-module module name)
+      (let ((m (make-module 31)))
+        (set-module-kind! m 'directory)
+        (set-module-name! m (append (module-name module) name))
+        (nested-define-module! module name m)
+        m)))
+
+(define (beautify-user-module! module)
+  (let ((interface (module-public-interface module)))
+    (if (or (not interface)
+            (eq? interface module))
+        (let ((interface (make-module 31)))
+          (set-module-name! interface (module-name module))
+          (set-module-version! interface (module-version module))
+          (set-module-kind! interface 'interface)
+          (set-module-public-interface! module interface))))
+  (if (and (not (memq the-scm-module (module-uses module)))
+           (not (eq? module the-root-module)))
+      ;; Import the default set of bindings (from the SCM module) in MODULE.
+      (module-use! module the-scm-module)))
+
+(define (version-matches? version-ref target)
+  (define (sub-versions-match? v-refs t)
+    (define (sub-version-matches? v-ref t)
+      (let ((matches? (lambda (v) (sub-version-matches? v t))))
+        (cond
+         ((number? v-ref) (eqv? v-ref t))
+         ((list? v-ref)
+          (case (car v-ref)
+            ((>=)  (>= t (cadr v-ref)))
+            ((<=)  (<= t (cadr v-ref)))
+            ((and) (and-map matches? (cdr v-ref)))
+            ((or)  (or-map matches? (cdr v-ref)))
+            ((not) (not (matches? (cadr v-ref))))
+            (else (error "Invalid sub-version reference" v-ref))))
+         (else (error "Invalid sub-version reference" v-ref)))))
+    (or (null? v-refs)
+        (and (not (null? t))
+             (sub-version-matches? (car v-refs) (car t))
+             (sub-versions-match? (cdr v-refs) (cdr t)))))
+
+  (let ((matches? (lambda (v) (version-matches? v target))))
+    (or (null? version-ref)
+        (case (car version-ref)
+          ((and) (and-map matches? (cdr version-ref)))
+          ((or)  (or-map matches? (cdr version-ref)))
+          ((not) (not (matches? (cadr version-ref))))
+          (else  (sub-versions-match? version-ref target))))))
+
+(define (make-fresh-user-module)
+  (let ((m (make-module)))
+    (beautify-user-module! m)
+    m))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
+(define resolve-module
+  (let ((root (make-module)))
+    (set-module-name! root '())
+    ;; Define the-root-module as '(guile).
+    (module-define-submodule! root 'guile the-root-module)
+
+    (lambda* (name #\optional (autoload #t) (version #f) #\key (ensure #t))
+      (let ((already (nested-ref-module root name)))
+        (cond
+         ((and already
+               (or (not autoload) (module-public-interface already)))
+          ;; A hit, a palpable hit.
+          (if (and version
+                   (not (version-matches? version (module-version already))))
+              (error "incompatible module version already loaded" name))
+          already)
+         (autoload
+          ;; Try to autoload the module, and recurse.
+          (try-load-module name version)
+          (resolve-module name #f #\ensure ensure))
+         (else
+          ;; No module found (or if one was, it had no public interface), and
+          ;; we're not autoloading. Make an empty module if #\ensure is true.
+          (or already
+              (and ensure
+                   (make-modules-in root name)))))))))
+
+
+(define (try-load-module name version)
+  (try-module-autoload name version))
+
+(define (reload-module m)
+  "Revisit the source file corresponding to the module @var{m}."
+  (let ((f (module-filename m)))
+    (if f
+        (save-module-excursion
+         (lambda () 
+           ;; Re-set the initial environment, as in try-module-autoload.
+           (set-current-module (make-fresh-user-module))
+           (primitive-load-path f)
+           m))
+        ;; Though we could guess, we *should* know it.
+        (error "unknown file name for module" m))))
+
+(define (purify-module! module)
+  "Removes bindings in MODULE which are inherited from the (guile) module."
+  (let ((use-list (module-uses module)))
+    (if (and (pair? use-list)
+             (eq? (car (last-pair use-list)) the-scm-module))
+        (set-module-uses! module (reverse (cdr (reverse use-list)))))))
+
+;; Return a module that is an interface to the module designated by
+;; NAME.
+;;
+;; `resolve-interface' takes four keyword arguments:
+;;
+;;   #\select SELECTION
+;;
+;; SELECTION is a list of binding-specs to be imported; A binding-spec
+;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
+;; is the name in the used module and SEEN is the name in the using
+;; module.  Note that SEEN is also passed through RENAMER, below.  The
+;; default is to select all bindings.  If you specify no selection but
+;; a renamer, only the bindings that already exist in the used module
+;; are made available in the interface.  Bindings that are added later
+;; are not picked up.
+;;
+;;   #\hide BINDINGS
+;;
+;; BINDINGS is a list of bindings which should not be imported.
+;;
+;;   #\prefix PREFIX
+;;
+;; PREFIX is a symbol that will be appended to each exported name.
+;; The default is to not perform any renaming.
+;;
+;;   #\renamer RENAMER
+;;
+;; RENAMER is a procedure that takes a symbol and returns its new
+;; name.  The default is not perform any renaming.
+;;
+;; Signal "no code for module" error if module name is not resolvable
+;; or its public interface is not available.  Signal "no binding"
+;; error if selected binding does not exist in the used module.
+;;
+(define* (resolve-interface name #\key
+                            (select #f)
+                            (hide '())
+                            (prefix #f)
+                            (renamer (if prefix
+                                         (symbol-prefix-proc prefix)
+                                         identity))
+                            version)
+  (let* ((module (resolve-module name #t version #\ensure #f))
+         (public-i (and module (module-public-interface module))))
+    (unless public-i
+      (error "no code for module" name))
+    (if (and (not select) (null? hide) (eq? renamer identity))
+        public-i
+        (let ((selection (or select (module-map (lambda (sym var) sym)
+                                                public-i)))
+              (custom-i (make-module 31)))
+          (set-module-kind! custom-i 'custom-interface)
+          (set-module-name! custom-i name)
+          ;; XXX - should use a lazy binder so that changes to the
+          ;; used module are picked up automatically.
+          (for-each (lambda (bspec)
+                      (let* ((direct? (symbol? bspec))
+                             (orig (if direct? bspec (car bspec)))
+                             (seen (if direct? bspec (cdr bspec)))
+                             (var (or (module-local-variable public-i orig)
+                                      (module-local-variable module orig)
+                                      (error
+                                       ;; fixme: format manually for now
+                                       (simple-format
+                                        #f "no binding `~A' in module ~A"
+                                        orig name)))))
+                        (if (memq orig hide)
+                            (set! hide (delq! orig hide))
+                            (module-add! custom-i
+                                         (renamer seen)
+                                         var))))
+                    selection)
+          ;; Check that we are not hiding bindings which don't exist
+          (for-each (lambda (binding)
+                      (if (not (module-local-variable public-i binding))
+                          (error
+                           (simple-format
+                            #f "no binding `~A' to hide in module ~A"
+                            binding name))))
+                    hide)
+          custom-i))))
+
+(define (symbol-prefix-proc prefix)
+  (lambda (symbol)
+    (symbol-append prefix symbol)))
+
+;; This function is called from "modules.c".  If you change it, be
+;; sure to update "modules.c" as well.
+
+(define* (define-module* name
+           #\key filename pure version (duplicates '())
+           (imports '()) (exports '()) (replacements '())
+           (re-exports '()) (autoloads '()) transformer)
+  (define (list-of pred l)
+    (or (null? l)
+        (and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
+  (define (valid-export? x)
+    (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
+  (define (valid-autoload? x)
+    (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
+  
+  (define (resolve-imports imports)
+    (define (resolve-import import-spec)
+      (if (list? import-spec)
+          (apply resolve-interface import-spec)
+          (error "unexpected use-module specification" import-spec)))
+    (let lp ((imports imports) (out '()))
+      (cond
+       ((null? imports) (reverse! out))
+       ((pair? imports)
+        (lp (cdr imports)
+            (cons (resolve-import (car imports)) out)))
+       (else (error "unexpected tail of imports list" imports)))))
+
+  ;; We could add a #\no-check arg, set by the define-module macro, if
+  ;; these checks are taking too much time.
+  ;;
+  (let ((module (resolve-module name #f)))
+    (beautify-user-module! module)
+    (if filename
+        (set-module-filename! module filename))
+    (if pure
+        (purify-module! module))
+    (if version
+        (begin 
+          (if (not (list-of integer? version))
+              (error "expected list of integers for version"))
+          (set-module-version! module version)
+          (set-module-version! (module-public-interface module) version)))
+    (let ((imports (resolve-imports imports)))
+      (call-with-deferred-observers
+       (lambda ()
+         (if (pair? imports)
+             (module-use-interfaces! module imports))
+         (if (list-of valid-export? exports)
+             (if (pair? exports)
+                 (module-export! module exports))
+             (error "expected exports to be a list of symbols or symbol pairs"))
+         (if (list-of valid-export? replacements)
+             (if (pair? replacements)
+                 (module-replace! module replacements))
+             (error "expected replacements to be a list of symbols or symbol pairs"))
+         (if (list-of valid-export? re-exports)
+             (if (pair? re-exports)
+                 (module-re-export! module re-exports))
+             (error "expected re-exports to be a list of symbols or symbol pairs"))
+         ;; FIXME
+         (if (not (null? autoloads))
+             (apply module-autoload! module autoloads))
+         ;; Wait until modules have been loaded to resolve duplicates
+         ;; handlers.
+         (if (pair? duplicates)
+             (let ((handlers (lookup-duplicates-handlers duplicates)))
+               (set-module-duplicates-handlers! module handlers))))))
+
+    (if transformer
+        (if (and (pair? transformer) (list-of symbol? transformer))
+            (let ((iface (resolve-interface transformer))
+                  (sym (car (last-pair transformer))))
+              (set-module-transformer! module (module-ref iface sym)))
+            (error "expected transformer to be a module name" transformer)))
+    
+    (run-hook module-defined-hook module)
+    module))
+
+;; `module-defined-hook' is a hook that is run whenever a new module
+;; is defined.  Its members are called with one argument, the new
+;; module.
+(define module-defined-hook (make-hook 1))
+
+
+
+;;; {Autoload}
+;;;
+
+(define (make-autoload-interface module name bindings)
+  (let ((b (lambda (a sym definep)
+             (false-if-exception
+              (and (memq sym bindings)
+                   (let ((i (module-public-interface (resolve-module name))))
+                     (if (not i)
+                         (error "missing interface for module" name))
+                     (let ((autoload (memq a (module-uses module))))
+                       ;; Replace autoload-interface with actual interface if
+                       ;; that has not happened yet.
+                       (if (pair? autoload)
+                           (set-car! autoload i)))
+                     (module-local-variable i sym)))
+              #\warning "Failed to autoload ~a in ~a:\n" sym name))))
+    (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
+                        (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
+                        (make-hash-table 0) #f #f #f 0)))
+
+(define (module-autoload! module . args)
+  "Have @var{module} automatically load the module named @var{name} when one
+of the symbols listed in @var{bindings} is looked up.  @var{args} should be a
+list of module-name/binding-list pairs, e.g., as in @code{(module-autoload!
+module '(ice-9 q) '(make-q q-length))}."
+  (let loop ((args args))
+    (cond ((null? args)
+           #t)
+          ((null? (cdr args))
+           (error "invalid name+binding autoload list" args))
+          (else
+           (let ((name     (car args))
+                 (bindings (cadr args)))
+             (module-use! module (make-autoload-interface module
+                                                          name bindings))
+             (loop (cddr args)))))))
+
+
+
+
+;;; {Autoloading modules}
+;;;
+
+;;; XXX FIXME autoloads-in-progress and autoloads-done
+;;;           are not handled in a thread-safe way.
+
+(define autoloads-in-progress '())
+
+;; This function is called from scm_load_scheme_module in
+;; "deprecated.c".  Please do not change its interface.
+;;
+(define* (try-module-autoload module-name #\optional version)
+  "Try to load a module of the given name.  If it is not found, return
+#f.  Otherwise return #t.  May raise an exception if a file is found,
+but it fails to load."
+  (let* ((reverse-name (reverse module-name))
+         (name (symbol->string (car reverse-name)))
+         (dir-hint-module-name (reverse (cdr reverse-name)))
+         (dir-hint (apply string-append
+                          (map (lambda (elt)
+                                 (string-append (symbol->string elt)
+                                                file-name-separator-string))
+                               dir-hint-module-name))))
+    (resolve-module dir-hint-module-name #f)
+    (and (not (autoload-done-or-in-progress? dir-hint name))
+         (let ((didit #f))
+           (dynamic-wind
+            (lambda () (autoload-in-progress! dir-hint name))
+            (lambda ()
+              (with-fluids ((current-reader #f))
+                (save-module-excursion
+                 (lambda () 
+                   (define (call/ec proc)
+                     (let ((tag (make-prompt-tag)))
+                       (call-with-prompt
+                        tag
+                        (lambda ()
+                          (proc (lambda () (abort-to-prompt tag))))
+                        (lambda (k) (values)))))
+                   ;; The initial environment when loading a module is a fresh
+                   ;; user module.
+                   (set-current-module (make-fresh-user-module))
+                   ;; Here we could allow some other search strategy (other than
+                   ;; primitive-load-path), for example using versions encoded
+                   ;; into the file system -- but then we would have to figure
+                   ;; out how to locate the compiled file, do auto-compilation,
+                   ;; etc. Punt for now, and don't use versions when locating
+                   ;; the file.
+                   (call/ec
+                    (lambda (abort)
+                      (primitive-load-path (in-vicinity dir-hint name)
+                                           abort)
+                      (set! didit #t)))))))
+            (lambda () (set-autoloaded! dir-hint name didit)))
+           didit))))
+
+
+
+;;; {Dynamic linking of modules}
+;;;
+
+(define autoloads-done '((guile . guile)))
+
+(define (autoload-done-or-in-progress? p m)
+  (let ((n (cons p m)))
+    (->bool (or (member n autoloads-done)
+                (member n autoloads-in-progress)))))
+
+(define (autoload-done! p m)
+  (let ((n (cons p m)))
+    (set! autoloads-in-progress
+          (delete! n autoloads-in-progress))
+    (or (member n autoloads-done)
+        (set! autoloads-done (cons n autoloads-done)))))
+
+(define (autoload-in-progress! p m)
+  (let ((n (cons p m)))
+    (set! autoloads-done
+          (delete! n autoloads-done))
+    (set! autoloads-in-progress (cons n autoloads-in-progress))))
+
+(define (set-autoloaded! p m done?)
+  (if done?
+      (autoload-done! p m)
+      (let ((n (cons p m)))
+        (set! autoloads-done (delete! n autoloads-done))
+        (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
+
+
+
+;;; {Run-time options}
+;;;
+
+(define-syntax define-option-interface
+  (syntax-rules ()
+    ((_ (interface (options enable disable) (option-set!)))
+     (begin
+       (define options
+        (case-lambda
+          (() (interface))
+          ((arg)
+           (if (list? arg)
+               (begin (interface arg) (interface))
+               (for-each
+                (lambda (option)
+                  (apply (lambda (name value documentation)
+                           (display name)
+                           (let ((len (string-length (symbol->string name))))
+                             (when (< len 16)
+                               (display #\tab)
+                               (when (< len 8)
+                                 (display #\tab))))
+                           (display #\tab)
+                           (display value)
+                           (display #\tab)
+                           (display documentation)
+                           (newline))
+                         option))
+                (interface #t))))))
+       (define (enable . flags)
+         (interface (append flags (interface)))
+         (interface))
+       (define (disable . flags)
+         (let ((options (interface)))
+           (for-each (lambda (flag) (set! options (delq! flag options)))
+                     flags)
+           (interface options)
+           (interface)))
+       (define-syntax-rule (option-set! opt val)
+         (eval-when (expand load eval)
+           (options (append (options) (list 'opt val)))))))))
+
+(define-option-interface
+  (debug-options-interface
+   (debug-options debug-enable debug-disable)
+   (debug-set!)))
+
+(define-option-interface
+  (read-options-interface
+   (read-options read-enable read-disable)
+   (read-set!)))
+
+(define-option-interface
+  (print-options-interface
+   (print-options print-enable print-disable)
+   (print-set!)))
+
+
+
+;;; {The Unspecified Value}
+;;;
+;;; Currently Guile represents unspecified values via one particular value,
+;;; which may be obtained by evaluating (if #f #f). It would be nice in the
+;;; future if we could replace this with a return of 0 values, though.
+;;;
+
+(define-syntax *unspecified*
+  (identifier-syntax (if #f #f)))
+
+(define (unspecified? v) (eq? v *unspecified*))
+
+
+
+
+;;; {Parameters}
+;;;
+
+(define <parameter>
+  ;; Three fields: the procedure itself, the fluid, and the converter.
+  (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #\optional (conv (lambda (x) x)))
+  "Make a new parameter.
+
+A parameter is a dynamically bound value, accessed through a procedure.
+To access the current value, apply the procedure with no arguments:
+
+  (define p (make-parameter 10))
+  (p) => 10
+
+To provide a new value for the parameter in a dynamic extent, use
+`parameterize':
+
+  (parameterize ((p 20))
+    (p)) => 20
+  (p) => 10
+
+The value outside of the dynamic extent of the body is unaffected.  To
+update the current value, apply it to one argument:
+
+  (p 20) => 10
+  (p) => 20
+
+As you can see, the call that updates a parameter returns its previous
+value.
+
+All values for the parameter are first run through the CONV procedure,
+including INIT, the initial value.  The default CONV procedure is the
+identity procedure.  CONV is commonly used to ensure some set of
+invariants on the values that a parameter may have."
+  (let ((fluid (make-fluid (conv init))))
+    (make-struct <parameter> 0
+                 (case-lambda
+                   (() (fluid-ref fluid))
+                   ((x) (let ((prev (fluid-ref fluid)))
+                          (fluid-set! fluid (conv x))
+                          prev)))
+                 fluid conv)))
+
+(define* (fluid->parameter fluid #\optional (conv (lambda (x) x)))
+  "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter.  Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+  (make-struct <parameter> 0
+               (case-lambda
+                 (() (fluid-ref fluid))
+                 ((x) (let ((prev (fluid-ref fluid)))
+                        (fluid-set! fluid (conv x))
+                        prev)))
+               fluid conv))
+
+(define (parameter? x)
+  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+  (if (parameter? p)
+      (struct-ref p 1)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+  (if (parameter? p)
+      (struct-ref p 2)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((param value) ...) body body* ...)
+       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+         #'(let ((p param) ...)
+             (if (not (parameter? p))
+                        (scm-error 'wrong-type-arg "parameterize"
+                                   "Not a parameter: ~S" (list p) #f))
+             ...
+             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+                           ...)
+               body body* ...)))))))
+
+
+;;;
+;;; Current ports as parameters.
+;;;
+
+(let ()
+  (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+    (begin
+      (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+                                      (lambda (x)
+                                        (if (predicate x) x
+                                            (error msg x)))))
+      (module-remove! (current-module) 'fluid)))
+  
+  (port-parameterize! current-input-port %current-input-port-fluid
+                      input-port? "expected an input port")
+  (port-parameterize! current-output-port %current-output-port-fluid
+                      output-port? "expected an output port")
+  (port-parameterize! current-error-port %current-error-port-fluid
+                      output-port? "expected an output port")
+  (port-parameterize! current-warning-port %current-warning-port-fluid
+                      output-port? "expected an output port"))
+
+
+
+;;;
+;;; Languages.
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
+
+
+;;; {Running Repls}
+;;;
+
+(define *repl-stack* (make-fluid '()))
+
+;; Programs can call `batch-mode?' to see if they are running as part of a
+;; script or if they are running interactively. REPL implementations ensure that
+;; `batch-mode?' returns #f during their extent.
+;;
+(define (batch-mode?)
+  (null? (fluid-ref *repl-stack*)))
+
+;; Programs can re-enter batch mode, for example after a fork, by calling
+;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
+;; to abort to the outermost prompt, and call a thunk there.
+;;
+(define (ensure-batch-mode!)
+  (set! batch-mode? (lambda () #t)))
+
+(define (quit . args)
+  (apply throw 'quit args))
+
+(define exit quit)
+
+(define (gc-run-time)
+  (cdr (assq 'gc-time-taken (gc-stats))))
+
+(define abort-hook (make-hook))
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))
+
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
+(define before-eval-hook (make-hook 1))
+(define after-eval-hook (make-hook 1))
+(define before-print-hook (make-hook 1))
+(define after-print-hook (make-hook 1))
+
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
+;;; The default repl-reader function.  We may override this if we've
+;;; the readline library.
+(define repl-reader
+  (lambda* (prompt #\optional (reader (fluid-ref current-reader)))
+    (if (not (char-ready?))
+        (begin
+          (display (if (string? prompt) prompt (prompt)))
+          ;; An interesting situation.  The printer resets the column to
+          ;; 0 by printing a newline, but we then advance it by printing
+          ;; the prompt.  However the port-column of the output port
+          ;; does not typically correspond with the actual column on the
+          ;; screen, because the input is echoed back!  Since the
+          ;; input is line-buffered and thus ends with a newline, the
+          ;; output will really start on column zero.  So, here we zero
+          ;; it out.  See bug 9664.
+          ;;
+          ;; Note that for similar reasons, the output-line will not
+          ;; reflect the actual line on the screen.  But given the
+          ;; possibility of multiline input, the fix is not as
+          ;; straightforward, so we don't bother.
+          ;;
+          ;; Also note that the readline implementation papers over
+          ;; these concerns, because it's readline itself printing the
+          ;; prompt, and not Guile.
+          (set-port-column! (current-output-port) 0)))
+    (force-output)
+    (run-hook before-read-hook)
+    ((or reader read) (current-input-port))))
+
+
+
+
+;;; {IOTA functions: generating lists of numbers}
+;;;
+
+(define (iota n)
+  (let loop ((count (1- n)) (result '()))
+    (if (< count 0) result
+        (loop (1- count) (cons count result)))))
+
+
+
+;;; {While}
+;;;
+;;; with `continue' and `break'.
+;;;
+
+;; The inliner will remove the prompts at compile-time if it finds that
+;; `continue' or `break' are not used.
+;;
+(define-syntax while
+  (lambda (x)
+    (syntax-case x ()
+      ((while cond body ...)
+       #`(let ((break-tag (make-prompt-tag "break"))
+               (continue-tag (make-prompt-tag "continue")))
+           (call-with-prompt
+            break-tag
+            (lambda ()
+              (define-syntax #,(datum->syntax #'while 'break)
+                (lambda (x)
+                  (syntax-case x ()
+                    ((_ arg (... ...))
+                     #'(abort-to-prompt break-tag arg (... ...)))
+                    (_
+                     #'(lambda args
+                         (apply abort-to-prompt break-tag args))))))
+              (let lp ()
+                (call-with-prompt
+                 continue-tag
+                 (lambda () 
+                   (define-syntax #,(datum->syntax #'while 'continue)
+                     (lambda (x)
+                       (syntax-case x ()
+                         ((_)
+                          #'(abort-to-prompt continue-tag))
+                         ((_ . args)
+                          (syntax-violation 'continue "too many arguments" x))
+                         (_
+                          #'(lambda ()
+                              (abort-to-prompt continue-tag))))))
+                   (do () ((not cond) #f) body ...))
+                 (lambda (k) (lp)))))
+            (lambda (k . args)
+              (if (null? args)
+                  #t
+                  (apply values args)))))))))
+
+
+
+
+;;; {Module System Macros}
+;;;
+
+;; Return a list of expressions that evaluate to the appropriate
+;; arguments for resolve-interface according to SPEC.
+
+(eval-when (expand)
+  (if (memq 'prefix (read-options))
+      (error "boot-9 must be compiled with #:kw, not :kw")))
+
+(define (keyword-like-symbol->keyword sym)
+  (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+
+(define-syntax define-module
+  (lambda (x)
+    (define (keyword-like? stx)
+      (let ((dat (syntax->datum stx)))
+        (and (symbol? dat)
+             (eqv? (string-ref (symbol->string dat) 0) #\:))))
+    (define (->keyword sym)
+      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+    
+    (define (parse-iface args)
+      (let loop ((in args) (out '()))
+        (syntax-case in ()
+          (() (reverse! out))
+          ;; The user wanted #\foo, but wrote :foo. Fix it.
+          ((sym . in) (keyword-like? #'sym)
+           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+          ((kw . in) (not (keyword? (syntax->datum #'kw)))
+           (syntax-violation 'define-module "expected keyword arg" x #'kw))
+          ((#\renamer renamer . in)
+           (loop #'in (cons* #',renamer #\renamer out)))
+          ((kw val . in)
+           (loop #'in (cons* #'val #'kw out))))))
+
+    (define (parse args imp exp rex rep aut)
+      ;; Just quote everything except #\use-module and #\use-syntax.  We
+      ;; need to know about all arguments regardless since we want to turn
+      ;; symbols that look like keywords into real keywords, and the
+      ;; keyword args in a define-module form are not regular
+      ;; (i.e. no-backtrace doesn't take a value).
+      (syntax-case args ()
+        (()
+         (let ((imp (if (null? imp) '() #`(#\imports `#,imp)))
+               (exp (if (null? exp) '() #`(#\exports '#,exp)))
+               (rex (if (null? rex) '() #`(#\re-exports '#,rex)))
+               (rep (if (null? rep) '() #`(#\replacements '#,rep)))
+               (aut (if (null? aut) '() #`(#\autoloads '#,aut))))
+           #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
+        ;; The user wanted #\foo, but wrote :foo. Fix it.
+        ((sym . args) (keyword-like? #'sym)
+         (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
+                  imp exp rex rep aut))
+        ((kw . args) (not (keyword? (syntax->datum #'kw)))
+         (syntax-violation 'define-module "expected keyword arg" x #'kw))
+        ((#\no-backtrace . args)
+         ;; Ignore this one.
+         (parse #'args imp exp rex rep aut))
+        ((#\pure . args)
+         #`(#\pure #t . #,(parse #'args imp exp rex rep aut)))
+        ((kw)
+         (syntax-violation 'define-module "keyword arg without value" x #'kw))
+        ((#\version (v ...) . args)
+         #`(#\version '(v ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#\duplicates (d ...) . args)
+         #`(#\duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#\filename f . args)
+         #`(#\filename 'f . #,(parse #'args imp exp rex rep aut)))
+        ((#\use-module (name name* ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
+        ((#\use-syntax (name name* ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         #`(#\transformer '(name name* ...)
+            . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
+        ((#\use-module ((name name* ...) arg ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args
+                #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
+                exp rex rep aut))
+        ((#\export (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#\export-syntax (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#\re-export (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#\re-export-syntax (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#\replace (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#\replace-syntax (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#\autoload name bindings . args)
+         (parse #'args imp exp rex rep #`(#,@aut name bindings)))
+        ((kw val . args)
+         (syntax-violation 'define-module "unknown keyword or bad argument"
+                           #'kw #'val))))
+    
+    (syntax-case x ()
+      ((_ (name name* ...) arg ...)
+       (and-map symbol? (syntax->datum #'(name name* ...)))
+       (with-syntax (((quoted-arg ...)
+                      (parse #'(arg ...) '() '() '() '() '()))
+                     ;; Ideally the filename is either a string or #f;
+                     ;; this hack is to work around a case in which
+                     ;; port-filename returns a symbol (`socket') for
+                     ;; sockets.
+                     (filename (let ((f (assq-ref (or (syntax-source x) '())
+                                                  'filename)))
+                                 (and (string? f) f))))
+         #'(eval-when (expand load eval)
+             (let ((m (define-module* '(name name* ...)
+                        #\filename filename quoted-arg ...)))
+               (set-current-module m)
+               m)))))))
+
+;; The guts of the use-modules macro.  Add the interfaces of the named
+;; modules to the use-list of the current module, in order.
+
+;; This function is called by "modules.c".  If you change it, be sure
+;; to change scm_c_use_module as well.
+
+(define (process-use-modules module-interface-args)
+  (let ((interfaces (map (lambda (mif-args)
+                           (or (apply resolve-interface mif-args)
+                               (error "no such module" mif-args)))
+                         module-interface-args)))
+    (call-with-deferred-observers
+     (lambda ()
+       (module-use-interfaces! (current-module) interfaces)))))
+
+(define-syntax use-modules
+  (lambda (x)
+    (define (keyword-like? stx)
+      (let ((dat (syntax->datum stx)))
+        (and (symbol? dat)
+             (eqv? (string-ref (symbol->string dat) 0) #\:))))
+    (define (->keyword sym)
+      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+    
+    (define (quotify-iface args)
+      (let loop ((in args) (out '()))
+        (syntax-case in ()
+          (() (reverse! out))
+          ;; The user wanted #\foo, but wrote :foo. Fix it.
+          ((sym . in) (keyword-like? #'sym)
+           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+          ((kw . in) (not (keyword? (syntax->datum #'kw)))
+           (syntax-violation 'define-module "expected keyword arg" x #'kw))
+          ((#\renamer renamer . in)
+           (loop #'in (cons* #'renamer #\renamer out)))
+          ((kw val . in)
+           (loop #'in (cons* #''val #'kw out))))))
+
+    (define (quotify specs)
+      (let lp ((in specs) (out '()))
+        (syntax-case in ()
+          (() (reverse out))
+          (((name name* ...) . in)
+           (and-map symbol? (syntax->datum #'(name name* ...)))
+           (lp #'in (cons #''((name name* ...)) out)))
+          ((((name name* ...) arg ...) . in)
+           (and-map symbol? (syntax->datum #'(name name* ...)))
+           (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
+             (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
+                            out)))))))
+    
+    (syntax-case x ()
+      ((_ spec ...)
+       (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
+         #'(eval-when (expand load eval)
+             (process-use-modules (list quoted-args ...))
+             *unspecified*))))))
+
+(define-syntax-rule (use-syntax spec ...)
+  (begin
+    (eval-when (expand load eval)
+      (issue-deprecation-warning
+       "`use-syntax' is deprecated. Please contact guile-devel for more info."))
+    (use-modules spec ...)))
+
+(include-from-path "ice-9/r6rs-libraries")
+
+(define-syntax-rule (define-private foo bar)
+  (define foo bar))
+
+(define-syntax define-public
+  (syntax-rules ()
+    ((_ (name . args) . body)
+     (begin
+       (define (name . args) . body)
+       (export name)))
+    ((_ name val)
+     (begin
+       (define name val)
+       (export name)))))
+
+(define-syntax-rule (defmacro-public name args body ...)
+  (begin
+    (defmacro name args body ...)
+    (export-syntax name)))
+
+;; And now for the most important macro.
+(define-syntax-rule (lumbum formals body ...)
+  (lambda formals body ...))
+
+
+;; Export a local variable
+
+;; This function is called from "modules.c".  If you change it, be
+;; sure to update "modules.c" as well.
+
+(define (module-export! m names)
+  (let ((public-i (module-public-interface m)))
+    (for-each (lambda (name)
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-ensure-local-variable! m internal-name)))
+                  (module-add! public-i external-name var)))
+              names)))
+
+(define (module-replace! m names)
+  (let ((public-i (module-public-interface m)))
+    (for-each (lambda (name)
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-ensure-local-variable! m internal-name)))
+                  ;; FIXME: use a bit on variables instead of object
+                  ;; properties.
+                  (set-object-property! var 'replace #t)
+                  (module-add! public-i external-name var)))
+              names)))
+
+;; Export all local variables from a module
+;;
+(define (module-export-all! mod)
+  (define (fresh-interface!)
+    (let ((iface (make-module)))
+      (set-module-name! iface (module-name mod))
+      (set-module-version! iface (module-version mod))
+      (set-module-kind! iface 'interface)
+      (set-module-public-interface! mod iface)
+      iface))
+  (let ((iface (or (module-public-interface mod)
+                   (fresh-interface!))))
+    (set-module-obarray! iface (module-obarray mod))))
+
+;; Re-export a imported variable
+;;
+(define (module-re-export! m names)
+  (let ((public-i (module-public-interface m)))
+    (for-each (lambda (name)
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-variable m internal-name)))
+                  (cond ((not var)
+                         (error "Undefined variable:" internal-name))
+                        ((eq? var (module-local-variable m internal-name))
+                         (error "re-exporting local variable:" internal-name))
+                        (else
+                         (module-add! public-i external-name var)))))
+              names)))
+
+(define-syntax-rule (export name ...)
+  (eval-when (expand load eval)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-export! (current-module) '(name ...))))))
+
+(define-syntax-rule (re-export name ...)
+  (eval-when (expand load eval)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-re-export! (current-module) '(name ...))))))
+
+(define-syntax-rule (export! name ...)
+  (eval-when (expand load eval)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-replace! (current-module) '(name ...))))))
+
+(define-syntax-rule (export-syntax name ...)
+  (export name ...))
+
+(define-syntax-rule (re-export-syntax name ...)
+  (re-export name ...))
+
+
+
+;;; {Parameters}
+;;;
+
+(define* (make-mutable-parameter init #\optional (converter identity))
+  (let ((fluid (make-fluid (converter init))))
+    (case-lambda
+      (() (fluid-ref fluid))
+      ((val) (fluid-set! fluid (converter val))))))
+
+
+
+
+;;; {Handling of duplicate imported bindings}
+;;;
+
+;; Duplicate handlers take the following arguments:
+;;
+;; module  importing module
+;; name    conflicting name
+;; int1    old interface where name occurs
+;; val1    value of binding in old interface
+;; int2    new interface where name occurs
+;; val2    value of binding in new interface
+;; var     previous resolution or #f
+;; val     value of previous resolution
+;;
+;; A duplicate handler can take three alternative actions:
+;;
+;; 1. return #f => leave responsibility to next handler
+;; 2. exit with an error
+;; 3. return a variable resolving the conflict
+;;
+
+(define duplicate-handlers
+  (let ((m (make-module 7)))
+    
+    (define (check module name int1 val1 int2 val2 var val)
+      (scm-error 'misc-error
+                 #f
+                 "~A: `~A' imported from both ~A and ~A"
+                 (list (module-name module)
+                       name
+                       (module-name int1)
+                       (module-name int2))
+                 #f))
+    
+    (define (warn module name int1 val1 int2 val2 var val)
+      (format (current-warning-port)
+              "WARNING: ~A: `~A' imported from both ~A and ~A\n"
+              (module-name module)
+              name
+              (module-name int1)
+              (module-name int2))
+      #f)
+     
+    (define (replace module name int1 val1 int2 val2 var val)
+      (let ((old (or (and var (object-property var 'replace) var)
+                     (module-variable int1 name)))
+            (new (module-variable int2 name)))
+        (if (object-property old 'replace)
+            (and (or (eq? old new)
+                     (not (object-property new 'replace)))
+                 old)
+            (and (object-property new 'replace)
+                 new))))
+    
+    (define (warn-override-core module name int1 val1 int2 val2 var val)
+      (and (eq? int1 the-scm-module)
+           (begin
+             (format (current-warning-port)
+                     "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
+                     (module-name module)
+                     (module-name int2)
+                     name)
+             (module-local-variable int2 name))))
+     
+    (define (first module name int1 val1 int2 val2 var val)
+      (or var (module-local-variable int1 name)))
+     
+    (define (last module name int1 val1 int2 val2 var val)
+      (module-local-variable int2 name))
+     
+    (define (noop module name int1 val1 int2 val2 var val)
+      #f)
+    
+    (set-module-name! m 'duplicate-handlers)
+    (set-module-kind! m 'interface)
+    (module-define! m 'check check)
+    (module-define! m 'warn warn)
+    (module-define! m 'replace replace)
+    (module-define! m 'warn-override-core warn-override-core)
+    (module-define! m 'first first)
+    (module-define! m 'last last)
+    (module-define! m 'merge-generics noop)
+    (module-define! m 'merge-accessors noop)
+    m))
+
+(define (lookup-duplicates-handlers handler-names)
+  (and handler-names
+       (map (lambda (handler-name)
+              (or (module-symbol-local-binding
+                   duplicate-handlers handler-name #f)
+                  (error "invalid duplicate handler name:"
+                         handler-name)))
+            (if (list? handler-names)
+                handler-names
+                (list handler-names)))))
+
+(define default-duplicate-binding-procedures
+  (make-mutable-parameter #f))
+
+(define default-duplicate-binding-handler
+  (make-mutable-parameter '(replace warn-override-core warn last)
+                          (lambda (handler-names)
+                            (default-duplicate-binding-procedures
+                              (lookup-duplicates-handlers handler-names))
+                            handler-names)))
+
+
+
+;;; {`load'.}
+;;;
+;;; Load is tricky when combined with relative file names, compilation,
+;;; and the file system.  If a file name is relative, what is it
+;;; relative to?  The name of the source file at the time it was
+;;; compiled?  The name of the compiled file?  What if both or either
+;;; were installed?  And how do you get that information?  Tricky, I
+;;; say.
+;;;
+;;; To get around all of this, we're going to do something nasty, and
+;;; turn `load' into a macro.  That way it can know the name of the
+;;; source file with respect to which it was invoked, so it can resolve
+;;; relative file names with respect to the original source file.
+;;;
+;;; There is an exception, and that is that if the source file was in
+;;; the load path when it was compiled, instead of looking up against
+;;; the absolute source location, we load-from-path against the relative
+;;; source location.
+;;;
+
+(define %auto-compilation-options
+  ;; Default `compile-file' option when auto-compiling.
+  '(#\warnings (unbound-variable arity-mismatch format
+                duplicate-case-datum bad-case-datum)))
+
+(define* (load-in-vicinity dir file-name #\optional reader)
+  "Load source file FILE-NAME in vicinity of directory DIR.  Use a
+pre-compiled version of FILE-NAME when available, and auto-compile one
+when none is available, reading FILE-NAME with READER."
+
+  ;; The auto-compilation code will residualize a .go file in the cache
+  ;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go.  This
+  ;; function determines the PATH to use as a key into the compilation
+  ;; cache.
+  (define (canonical->suffix canon)
+    (cond
+     ((and (not (string-null? canon))
+           (file-name-separator? (string-ref canon 0)))
+      canon)
+     ((and (eq? (system-file-name-convention) 'windows)
+           (absolute-file-name? canon))
+      ;; An absolute file name that doesn't start with a separator
+      ;; starts with a drive component.  Transform the drive component
+      ;; to a file name element:  c:\foo -> \c\foo.
+      (string-append file-name-separator-string
+                     (substring canon 0 1)
+                     (substring canon 2)))
+     (else canon)))
+
+  (define compiled-extension
+    ;; File name extension of compiled files.
+    (cond ((or (null? %load-compiled-extensions)
+               (string-null? (car %load-compiled-extensions)))
+           (warn "invalid %load-compiled-extensions"
+                 %load-compiled-extensions)
+           ".go")
+          (else (car %load-compiled-extensions))))
+
+  (define (more-recent? stat1 stat2)
+    ;; Return #t when STAT1 has an mtime greater than that of STAT2.
+    (or (> (stat:mtime stat1) (stat:mtime stat2))
+        (and (= (stat:mtime stat1) (stat:mtime stat2))
+             (>= (stat:mtimensec stat1)
+                 (stat:mtimensec stat2)))))
+
+  (define (fallback-file-name canon-file-name)
+    ;; Return the in-cache compiled file name for source file
+    ;; CANON-FILE-NAME.
+
+    ;; FIXME: would probably be better just to append
+    ;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid
+    ;; deep directory stats.
+    (and %compile-fallback-path
+         (string-append %compile-fallback-path
+                        (canonical->suffix canon-file-name)
+                        compiled-extension)))
+
+  (define (compile file)
+    ;; Compile source FILE, lazily loading the compiler.
+    ((module-ref (resolve-interface '(system base compile))
+                 'compile-file)
+     file
+     #\opts %auto-compilation-options
+     #\env (current-module)))
+
+  (define (load-thunk-from-file file)
+    (let ((objcode (resolve-interface '(system vm objcode)))
+          (program (resolve-interface '(system vm program))))
+      ((module-ref program 'make-program)
+       ((module-ref objcode 'load-objcode) file))))
+
+  ;; Returns a thunk loaded from the .go file corresponding to `name'.
+  ;; Does not search load paths, only the fallback path.  If the .go
+  ;; file is missing or out of date, and auto-compilation is enabled,
+  ;; will try auto-compilation, just as primitive-load-path does
+  ;; internally.  primitive-load is unaffected.  Returns #f if
+  ;; auto-compilation failed or was disabled.
+  ;;
+  ;; NB: Unless we need to compile the file, this function should not
+  ;; cause (system base compile) to be loaded up.  For that reason
+  ;; compiled-file-name partially duplicates functionality from (system
+  ;; base compile).
+
+  (define (fresh-compiled-thunk name scmstat go-file-name)
+    ;; Return GO-FILE-NAME after making sure that it contains a freshly
+    ;; compiled version of source file NAME with stat SCMSTAT; return #f
+    ;; on failure.
+    (false-if-exception
+     (let ((gostat (and (not %fresh-auto-compile)
+                        (stat go-file-name #f))))
+       (if (and gostat (more-recent? gostat scmstat))
+           (load-thunk-from-file go-file-name)
+           (begin
+             (when gostat
+               (format (current-warning-port)
+                       ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
+                       name go-file-name))
+             (cond
+              (%load-should-auto-compile
+               (%warn-auto-compilation-enabled)
+               (format (current-warning-port) ";;; compiling ~a\n" name)
+               (let ((cfn (compile name)))
+                 (format (current-warning-port) ";;; compiled ~a\n" cfn)
+                 (load-thunk-from-file cfn)))
+              (else #f)))))
+     #\warning "WARNING: compilation of ~a failed:\n" name))
+
+  (define (sans-extension file)
+    (let ((dot (string-rindex file #\.)))
+      (if dot
+          (substring file 0 dot)
+          file)))
+
+  (define (load-absolute abs-file-name)
+    ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling
+    ;; if needed.
+    (define scmstat
+      (false-if-exception
+       (stat abs-file-name)
+       #\warning "Stat of ~a failed:\n" abs-file-name))
+
+    (define (pre-compiled)
+      (or-map
+       (lambda (dir)
+         (or-map
+          (lambda (ext)
+            (let ((candidate (string-append (in-vicinity dir file-name) ext)))
+              (let ((gostat (stat candidate #f)))
+                (and gostat
+                     (more-recent? gostat scmstat)
+                     (false-if-exception
+                      (load-thunk-from-file candidate)
+                      #\warning "WARNING: failed to load compiled file ~a:\n"
+                      candidate)))))
+          %load-compiled-extensions))
+       %load-compiled-path))
+
+    (define (fallback)
+      (and=> (false-if-exception (canonicalize-path abs-file-name))
+             (lambda (canon)
+               (and=> (fallback-file-name canon)
+                      (lambda (go-file-name)
+                        (fresh-compiled-thunk abs-file-name
+                                              scmstat
+                                              go-file-name))))))
+
+    (let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
+      (if compiled
+          (begin
+            (if %load-hook
+                (%load-hook abs-file-name))
+            (compiled))
+          (start-stack 'load-stack
+                       (primitive-load abs-file-name)))))
+
+  (save-module-excursion
+   (lambda ()
+     (with-fluids ((current-reader reader)
+                   (%file-port-name-canonicalization 'relative))
+       (cond
+        ((absolute-file-name? file-name)
+         (load-absolute file-name))
+        ((absolute-file-name? dir)
+         (load-absolute (in-vicinity dir file-name)))
+        (else
+         (load-from-path (in-vicinity dir file-name))))))))
+
+(define-syntax load
+  (make-variable-transformer
+   (lambda (x)
+     (let* ((src (syntax-source x))
+            (file (and src (assq-ref src 'filename)))
+            (dir (and (string? file) (dirname file))))
+       (syntax-case x ()
+         ((_ arg ...)
+          #`(load-in-vicinity #,(or dir #'(getcwd)) arg ...))
+         (id
+          (identifier? #'id)
+          #`(lambda args
+              (apply load-in-vicinity #,(or dir #'(getcwd)) args))))))))
+
+
+
+;;; {`cond-expand' for SRFI-0 support.}
+;;;
+;;; This syntactic form expands into different commands or
+;;; definitions, depending on the features provided by the Scheme
+;;; implementation.
+;;;
+;;; Syntax:
+;;;
+;;; <cond-expand>
+;;;   --> (cond-expand <cond-expand-clause>+)
+;;;     | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
+;;; <cond-expand-clause>
+;;;   --> (<feature-requirement> <command-or-definition>*)
+;;; <feature-requirement>
+;;;   --> <feature-identifier>
+;;;     | (and <feature-requirement>*)
+;;;     | (or <feature-requirement>*)
+;;;     | (not <feature-requirement>)
+;;; <feature-identifier>
+;;;   --> <a symbol which is the name or alias of a SRFI>
+;;;
+;;; Additionally, this implementation provides the
+;;; <feature-identifier>s `guile' and `r5rs', so that programs can
+;;; determine the implementation type and the supported standard.
+;;;
+;;; Remember to update the features list when adding more SRFIs.
+;;;
+
+(define %cond-expand-features
+  ;; This should contain only features that are present in core Guile,
+  ;; before loading any modules.  Modular features are handled by
+  ;; placing 'cond-expand-provide' in the relevant module.
+  '(guile
+    guile-2
+    r5rs
+    srfi-0   ;; cond-expand itself
+    srfi-4   ;; homogeneous numeric vectors
+    ;; We omit srfi-6 because the 'open-input-string' etc in Guile
+    ;; core are not conformant with SRFI-6; they expose details
+    ;; of the binary I/O model and may fail to support some characters.
+    srfi-13  ;; string library
+    srfi-14  ;; character sets
+    srfi-16  ;; case-lambda
+    srfi-23  ;; `error` procedure
+    srfi-30  ;; nested multi-line comments
+    srfi-39  ;; parameterize
+    srfi-46  ;; basic syntax-rules extensions
+    srfi-55  ;; require-extension
+    srfi-61  ;; general cond clause
+    srfi-62  ;; s-expression comments
+    srfi-87  ;; => in case clauses
+    srfi-105 ;; curly infix expressions
+    ))
+
+;; This table maps module public interfaces to the list of features.
+;;
+(define %cond-expand-table (make-hash-table 31))
+
+;; Add one or more features to the `cond-expand' feature list of the
+;; module `module'.
+;;
+(define (cond-expand-provide module features)
+  (let ((mod (module-public-interface module)))
+    (and mod
+         (hashq-set! %cond-expand-table mod
+                     (append (hashq-ref %cond-expand-table mod '())
+                             features)))))
+
+(define-syntax cond-expand
+  (lambda (x)
+    (define (module-has-feature? mod sym)
+      (or-map (lambda (mod)
+                (memq sym (hashq-ref %cond-expand-table mod '())))
+              (module-uses mod)))
+
+    (define (condition-matches? condition)
+      (syntax-case condition (and or not)
+        ((and c ...)
+         (and-map condition-matches? #'(c ...)))
+        ((or c ...)
+         (or-map condition-matches? #'(c ...)))
+        ((not c)
+         (if (condition-matches? #'c) #f #t))
+        (c
+         (identifier? #'c)
+         (let ((sym (syntax->datum #'c)))
+           (if (memq sym %cond-expand-features)
+               #t
+               (module-has-feature? (current-module) sym))))))
+
+    (define (match clauses alternate)
+      (syntax-case clauses ()
+        (((condition form ...) . rest)
+         (if (condition-matches? #'condition)
+             #'(begin form ...)
+             (match #'rest alternate)))
+        (() (alternate))))
+
+    (syntax-case x (else)
+      ((_ clause ... (else form ...))
+       (match #'(clause ...)
+         (lambda ()
+           #'(begin form ...))))
+      ((_ clause ...)
+       (match #'(clause ...)
+         (lambda ()
+           (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
+
+;; This procedure gets called from the startup code with a list of
+;; numbers, which are the numbers of the SRFIs to be loaded on startup.
+;;
+(define (use-srfis srfis)
+  (process-use-modules
+   (map (lambda (num)
+          (list (list 'srfi (string->symbol
+                             (string-append "srfi-" (number->string num))))))
+        srfis)))
+
+
+
+;;; srfi-55: require-extension
+;;;
+
+(define-syntax require-extension
+  (lambda (x)
+    (syntax-case x (srfi)
+      ((_ (srfi n ...))
+       (and-map integer? (syntax->datum #'(n ...)))
+       (with-syntax
+           (((srfi-n ...)
+             (map (lambda (n)
+                    (datum->syntax x (symbol-append 'srfi- n)))
+                  (map string->symbol
+                       (map number->string (syntax->datum #'(n ...)))))))
+         #'(use-modules (srfi srfi-n) ...)))
+      ((_ (type arg ...))
+       (identifier? #'type)
+       (syntax-violation 'require-extension "Not a recognized extension type"
+                         x)))))
+
+
+;;; Defining transparently inlinable procedures
+;;;
+
+(define-syntax define-inlinable
+  ;; Define a macro and a procedure such that direct calls are inlined, via
+  ;; the macro expansion, whereas references in non-call contexts refer to
+  ;; the procedure.  Inspired by the `define-integrable' macro by Dybvig et al.
+  (lambda (x)
+    ;; Use a space in the prefix to avoid potential -Wunused-toplevel
+    ;; warning
+    (define prefix (string->symbol "% "))
+    (define (make-procedure-name name)
+      (datum->syntax name
+                     (symbol-append prefix (syntax->datum name)
+                                    '-procedure)))
+
+    (syntax-case x ()
+      ((_ (name formals ...) body ...)
+       (identifier? #'name)
+       (with-syntax ((proc-name  (make-procedure-name #'name))
+                     ((args ...) (generate-temporaries #'(formals ...))))
+         #`(begin
+             (define (proc-name formals ...)
+               (syntax-parameterize ((name (identifier-syntax proc-name)))
+                 body ...))
+             (define-syntax-parameter name
+               (lambda (x)
+                 (syntax-case x ()
+                   ((_ args ...)
+                    #'((syntax-parameterize ((name (identifier-syntax proc-name)))
+                         (lambda (formals ...)
+                           body ...))
+                       args ...))
+                   ((_ a (... ...))
+                    (syntax-violation 'name "Wrong number of arguments" x))
+                   (_
+                    (identifier? x)
+                    #'proc-name))))))))))
+
+
+
+(define using-readline?
+  (let ((using-readline? (make-fluid)))
+     (make-procedure-with-setter
+      (lambda () (fluid-ref using-readline?))
+      (lambda (v) (fluid-set! using-readline? v)))))
+
+
+
+;;; {Deprecated stuff}
+;;;
+
+(begin-deprecated
+ (module-use! the-scm-module (resolve-interface '(ice-9 deprecated))))
+
+
+
+;;; SRFI-4 in the default environment.  FIXME: we should figure out how
+;;; to deprecate this.
+;;;
+
+;; FIXME:
+(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
+
+
+
+;;; A few identifiers that need to be defined in this file are really
+;;; internal implementation details.  We shove them off into internal
+;;; modules, removing them from the (guile) module.
+;;;
+
+(define-module (system syntax))
+
+(let ()
+  (define (steal-bindings! from to ids)
+    (for-each
+     (lambda (sym)
+       (let ((v (module-local-variable from sym)))
+         (module-remove! from sym)
+         (module-add! to sym v)))
+     ids)
+    (module-export! to ids))
+
+  (steal-bindings! the-root-module (resolve-module '(system syntax))
+                   '(syntax-local-binding
+                     syntax-module
+                     syntax-locally-bound-identifiers
+                     syntax-session-id)))
+
+
+
+
+;;; Place the user in the guile-user module.
+;;;
+
+;; Set filename to #f to prevent reload.
+(define-module (guile-user)
+  #\autoload (system base compile) (compile compile-file)
+  #\filename #f)
+
+;; Remain in the `(guile)' module at compilation-time so that the
+;; `-Wunused-toplevel' warning works as expected.
+(eval-when (compile) (set-current-module the-root-module))
+
+;;; boot-9.scm ends here
+;;;; buffered-input.scm --- construct a port from a buffered input reader
+;;;;
+;;;; 	Copyright (C) 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 buffered-input)
+  #\export (make-buffered-input-port
+            make-line-buffered-input-port
+            set-buffered-input-continuation?!))
+
+;; @code{buffered-input-continuation?} is a property of the ports
+;; created by @code{make-line-buffered-input-port} that stores the
+;; read continuation flag for each such port.
+(define buffered-input-continuation? (make-object-property))
+
+(define (set-buffered-input-continuation?! port val)
+  "Set the read continuation flag for @var{port} to @var{val}.
+
+See @code{make-buffered-input-port} for the meaning and use of this
+flag."
+  (set! (buffered-input-continuation? port) val))
+
+(define (make-buffered-input-port reader)
+  "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a chunk of input and returns it as a string.
+
+The port created by @code{make-buffered-input-port} does @emph{not}
+interpolate any additional characters between the strings returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument.
+@var{continuation?} indicates whether @var{reader} is being called to
+start a logically new read operation (in which case
+@var{continuation?} is @code{#f}) or to continue a read operation for
+which some input has already been read (in which case
+@var{continuation?} is @code{#t}).  Some @var{reader} implementations
+use the @var{continuation?} argument to determine what prompt to
+display to the user.
+
+The new/continuation distinction is largely an application-level
+concept: @code{set-buffered-input-continuation?!} allows an
+application to specify when a read operation is considered to be new.
+But note that if there is non-whitespace data already buffered in the
+port when a new read operation starts, this data will be read before
+the first call to @var{reader}, and so @var{reader} will be called
+with @var{continuation?} set to @code{#t}."
+  (let ((read-string "")
+	(string-index 0))
+    (letrec ((get-character
+	      (lambda ()
+		(if (< string-index (string-length read-string))
+                    ;; Read a char.
+                    (let ((res (string-ref read-string string-index)))
+                      (set! string-index (+ 1 string-index))
+                      (if (not (char-whitespace? res))
+                          (set! (buffered-input-continuation? port) #t))
+                      res)
+                    ;; Fill the buffer.
+                    (let ((x (reader (buffered-input-continuation? port))))
+                      (cond
+                       ((eof-object? x)
+                        ;; Don't buffer the EOF object.
+                        x)
+                       (else
+                        (set! read-string x)
+                        (set! string-index 0)
+                        (get-character)))))))
+	     (input-waiting
+	      (lambda ()
+                (- (string-length read-string) string-index)))
+             (port #f))
+      (set! port (make-soft-port (vector #f #f #f get-character #f input-waiting) "r"))
+      (set! (buffered-input-continuation? port) #f)
+      port)))
+
+(define (make-line-buffered-input-port reader)
+  "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a line of input and returns it as a string @emph{without} the
+terminating newline character.
+
+The port created by @code{make-line-buffered-input-port} automatically
+interpolates a newline character after each string returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument.  For
+the meaning and use of this argument, see
+@code{make-buffered-input-port}."
+  (make-buffered-input-port (lambda (continuation?)
+                              (let ((str (reader continuation?)))
+                                (if (eof-object? str)
+                                    str
+                                    (string-append str "\n"))))))
+
+;;; buffered-input.scm ends here
+;;;; calling.scm --- Calling Conventions
+;;;;
+;;;; 	Copyright (C) 1995, 1996, 1997, 2000, 2001, 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 calling)
+  \:export-syntax (with-excursion-function
+		  with-getter-and-setter
+		  with-getter
+		  with-delegating-getter-and-setter
+		  with-excursion-getter-and-setter
+		  with-configuration-getter-and-setter
+		  with-delegating-configuration-getter-and-setter
+		  let-with-configuration-getter-and-setter))
+
+;;;;
+;;;
+;;; This file contains a number of macros that support 
+;;; common calling conventions.
+
+;;;
+;;; with-excursion-function <vars> proc
+;;;  <vars> is an unevaluated list of names that are bound in the caller.
+;;;  proc is a procedure, called:
+;;;	     (proc excursion)
+;;;
+;;;  excursion is a procedure isolates all changes to <vars>
+;;;  in the dynamic scope of the call to proc.  In other words,
+;;;  the values of <vars> are saved when proc is entered, and when
+;;;  proc returns, those values are restored.   Values are also restored
+;;;  entering and leaving the call to proc non-locally, such as using
+;;;  call-with-current-continuation, error, or throw.
+;;;
+(defmacro with-excursion-function (vars proc)
+  `(,proc ,(excursion-function-syntax vars)))
+
+
+
+;;; with-getter-and-setter <vars> proc
+;;;  <vars> is an unevaluated list of names that are bound in the caller.
+;;;  proc is a procedure, called:
+;;;	(proc getter setter)
+;;; 
+;;;  getter and setter are procedures used to access
+;;;  or modify <vars>.
+;;; 
+;;;  setter, called with keywords arguments, modifies the named
+;;;  values.   If "foo" and "bar" are among <vars>, then:
+;;; 
+;;;	(setter :foo 1 :bar 2)
+;;;	== (set! foo 1 bar 2)
+;;; 
+;;;  getter, called with just keywords, returns
+;;;  a list of the corresponding values.  For example,
+;;;  if "foo" and "bar" are among the <vars>, then
+;;; 
+;;;	(getter :foo :bar)
+;;;	=> (<value-of-foo> <value-of-bar>)
+;;; 
+;;;  getter, called with no arguments, returns a list of all accepted 
+;;;  keywords and the corresponding values.  If "foo" and "bar" are
+;;;  the *only* <vars>, then:
+;;; 
+;;;	(getter)
+;;;	=> (\:foo <value-of-bar> :bar <value-of-foo>)
+;;; 
+;;;  The unusual calling sequence of a getter supports too handy
+;;;  idioms:
+;;; 
+;;;	(apply setter (getter))		;; save and restore
+;;; 
+;;;	(apply-to-args (getter :foo :bar)		;; fetch and bind
+;;;		    (lambda (foo bar) ....))
+;;; 
+;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it 
+;;;	;;   takes its arguments in a different order.
+;;; 
+;;;
+(defmacro with-getter-and-setter (vars proc)
+  `(,proc ,@ (getter-and-setter-syntax vars)))
+
+;;; with-getter vars proc
+;;;   A short-hand for a call to with-getter-and-setter.
+;;;   The procedure is called:
+;;;		(proc getter)
+;;;
+(defmacro with-getter (vars proc)
+  `(,proc ,(car (getter-and-setter-syntax vars))))
+
+
+;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
+;;;   Compose getters and setters.
+;;; 
+;;;   <vars> is an unevaluated list of names that are bound in the caller.
+;;;   
+;;;   get-delegate is called by the new getter to extend the set of 
+;;;	gettable variables beyond just <vars>
+;;;   set-delegate is called by the new setter to extend the set of 
+;;;	gettable variables beyond just <vars>
+;;;
+;;;   proc is a procedure that is called
+;;;		(proc getter setter)
+;;;
+(defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
+  `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
+
+
+;;; with-excursion-getter-and-setter <vars> proc
+;;;   <vars> is an unevaluated list of names that are bound in the caller.
+;;;   proc is called:
+;;;
+;;;		(proc excursion getter setter)
+;;;
+;;;   See also:
+;;;	with-getter-and-setter
+;;;	with-excursion-function
+;;;
+(defmacro with-excursion-getter-and-setter (vars proc)
+  `(,proc  ,(excursion-function-syntax vars)
+	  ,@ (getter-and-setter-syntax vars)))
+
+
+(define (excursion-function-syntax vars)
+  (let ((saved-value-names (map gensym vars))
+	(tmp-var-name (gensym "temp"))
+	(swap-fn-name (gensym "swap"))
+	(thunk-name (gensym "thunk")))
+    `(lambda (,thunk-name)
+       (letrec ((,tmp-var-name #f)
+		(,swap-fn-name
+		 (lambda () ,@ (map (lambda (n sn) 
+				      `(begin (set! ,tmp-var-name ,n)
+					      (set! ,n ,sn)
+					      (set! ,sn ,tmp-var-name)))
+				    vars saved-value-names)))
+		,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
+	 (dynamic-wind
+	  ,swap-fn-name
+	  ,thunk-name
+	  ,swap-fn-name)))))
+
+
+(define (getter-and-setter-syntax vars)
+  (let ((args-name (gensym "args"))
+	(an-arg-name (gensym "an-arg"))
+	(new-val-name (gensym "new-value"))
+	(loop-name (gensym "loop"))
+	(kws (map symbol->keyword vars)))
+    (list `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (if (null? ,args-name)
+		      ,(if (null? kws)
+			   ''()
+			   `(let ((all-vals (,loop-name ',kws)))
+			      (let ,loop-name ((vals all-vals)
+					       (kws ',kws))
+				   (if (null? vals)
+				       '()
+				       `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+		      (map (lambda (,an-arg-name)
+			     (case ,an-arg-name
+			       ,@ (append
+				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
+				   `((else (throw 'bad-get-option ,an-arg-name))))))
+			   ,args-name))))
+
+	  `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (or (null? ,args-name)
+		      (null? (cdr ,args-name))
+		      (let ((,an-arg-name (car ,args-name))
+			    (,new-val-name (cadr ,args-name)))
+			(case ,an-arg-name
+			  ,@ (append
+			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+			      `((else (throw 'bad-set-option ,an-arg-name)))))
+			(,loop-name (cddr ,args-name)))))))))
+
+(define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
+  (let ((args-name (gensym "args"))
+	(an-arg-name (gensym "an-arg"))
+	(new-val-name (gensym "new-value"))
+	(loop-name (gensym "loop"))
+	(kws (map symbol->keyword vars)))
+    (list `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (if (null? ,args-name)
+		      (append!
+		       ,(if (null? kws)
+			    ''()
+			    `(let ((all-vals (,loop-name ',kws)))
+			       (let ,loop-name ((vals all-vals)
+						(kws ',kws))
+				    (if (null? vals)
+					'()
+					`(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+		       (,get-delegate))
+		      (map (lambda (,an-arg-name)
+			     (case ,an-arg-name
+			       ,@ (append
+				   (map (lambda (kw v) `((,kw) ,v)) kws vars)
+				   `((else (car (,get-delegate ,an-arg-name)))))))
+			   ,args-name))))
+
+	  `(lambda ,args-name
+	     (let ,loop-name ((,args-name ,args-name))
+		  (or (null? ,args-name)
+		      (null? (cdr ,args-name))
+		      (let ((,an-arg-name (car ,args-name))
+			    (,new-val-name (cadr ,args-name)))
+			(case ,an-arg-name
+			  ,@ (append
+			      (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+			      `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
+			(,loop-name (cddr ,args-name)))))))))
+
+
+
+
+;;; with-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;;  Create a getter and setter that can trigger arbitrary computation.
+;;;
+;;;  <vars-etc> is a list of variable specifiers, explained below.
+;;;  proc is called:
+;;;
+;;;		(proc getter setter)
+;;;
+;;;   Each element of the <vars-etc> list is of the form:
+;;;
+;;;	(<var> getter-hook setter-hook)
+;;;
+;;;   Both hook elements are evaluated; the variable name is not.
+;;;   Either hook may be #f or procedure.
+;;;
+;;;   A getter hook is a thunk that returns a value for the corresponding
+;;;   variable.   If omitted (#f is passed), the binding of <var> is
+;;;   returned.
+;;;
+;;;   A setter hook is a procedure of one argument that accepts a new value
+;;;   for the corresponding variable.  If omitted, the binding of <var>
+;;;   is simply set using set!.
+;;;
+(defmacro with-configuration-getter-and-setter (vars-etc proc)
+  `((lambda (simpler-get simpler-set body-proc)
+      (with-delegating-getter-and-setter ()
+	simpler-get simpler-set body-proc))
+
+    (lambda (kw)
+      (case kw
+	,@(map (lambda (v) `((,(symbol->keyword (car v)))
+			     ,(cond
+			       ((cadr v)	=> list)
+			       (else		`(list ,(car v))))))
+	       vars-etc)))
+
+    (lambda (kw new-val)
+      (case kw
+	,@(map (lambda (v) `((,(symbol->keyword (car v)))
+			     ,(cond
+			       ((caddr v)	=> (lambda (proc) `(,proc new-val)))
+			       (else		`(set! ,(car v) new-val)))))
+	       vars-etc)))
+
+       ,proc))
+
+(defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
+  `((lambda (simpler-get simpler-set body-proc)
+      (with-delegating-getter-and-setter ()
+	simpler-get simpler-set body-proc))
+
+    (lambda (kw)
+      (case kw
+	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+				      ,(cond
+					((cadr v)	=> list)
+					(else		`(list ,(car v))))))
+			vars-etc)
+		   `((else (,delegate-get kw))))))
+
+    (lambda (kw new-val)
+      (case kw
+	,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+				      ,(cond
+					((caddr v)	=> (lambda (proc) `(,proc new-val)))
+					(else		`(set! ,(car v) new-val)))))
+			vars-etc)
+		   `((else (,delegate-set kw new-val))))))
+
+    ,proc))
+
+
+;;; let-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
+;;;   except that each element of <vars-etc> is:
+;;;
+;;;		(<var> initial-value getter-hook setter-hook)
+;;;
+;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
+;;;   introduces bindings for the variables named in <vars-etc>.
+;;;   It is short-hand for:
+;;;
+;;;		(let ((<var1> initial-value-1)
+;;;		      (<var2> initial-value-2)
+;;;			...)
+;;;		  (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
+;;;
+(defmacro let-with-configuration-getter-and-setter (vars-etc proc)
+  `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
+     (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
+					   ,proc)))
+;;; Guile object channel
+
+;; Copyright (C) 2001, 2006, 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
+
+;;; Commentary:
+
+;; Now you can use Guile's modules in Emacs Lisp like this:
+;;
+;;   (guile-import current-module)
+;;   (guile-import module-ref)
+;;
+;;   (setq assq (module-ref (current-module) 'assq))
+;;     => ("<guile>" %%1%% . "#<primitive-procedure assq>")
+;;
+;;   (guile-use-modules (ice-9 documentation))
+;;
+;;   (object-documentation assq)
+;;     =>
+;;  " - primitive: assq key alist
+;;    - primitive: assv key alist
+;;    - primitive: assoc key alist
+;;        Fetches the entry in ALIST that is associated with KEY.  To decide
+;;        whether the argument KEY matches a particular entry in ALIST,
+;;        `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc'
+;;        uses `equal?'.  If KEY cannot be found in ALIST (according to
+;;        whichever equality predicate is in use), then `#f' is returned.
+;;        These functions return the entire alist entry found (i.e. both the
+;;        key and the value)."
+;;
+;; Probably we can use GTK in Emacs Lisp.  Can anybody try it?
+;;
+;; I have also implemented Guile Scheme mode and Scheme Interaction mode.
+;; Just put the following lines in your ~/.emacs:
+;;
+;;   (require 'guile-scheme)
+;;   (setq initial-major-mode 'scheme-interaction-mode)
+;;
+;; Currently, the following commands are available:
+;;
+;;   M-TAB    guile-scheme-complete-symbol
+;;   M-C-x    guile-scheme-eval-define
+;;   C-x C-e  guile-scheme-eval-last-sexp
+;;   C-c C-b  guile-scheme-eval-buffer
+;;   C-c C-r  guile-scheme-eval-region
+;;   C-c :    guile-scheme-eval-expression
+;;
+;; I'll write more commands soon, or if you want to hack, please take
+;; a look at the following files:
+;;
+;;   guile-core/ice-9/channel.scm       ;; object channel
+;;   guile-core/emacs/guile.el          ;; object adapter
+;;   guile-core/emacs/guile-emacs.scm   ;; Guile <-> Emacs channels
+;;   guile-core/emacs/guile-scheme.el   ;; Guile Scheme mode
+;;
+;; As always, there are more than one bugs ;)
+
+;;; Code:
+
+(define-module (ice-9 channel)
+  \:export (make-object-channel
+	   channel-open
+	   channel-print-value
+	   channel-print-token))
+
+;;;
+;;; Channel type
+;;;
+
+(define channel-type
+  (make-record-type 'channel '(stdin stdout printer token-module)))
+
+(define make-channel (record-constructor channel-type))
+
+(define (make-object-channel printer)
+  (make-channel (current-input-port)
+		(current-output-port)
+		printer
+		(make-module)))
+
+(define channel-stdin (record-accessor channel-type 'stdin))
+(define channel-stdout (record-accessor channel-type 'stdout))
+(define channel-printer (record-accessor channel-type 'printer))
+(define channel-token-module (record-accessor channel-type 'token-module))
+
+;;;
+;;; Channel
+;;;
+
+(define (channel-open ch)
+  (let ((stdin (channel-stdin ch))
+	(stdout (channel-stdout ch))
+	(printer (channel-printer ch))
+	(token-module (channel-token-module ch)))
+    (let loop ()
+      (catch #t
+	(lambda ()
+	  (channel:prompt stdout)
+	  (let ((cmd (read stdin)))
+	    (if (eof-object? cmd)
+	      (throw 'quit)
+	      (case cmd
+		((eval)
+		 (module-use! (current-module) token-module)
+		 (printer ch (eval (read stdin) (current-module))))
+		((destroy)
+		 (let ((token (read stdin)))
+		   (if (module-defined? token-module token)
+		     (module-remove! token-module token)
+		     (channel:error stdout "Invalid token: ~S" token))))
+		((quit)
+		 (throw 'quit))
+		(else
+		 (channel:error stdout "Unknown command: ~S" cmd)))))
+	  (loop))
+	(lambda (key . args)
+	  (case key
+	    ((quit) (throw 'quit))
+	    (else
+	     (format stdout "exception = ~S\n"
+		     (list key (apply format #f (cadr args) (caddr args))))
+	     (loop))))))))
+
+(define (channel-print-value ch val)
+  (format (channel-stdout ch) "value = ~S\n" val))
+
+(define (channel-print-token ch val)
+  (let* ((token (symbol-append (gensym "%%") '%%))
+	 (pair (cons token (object->string val))))
+    (format (channel-stdout ch) "token = ~S\n" pair)
+    (module-define! (channel-token-module ch) token val)))
+
+(define (channel:prompt port)
+  (display "channel> " port)
+  (force-output port))
+
+(define (channel:error port msg . args)
+  (display "ERROR: " port)
+  (apply format port msg args)
+  (newline port))
+
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define guile:eval eval)
+(define eval
+  (if (= (car (procedure-minimum-arity guile:eval)) 1)
+    (lambda (x e) (guile:eval x e))
+    guile:eval))
+
+(define object->string
+  (if (defined? 'object->string)
+    object->string
+    (lambda (x) (format #f "~S" x))))
+
+;;; channel.scm ends here
+;;; Parsing Guile's command-line
+
+;;; Copyright (C) 1994-1998, 2000-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
+
+;;; Code:
+
+;;;
+;;; Please be careful not to load up other modules in this file, unless
+;;; they are explicitly requested.  Loading modules currently imposes a
+;;; speed penalty of a few stats, an mmap, and some allocation, which
+;;; can range from 1 to 20ms, depending on the state of your disk cache.
+;;; Since `compile-shell-switches' is called even for the most transient
+;;; of command-line programs, we need to keep it lean.
+;;;
+;;; Generally speaking, the goal is for Guile to boot and execute simple
+;;; expressions like "1" within 20ms or less, measured using system time
+;;; from the time of the `guile' invocation to exit.
+;;;
+
+(define-module (ice-9 command-line)
+  #\autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+  #\export (compile-shell-switches
+            version-etc
+            *GPLv3+*
+            *LGPLv3+*
+            emit-bug-reporting-address))
+
+;; An initial stab at i18n.
+(define _ gettext)
+
+(define *GPLv3+*
+  (_ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+(define *LGPLv3+*
+  (_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+;; Display the --version information in the
+;; standard way: command and package names, package version, followed
+;; by a short license notice and a list of up to 10 author names.
+;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of
+;; the program.  The formats are therefore:
+;; PACKAGE VERSION
+;; or
+;; COMMAND_NAME (PACKAGE) VERSION.
+;;
+;; Based on the version-etc gnulib module.
+;;
+(define* (version-etc package version #\key
+                      (port (current-output-port))
+                      ;; FIXME: authors
+                      (copyright-year 2016)
+                      (copyright-holder "Free Software Foundation, Inc.")
+                      (copyright (format #f "Copyright (C) ~a ~a"
+                                         copyright-year copyright-holder))
+                      (license *GPLv3+*)
+                      command-name
+                      packager packager-version)
+  (if command-name
+      (format port "~a (~a) ~a\n" command-name package version)
+      (format port "~a ~a\n" package version))
+
+  (if packager
+      (if packager-version
+          (format port (_ "Packaged by ~a (~a)\n") packager packager-version)
+          (format port (_ "Packaged by ~a\n") packager)))
+  
+  (display copyright port)
+  (newline port)
+  (newline port)
+  (display license port)
+  (newline port))
+
+
+;; Display the usual `Report bugs to' stanza.
+;;
+(define* (emit-bug-reporting-address package bug-address #\key
+                                     (port (current-output-port))
+                                     (url (string-append
+                                           "http://www.gnu.org/software/"
+                                           package
+                                           "/"))
+                                     packager packager-bug-address)
+  (format port (_ "\nReport bugs to: ~a\n") bug-address)
+  (if (and packager packager-bug-address)
+      (format port (_ "Report ~a bugs to: ~a\n") packager packager-bug-address))
+  (format port (_ "~a home page: <~a>\n") package url)
+  (format port
+          (_ "General help using GNU software: <http://www.gnu.org/gethelp/>\n")))
+
+(define *usage*
+  (_ "Evaluate code with Guile, interactively or from a script.
+
+  [-s] FILE      load source code from FILE, and exit
+  -c EXPR        evalute expression EXPR, and exit
+  --             stop scanning arguments; run interactively
+
+The above switches stop argument processing, and pass all
+remaining arguments as the value of (command-line).
+If FILE begins with `-' the -s switch is mandatory.
+
+  -L DIRECTORY   add DIRECTORY to the front of the module load path
+  -C DIRECTORY   like -L, but for compiled files
+  -x EXTENSION   add EXTENSION to the front of the load extensions
+  -l FILE        load source code from FILE
+  -e FUNCTION    after reading script, apply FUNCTION to
+                 command line arguments
+  --language=LANG  change language; default: scheme
+  -ds            do -s script at this point
+  --debug        start with the \"debugging\" VM engine
+  --no-debug     start with the normal VM engine (backtraces but
+                 no breakpoints); default is --debug for interactive
+                 use, but not for `-s' and `-c'.
+  --auto-compile compile source files automatically
+  --fresh-auto-compile  invalidate auto-compilation cache
+  --no-auto-compile  disable automatic source file compilation;
+                 default is to enable auto-compilation of source
+                 files.
+  --listen[=P]   listen on a local port or a path for REPL clients;
+                 if P is not given, the default is local port 37146
+  -q             inhibit loading of user init file
+  --use-srfi=LS  load SRFI modules for the SRFIs in LS,
+                 which is a list of numbers like \"2,13,14\"
+  -h, --help     display this help and exit
+  -v, --version  display version information and exit
+  \\              read arguments from following script lines"))
+
+
+(define* (shell-usage name fatal? #\optional fmt . args)
+  (let ((port (if fatal?
+                  (current-error-port)
+                  (current-output-port))))
+    (when fmt
+      (apply format port fmt args)
+      (newline port))
+
+    (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
+    (display *usage* port)
+    (newline port)
+
+    (emit-bug-reporting-address
+     "GNU Guile" "bug-guile@gnu.org"
+     #\port port
+     #\url "http://www.gnu.org/software/guile/"
+     #\packager (assq-ref %guile-build-info 'packager)
+     #\packager-bug-address
+     (assq-ref %guile-build-info 'packager-bug-address))
+
+    (if fatal?
+        (exit 1))))
+
+;; Try to avoid loading (ice-9 eval-string) and (system base compile) if
+;; possible.
+(define (eval-string/lang str)
+  (case (current-language)
+    ((scheme)
+     (call-with-input-string
+      str
+      (lambda (port)
+        (let lp ()
+          (let ((exp (read port)))
+            (if (not (eof-object? exp))
+                (begin
+                  (eval exp (current-module))
+                  (lp))))))))
+    (else
+     ((module-ref (resolve-module '(ice-9 eval-string)) 'eval-string) str))))
+
+(define (load/lang f)
+  (case (current-language)
+    ((scheme)
+     (load-in-vicinity (getcwd) f))
+    (else
+     ((module-ref (resolve-module '(system base compile)) 'compile-file)
+      f #\to 'value))))
+
+(define* (compile-shell-switches args #\optional (usage-name "guile"))
+  (let ((arg0 "guile")
+        (script-cell #f)
+        (entry-point #f)
+        (user-load-path '())
+        (user-load-compiled-path '())
+        (user-extensions '())
+        (interactive? #t)
+        (inhibit-user-init? #f)
+        (turn-on-debugging? #f)
+        (turn-off-debugging? #f))
+
+    (define (error fmt . args)
+      (apply shell-usage usage-name #t
+             (string-append "error: " fmt "~%") args))
+
+    (define (parse args out)
+      (cond
+       ((null? args)
+        (finish args out))
+       (else
+        (let ((arg (car args))
+              (args (cdr args)))
+          (cond
+           ((not (string-prefix? "-" arg)) ; foo
+            ;; If we specified the -ds option, script-cell is the cdr of
+            ;; an expression like (load #f).  We replace the car (i.e.,
+            ;; the #f) with the script name.
+            (set! arg0 arg)
+            (set! interactive? #f)
+            (if script-cell
+                (begin
+                  (set-car! script-cell arg0)
+                  (finish args out))
+                (finish args
+                        (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
+                              out))))
+
+           ((string=? arg "-s")         ; foo
+            (if (null? args)
+                (error "missing argument to `-s' switch"))
+            (set! arg0 (car args))
+            (set! interactive? #f)
+            (if script-cell
+                (begin
+                  (set-car! script-cell arg0)
+                  (finish (cdr args) out))
+                (finish (cdr args)
+                        (cons `((@@ (ice-9 command-line) load/lang) ,arg0)
+                              out))))
+           
+           ((string=? arg "-c")         ; evaluate expr
+            (if (null? args)
+                (error "missing argument to `-c' switch"))
+            (set! interactive? #f)
+            (finish (cdr args)
+                    (cons `((@@ (ice-9 command-line) eval-string/lang)
+                            ,(car args))
+                          out)))
+
+           ((string=? arg "--")         ; end args go interactive
+            (finish args out))
+
+           ((string=? arg "-l")         ; load a file
+            (if (null? args)
+                (error "missing argument to `-l' switch"))
+            (parse (cdr args)
+                   (cons `((@@ (ice-9 command-line) load/lang) ,(car args))
+                         out)))
+
+           ((string=? arg "-L")         ; add to %load-path
+            (if (null? args)
+                (error "missing argument to `-L' switch"))
+            (set! user-load-path (cons (car args) user-load-path))
+            (parse (cdr args)
+                   out))
+
+           ((string=? arg "-C")         ; add to %load-compiled-path
+            (if (null? args)
+                (error "missing argument to `-C' switch"))
+            (set! user-load-compiled-path
+                  (cons (car args) user-load-compiled-path))
+            (parse (cdr args)
+                   out))
+
+           ((string=? arg "-x")         ; add to %load-extensions
+            (if (null? args)
+                (error "missing argument to `-x' switch"))
+            (set! user-extensions (cons (car args) user-extensions))
+            (parse (cdr args)
+                   out))
+
+           ((string=? arg "-e")         ; entry point
+            (if (null? args)
+                (error "missing argument to `-e' switch"))
+            (let* ((port (open-input-string (car args)))
+                   (arg1 (read port))
+                   (arg2 (read port)))
+              ;; Recognize syntax of certain versions of guile 1.4 and
+              ;; transform to (@ MODULE-NAME FUNC).
+              (set! entry-point
+                    (cond
+                     ((not (eof-object? arg2))
+                      `(@ ,arg1 ,arg2))
+                     ((and (pair? arg1)
+                           (not (memq (car arg1) '(@ @@)))
+                           (and-map symbol? arg1))
+                      `(@ ,arg1 main))
+                     (else
+                      arg1))))
+            (parse (cdr args)
+                   out))
+
+           ((string-prefix? "--language=" arg) ; language
+            (parse args
+                   (cons `(current-language
+                           ',(string->symbol
+                              (substring arg (string-length "--language="))))
+                         out)))
+
+           ((string=? "--language" arg) ; language
+            (when (null? args)
+              (error "missing argument to `--language' option"))
+            (parse (cdr args)
+                   (cons `(current-language ',(string->symbol (car args)))
+                         out)))
+
+           ((string=? arg "-ds")        ; do script here
+            ;; We put a dummy "load" expression, and let the -s put the
+            ;; filename in.
+            (when script-cell
+              (error "the -ds switch may only be specified once"))
+            (set! script-cell (list #f))
+            (parse args
+                   (acons '(@@ (ice-9 command-line) load/lang)
+                          script-cell
+                          out)))
+
+           ((string=? arg "--debug")
+            (set! turn-on-debugging? #t)
+            (set! turn-off-debugging? #f)
+            (parse args out))
+
+           ((string=? arg "--no-debug")
+            (set! turn-off-debugging? #t)
+            (set! turn-on-debugging? #f)
+            (parse args out))
+
+           ;; Do auto-compile on/off now, because the form itself might
+           ;; need this decision.
+           ((string=? arg "--auto-compile")
+            (set! %load-should-auto-compile #t)
+            (parse args out))
+
+           ((string=? arg "--fresh-auto-compile")
+            (set! %load-should-auto-compile #t)
+            (set! %fresh-auto-compile #t)
+            (parse args out))
+
+           ((string=? arg "--no-auto-compile")
+            (set! %load-should-auto-compile #f)
+            (parse args out))
+
+           ((string=? arg "-q")         ; don't load user init
+            (set! inhibit-user-init? #t)
+            (parse args out))
+
+           ((string-prefix? "--use-srfi=" arg)
+            (let ((srfis (map (lambda (x)
+                                (let ((n (string->number x)))
+                                  (if (and n (exact? n) (integer? n) (>= n 0))
+                                      n
+                                      (error "invalid SRFI specification"))))
+                              (string-split (substring arg 11) #\,))))
+              (if (null? srfis)
+                  (error "invalid SRFI specification"))
+              (parse args
+                     (cons `(use-srfis ',srfis) out))))
+
+           ((string=? arg "--listen")   ; start a repl server
+            (parse args
+                   (cons '((@@ (system repl server) spawn-server)) out)))
+           
+           ((string-prefix? "--listen=" arg) ; start a repl server
+            (parse
+             args
+             (cons
+              (let ((where (substring arg 9)))
+                (cond
+                 ((string->number where) ; --listen=PORT
+                  => (lambda (port)
+                       (if (and (integer? port) (exact? port) (>= port 0))
+                           `((@@ (system repl server) spawn-server)
+                             ((@@ (system repl server) make-tcp-server-socket) #\port ,port))
+                           (error "invalid port for --listen"))))
+                 ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
+                  `((@@ (system repl server) spawn-server)
+                    ((@@ (system repl server) make-unix-domain-server-socket) #\path ,where)))
+                 (else
+                  (error "unknown argument to --listen"))))
+              out)))
+
+           ((or (string=? arg "-h") (string=? arg "--help"))
+            (shell-usage usage-name #f)
+            (exit 0))
+
+           ((or (string=? arg "-v") (string=? arg "--version"))
+            (version-etc "GNU Guile" (version)
+                         #\license *LGPLv3+*
+                         #\command-name "guile"
+                         #\packager (assq-ref %guile-build-info 'packager)
+                         #\packager-version
+                         (assq-ref %guile-build-info 'packager-version))
+            (exit 0))
+
+           (else
+            (error "unrecognized switch ~a" arg)))))))
+
+    (define (finish args out)
+      ;; Check to make sure the -ds got a -s.
+      (when (and script-cell (not (car script-cell)))
+        (error "the `-ds' switch requires the use of `-s' as well"))
+
+      ;; Make any remaining arguments available to the
+      ;; script/command/whatever.
+      (set-program-arguments (cons arg0 args))
+
+      ;; If debugging was requested, or we are interactive and debugging
+      ;; was not explicitly turned off, use the debug engine.
+      (if (or turn-on-debugging?
+              (and interactive? (not turn-off-debugging?)))
+          (begin
+            (set-default-vm-engine! 'debug)
+            (set-vm-engine! (the-vm) 'debug)))
+      
+      ;; Return this value.
+      `(;; It would be nice not to load up (ice-9 control), but the
+        ;; default-prompt-handler is nontrivial.
+        (@ (ice-9 control) %)
+        (begin
+          ;; If we didn't end with a -c or a -s and didn't supply a -q, load
+          ;; the user's customization file.
+          ,@(if (and interactive? (not inhibit-user-init?))
+                '((load-user-init))
+                '())
+
+          ;; Use-specified extensions.
+          ,@(map (lambda (ext)
+                   `(set! %load-extensions (cons ,ext %load-extensions)))
+                 user-extensions)
+
+          ;; Add the user-specified load paths here, so they won't be in
+          ;; effect during the loading of the user's customization file.
+          ,@(map (lambda (path)
+                   `(set! %load-path (cons ,path %load-path)))
+                 user-load-path)
+          ,@(map (lambda (path)
+                   `(set! %load-compiled-path
+                          (cons ,path %load-compiled-path)))
+                 user-load-compiled-path)
+
+          ;; Put accumulated actions in their correct order.
+          ,@(reverse! out)
+
+          ;; Handle the `-e' switch, if it was specified.
+          ,@(if entry-point
+                `((,entry-point (command-line)))
+                '())
+          ,(if interactive?
+               ;; If we didn't end with a -c or a -s, start the
+               ;; repl.
+               '((@ (ice-9 top-repl) top-repl))
+               ;; Otherwise, after doing all the other actions
+               ;; prescribed by the command line, quit.
+               '(quit)))))
+
+      (if (pair? args)
+          (begin
+            (set! arg0 (car args))
+            (let ((slash (string-rindex arg0 #\/)))
+              (set! usage-name
+                    (if slash (substring arg0 (1+ slash)) arg0)))
+            (parse (cdr args) '()))
+          (parse args '()))))
+;;;; common-list.scm --- COMMON LISP list functions for Scheme
+;;;;
+;;;; 	Copyright (C) 1995, 1996, 1997, 2001, 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:
+
+;; These procedures are exported:
+;;  (adjoin e l)
+;;  (union l1 l2)
+;;  (intersection l1 l2)
+;;  (set-difference l1 l2)
+;;  (reduce-init p init l)
+;;  (reduce p l)
+;;  (some pred l . rest)
+;;  (every pred l . rest)
+;;  (notany pred . ls)
+;;  (notevery pred . ls)
+;;  (count-if pred l)
+;;  (find-if pred l)
+;;  (member-if pred l)
+;;  (remove-if pred l)
+;;  (remove-if-not pred l)
+;;  (delete-if! pred l)
+;;  (delete-if-not! pred l)
+;;  (butlast lst n)
+;;  (and? . args)
+;;  (or? . args)
+;;  (has-duplicates? lst)
+;;  (pick p l)
+;;  (pick-mappings p l)
+;;  (uniq l)
+;;
+;; See docstrings for each procedure for more info.  See also module
+;; `(srfi srfi-1)' for a complete list handling library.
+
+;;; Code:
+
+(define-module (ice-9 common-list)
+  \:export (adjoin union intersection set-difference reduce-init reduce
+	   some every notany notevery count-if find-if member-if remove-if
+	   remove-if-not delete-if! delete-if-not! butlast and? or?
+	   has-duplicates? pick pick-mappings uniq))
+
+;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
+; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define (adjoin e l)
+  "Return list L, possibly with element E added if it is not already in L."
+  (if (memq e l) l (cons e l)))
+
+(define (union l1 l2)
+  "Return a new list that is the union of L1 and L2.
+Elements that occur in both lists occur only once in
+the result list."
+  (cond ((null? l1) l2)
+	((null? l2) l1)
+	(else (union (cdr l1) (adjoin (car l1) l2)))))
+
+(define (intersection l1 l2)
+  "Return a new list that is the intersection of L1 and L2.
+Only elements that occur in both lists occur in the result list."
+  (if (null? l2) l2
+      (let loop ((l1 l1) (result '()))
+	(cond ((null? l1) (reverse! result))
+	      ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result)))
+	      (else (loop (cdr l1) result))))))
+
+(define (set-difference l1 l2)
+  "Return elements from list L1 that are not in list L2."
+  (let loop ((l1 l1) (result '()))
+    (cond ((null? l1) (reverse! result))
+	  ((memv (car l1) l2) (loop (cdr l1) result))
+	  (else (loop (cdr l1) (cons (car l1) result))))))
+
+(define (reduce-init p init l)
+  "Same as `reduce' except it implicitly inserts INIT at the start of L."
+  (if (null? l)
+      init
+      (reduce-init p (p init (car l)) (cdr l))))
+
+(define (reduce p l)
+  "Combine all the elements of sequence L using a binary operation P.
+The combination is left-associative.  For example, using +, one can
+add up all the elements.  `reduce' allows you to apply a function which
+accepts only two arguments to more than 2 objects.  Functional
+programmers usually refer to this as foldl."
+  (cond ((null? l) l)
+	((null? (cdr l)) (car l))
+	(else (reduce-init p (car l) (cdr l)))))
+
+(define (some pred l . rest)
+  "PRED is a boolean function of as many arguments as there are list
+arguments to `some', i.e., L plus any optional arguments.  PRED is
+applied to successive elements of the list arguments in order.  As soon
+as one of these applications returns a true value, return that value.
+If no application returns a true value, return #f.
+All the lists should have the same length."
+  (cond ((null? rest)
+	 (let mapf ((l l))
+	   (and (not (null? l))
+		(or (pred (car l)) (mapf (cdr l))))))
+	(else (let mapf ((l l) (rest rest))
+		(and (not (null? l))
+		     (or (apply pred (car l) (map car rest))
+			 (mapf (cdr l) (map cdr rest))))))))
+
+(define (every pred l . rest)
+  "Return #t iff every application of PRED to L, etc., returns #t.
+Analogous to `some' except it returns #t if every application of
+PRED is #t and #f otherwise."
+  (cond ((null? rest)
+	 (let mapf ((l l))
+	   (or (null? l)
+	       (and (pred (car l)) (mapf (cdr l))))))
+	(else (let mapf ((l l) (rest rest))
+		(or (null? l)
+		    (and (apply pred (car l) (map car rest))
+			 (mapf (cdr l) (map cdr rest))))))))
+
+(define (notany pred . ls)
+  "Return #t iff every application of PRED to L, etc., returns #f.
+Analogous to some but returns #t if no application of PRED returns a
+true value or #f as soon as any one does."
+  (not (apply some pred ls)))
+
+(define (notevery pred . ls)
+  "Return #t iff there is an application of PRED to L, etc., that returns #f.
+Analogous to some but returns #t as soon as an application of PRED returns #f,
+or #f otherwise."
+  (not (apply every pred ls)))
+
+(define (count-if pred l)
+  "Return the number of elements in L for which (PRED element) returns true."
+  (let loop ((n 0) (l l))
+    (cond ((null? l) n)
+	  ((pred (car l)) (loop (+ n 1) (cdr l)))
+	  (else (loop n (cdr l))))))
+
+(define (find-if pred l)
+  "Search for the first element in L for which (PRED element) returns true.
+If found, return that element, otherwise return #f."
+  (cond ((null? l) #f)
+	((pred (car l)) (car l))
+	(else (find-if pred (cdr l)))))
+
+(define (member-if pred l)
+  "Return the first sublist of L for whose car PRED is true."
+  (cond ((null? l) #f)
+	((pred (car l)) l)
+	(else (member-if pred (cdr l)))))
+
+(define (remove-if pred l)
+  "Remove all elements from L where (PRED element) is true.
+Return everything that's left."
+  (let loop ((l l) (result '()))
+    (cond ((null? l) (reverse! result))
+	  ((pred (car l)) (loop (cdr l) result))
+	  (else (loop (cdr l) (cons (car l) result))))))
+
+(define (remove-if-not pred l)
+  "Remove all elements from L where (PRED element) is #f.
+Return everything that's left."
+  (let loop ((l l) (result '()))
+    (cond ((null? l) (reverse! result))
+	  ((not (pred (car l))) (loop (cdr l) result))
+	  (else (loop (cdr l) (cons (car l) result))))))
+
+(define (delete-if! pred l)
+  "Destructive version of `remove-if'."
+  (let delete-if ((l l))
+    (cond ((null? l) '())
+	  ((pred (car l)) (delete-if (cdr l)))
+	  (else
+	   (set-cdr! l (delete-if (cdr l)))
+	   l))))
+
+(define (delete-if-not! pred l)
+  "Destructive version of `remove-if-not'."
+  (let delete-if-not ((l l))
+    (cond ((null? l) '())
+	  ((not (pred (car l))) (delete-if-not (cdr l)))
+	  (else
+	   (set-cdr! l (delete-if-not (cdr l)))
+	   l))))
+
+(define (butlast lst n)
+  "Return all but the last N elements of LST."
+  (letrec ((l (- (length lst) n))
+	   (bl (lambda (lst n)
+		 (cond ((null? lst) lst)
+		       ((positive? n)
+			(cons (car lst) (bl (cdr lst) (+ -1 n))))
+		       (else '())))))
+    (bl lst (if (negative? n)
+		(error "negative argument to butlast" n)
+		l))))
+
+(define (and? . args)
+  "Return #t iff all of ARGS are true."
+  (cond ((null? args) #t)
+	((car args) (apply and? (cdr args)))
+	(else #f)))
+
+(define (or? . args)
+  "Return #t iff any of ARGS is true."
+  (cond ((null? args) #f)
+	((car args) #t)
+	(else (apply or? (cdr args)))))
+
+(define (has-duplicates? lst)
+  "Return #t iff 2 members of LST are equal?, else #f."
+  (cond ((null? lst) #f)
+	((member (car lst) (cdr lst)) #t)
+	(else (has-duplicates? (cdr lst)))))
+
+(define (pick p l)
+  "Apply P to each element of L, returning a list of elts
+for which P returns a non-#f value."
+  (let loop ((s '())
+	     (l l))
+    (cond
+     ((null? l) 	s)
+     ((p (car l))	(loop (cons (car l) s) (cdr l)))
+     (else		(loop s (cdr l))))))
+
+(define (pick-mappings p l)
+  "Apply P to each element of L, returning a list of the
+non-#f return values of P."
+  (let loop ((s '())
+	     (l l))
+    (cond
+     ((null? l) 	s)
+     ((p (car l)) =>	(lambda (mapping) (loop (cons mapping s) (cdr l))))
+     (else		(loop s (cdr l))))))
+
+(define (uniq l)
+  "Return a list containing elements of L, with duplicates removed."
+  (let loop ((acc '())
+	     (l l))
+    (if (null? l)
+	(reverse! acc)
+	(loop (if (memq (car l) acc)
+		  acc
+		  (cons (car l) acc))
+	      (cdr l)))))
+
+;;; common-list.scm ends here
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2009, 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
+
+(use-modules (language tree-il)
+             (language tree-il primitives)
+             (language tree-il canonicalize)
+             (srfi srfi-1)
+             (ice-9 pretty-print)
+             (system syntax))
+
+;; Minimize a syntax-object such that it can no longer be used as the
+;; first argument to 'datum->syntax', but is otherwise equivalent.
+(define (squeeze-syntax-object! syn)
+  (define (ensure-list x) (if (vector? x) (vector->list x) x))
+  (let ((x    (vector-ref syn 1))
+        (wrap (vector-ref syn 2))
+        (mod  (vector-ref syn 3)))
+    (let ((marks (car wrap))
+          (subst (cdr wrap)))
+      (define (set-wrap! marks subst)
+        (vector-set! syn 2 (cons marks subst)))
+      (cond
+       ((symbol? x)
+        (let loop ((marks marks) (subst subst))
+          (cond
+           ((null? subst) (set-wrap! marks subst) syn)
+           ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
+           ((find (lambda (entry) (and (eq? x (car entry))
+                                       (equal? marks (cadr entry))))
+                  (apply map list (map ensure-list
+                                       (cdr (vector->list (car subst))))))
+            => (lambda (entry)
+                 (set-wrap! marks
+                            (list (list->vector
+                                   (cons 'ribcage
+                                         (map vector entry)))))
+                 syn))
+           (else (loop marks (cdr subst))))))
+       ((or (pair? x) (vector? x))
+        syn)
+       (else x)))))
+
+(define (squeeze-constant! x)
+  (define (syntax-object? x)
+    (and (vector? x)
+         (= 4 (vector-length x))
+         (eq? 'syntax-object (vector-ref x 0))))
+  (cond ((syntax-object? x)
+         (squeeze-syntax-object! x))
+        ((pair? x)
+         (set-car! x (squeeze-constant! (car x)))
+         (set-cdr! x (squeeze-constant! (cdr x)))
+         x)
+        ((vector? x)
+         (for-each (lambda (i)
+                     (vector-set! x i (squeeze-constant! (vector-ref x i))))
+                   (iota (vector-length x)))
+         x)
+        (else x)))
+
+(define (squeeze-tree-il! x)
+  (post-order! (lambda (x)
+                 (if (const? x)
+                     (set! (const-exp x)
+                           (squeeze-constant! (const-exp x))))
+                 #f)
+               x))
+
+;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
+;; changing session identifiers.
+(set! syntax-session-id (lambda () "*"))
+
+(let ((source (list-ref (command-line) 1))
+      (target (list-ref (command-line) 2)))
+  (let ((in (open-input-file source))
+        (out (open-output-file (string-append target ".tmp"))))
+    (write '(eval-when (compile) (set-current-module (resolve-module '(guile))))
+           out)
+    (newline out)
+    (let loop ((x (read in)))
+      (if (eof-object? x)
+          (begin
+            (close-port out)
+            (close-port in))
+          (begin
+            (pretty-print (tree-il->scheme
+                           (squeeze-tree-il!
+                            (canonicalize!
+                             (resolve-primitives!
+                              (macroexpand x 'c '(compile load eval))
+                              (current-module))))
+                           (current-module)
+                           (list #\avoid-lambda? #f
+                                 #\use-case? #f
+                                 #\strip-numeric-suffixes? #t
+                                 #\use-derived-syntax?
+                                 (and (pair? x)
+                                      (eq? 'let (car x)))))
+                          out #\width 120 #\max-expr-width 70)
+            (newline out)
+            (loop (read in))))))
+  (system (format #f "mv -f ~s.tmp ~s" target target)))
+;;; Beyond call/cc
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (ice-9 control)
+  #\re-export (call-with-prompt abort-to-prompt
+               default-prompt-tag make-prompt-tag)
+  #\export (% abort shift reset shift* reset*
+            call-with-escape-continuation call/ec
+            let-escape-continuation let/ec))
+
+(define (abort . args)
+  (apply abort-to-prompt (default-prompt-tag) args))
+
+(define-syntax %
+  (syntax-rules ()
+    ((_ expr)
+     (call-with-prompt (default-prompt-tag)
+                       (lambda () expr)
+                       default-prompt-handler))
+    ((_ expr handler)
+     (call-with-prompt (default-prompt-tag)
+                       (lambda () expr)
+                       handler))
+    ((_ tag expr handler)
+     (call-with-prompt tag
+                       (lambda () expr)
+                       handler))))
+
+;; Each prompt tag has a type -- an expected set of arguments, and an unwritten
+;; contract of what its handler will do on an abort. In the case of the default
+;; prompt tag, we could choose to return values, exit nonlocally, or punt to the
+;; user.
+;;
+;; We choose the latter, by requiring that the user return one value, a
+;; procedure, to an abort to the prompt tag. That argument is then invoked with
+;; the continuation as an argument, within a reinstated default prompt. In this
+;; way the return value(s) from a default prompt are under the user's control.
+(define (default-prompt-handler k proc)
+  (% (default-prompt-tag)
+     (proc k)
+     default-prompt-handler))
+
+;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled
+;; after the ones by Oleg Kiselyov in
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
+;; public domain, as noted at the top of http://okmij.org/ftp/.
+;; 
+(define-syntax-rule (reset . body)
+  (call-with-prompt (default-prompt-tag)
+                    (lambda () . body)
+                    (lambda (cont f) (f cont))))
+
+(define-syntax-rule (shift var . body)
+  (abort-to-prompt (default-prompt-tag)
+                   (lambda (cont)
+                     ((lambda (var) (reset . body))
+                      (lambda vals (reset (apply cont vals)))))))
+
+(define (reset* thunk)
+  (reset (thunk)))
+
+(define (shift* fc)
+  (shift c (fc c)))
+
+(define (call-with-escape-continuation proc)
+  "Call PROC with an escape continuation."
+  (let ((tag (list 'call/ec)))
+    (call-with-prompt tag
+                      (lambda ()
+                        (proc (lambda args
+                                (apply abort-to-prompt tag args))))
+                      (lambda (_ . args)
+                        (apply values args)))))
+
+(define call/ec call-with-escape-continuation)
+
+(define-syntax-rule (let-escape-continuation k body ...)
+  "Bind K to an escape continuation within the lexical extent of BODY."
+  (let ((tag (list 'let/ec)))
+    (call-with-prompt tag
+                      (lambda ()
+                        (let ((k (lambda args
+                                   (apply abort-to-prompt tag args))))
+                          body ...))
+                      (lambda (_ . results)
+                        (apply values results)))))
+
+(define-syntax-rule (let/ec k body ...)
+  (let-escape-continuation k body ...))
+;;; Copyright (C) 2010, 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 curried-definitions)
+  #\replace ((cdefine . define)
+             (cdefine* . define*)
+             define-public
+             define*-public))
+
+(define-syntax cdefine
+  (syntax-rules ()
+    ((_ (head . rest) body body* ...)
+     (cdefine head
+       (lambda rest body body* ...)))
+    ((_ name val)
+     (define name val))))
+
+(define-syntax cdefine*
+  (syntax-rules ()
+    ((_ (head . rest) body body* ...)
+     (cdefine* head
+       (lambda* rest body body* ...)))
+    ((_ name val)
+     (define* name val))))
+
+(define-syntax define-public
+  (syntax-rules ()
+    ((_ (head . rest) body body* ...)
+     (define-public head
+       (lambda rest body body* ...)))
+    ((_ name val)
+     (begin
+       (define name val)
+       (export name)))))
+
+(define-syntax define*-public
+  (syntax-rules ()
+    ((_ (head . rest) body body* ...)
+     (define*-public head
+       (lambda* rest body body* ...)))
+    ((_ name val)
+     (begin
+       (define* name val)
+       (export name)))))
+;;;; 	Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006, 2010 Free Software Foundation
+;;;; 
+;;;; 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
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+(define-module (ice-9 debug))
+
+(issue-deprecation-warning
+ "(ice-9 debug) is deprecated. Use (system vm trace) for tracing.")
+;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 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 deprecated)
+  #\export (substring-move-left! substring-move-right!
+            dynamic-maybe-call dynamic-maybe-link
+            try-module-linked try-module-dynamic-link
+            list* feature? eval-case unmemoize-expr
+            $asinh
+            $acosh
+            $atanh
+            $sqrt
+            $abs
+            $exp
+            $expt
+            $log
+            $sin
+            $cos
+            $tan
+            $asin
+            $acos
+            $atan
+            $sinh
+            $cosh
+            $tanh
+            closure?
+            %nil
+            @bind
+            bad-throw
+            error-catching-loop
+            error-catching-repl
+            scm-style-repl
+            apply-to-args
+            has-suffix?
+            scheme-file-suffix
+            get-option
+            for-next-option
+            display-usage-report
+            transform-usage-lambda
+            collect
+            assert-repl-silence
+            assert-repl-print-unspecified
+            assert-repl-verbosity
+            set-repl-prompt!
+            set-batch-mode?!
+            repl
+            pre-unwind-handler-dispatch
+            default-pre-unwind-handler
+            handle-system-error
+            stack-saved?
+            the-last-stack
+            save-stack
+            named-module-use!
+            top-repl
+            turn-on-debugging
+            read-hash-procedures
+            process-define-module
+            fluid-let-syntax
+            set-system-module!
+            char-code-limit
+            generalized-vector?
+            generalized-vector-length
+            generalized-vector-ref
+            generalized-vector-set!
+            generalized-vector->list))
+
+
+;;;; Deprecated definitions.
+
+(define substring-move-left!
+  (lambda args
+    (issue-deprecation-warning
+     "`substring-move-left!' is deprecated.  Use `substring-move!' instead.")
+    (apply substring-move! args)))
+(define substring-move-right!
+  (lambda args
+    (issue-deprecation-warning
+     "`substring-move-right!' is deprecated.  Use `substring-move!' instead.")
+    (apply substring-move! args)))
+
+
+
+;; This method of dynamically linking Guile Extensions is deprecated.
+;; Use `load-extension' explicitly from Scheme code instead.
+
+(define (split-c-module-name str)
+  (let loop ((rev '())
+	     (start 0)
+	     (pos 0)
+	     (end (string-length str)))
+    (cond
+     ((= pos end)
+      (reverse (cons (string->symbol (substring str start pos)) rev)))
+     ((eq? (string-ref str pos) #\space)
+      (loop (cons (string->symbol (substring str start pos)) rev)
+	    (+ pos 1)
+	    (+ pos 1)
+	    end))
+     (else
+      (loop rev start (+ pos 1) end)))))
+
+(define (convert-c-registered-modules dynobj)
+  (let ((res (map (lambda (c)
+		    (list (split-c-module-name (car c)) (cdr c) dynobj))
+		  (c-registered-modules))))
+    (c-clear-registered-modules)
+    res))
+
+(define registered-modules '())
+
+(define (register-modules dynobj)
+  (set! registered-modules
+	(append! (convert-c-registered-modules dynobj)
+		 registered-modules)))
+
+(define (warn-autoload-deprecation modname)
+  (issue-deprecation-warning
+   "Autoloading of compiled code modules is deprecated."
+   "Write a Scheme file instead that uses `load-extension'.")
+  (issue-deprecation-warning
+   (simple-format #f "(You just autoloaded module ~S.)" modname)))
+
+(define (init-dynamic-module modname)
+  ;; Register any linked modules which have been registered on the C level
+  (register-modules #f)
+  (or-map (lambda (modinfo)
+	    (if (equal? (car modinfo) modname)
+		(begin
+		  (warn-autoload-deprecation modname)
+		  (set! registered-modules (delq! modinfo registered-modules))
+		  (let ((mod (resolve-module modname #f)))
+		    (save-module-excursion
+		     (lambda ()
+		       (set-current-module mod)
+		       (set-module-public-interface! mod mod)
+		       (dynamic-call (cadr modinfo) (caddr modinfo))
+		       ))
+		    #t))
+		#f))
+	  registered-modules))
+
+(define (dynamic-maybe-call name dynobj)
+  (issue-deprecation-warning
+   "`dynamic-maybe-call' is deprecated.  "
+   "Wrap `dynamic-call' in a `false-if-exception' yourself.")
+  (false-if-exception (dynamic-call name dynobj)))
+
+
+(define (dynamic-maybe-link filename)
+  (issue-deprecation-warning
+   "`dynamic-maybe-link' is deprecated.  "
+   "Wrap `dynamic-link' in a `false-if-exception' yourself.")
+  (false-if-exception (dynamic-link filename)))
+
+(define (find-and-link-dynamic-module module-name)
+  (define (make-init-name mod-name)
+    (string-append "scm_init"
+		   (list->string (map (lambda (c)
+					(if (or (char-alphabetic? c)
+						(char-numeric? c))
+					    c
+					    #\_))
+				      (string->list mod-name)))
+		   "_module"))
+
+  ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+  ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+  ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+  ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+  (let ((subdir-and-libname
+	 (let loop ((dirs "")
+		    (syms module-name))
+	   (if (null? (cdr syms))
+	       (cons dirs (string-append "lib" (symbol->string (car syms))))
+	       (loop (string-append dirs (symbol->string (car syms)) "/")
+		     (cdr syms)))))
+	(init (make-init-name (apply string-append
+				     (map (lambda (s)
+					    (string-append "_"
+							   (symbol->string s)))
+					  module-name)))))
+    (let ((subdir (car subdir-and-libname))
+	  (libname (cdr subdir-and-libname)))
+
+      ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
+      ;; file exists, fetch the dlname from that file and attempt to link
+      ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
+      ;; to name any shared library, look for `subdir/libfoo.so' instead and
+      ;; link against that.
+      (let check-dirs ((dir-list %load-path))
+	(if (null? dir-list)
+	    #f
+	    (let* ((dir (in-vicinity (car dir-list) subdir))
+		   (sharlib-full
+		    (or (try-using-libtool-name dir libname)
+			(try-using-sharlib-name dir libname))))
+	      (if (and sharlib-full (file-exists? sharlib-full))
+		  (link-dynamic-module sharlib-full init)
+		  (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+  (let ((libtool-filename (in-vicinity libdir
+				       (string-append libname ".la"))))
+    (and (file-exists? libtool-filename)
+	 libtool-filename)))
+
+(define (try-using-sharlib-name libdir libname)
+  (in-vicinity libdir (string-append libname ".so")))
+
+(define (link-dynamic-module filename initname)
+  ;; Register any linked modules which have been registered on the C level
+  (register-modules #f)
+  (let ((dynobj (dynamic-link filename)))
+    (dynamic-call initname dynobj)
+    (register-modules dynobj)))
+
+(define (try-module-linked module-name)
+  (issue-deprecation-warning
+   "`try-module-linked' is deprecated."
+   "See the manual for how more on C extensions.")
+  (init-dynamic-module module-name))
+
+(define (try-module-dynamic-link module-name)
+  (issue-deprecation-warning
+   "`try-module-dynamic-link' is deprecated."
+   "See the manual for how more on C extensions.")
+  (and (find-and-link-dynamic-module module-name)
+       (init-dynamic-module module-name)))
+
+
+(define (list* . args)
+  (issue-deprecation-warning "'list*' is deprecated.  Use 'cons*' instead.")
+  (apply cons* args))
+
+(define (feature? sym)
+  (issue-deprecation-warning
+   "`feature?' is deprecated.  Use `provided?' instead.")
+  (provided? sym))
+
+(define-macro (eval-case . clauses)
+  (issue-deprecation-warning
+   "`eval-case' is deprecated.  Use `eval-when' instead.")
+  ;; Practically speaking, eval-case only had load-toplevel and else as
+  ;; conditions.
+  (cond
+   ((assoc-ref clauses '(load-toplevel))
+    => (lambda (exps)
+         ;; the *unspecified so that non-toplevel definitions will be
+         ;; caught
+         `(begin *unspecified* . ,exps)))
+   ((assoc-ref clauses 'else)
+    => (lambda (exps)
+         `(begin *unspecified* . ,exps)))
+   (else
+    `(begin))))
+
+;; The strange prototype system for uniform arrays has been
+;; deprecated.
+(read-hash-extend
+ #\y
+ (lambda (c port)
+   (issue-deprecation-warning
+    "The `#y' bytevector syntax is deprecated.  Use `#s8' instead.")
+   (let ((x (read port)))
+     (cond
+      ((list? x) (list->s8vector x))
+      (else (error "#y needs to be followed by a list" x))))))
+
+(define (unmemoize-expr . args)
+  (issue-deprecation-warning
+   "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
+  (apply unmemoize-expression args))
+
+(define ($asinh z)
+  (issue-deprecation-warning
+   "`$asinh' is deprecated.  Use `asinh' instead.")
+  (asinh z))
+(define ($acosh z)
+  (issue-deprecation-warning
+   "`$acosh' is deprecated.  Use `acosh' instead.")
+  (acosh z))
+(define ($atanh z)
+  (issue-deprecation-warning
+   "`$atanh' is deprecated.  Use `atanh' instead.")
+  (atanh z))
+(define ($sqrt z)
+  (issue-deprecation-warning
+   "`$sqrt' is deprecated.  Use `sqrt' instead.")
+  (sqrt z))
+(define ($abs z)
+  (issue-deprecation-warning
+   "`$abs' is deprecated.  Use `abs' instead.")
+  (abs z))
+(define ($exp z)
+  (issue-deprecation-warning
+   "`$exp' is deprecated.  Use `exp' instead.")
+  (exp z))
+(define ($expt z1 z2)
+  (issue-deprecation-warning
+   "`$expt' is deprecated.  Use `expt' instead.")
+  (expt z1 z2))
+(define ($log z)
+  (issue-deprecation-warning
+   "`$log' is deprecated.  Use `log' instead.")
+  (log z))
+(define ($sin z)
+  (issue-deprecation-warning
+   "`$sin' is deprecated.  Use `sin' instead.")
+  (sin z))
+(define ($cos z)
+  (issue-deprecation-warning
+   "`$cos' is deprecated.  Use `cos' instead.")
+  (cos z))
+(define ($tan z)
+  (issue-deprecation-warning
+   "`$tan' is deprecated.  Use `tan' instead.")
+  (tan z))
+(define ($asin z)
+  (issue-deprecation-warning
+   "`$asin' is deprecated.  Use `asin' instead.")
+  (asin z))
+(define ($acos z)
+  (issue-deprecation-warning
+   "`$acos' is deprecated.  Use `acos' instead.")
+  (acos z))
+(define ($atan z)
+  (issue-deprecation-warning
+   "`$atan' is deprecated.  Use `atan' instead.")
+  (atan z))
+(define ($sinh z)
+  (issue-deprecation-warning
+   "`$sinh' is deprecated.  Use `sinh' instead.")
+  (sinh z))
+(define ($cosh z)
+  (issue-deprecation-warning
+   "`$cosh' is deprecated.  Use `cosh' instead.")
+  (cosh z))
+(define ($tanh z)
+  (issue-deprecation-warning
+   "`$tanh' is deprecated.  Use `tanh' instead.")
+  (tanh z))
+
+(define (closure? x)
+  (issue-deprecation-warning
+   "`closure?' is deprecated. Use `procedure?' instead.")
+  (procedure? x))
+
+(define %nil #nil)
+
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+  (lambda (x)
+    (define (bound-member id ids)
+      (cond ((null? ids) #f)
+            ((bound-identifier=? id (car ids)) #t)
+            ((bound-member (car ids) (cdr ids)))))
+    
+    (issue-deprecation-warning
+     "`@bind' is deprecated. Use `with-fluids' instead.")
+
+    (syntax-case x ()
+      ((_ () b0 b1 ...)
+       #'(let () b0 b1 ...))
+      ((_ ((id val) ...) b0 b1 ...)
+       (and-map identifier? #'(id ...))
+       (if (let lp ((ids #'(id ...)))
+             (cond ((null? ids) #f)
+                   ((bound-member (car ids) (cdr ids)) #t)
+                   (else (lp (cdr ids)))))
+           (syntax-violation '@bind "duplicate bound identifier" x)
+           (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+                         ((v ...) (generate-temporaries #'(id ...))))
+             #'(let ((old-v id) ...
+                     (v val) ...)
+                 (dynamic-wind
+                   (lambda ()
+                     (set! id v) ...)
+                   (lambda () b0 b1 ...)
+                   (lambda ()
+                     (set! id old-v) ...)))))))))
+
+;; There are deprecated definitions for module-ref-submodule and
+;; module-define-submodule! in boot-9.scm.
+
+;; Define (%app) and (%app modules), and have (app) alias (%app). This
+;; side-effects the-root-module, both to the submodules table and (through
+;; module-define-submodule! above) the obarray.
+;;
+(let ((%app (make-module 31)))
+  (set-module-name! %app '(%app))
+  (module-define-submodule! the-root-module '%app %app)
+  (module-define-submodule! the-root-module 'app %app)
+  (module-define-submodule! %app 'modules (resolve-module '() #f)))
+
+;; Allow code that poked %module-public-interface to keep on working.
+;;
+(set! module-public-interface
+      (let ((getter module-public-interface))
+        (lambda (mod)
+          (or (getter mod)
+              (cond
+               ((and=> (module-local-variable mod '%module-public-interface)
+                       variable-ref)
+                => (lambda (iface)
+                     (issue-deprecation-warning 
+"Setting a module's public interface via munging %module-public-interface is
+deprecated. Use set-module-public-interface! instead.")
+                     (set-module-public-interface! mod iface)
+                     iface))
+               (else #f))))))
+
+(set! set-module-public-interface!
+      (let ((setter set-module-public-interface!))
+        (lambda (mod iface)
+          (setter mod iface)
+          (module-define! mod '%module-public-interface iface))))
+
+(define (bad-throw key . args)
+  (issue-deprecation-warning 
+   "`bad-throw' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+  (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
+
+(define (error-catching-loop thunk)
+  (issue-deprecation-warning 
+   "`error-catching-loop' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+  ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
+
+(define (error-catching-repl r e p)
+  (issue-deprecation-warning 
+   "`error-catching-repl' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead.")
+  ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
+
+(define (scm-style-repl)
+  (issue-deprecation-warning 
+   "`scm-style-repl' in the default environment is deprecated.
+Find it in the `(ice-9 scm-style-repl)' module instead, or
+better yet, use the repl from `(system repl repl)'.")
+  ((@ (ice-9 scm-style-repl) scm-style-repl)))
+
+
+;;; Apply-to-args had the following comment attached to it in boot-9, but it's
+;;; wrong-headed: in the mentioned case, a point should either be a record or
+;;; multiple values.
+;;;
+;;; apply-to-args is functionally redundant with apply and, worse,
+;;; is less general than apply since it only takes two arguments.
+;;;
+;;; On the other hand, apply-to-args is a syntacticly convenient way to
+;;; perform binding in many circumstances when the "let" family of
+;;; of forms don't cut it.  E.g.:
+;;;
+;;;     (apply-to-args (return-3d-mouse-coords)
+;;;       (lambda (x y z)
+;;;             ...))
+;;;
+
+(define (apply-to-args args fn)
+  (issue-deprecation-warning 
+   "`apply-to-args' is deprecated. Include a local copy in your program.")
+  (apply fn args))
+
+(define (has-suffix? str suffix)
+  (issue-deprecation-warning 
+   "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
+  (string-suffix? suffix str))
+
+(define scheme-file-suffix
+  (lambda ()
+    (issue-deprecation-warning
+     "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
+    ".scm"))
+
+
+
+;;; {Command Line Options}
+;;;
+
+(define (get-option argv kw-opts kw-args return)
+  (issue-deprecation-warning
+   "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
+  (cond
+   ((null? argv)
+    (return #f #f argv))
+
+   ((or (not (eq? #\- (string-ref (car argv) 0)))
+        (eq? (string-length (car argv)) 1))
+    (return 'normal-arg (car argv) (cdr argv)))
+
+   ((eq? #\- (string-ref (car argv) 1))
+    (let* ((kw-arg-pos (or (string-index (car argv) #\=)
+                           (string-length (car argv))))
+           (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+           (kw-opt? (member kw kw-opts))
+           (kw-arg? (member kw kw-args))
+           (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+                         (substring (car argv)
+                                    (+ kw-arg-pos 1)
+                                    (string-length (car argv))))
+                    (and kw-arg?
+                         (begin (set! argv (cdr argv)) (car argv))))))
+      (if (or kw-opt? kw-arg?)
+          (return kw arg (cdr argv))
+          (return 'usage-error kw (cdr argv)))))
+
+   (else
+    (let* ((char (substring (car argv) 1 2))
+           (kw (symbol->keyword char)))
+      (cond
+
+       ((member kw kw-opts)
+        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+               (new-argv (if (= 0 (string-length rest-car))
+                             (cdr argv)
+                             (cons (string-append "-" rest-car) (cdr argv)))))
+          (return kw #f new-argv)))
+
+       ((member kw kw-args)
+        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+               (arg (if (= 0 (string-length rest-car))
+                        (cadr argv)
+                        rest-car))
+               (new-argv (if (= 0 (string-length rest-car))
+                             (cddr argv)
+                             (cdr argv))))
+          (return kw arg new-argv)))
+
+       (else (return 'usage-error kw argv)))))))
+
+(define (for-next-option proc argv kw-opts kw-args)
+  (issue-deprecation-warning
+   "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
+  (let loop ((argv argv))
+    (get-option argv kw-opts kw-args
+                (lambda (opt opt-arg argv)
+                  (and opt (proc opt opt-arg argv loop))))))
+
+(define (display-usage-report kw-desc)
+  (issue-deprecation-warning
+   "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
+  (for-each
+   (lambda (kw)
+     (or (eq? (car kw) #t)
+         (eq? (car kw) 'else)
+         (let* ((opt-desc kw)
+                (help (cadr opt-desc))
+                (opts (car opt-desc))
+                (opts-proper (if (string? (car opts)) (cdr opts) opts))
+                (arg-name (if (string? (car opts))
+                              (string-append "<" (car opts) ">")
+                              ""))
+                (left-part (string-append
+                            (with-output-to-string
+                              (lambda ()
+                                (map (lambda (x) (display (keyword->symbol x)) (display " "))
+                                     opts-proper)))
+                            arg-name))
+                (middle-part (if (and (< (string-length left-part) 30)
+                                      (< (string-length help) 40))
+                                 (make-string (- 30 (string-length left-part)) #\space)
+                                 "\n\t")))
+           (display left-part)
+           (display middle-part)
+           (display help)
+           (newline))))
+   kw-desc))
+
+(define (transform-usage-lambda cases)
+  (issue-deprecation-warning
+   "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
+  (let* ((raw-usage (delq! 'else (map car cases)))
+         (usage-sans-specials (map (lambda (x)
+                                    (or (and (not (list? x)) x)
+                                        (and (symbol? (car x)) #t)
+                                        (and (boolean? (car x)) #t)
+                                        x))
+                                  raw-usage))
+         (usage-desc (delq! #t usage-sans-specials))
+         (kw-desc (map car usage-desc))
+         (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
+         (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
+         (transmogrified-cases (map (lambda (case)
+                                      (cons (let ((opts (car case)))
+                                              (if (or (boolean? opts) (eq? 'else opts))
+                                                  opts
+                                                  (cond
+                                                   ((symbol? (car opts))  opts)
+                                                   ((boolean? (car opts)) opts)
+                                                   ((string? (caar opts)) (cdar opts))
+                                                   (else (car opts)))))
+                                            (cdr case)))
+                                    cases)))
+    `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
+       (lambda (%argv)
+         (let %next-arg ((%argv %argv))
+           (get-option %argv
+                       ',kw-opts
+                       ',kw-args
+                       (lambda (%opt %arg %new-argv)
+                         (case %opt
+                           ,@ transmogrified-cases))))))))
+
+
+
+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;;
+
+(define-syntax collect
+  (lambda (x)
+    (issue-deprecation-warning
+     "`collect' is deprecated. Define it yourself.")
+    (syntax-case x ()
+      ((_) #''())
+      ((_ x x* ...)
+       #'(let ((val x))
+           (cons val (collect x* ...)))))))
+
+
+
+
+(define (assert-repl-silence v)
+  (issue-deprecation-warning
+   "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
+  ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
+
+(define (assert-repl-print-unspecified v)
+  (issue-deprecation-warning
+   "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
+  ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
+
+(define (assert-repl-verbosity v)
+  (issue-deprecation-warning
+   "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
+  ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
+
+(define (set-repl-prompt! v)
+  (issue-deprecation-warning
+   "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
+the `(system repl common)' module.")
+  ;; Avoid @, as when bootstrapping it will cause the (system repl common)
+  ;; module to be loaded at expansion time, which eventually loads srfi-1, but
+  ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
+  ((module-ref (resolve-interface '(system repl common))
+               'repl-default-prompt-set!)
+   v))
+
+(define (set-batch-mode?! arg)
+  (cond
+   (arg
+    (issue-deprecation-warning
+     "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
+    (ensure-batch-mode!))
+   (else
+    (issue-deprecation-warning
+     "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
+`*repl-stack*' fluid instead.")
+    #t)))
+
+(define (repl read evaler print)
+  (issue-deprecation-warning
+   "`repl' is deprecated. Define it yourself.")
+  (let loop ((source (read (current-input-port))))
+    (print (evaler source))
+    (loop (read (current-input-port)))))
+
+(define (pre-unwind-handler-dispatch key . args)
+  (issue-deprecation-warning
+   "`pre-unwind-handler-dispatch' is deprecated. Use
+`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
+  (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
+
+(define (default-pre-unwind-handler key . args)
+  (issue-deprecation-warning
+   "`default-pre-unwind-handler' is deprecated. Use it from 
+`(ice-9 scm-style-repl)' if you need it.")
+  (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
+
+(define (handle-system-error key . args)
+  (issue-deprecation-warning
+   "`handle-system-error' is deprecated. Use it from 
+`(ice-9 scm-style-repl)' if you need it.")
+  (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
+
+(define-syntax stack-saved?
+  (make-variable-transformer
+   (lambda (x)
+     (issue-deprecation-warning
+      "`stack-saved?' is deprecated. Use it from
+`(ice-9 save-stack)' if you need it.")
+     (syntax-case x (set!)
+       ((set! id val)
+        (identifier? #'id)
+        #'(set! (@ (ice-9 save-stack) stack-saved?) val))
+       (id
+        (identifier? #'id)
+        #'(@ (ice-9 save-stack) stack-saved?))))))
+
+(define-syntax the-last-stack
+  (lambda (x)
+    (issue-deprecation-warning
+     "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
+if you need it.")
+    (syntax-case x ()
+      (id
+       (identifier? #'id)
+       #'(@ (ice-9 save-stack) the-last-stack)))))
+
+(define (save-stack . args)
+  (issue-deprecation-warning
+   "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
+it.")
+  (apply (@ (ice-9 save-stack) save-stack) args))
+
+(define (named-module-use! user usee)
+  (issue-deprecation-warning
+   "`named-module-use!' is deprecated. Define it yourself if you need it.")
+  (module-use! (resolve-module user) (resolve-interface usee)))
+
+(define (top-repl)
+  (issue-deprecation-warning
+   "`top-repl' has moved to the `(ice-9 top-repl)' module.")
+  ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
+
+(set! debug-enable
+      (let ((debug-enable debug-enable))
+        (lambda opts
+          (if (memq 'debug opts)
+              (begin
+                (issue-deprecation-warning
+                 "`(debug-enable 'debug)' is obsolete and has no effect."
+                 "Remove it from your code.")
+                (apply debug-enable (delq 'debug opts)))
+              (apply debug-enable opts)))))
+
+(define (turn-on-debugging)
+  (issue-deprecation-warning
+   "`(turn-on-debugging)' is obsolete and usually has no effect."
+   "Debugging capabilities are present by default.")
+  (debug-enable 'backtrace)
+  (read-enable 'positions))
+
+(define (read-hash-procedures-warning)
+  (issue-deprecation-warning
+   "`read-hash-procedures' is deprecated."
+   "Use the fluid `%read-hash-procedures' instead."))
+
+(define-syntax read-hash-procedures
+  (identifier-syntax
+    (_
+     (begin (read-hash-procedures-warning)
+            (fluid-ref %read-hash-procedures)))
+    ((set! _ expr)
+     (begin (read-hash-procedures-warning)
+            (fluid-set! %read-hash-procedures expr)))))
+
+(define (process-define-module args)
+  (define (missing kw)
+    (error "missing argument to define-module keyword" kw))
+  (define (unrecognized arg)
+    (error "unrecognized define-module argument" arg))
+
+  (issue-deprecation-warning
+   "`process-define-module' is deprecated.  Use `define-module*' instead.")
+
+  (let ((name (car args))
+        (filename #f)
+        (pure? #f)
+        (version #f)
+        (system? #f)
+        (duplicates '())
+        (transformer #f))
+    (let loop ((kws (cdr args))
+               (imports '())
+               (exports '())
+               (re-exports '())
+               (replacements '())
+               (autoloads '()))
+      (if (null? kws)
+          (define-module* name
+            #\filename filename #\pure pure? #\version version
+            #\duplicates duplicates #\transformer transformer
+            #\imports (reverse! imports)
+            #\exports exports
+            #\re-exports re-exports
+            #\replacements replacements
+            #\autoloads autoloads)
+          (case (car kws)
+            ((#\use-module #\use-syntax)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (cond
+              ((equal? (cadr kws) '(ice-9 syncase))
+               (issue-deprecation-warning
+                "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
+               (loop (cddr kws)
+                     imports exports re-exports replacements autoloads))
+              (else
+               (let ((iface-spec (cadr kws)))
+                 (if (eq? (car kws) #\use-syntax)
+                     (set! transformer iface-spec))
+                 (loop (cddr kws)
+                       (cons iface-spec imports) exports re-exports
+                       replacements autoloads)))))
+            ((#\autoload)
+             (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+                 (missing (car kws)))
+             (let ((name (cadr kws))
+                   (bindings (caddr kws)))
+               (loop (cdddr kws)
+                     imports exports re-exports
+                     replacements (cons* name bindings autoloads))))
+            ((#\no-backtrace)
+             ;; FIXME: deprecate?
+             (set! system? #t)
+             (loop (cdr kws)
+                   imports exports re-exports replacements autoloads))
+            ((#\pure)
+             (set! pure? #t)
+             (loop (cdr kws)
+                   imports exports re-exports replacements autoloads))
+            ((#\version)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (set! version (cadr kws))
+             (loop (cddr kws)
+                   imports exports re-exports replacements autoloads))
+            ((#\duplicates)
+             (if (not (pair? (cdr kws)))
+                 (missing (car kws)))
+             (set! duplicates (cadr kws))
+             (loop (cddr kws)
+                   imports exports re-exports replacements autoloads))
+            ((#\export #\export-syntax)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (loop (cddr kws)
+                   imports (append exports (cadr kws)) re-exports
+                   replacements autoloads))
+            ((#\re-export #\re-export-syntax)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (loop (cddr kws)
+                   imports exports (append re-exports (cadr kws))
+                   replacements autoloads))
+            ((#\replace #\replace-syntax)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (loop (cddr kws)
+                   imports exports re-exports
+                   (append replacements (cadr kws)) autoloads))
+            ((#\filename)
+             (or (pair? (cdr kws))
+                 (missing (car kws)))
+             (set! filename (cadr kws))
+             (loop (cddr kws)
+                   imports exports re-exports replacements autoloads))
+            (else
+             (unrecognized kws)))))))
+
+(define-syntax fluid-let-syntax
+  (lambda (x)
+    (issue-deprecation-warning
+     "`fluid-let-syntax' is deprecated.  Use syntax parameters instead.")
+    (syntax-case x ()
+      ((_ ((k v) ...) body0 body ...)
+       #'(syntax-parameterize ((k v) ...)
+           body0 body ...)))))
+
+(define (close-io-port port)
+  (issue-deprecation-warning
+   "`close-io-port' is deprecated.  Use `close-port' instead.")
+  (close-port port))
+
+(define (set-system-module! m s)
+  (issue-deprecation-warning
+   "`set-system-module!' is deprecated.  There is no need to use it.")
+  (set-procedure-property! (module-eval-closure m) 'system-module s))
+
+(set! module-eval-closure
+      (lambda (m)
+        (issue-deprecation-warning
+         "`module-eval-closure' is deprecated.  Use module-variable or module-define! instead.")
+        (standard-eval-closure m)))
+
+;; Legacy definition.  We can't make it identifier-syntax yet though,
+;; because compiled code might rely on it.
+(define char-code-limit 256)
+;;;; 	Copyright (C) 2000,2001, 2002, 2003, 2006, 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
+;;;;
+
+;;; Commentary:
+
+;; * This module exports:
+;;
+;; file-commentary      -- a procedure that returns a file's "commentary"
+;;
+;; documentation-files  -- a search-list of files using the Guile
+;;                         Documentation Format Version 2.
+;;
+;; search-documentation-files -- a procedure that takes NAME (a symbol)
+;;                               and searches `documentation-files' for
+;;                               associated documentation.  optional
+;;                               arg FILES is a list of filenames to use
+;;                               instead of `documentation-files'.
+;;
+;; object-documentation -- a procedure that returns its arg's docstring
+;;
+;; * Guile Documentation Format
+;;
+;; Here is the complete and authoritative documentation for the Guile
+;; Documentation Format Version 2:
+;;
+;; HEADER
+;; ^LPROC1
+;; DOCUMENTATION1
+;;
+;; ^LPROC2
+;; DOCUMENTATION2
+;;
+;; ^L...
+;;
+;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
+;; and so on are symbols that name the element documented.  DOCUMENTATION1,
+;; DOCUMENTATION2 and so on are the related documentation, w/o any further
+;; formatting.  Note that there are two newlines before the next formfeed;
+;; these are discarded when the documentation is read in.
+;;
+;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
+;; not documented anywhere except by this embarrassingly circular comment.)
+;;
+;; * File Commentary
+;;
+;; A file's commentary is the body of text found between comments
+;;     ;;; Commentary:
+;; and
+;;     ;;; Code:
+;; both of which must be at the beginning of the line.  In the result string,
+;; semicolons at the beginning of each line are discarded.
+;;
+;; You can specify to `file-commentary' alternate begin and end strings, and
+;; scrub procedure.  Use #t to get default values.  For example:
+;;
+;; (file-commentary "documentation.scm")
+;; You should see this text!
+;;
+;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
+;; You should see the rest of this file.
+;;
+;; (file-commentary "documentation.scm" #t #t string-upcase)
+;; You should see this text very loudly (note semicolons untouched).
+
+;;; Code:
+
+(define-module (ice-9 documentation)
+  \:use-module (ice-9 rdelim)
+  \:export (file-commentary
+           documentation-files search-documentation-files
+           object-documentation)
+  \:autoload (ice-9 regex) (match:suffix)
+  \:no-backtrace)
+
+
+;;
+;; commentary extraction
+;;
+
+(define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
+   
+  ;; These are constants but are not at the top level because the repl in
+  ;; boot-9.scm loads session.scm which in turn loads this file, and we want
+  ;; that to work even even when regexps are not available (ie. make-regexp
+  ;; doesn't exist), as for instance is the case on mingw.
+  ;;
+  (define default-in-line-re (make-regexp "^;;; Commentary:"))
+  (define default-after-line-re (make-regexp "^;;; Code:"))
+  (define default-scrub (let ((dirt (make-regexp "^;+")))
+			  (lambda (line)
+			    (let ((m (regexp-exec dirt line)))
+			      (if m (match:suffix m) line)))))
+       
+  ;; fixme: might be cleaner to use optargs here...
+  (let ((in-line-re (if (> 1 (length cust))
+                        default-in-line-re
+                        (let ((v (car cust)))
+                          (cond ((regexp? v) v)
+                                ((string? v) (make-regexp v))
+                                (else default-in-line-re)))))
+        (after-line-re (if (> 2 (length cust))
+                           default-after-line-re
+                           (let ((v (cadr cust)))
+                             (cond ((regexp? v) v)
+                                   ((string? v) (make-regexp v))
+                                   (else default-after-line-re)))))
+        (scrub (if (> 3 (length cust))
+                   default-scrub
+                   (let ((v (caddr cust)))
+                     (cond ((procedure? v) v)
+                           (else default-scrub))))))
+    (call-with-input-file filename
+      (lambda (port)
+	(let loop ((line (read-delimited "\n" port))
+		   (doc "")
+		   (parse-state 'before))
+	  (if (or (eof-object? line) (eq? 'after parse-state))
+	      doc
+	      (let ((new-state
+		     (cond ((regexp-exec in-line-re line) 'in)
+			   ((regexp-exec after-line-re line) 'after)
+			   (else parse-state))))
+		(if (eq? 'after new-state)
+		    doc
+		    (loop (read-delimited "\n" port)
+			  (if (and (eq? 'in new-state) (eq? 'in parse-state))
+			      (string-append doc (scrub line) "\n")
+			      doc)
+			  new-state)))))))))
+
+
+
+;;
+;; documentation-files is the list of places to look for documentation
+;;
+(define documentation-files
+  (map (lambda (vicinity)
+	 (in-vicinity (vicinity) "guile-procedures.txt"))
+       (list %library-dir
+	     %package-data-dir
+	     %site-dir
+	     (lambda () "."))))
+
+(define entry-delimiter "\f")
+
+(define (find-documentation-in-file name file)
+  (and (file-exists? file)
+       (call-with-input-file file
+	 (lambda (port)
+	   (let ((name (symbol->string name)))
+	     (let ((len (string-length name)))
+	       (read-delimited entry-delimiter port) ;skip to first entry
+	       (let loop ((entry (read-delimited entry-delimiter port)))
+		 (cond ((eof-object? entry) #f)
+		       ;; match?
+		       ((and ;; large enough?
+		         (>= (string-length entry) len)
+			 ;; matching name?
+			 (string=? (substring entry 0 len) name)
+			 ;; terminated?
+			 (memq (string-ref entry len) '(#\newline)))
+			;; cut away name tag and extra surrounding newlines
+			(substring entry (+ len 2) (- (string-length entry) 2)))
+		       (else (loop (read-delimited entry-delimiter port)))))))))))
+
+(define (search-documentation-files name . files)
+  (or-map (lambda (file)
+	    (find-documentation-in-file name file))
+          (cond ((null? files) documentation-files)
+                (else files))))
+
+(define (object-documentation object)
+  "Return the docstring for OBJECT.
+OBJECT can be a procedure, macro or any object that has its
+`documentation' property set."
+  (or (and (procedure? object)
+	   (procedure-documentation object))
+      (object-property object 'documentation)
+      (and (macro? object)
+           (object-documentation (macro-transformer object)))
+      (and (procedure? object)
+	   (procedure-name object)
+	   (let ((docstring (search-documentation-files
+                             (procedure-name object))))
+	     (if docstring
+		 (set-procedure-property! object 'documentation docstring))
+	     docstring))))
+
+;;; documentation.scm ends here
+;;; Evaluating code from users
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (ice-9 eval-string)
+  #\use-module (system base compile)
+  #\use-module (system base language)
+  #\use-module (system vm program)
+  #\replace (eval-string))
+
+(define (ensure-language x)
+  (if (language? x)
+      x
+      (lookup-language x)))
+
+(define* (read-and-eval port #\key (lang (current-language)))
+  (parameterize ((current-language (ensure-language lang)))
+    (define (read)
+      ((language-reader (current-language)) port (current-module)))
+    (define (eval exp)
+      ((language-evaluator (current-language)) exp (current-module)))
+            
+    (let ((exp (read)))
+      (if (eof-object? exp)
+          ;; The behavior of read-and-compile and of the old
+          ;; eval-string.
+          *unspecified*
+          (let lp ((exp exp))
+            (call-with-values
+                (lambda () (eval exp))
+              (lambda vals
+                (let ((next (read)))
+                  (cond
+                   ((eof-object? next)
+                    (apply values vals))
+                   (else
+                    (lp next)))))))))))
+
+(define* (eval-string str #\key
+                      (module (current-module))
+                      (file #f)
+                      (line #f)
+                      (column #f)
+                      (lang (current-language))
+                      (compile? #f))
+  (define (maybe-with-module module thunk)
+    (if module
+        (save-module-excursion
+         (lambda ()
+           (set-current-module module)
+           (thunk)))
+        (thunk)))
+
+  (let ((lang (ensure-language lang)))
+    (call-with-input-string
+     str
+     (lambda (port)
+       (maybe-with-module
+        module
+        (lambda ()
+          (if module
+              (set-current-module module))
+          (if file
+              (set-port-filename! port file))
+          (if line
+              (set-port-line! port line))
+          (if column
+              (set-port-column! port line))
+
+          (if (or compile? (not (language-evaluator lang)))
+              ((make-program (read-and-compile port #\from lang #\to 'objcode)))
+              (read-and-eval port #\lang lang))))))))
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 2009, 2010, 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
+;;;;
+
+
+
+;;; Commentary:
+
+;;; Scheme eval, written in Scheme.
+;;;
+;;; Expressions are first expanded, by the syntax expander (i.e.
+;;; psyntax), then memoized into internal forms. The evaluator itself
+;;; only operates on the internal forms ("memoized expressions").
+;;;
+;;; Environments are represented as linked lists of the form (VAL ... .
+;;; MOD). If MOD is #f, it means the environment was captured before
+;;; modules were booted. If MOD is the literal value '(), we are
+;;; evaluating at the top level, and so should track changes to the
+;;; current module.
+;;;
+;;; Evaluate this in Emacs to make code indentation work right:
+;;;
+;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
+;;;
+
+;;; Code:
+
+
+
+(eval-when (compile)
+  (define-syntax capture-env
+    (syntax-rules ()
+      ((_ (exp ...))
+       (let ((env (exp ...)))
+         (capture-env env)))
+      ((_ env)
+       (if (null? env)
+           (current-module)
+           (if (not env)
+               ;; the and current-module checks that modules are booted,
+               ;; and thus the-root-module is defined
+               (and (current-module) the-root-module)
+               env)))))
+
+  ;; Fast case for procedures with fixed arities.
+  (define-syntax make-fixed-closure
+    (lambda (x)
+      (define *max-static-argument-count* 8)
+      (define (make-formals n)
+        (map (lambda (i)
+               (datum->syntax
+                x
+                (string->symbol
+                 (string (integer->char (+ (char->integer #\a) i))))))
+             (iota n)))
+      (syntax-case x ()
+        ((_ eval nreq body env) (not (identifier? #'env))
+         #'(let ((e env))
+             (make-fixed-closure eval nreq body e)))
+        ((_ eval nreq body env)
+         #`(case nreq
+             #,@(map (lambda (nreq)
+                       (let ((formals (make-formals nreq)))
+                         #`((#,nreq)
+                            (lambda (#,@formals)
+                              (eval body
+                                    (cons* #,@(reverse formals) env))))))
+                     (iota *max-static-argument-count*))
+             (else
+              #,(let ((formals (make-formals *max-static-argument-count*)))
+                  #`(lambda (#,@formals . more)
+                      (let lp ((new-env (cons* #,@(reverse formals) env))
+                               (nreq (- nreq #,*max-static-argument-count*))
+                               (args more))
+                        (if (zero? nreq)
+                            (eval body
+                                  (if (null? args)
+                                      new-env
+                                      (scm-error 'wrong-number-of-args
+                                                 "eval" "Wrong number of arguments"
+                                                 '() #f)))
+                            (if (null? args)
+                                (scm-error 'wrong-number-of-args
+                                           "eval" "Wrong number of arguments"
+                                           '() #f)
+                                (lp (cons (car args) new-env)
+                                    (1- nreq)
+                                    (cdr args)))))))))))))
+
+  (define-syntax call
+    (lambda (x)
+      (define *max-static-call-count* 4)
+      (syntax-case x ()
+        ((_ eval proc nargs args env) (identifier? #'env)
+         #`(case nargs
+             #,@(map (lambda (nargs)
+                       #`((#,nargs)
+                          (proc
+                           #,@(map
+                               (lambda (n)
+                                 (let lp ((n n) (args #'args))
+                                   (if (zero? n)
+                                       #`(eval (car #,args) env)
+                                       (lp (1- n) #`(cdr #,args)))))
+                               (iota nargs)))))
+                     (iota *max-static-call-count*))
+             (else
+              (apply proc
+                     #,@(map
+                         (lambda (n)
+                           (let lp ((n n) (args #'args))
+                             (if (zero? n)
+                                 #`(eval (car #,args) env)
+                                 (lp (1- n) #`(cdr #,args)))))
+                         (iota *max-static-call-count*))
+                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
+                                               (args #'args))
+                                        (if (zero? n)
+                                            args
+                                            (lp (1- n) #`(cdr #,args)))))
+                              (args '()))
+                       (if (null? exps)
+                           (reverse args)
+                           (lp (cdr exps)
+                               (cons (eval (car exps) env) args)))))))))))
+
+  ;; This macro could be more straightforward if the compiler had better
+  ;; copy propagation. As it is we do some copy propagation by hand.
+  (define-syntax mx-bind
+    (lambda (x)
+      (syntax-case x ()
+        ((_ data () body)
+         #'body)
+        ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
+         #'(let ((a (car data))
+                 (b (cdr data)))
+             body))
+        ((_ data (a . b) body) (identifier? #'a)
+         #'(let ((a (car data))
+                 (xb (cdr data)))
+             (mx-bind xb b body)))
+        ((_ data (a . b) body) 
+         #'(let ((xa (car data))
+                 (xb (cdr data)))
+             (mx-bind xa a (mx-bind xb b body))))
+        ((_ data v body) (identifier? #'v)
+         #'(let ((v data))
+             body)))))
+  
+  ;; The resulting nested if statements will be an O(n) dispatch. Once
+  ;; we compile `case' effectively, this situation will improve.
+  (define-syntax mx-match
+    (lambda (x)
+      (syntax-case x (quote)
+        ((_ mx data tag)
+         #'(error "what" mx))
+        ((_ mx data tag (('type pat) body) c* ...)
+         #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
+                               (error "not a typecode" #'type)))
+               (mx-bind data pat body)
+               (mx-match mx data tag c* ...))))))
+
+  (define-syntax memoized-expression-case
+    (lambda (x)
+      (syntax-case x ()
+        ((_ mx c ...)
+         #'(let ((tag (memoized-expression-typecode mx))
+                 (data (memoized-expression-data mx)))
+             (mx-match mx data tag c ...)))))))
+
+
+;;;
+;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
+;;; types occur when getting to a prompt on a fresh build. Here are the numbers
+;;; I got:
+;;;
+;;;      lexical-ref: 32933054
+;;;             call: 20281547
+;;;     toplevel-ref: 13228724
+;;;               if: 9156156
+;;;            quote: 6610137
+;;;              let: 2619707
+;;;           lambda: 1010921
+;;;            begin: 948945
+;;;      lexical-set: 509862
+;;; call-with-values: 139668
+;;;            apply: 49402
+;;;       module-ref: 14468
+;;;           define: 1259
+;;;     toplevel-set: 328
+;;;          dynwind: 162
+;;;      with-fluids: 0
+;;;          call/cc: 0
+;;;       module-set: 0
+;;;
+;;; So until we compile `case' into a computed goto, we'll order the clauses in
+;;; `eval' in this order, to put the most frequent cases first.
+;;;
+
+(define primitive-eval
+  (let ()
+    ;; We pre-generate procedures with fixed arities, up to some number of
+    ;; arguments; see make-fixed-closure above.
+
+    ;; A unique marker for unbound keywords.
+    (define unbound-arg (list 'unbound-arg))
+
+    ;; Procedures with rest, optional, or keyword arguments, potentially with
+    ;; multiple arities, as with case-lambda.
+    (define (make-general-closure env body nreq rest? nopt kw inits alt)
+      (define alt-proc
+        (and alt                             ; (body docstring nreq ...)
+             (let* ((body (car alt))
+                    (spec (cddr alt))
+                    (nreq (car spec))
+                    (rest (if (null? (cdr spec)) #f (cadr spec)))
+                    (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
+                    (nopt (if tail (car tail) 0))
+                    (kw (and tail (cadr tail)))
+                    (inits (if tail (caddr tail) '()))
+                    (alt (and tail (cadddr tail))))
+               (make-general-closure env body nreq rest nopt kw inits alt))))
+      (define (set-procedure-arity! proc)
+        (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
+          (if (not alt)
+              (begin
+                (set-procedure-property! proc 'arglist
+                                         (list nreq
+                                               nopt
+                                               (if kw (cdr kw) '())
+                                               (and kw (car kw))
+                                               (and rest? '_)))
+                (set-procedure-minimum-arity! proc nreq nopt rest?))
+              (let* ((spec (cddr alt))
+                     (nreq* (car spec))
+                     (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
+                     (nopt* (if tail (car tail) 0))
+                     (alt* (and tail (cadddr tail))))
+                (if (or (< nreq* nreq)
+                        (and (= nreq* nreq)
+                             (if rest?
+                                 (and rest?* (> nopt* nopt))
+                                 (or rest?* (> nopt* nopt)))))
+                    (lp alt* nreq* nopt* rest?*)
+                    (lp alt* nreq nopt rest?)))))
+        proc)
+      (set-procedure-arity!
+       (lambda %args
+         (let lp ((env env)
+                  (nreq* nreq)
+                  (args %args))
+           (if (> nreq* 0)
+               ;; First, bind required arguments.
+               (if (null? args)
+                   (if alt
+                       (apply alt-proc %args)
+                       (scm-error 'wrong-number-of-args
+                                  "eval" "Wrong number of arguments"
+                                  '() #f))
+                   (lp (cons (car args) env)
+                       (1- nreq*)
+                       (cdr args)))
+               ;; Move on to optional arguments.
+               (if (not kw)
+                   ;; Without keywords, bind optionals from arguments.
+                   (let lp ((env env)
+                            (nopt nopt)
+                            (args args)
+                            (inits inits))
+                     (if (zero? nopt)
+                         (if rest?
+                             (eval body (cons args env))
+                             (if (null? args)
+                                 (eval body env)
+                                 (if alt
+                                     (apply alt-proc %args)
+                                     (scm-error 'wrong-number-of-args
+                                                "eval" "Wrong number of arguments"
+                                                '() #f))))
+                         (if (null? args)
+                             (lp (cons (eval (car inits) env) env)
+                                 (1- nopt) args (cdr inits))
+                             (lp (cons (car args) env)
+                                 (1- nopt) (cdr args) (cdr inits)))))
+                   (let lp ((env env)
+                            (nopt* nopt)
+                            (args args)
+                            (inits inits))
+                     (cond
+                      ;; With keywords, we stop binding optionals at the
+                      ;; first keyword.
+                      ((> nopt* 0)
+                       (if (or (null? args) (keyword? (car args)))
+                           (lp (cons (eval (car inits) env) env)
+                               (1- nopt*) args (cdr inits))
+                           (lp (cons (car args) env)
+                               (1- nopt*) (cdr args) (cdr inits))))
+                      ;; Finished with optionals.
+                      ((and alt (pair? args) (not (keyword? (car args)))
+                            (not rest?))
+                       ;; Too many positional args, no #\rest arg,
+                       ;; and we have an alternate.
+                       (apply alt-proc %args))
+                      (else
+                       (let* ((aok (car kw))
+                              (kw (cdr kw))
+                              (kw-base (+ nopt nreq (if rest? 1 0)))
+                              (imax (let lp ((imax (1- kw-base)) (kw kw))
+                                      (if (null? kw)
+                                          imax
+                                          (lp (max (cdar kw) imax)
+                                              (cdr kw)))))
+                              ;; Fill in kwargs  with "undefined" vals.
+                              (env (let lp ((i kw-base)
+                                            ;; Also, here we bind the rest
+                                            ;; arg, if any.
+                                            (env (if rest?
+                                                     (cons args env)
+                                                     env)))
+                                     (if (<= i imax)
+                                         (lp (1+ i) (cons unbound-arg env))
+                                         env))))
+                         ;; Now scan args for keywords.
+                         (let lp ((args args))
+                           (cond
+                            ((pair? args)
+                             (cond
+                              ((keyword? (car args))
+                               (let ((k (car args))
+                                     (args (cdr args)))
+                                 (cond
+                                  ((assq k kw)
+                                   => (lambda (kw-pair)
+                                        ;; Found a known keyword; set its value.
+                                        (if (pair? args)
+                                            (let ((v (car args))
+                                                  (args (cdr args)))
+                                              (list-set! env
+                                                         (- imax (cdr kw-pair))
+                                                         v)
+                                              (lp args))
+                                            (scm-error 'keyword-argument-error
+                                                       "eval"
+                                                       "Keyword argument has no value"
+                                                       '() (list k)))))
+                                  ;; Otherwise unknown keyword.
+                                  (aok
+                                   (lp (if (pair? args) (cdr args) args)))
+                                  (else
+                                   (scm-error 'keyword-argument-error
+                                              "eval" "Unrecognized keyword"
+                                              '() (list k))))))
+                              (rest?
+                               ;; Be lenient parsing rest args.
+                               (lp (cdr args)))
+                              (else
+                               (scm-error 'keyword-argument-error
+                                          "eval" "Invalid keyword"
+                                          '() (list (car args))))))
+                            (else
+                             ;; Finished parsing keywords. Fill in
+                             ;; uninitialized kwargs by evalling init
+                             ;; expressions in their appropriate
+                             ;; environment.
+                             (let lp ((i (- imax kw-base))
+                                      (inits inits))
+                               (if (pair? inits)
+                                   (let ((tail (list-tail env i)))
+                                     (if (eq? (car tail) unbound-arg)
+                                         (set-car! tail
+                                                   (eval (car inits)
+                                                         (cdr tail))))
+                                     (lp (1- i) (cdr inits)))
+                                   ;; Finally, eval the body.
+                                   (eval body env)))))
+                           )))))))))))
+
+    ;; The "engine". EXP is a memoized expression.
+    (define (eval exp env)
+      (memoized-expression-case exp
+        (('lexical-ref n)
+         (list-ref env n))
+        
+        (('call (f nargs . args))
+         (let ((proc (eval f env)))
+           (call eval proc nargs args env)))
+        
+        (('toplevel-ref var-or-sym)
+         (variable-ref
+          (if (variable? var-or-sym)
+              var-or-sym
+              (memoize-variable-access! exp
+                                        (capture-env (if (pair? env)
+                                                         (cdr (last-pair env))
+                                                         env))))))
+
+        (('if (test consequent . alternate))
+         (if (eval test env)
+             (eval consequent env)
+             (eval alternate env)))
+      
+        (('quote x)
+         x)
+
+        (('let (inits . body))
+         (let lp ((inits inits) (new-env (capture-env env)))
+           (if (null? inits)
+               (eval body new-env)
+               (lp (cdr inits)
+                   (cons (eval (car inits) env) new-env)))))
+
+        (('lambda (body docstring nreq . tail))
+         (let ((proc
+                (if (null? tail)
+                    (make-fixed-closure eval nreq body (capture-env env))
+                    (if (null? (cdr tail))
+                        (make-general-closure (capture-env env) body
+                                              nreq (car tail)
+                                              0 #f '() #f)
+                        (apply make-general-closure (capture-env env)
+                               body nreq tail)))))
+           (when docstring
+             (set-procedure-property! proc 'documentation docstring))
+           proc))
+
+        (('begin (first . rest))
+         (let lp ((first first) (rest rest))
+           (if (null? rest)
+               (eval first env)
+               (begin
+                 (eval first env)
+                 (lp (car rest) (cdr rest))))))
+      
+        (('lexical-set! (n . x))
+         (let ((val (eval x env)))
+           (list-set! env n val)))
+        
+        (('call-with-values (producer . consumer))
+         (call-with-values (eval producer env)
+           (eval consumer env)))
+
+        (('apply (f args))
+         (apply (eval f env) (eval args env)))
+
+        (('module-ref var-or-spec)
+         (variable-ref
+          (if (variable? var-or-spec)
+              var-or-spec
+              (memoize-variable-access! exp #f))))
+
+        (('define (name . x))
+         (let ((x (eval x env)))
+           (if (and (procedure? x) (not (procedure-property x 'name)))
+               (set-procedure-property! x 'name name))
+           (define! name x)
+           (if #f #f)))
+      
+        (('toplevel-set! (var-or-sym . x))
+         (variable-set!
+          (if (variable? var-or-sym)
+              var-or-sym
+              (memoize-variable-access! exp
+                                        (capture-env (if (pair? env)
+                                                         (cdr (last-pair env))
+                                                         env))))
+          (eval x env)))
+      
+        (('dynwind (in exp . out))
+         (dynamic-wind (eval in env)
+                       (lambda () (eval exp env))
+                       (eval out env)))
+        
+        (('with-fluids (fluids vals . exp))
+         (let* ((fluids (map (lambda (x) (eval x env)) fluids))
+                (vals (map (lambda (x) (eval x env)) vals)))
+           (let lp ((fluids fluids) (vals vals))
+             (if (null? fluids)
+                 (eval exp env)
+                 (with-fluids (((car fluids) (car vals)))
+                   (lp (cdr fluids) (cdr vals)))))))
+        
+        (('prompt (tag exp . handler))
+         (@prompt (eval tag env)
+                  (eval exp env)
+                  (eval handler env)))
+        
+        (('call/cc proc)
+         (call/cc (eval proc env)))
+
+        (('module-set! (x . var-or-spec))
+         (variable-set!
+          (if (variable? var-or-spec)
+              var-or-spec
+              (memoize-variable-access! exp #f))
+          (eval x env)))))
+  
+    ;; primitive-eval
+    (lambda (exp)
+      "Evaluate @var{exp} in the current module."
+      (eval 
+       (memoize-expression 
+        (if (macroexpanded? exp)
+            exp
+            ((module-transformer (current-module)) exp)))
+       '()))))
+;;;; 	Copyright (C) 1996, 1998, 1999, 2001, 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 documented in the Guile Reference Manual.
+;; Briefly, these are exported:
+;;  procedures: expect-select, expect-regexec
+;;   variables: expect-port, expect-timeout, expect-timeout-proc,
+;;              expect-eof-proc, expect-char-proc,
+;;              expect-strings-compile-flags, expect-strings-exec-flags,
+;;      macros: expect, expect-strings
+
+;;; Code:
+
+(define-module (ice-9 expect)
+  \:use-module (ice-9 regex)
+  \:export-syntax (expect expect-strings)
+  \:export (expect-port expect-timeout expect-timeout-proc
+	   expect-eof-proc expect-char-proc expect-strings-compile-flags
+	   expect-strings-exec-flags expect-select expect-regexec))
+
+;;; Expect: a macro for selecting actions based on what it reads from a port.
+;;; The idea is from Don Libes' expect based on Tcl.
+;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
+
+
+(define expect-port #f)
+(define expect-timeout #f)
+(define expect-timeout-proc #f)
+(define expect-eof-proc #f)
+(define expect-char-proc #f)
+
+;;; expect: each test is a procedure which is applied to the accumulating
+;;; string.
+(defmacro expect clauses
+  (let ((s (gensym))
+	(c (gensym))
+	(port (gensym))
+	(timeout (gensym)))
+    `(let ((,s "")
+	   (,port (or expect-port (current-input-port)))
+	   ;; when timeout occurs, in floating point seconds.
+	   (,timeout (if expect-timeout
+			 (let* ((secs-usecs (gettimeofday)))
+			   (+ (car secs-usecs)
+			      expect-timeout
+			      (/ (cdr secs-usecs)
+				 1000000))) ; one million.
+			 #f)))
+       (let next-char ()
+	 (if (and expect-timeout
+		  (not (expect-select ,port ,timeout)))
+	     (if expect-timeout-proc
+		 (expect-timeout-proc ,s)
+		 #f)
+	     (let ((,c (read-char ,port)))
+	       (if expect-char-proc
+		   (expect-char-proc ,c))
+	       (if (not (eof-object? ,c))
+		   (set! ,s (string-append ,s (string ,c))))
+	       (cond
+		;; this expands to clauses where the car invokes the
+		;; match proc and the cdr is the return value from expect
+		;; if the proc matched.
+		,@(let next-expr ((tests (map car clauses))
+				  (exprs (map cdr clauses))
+				  (body '()))
+		    (cond
+		     ((null? tests)
+		      (reverse body))
+		     (else
+		      (next-expr
+		       (cdr tests)
+		       (cdr exprs)
+		       (cons
+			`((,(car tests) ,s (eof-object? ,c))
+			  ,@(cond ((null? (car exprs))
+				   '())
+				  ((eq? (caar exprs) '=>)
+				   (if (not (= (length (car exprs))
+					       2))
+				       (scm-error 'misc-error
+						  "expect"
+						  "bad recipient: ~S"
+						  (list (car exprs))
+						  #f)
+				       `((apply ,(cadar exprs)
+						(,(car tests) ,s ,port)))))
+				  (else
+				   (car exprs))))
+			body)))))
+		;; if none of the clauses matched the current string.
+		(else (cond ((eof-object? ,c)
+			     (if expect-eof-proc
+				 (expect-eof-proc ,s)
+				 #f))
+			    (else
+			     (next-char)))))))))))
+
+
+(define expect-strings-compile-flags regexp/newline)
+(define expect-strings-exec-flags regexp/noteol)
+
+;;; the regexec front-end to expect:
+;;; each test must evaluate to a regular expression.
+(defmacro expect-strings clauses
+  `(let ,@(let next-test ((tests (map car clauses))
+			  (exprs (map cdr clauses))
+			  (defs '())
+			  (body '()))
+	    (cond ((null? tests)
+		   (list (reverse defs) `(expect ,@(reverse body))))
+		  (else
+		   (let ((rxname (gensym)))
+		     (next-test (cdr tests)
+				(cdr exprs)
+				(cons `(,rxname (make-regexp
+						 ,(car tests)
+						 expect-strings-compile-flags))
+				      defs)
+				(cons `((lambda (s eof?)
+					  (expect-regexec ,rxname s eof?))
+					,@(car exprs))
+				      body))))))))
+
+;;; simplified select: returns #t if input is waiting or #f if timed out or
+;;; select was interrupted by a signal.
+;;; timeout is an absolute time in floating point seconds.
+(define (expect-select port timeout)
+  (let* ((secs-usecs (gettimeofday))
+	 (relative (- timeout
+		      (car secs-usecs)
+		      (/ (cdr secs-usecs)
+			 1000000))))	; one million.
+    (and (> relative 0)
+	 (pair? (car (select (list port) '() '()
+			     relative))))))
+
+;;; match a string against a regexp, returning a list of strings (required
+;;; by the => syntax) or #f.  called once each time a character is added
+;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
+(define (expect-regexec rx s eof?)
+  ;; if expect-strings-exec-flags contains regexp/noteol,
+  ;; remove it for the eof test.
+  (let* ((flags (if (and eof?
+			 (logand expect-strings-exec-flags regexp/noteol))
+		    (logxor expect-strings-exec-flags regexp/noteol)
+		    expect-strings-exec-flags))
+	 (match (regexp-exec rx s 0 flags)))
+    (if match
+	(do ((i (- (match:count match) 1) (- i 1))
+	     (result '() (cons (match:substring match i) result)))
+	    ((< i 0) result))
+	#f)))
+
+;;; expect.scm ends here
+;;;; "format.scm" Common LISP text output formatter for SLIB
+;;; 	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
+;;;
+
+;;; This code was orignally in the public domain.
+;;;
+;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de).
+;;;
+;;; Authors of the version from SLIB (< 1.4) were Ken Dickey and Aubrey
+;;; Jaffer.
+;;;
+;;; Assimilated into Guile May 1999.
+;;;
+;;; Please don't bother the original authors with bug reports, though;
+;;; send them to bug-guile@gnu.org.
+;;;
+
+(define-module (ice-9 format)
+  #\autoload (ice-9 pretty-print) (pretty-print truncated-print)
+  #\autoload (ice-9 i18n)         (%global-locale number->locale-string)
+  #\replace (format))
+
+(define format:version "3.0")
+
+(define (format destination format-string . format-args)
+  (if (not (string? format-string))
+      (error "format: expected a string for format string" format-string))
+
+  (let* ((port
+          (cond
+           ((not destination)
+            ;; Use a Unicode-capable output string port.
+            (with-fluids ((%default-port-encoding "UTF-8"))
+              (open-output-string)))
+           ((boolean? destination) (current-output-port)) ; boolean but not false
+           ((output-port? destination) destination)
+           ((number? destination)
+            (issue-deprecation-warning
+             "Passing a number to format as the port is deprecated."
+             "Pass (current-error-port) instead.")
+            (current-error-port))
+           (else
+            (error "format: bad destination `~a'" destination))))
+
+         (output-col (or (port-column port) 0))
+
+         (flush-output? #f))
+
+    (define format:case-conversion #f)
+    (define format:pos 0)        ; curr. format string parsing position
+    (define format:arg-pos 0)    ; curr. format argument position
+					; this is global for error presentation
+       
+    ;; format string and char output routines on port
+
+    (define (format:out-str str)
+      (if format:case-conversion
+          (display (format:case-conversion str) port)
+          (display str port))
+      (set! output-col
+            (+ output-col (string-length str))))
+
+    (define (format:out-char ch)
+      (if format:case-conversion
+          (display (format:case-conversion (string ch))
+                   port)
+          (write-char ch port))
+      (set! output-col
+            (if (char=? ch #\newline)
+                0
+                (+ output-col 1))))
+       
+    ;;(define (format:out-substr str i n)  ; this allocates a new string
+    ;;  (display (substring str i n) port)
+    ;;  (set! output-col (+ output-col n)))
+
+    (define (format:out-substr str i n)
+      (do ((k i (+ k 1)))
+          ((= k n))
+        (write-char (string-ref str k) port))
+      (set! output-col (+ output-col (- n i))))
+
+    ;;(define (format:out-fill n ch)       ; this allocates a new string
+    ;;  (format:out-str (make-string n ch)))
+
+    (define (format:out-fill n ch)
+      (do ((i 0 (+ i 1)))
+          ((= i n))
+        (write-char ch port))
+      (set! output-col (+ output-col n)))
+
+    ;; format's user error handler
+
+    (define (format:error . args)       ; never returns!
+      (let ((port (current-error-port)))
+        (set! format:error format:intern-error)
+        (if (not (zero? format:arg-pos))
+            (set! format:arg-pos (- format:arg-pos 1)))
+        (format port
+                "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
+                                  ~{~a ~}===>~{~a ~})~%        "
+                destination
+                (substring format-string 0 format:pos)
+                (substring format-string format:pos
+                           (string-length format-string))
+                (list-head format-args format:arg-pos)
+                (list-tail format-args format:arg-pos))
+        (apply format port args)
+        (newline port)
+        (set! format:error format:error-save)
+        (format:abort)))
+
+    (define (format:intern-error . args)
+      ;;if something goes wrong in format:error
+      (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
+      (display "        destination: ") (write destination) (newline)
+      (display "        format string: ") (write format-string) (newline)
+      (display "        format args: ") (write format-args) (newline)
+      (display "        error args:  ") (write args) (newline)
+      (set! format:error format:error-save)
+      (format:abort))
+	      
+    (define format:error-save format:error)
+  
+    (define format:parameter-characters
+      '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
+
+    (define (format:format-work format-string arglist) ; does the formatting work
+      (letrec
+          ((format-string-len (string-length format-string))
+           (arg-pos 0)               ; argument position in arglist
+           (arg-len (length arglist))   ; number of arguments
+           (modifier #f)                ; 'colon | 'at | 'colon-at | #f
+           (params '())                 ; directive parameter list
+           (param-value-found #f)       ; a directive
+					; parameter value
+					; found
+           (conditional-nest 0)         ; conditional nesting level
+           (clause-pos 0)               ; last cond. clause
+					; beginning char pos
+           (clause-default #f)		; conditional default
+					; clause string
+           (clauses '())                ; conditional clause
+					; string list
+           (conditional-type #f)        ; reflects the
+					; contional modifiers
+           (conditional-arg #f)      ; argument to apply the conditional
+           (iteration-nest 0)        ; iteration nesting level
+           (iteration-pos 0)         ; iteration string
+					; beginning char pos
+           (iteration-type #f)		; reflects the
+					; iteration modifiers
+           (max-iterations #f)		; maximum number of
+					; iterations
+           (recursive-pos-save format:pos)
+	       
+           (next-char			; gets the next char
+					; from format-string
+            (lambda ()
+              (let ((ch (peek-next-char)))
+                (set! format:pos (+ 1 format:pos))
+                ch)))
+	       
+           (peek-next-char
+            (lambda ()
+              (if (>= format:pos format-string-len)
+                  (format:error "illegal format string")
+                  (string-ref format-string format:pos))))
+	       
+           (one-positive-integer?
+            (lambda (params)
+              (cond
+               ((null? params) #f)
+               ((and (integer? (car params))
+                     (>= (car params) 0)
+                     (= (length params) 1)) #t)
+               (else
+                (format:error
+                 "one positive integer parameter expected")))))
+	       
+           (next-arg
+            (lambda ()
+              (if (>= arg-pos arg-len)
+                  (begin
+                    (set! format:arg-pos (+ arg-len 1))
+                    (format:error "missing argument(s)")))
+              (add-arg-pos 1)
+              (list-ref arglist (- arg-pos 1))))
+	       
+           (prev-arg
+            (lambda ()
+              (add-arg-pos -1)
+              (if (negative? arg-pos)
+                  (format:error "missing backward argument(s)"))
+              (list-ref arglist arg-pos)))
+	       
+           (rest-args
+            (lambda ()
+              (let loop ((l arglist) (k arg-pos)) ; list-tail definition
+                (if (= k 0) l (loop (cdr l) (- k 1))))))
+	       
+           (add-arg-pos
+            (lambda (n) 
+              (set! arg-pos (+ n arg-pos))
+              (set! format:arg-pos arg-pos)))
+	       
+           (anychar-dispatch		; dispatches the format-string
+            (lambda ()
+              (if (>= format:pos format-string-len)
+                  arg-pos               ; used for ~? continuance
+                  (let ((char (next-char)))
+                    (cond
+                     ((char=? char #\~)
+                      (set! modifier #f)
+                      (set! params '())
+                      (set! param-value-found #f)
+                      (tilde-dispatch))
+                     (else
+                      (if (and (zero? conditional-nest)
+                               (zero? iteration-nest))
+                          (format:out-char char))
+                      (anychar-dispatch)))))))
+	       
+           (tilde-dispatch
+            (lambda ()
+              (cond
+               ((>= format:pos format-string-len)
+                (format:out-str "~")	; tilde at end of
+					; string is just
+					; output
+                arg-pos)                ; used for ~?
+					; continuance
+               ((and (or (zero? conditional-nest)
+                         (memv (peek-next-char) ; find conditional
+					; directives
+                               (append '(#\[ #\] #\; #\: #\@ #\^)
+                                       format:parameter-characters)))
+                     (or (zero? iteration-nest)
+                         (memv (peek-next-char) ; find iteration
+					; directives
+                               (append '(#\{ #\} #\: #\@ #\^)
+                                       format:parameter-characters))))
+                (case (char-upcase (next-char))
+		      
+                  ;; format directives
+		      
+                  ((#\A)                ; Any -- for humans
+                   (set! format:read-proof
+                         (memq modifier '(colon colon-at)))
+                   (format:out-obj-padded (memq modifier '(at colon-at))
+                                          (next-arg) #f params)
+                   (anychar-dispatch))
+                  ((#\S)                ; Slashified -- for parsers
+                   (set! format:read-proof
+                         (memq modifier '(colon colon-at)))
+                   (format:out-obj-padded (memq modifier '(at colon-at))
+                                          (next-arg) #t params)
+                   (anychar-dispatch))
+                  ((#\D)                ; Decimal
+                   (format:out-num-padded modifier (next-arg) params 10)
+                   (anychar-dispatch))
+                  ((#\H)                ; Localized number
+                   (let* ((num      (next-arg))
+                          (locale   (case modifier
+                                      ((colon) (next-arg))
+                                      (else    %global-locale)))
+                          (argc     (length params))
+                          (width    (format:par params argc 0 #f "width"))
+                          (decimals (format:par params argc 1 #t "decimals"))
+                          (padchar  (integer->char
+                                     (format:par params argc 2 format:space-ch
+                                                 "padchar")))
+                          (str      (number->locale-string num decimals
+                                                           locale)))
+                     (format:out-str (if (and width
+                                              (< (string-length str) width))
+                                         (string-pad str width padchar)
+                                         str)))
+                   (anychar-dispatch))
+                  ((#\X)                ; Hexadecimal
+                   (format:out-num-padded modifier (next-arg) params 16)
+                   (anychar-dispatch))
+                  ((#\O)                ; Octal
+                   (format:out-num-padded modifier (next-arg) params 8)
+                   (anychar-dispatch))
+                  ((#\B)                ; Binary
+                   (format:out-num-padded modifier (next-arg) params 2)
+                   (anychar-dispatch))
+                  ((#\R)
+                   (if (null? params)
+                       (format:out-obj-padded ; Roman, cardinal,
+					; ordinal numerals
+                        #f
+                        ((case modifier
+                           ((at) format:num->roman)
+                           ((colon-at) format:num->old-roman)
+                           ((colon) format:num->ordinal)
+                           (else format:num->cardinal))
+                         (next-arg))
+                        #f params)
+                       (format:out-num-padded ; any Radix
+                        modifier (next-arg) (cdr params) (car params)))
+                   (anychar-dispatch))
+                  ((#\F)                ; Fixed-format floating-point
+                   (format:out-fixed modifier (next-arg) params)
+                   (anychar-dispatch))
+                  ((#\E)                ; Exponential floating-point
+                   (format:out-expon modifier (next-arg) params)
+                   (anychar-dispatch))
+                  ((#\G)                ; General floating-point
+                   (format:out-general modifier (next-arg) params)
+                   (anychar-dispatch))
+                  ((#\$)                ; Dollars floating-point
+                   (format:out-dollar modifier (next-arg) params)
+                   (anychar-dispatch))
+                  ((#\I)                ; Complex numbers
+                   (let ((z (next-arg)))
+                     (if (not (complex? z))
+                         (format:error "argument not a complex number"))
+                     (format:out-fixed modifier (real-part z) params)
+                     (format:out-fixed 'at (imag-part z) params)
+                     (format:out-char #\i))
+                   (anychar-dispatch))
+                  ((#\C)                ; Character
+                   (let ((ch (if (one-positive-integer? params)
+                                 (integer->char (car params))
+                                 (next-arg))))
+                     (if (not (char? ch))
+                         (format:error "~~c expects a character"))
+                     (case modifier
+                       ((at)
+                        (format:out-str (object->string ch)))
+                       ((colon)
+                        (let ((c (char->integer ch)))
+                          (if (< c 0)
+                              (set! c (+ c 256))) ; compensate
+					; complement
+					; impl.
+                          (cond
+                           ((< c #x20)	; assumes that control
+					; chars are < #x20
+                            (format:out-char #\^)
+                            (format:out-char
+                             (integer->char (+ c #x40))))
+                           ((>= c #x7f)
+                            (format:out-str "#\\")
+                            (format:out-str
+                             (number->string c 8)))
+                           (else
+                            (format:out-char ch)))))
+                       (else (format:out-char ch))))
+                   (anychar-dispatch))
+                  ((#\P)                ; Plural
+                   (if (memq modifier '(colon colon-at))
+                       (prev-arg))
+                   (let ((arg (next-arg)))
+                     (if (not (number? arg))
+                         (format:error "~~p expects a number argument"))
+                     (if (= arg 1)
+                         (if (memq modifier '(at colon-at))
+                             (format:out-char #\y))
+                         (if (memq modifier '(at colon-at))
+                             (format:out-str "ies")
+                             (format:out-char #\s))))
+                   (anychar-dispatch))
+                  ((#\~)                ; Tilde
+                   (if (one-positive-integer? params)
+                       (format:out-fill (car params) #\~)
+                       (format:out-char #\~))
+                   (anychar-dispatch))
+                  ((#\%)                ; Newline
+                   (if (one-positive-integer? params)
+                       (format:out-fill (car params) #\newline)
+                       (format:out-char #\newline))
+                   (set! output-col 0)
+                   (anychar-dispatch))
+                  ((#\&)                ; Fresh line
+                   (if (one-positive-integer? params)
+                       (begin
+                         (if (> (car params) 0)
+                             (format:out-fill (- (car params)
+                                                 (if (>
+                                                      output-col
+                                                      0) 0 1))
+                                              #\newline))
+                         (set! output-col 0))
+                       (if (> output-col 0)
+                           (format:out-char #\newline)))
+                   (anychar-dispatch))
+                  ((#\_)                ; Space character
+                   (if (one-positive-integer? params)
+                       (format:out-fill (car params) #\space)
+                       (format:out-char #\space))
+                   (anychar-dispatch))
+                  ((#\/)                ; Tabulator character
+                   (if (one-positive-integer? params)
+                       (format:out-fill (car params) #\tab)
+                       (format:out-char #\tab))
+                   (anychar-dispatch))
+                  ((#\|)                ; Page seperator
+                   (if (one-positive-integer? params)
+                       (format:out-fill (car params) #\page)
+                       (format:out-char #\page))
+                   (set! output-col 0)
+                   (anychar-dispatch))
+                  ((#\T)                ; Tabulate
+                   (format:tabulate modifier params)
+                   (anychar-dispatch))
+                  ((#\Y)                ; Structured print
+                   (let ((width (if (one-positive-integer? params)
+                                    (car params)
+                                    79)))
+                     (case modifier
+                       ((at)
+                        (format:out-str
+                         (call-with-output-string
+                           (lambda (p)
+                             (truncated-print (next-arg) p
+                                              #\width width)))))
+                       ((colon-at)
+                        (format:out-str
+                         (call-with-output-string
+                           (lambda (p)
+                             (truncated-print (next-arg) p
+                                              #\width
+                                              (max (- width
+                                                      output-col)
+                                                   1))))))
+                       ((colon)
+                        (format:error "illegal modifier in ~~?"))
+                       (else
+                        (pretty-print (next-arg) port
+                                      #\width width)
+                        (set! output-col 0))))
+                   (anychar-dispatch))
+                  ((#\? #\K)         ; Indirection (is "~K" in T-Scheme)
+                   (cond
+                    ((memq modifier '(colon colon-at))
+                     (format:error "illegal modifier in ~~?"))
+                    ((eq? modifier 'at)
+                     (let* ((frmt (next-arg))
+                            (args (rest-args)))
+                       (add-arg-pos (format:format-work frmt args))))
+                    (else
+                     (let* ((frmt (next-arg))
+                            (args (next-arg)))
+                       (format:format-work frmt args))))
+                   (anychar-dispatch))
+                  ((#\!)                ; Flush output
+                   (set! flush-output? #t)
+                   (anychar-dispatch))
+                  ((#\newline)		; Continuation lines
+                   (if (eq? modifier 'at)
+                       (format:out-char #\newline))
+                   (if (< format:pos format-string-len)
+                       (do ((ch (peek-next-char) (peek-next-char)))
+                           ((or (not (char-whitespace? ch))
+                                (= format:pos (- format-string-len 1))))
+                         (if (eq? modifier 'colon)
+                             (format:out-char (next-char))
+                             (next-char))))
+                   (anychar-dispatch))
+                  ((#\*)                ; Argument jumping
+                   (case modifier
+                     ((colon)		; jump backwards
+                      (if (one-positive-integer? params)
+                          (do ((i 0 (+ i 1)))
+                              ((= i (car params)))
+                            (prev-arg))
+                          (prev-arg)))
+                     ((at)              ; jump absolute
+                      (set! arg-pos (if (one-positive-integer? params)
+                                        (car params) 0)))
+                     ((colon-at)
+                      (format:error "illegal modifier `:@' in ~~* directive"))
+                     (else              ; jump forward
+                      (if (one-positive-integer? params)
+                          (do ((i 0 (+ i 1)))
+                              ((= i (car params)))
+                            (next-arg))
+                          (next-arg))))
+                   (anychar-dispatch))
+                  ((#\()                ; Case conversion begin
+                   (set! format:case-conversion
+                         (case modifier
+                           ((at) string-capitalize-first)
+                           ((colon) string-capitalize)
+                           ((colon-at) string-upcase)
+                           (else string-downcase)))
+                   (anychar-dispatch))
+                  ((#\))                ; Case conversion end
+                   (if (not format:case-conversion)
+                       (format:error "missing ~~("))
+                   (set! format:case-conversion #f)
+                   (anychar-dispatch))
+                  ((#\[)                ; Conditional begin
+                   (set! conditional-nest (+ conditional-nest 1))
+                   (cond
+                    ((= conditional-nest 1)
+                     (set! clause-pos format:pos)
+                     (set! clause-default #f)
+                     (set! clauses '())
+                     (set! conditional-type
+                           (case modifier
+                             ((at) 'if-then)
+                             ((colon) 'if-else-then)
+                             ((colon-at) (format:error "illegal modifier in ~~["))
+                             (else 'num-case)))
+                     (set! conditional-arg
+                           (if (one-positive-integer? params)
+                               (car params)
+                               (next-arg)))))
+                   (anychar-dispatch))
+                  ((#\;)                ; Conditional separator
+                   (if (zero? conditional-nest)
+                       (format:error "~~; not in ~~[~~] conditional"))
+                   (if (not (null? params))
+                       (format:error "no parameter allowed in ~~;"))
+                   (if (= conditional-nest 1)
+                       (let ((clause-str
+                              (cond
+                               ((eq? modifier 'colon)
+                                (set! clause-default #t)
+                                (substring format-string clause-pos 
+                                           (- format:pos 3)))
+                               ((memq modifier '(at colon-at))
+                                (format:error "illegal modifier in ~~;"))
+                               (else
+                                (substring format-string clause-pos
+                                           (- format:pos 2))))))
+                         (set! clauses (append clauses (list clause-str)))
+                         (set! clause-pos format:pos)))
+                   (anychar-dispatch))
+                  ((#\])                ; Conditional end
+                   (if (zero? conditional-nest) (format:error "missing ~~["))
+                   (set! conditional-nest (- conditional-nest 1))
+                   (if modifier
+                       (format:error "no modifier allowed in ~~]"))
+                   (if (not (null? params))
+                       (format:error "no parameter allowed in ~~]"))
+                   (cond
+                    ((zero? conditional-nest)
+                     (let ((clause-str (substring format-string clause-pos
+                                                  (- format:pos 2))))
+                       (if clause-default
+                           (set! clause-default clause-str)
+                           (set! clauses (append clauses (list clause-str)))))
+                     (case conditional-type
+                       ((if-then)
+                        (if conditional-arg
+                            (format:format-work (car clauses)
+                                                (list conditional-arg))))
+                       ((if-else-then)
+                        (add-arg-pos
+                         (format:format-work (if conditional-arg
+                                                 (cadr clauses)
+                                                 (car clauses))
+                                             (rest-args))))
+                       ((num-case)
+                        (if (or (not (integer? conditional-arg))
+                                (< conditional-arg 0))
+                            (format:error "argument not a positive integer"))
+                        (if (not (and (>= conditional-arg (length clauses))
+                                      (not clause-default)))
+                            (add-arg-pos
+                             (format:format-work
+                              (if (>= conditional-arg (length clauses))
+                                  clause-default
+                                  (list-ref clauses conditional-arg))
+                              (rest-args))))))))
+                   (anychar-dispatch))
+                  ((#\{)                ; Iteration begin
+                   (set! iteration-nest (+ iteration-nest 1))
+                   (cond
+                    ((= iteration-nest 1)
+                     (set! iteration-pos format:pos)
+                     (set! iteration-type
+                           (case modifier
+                             ((at) 'rest-args)
+                             ((colon) 'sublists)
+                             ((colon-at) 'rest-sublists)
+                             (else 'list)))
+                     (set! max-iterations (if (one-positive-integer? params)
+                                              (car params) #f))))
+                   (anychar-dispatch))
+                  ((#\})                ; Iteration end
+                   (if (zero? iteration-nest) (format:error "missing ~~{"))
+                   (set! iteration-nest (- iteration-nest 1))
+                   (case modifier
+                     ((colon)
+                      (if (not max-iterations) (set! max-iterations 1)))
+                     ((colon-at at) (format:error "illegal modifier")))
+                   (if (not (null? params))
+                       (format:error "no parameters allowed in ~~}"))
+                   (if (zero? iteration-nest)
+                       (let ((iteration-str
+                              (substring format-string iteration-pos
+                                         (- format:pos (if modifier 3 2)))))
+                         (if (string=? iteration-str "")
+                             (set! iteration-str (next-arg)))
+                         (case iteration-type
+                           ((list)
+                            (let ((args (next-arg))
+                                  (args-len 0))
+                              (if (not (list? args))
+                                  (format:error "expected a list argument"))
+                              (set! args-len (length args))
+                              (do ((arg-pos 0 (+ arg-pos
+                                                 (format:format-work
+                                                  iteration-str
+                                                  (list-tail args arg-pos))))
+                                   (i 0 (+ i 1)))
+                                  ((or (>= arg-pos args-len)
+                                       (and max-iterations
+                                            (>= i max-iterations)))))))
+                           ((sublists)
+                            (let ((args (next-arg))
+                                  (args-len 0))
+                              (if (not (list? args))
+                                  (format:error "expected a list argument"))
+                              (set! args-len (length args))
+                              (do ((arg-pos 0 (+ arg-pos 1)))
+                                  ((or (>= arg-pos args-len)
+                                       (and max-iterations
+                                            (>= arg-pos max-iterations))))
+                                (let ((sublist (list-ref args arg-pos)))
+                                  (if (not (list? sublist))
+                                      (format:error
+                                       "expected a list of lists argument"))
+                                  (format:format-work iteration-str sublist)))))
+                           ((rest-args)
+                            (let* ((args (rest-args))
+                                   (args-len (length args))
+                                   (usedup-args
+                                    (do ((arg-pos 0 (+ arg-pos
+                                                       (format:format-work
+                                                        iteration-str
+                                                        (list-tail
+                                                         args arg-pos))))
+                                         (i 0 (+ i 1)))
+                                        ((or (>= arg-pos args-len)
+                                             (and max-iterations
+                                                  (>= i max-iterations)))
+                                         arg-pos))))
+                              (add-arg-pos usedup-args)))
+                           ((rest-sublists)
+                            (let* ((args (rest-args))
+                                   (args-len (length args))
+                                   (usedup-args
+                                    (do ((arg-pos 0 (+ arg-pos 1)))
+                                        ((or (>= arg-pos args-len)
+                                             (and max-iterations
+                                                  (>= arg-pos max-iterations)))
+                                         arg-pos)
+                                      (let ((sublist (list-ref args arg-pos)))
+                                        (if (not (list? sublist))
+                                            (format:error "expected list arguments"))
+                                        (format:format-work iteration-str sublist)))))
+                              (add-arg-pos usedup-args)))
+                           (else (format:error "internal error in ~~}")))))
+                   (anychar-dispatch))
+                  ((#\^)                ; Up and out
+                   (let* ((continue
+                           (cond
+                            ((not (null? params))
+                             (not
+                              (case (length params)
+                                ((1) (zero? (car params)))
+                                ((2) (= (list-ref params 0) (list-ref params 1)))
+                                ((3) (<= (list-ref params 0)
+                                         (list-ref params 1)
+                                         (list-ref params 2)))
+                                (else (format:error "too much parameters")))))
+                            (format:case-conversion ; if conversion stop conversion
+                             (set! format:case-conversion string-copy) #t)
+                            ((= iteration-nest 1) #t)
+                            ((= conditional-nest 1) #t)
+                            ((>= arg-pos arg-len)
+                             (set! format:pos format-string-len) #f)
+                            (else #t))))
+                     (if continue
+                         (anychar-dispatch))))
+
+                  ;; format directive modifiers and parameters
+
+                  ((#\@)                ; `@' modifier
+                   (if (memq modifier '(at colon-at))
+                       (format:error "double `@' modifier"))
+                   (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
+                   (tilde-dispatch))
+                  ((#\:)                ; `:' modifier
+                   (if (memq modifier '(colon colon-at))
+                       (format:error "double `:' modifier"))
+                   (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
+                   (tilde-dispatch))
+                  ((#\')                ; Character parameter
+                   (if modifier (format:error "misplaced modifier"))
+                   (set! params (append params (list (char->integer (next-char)))))
+                   (set! param-value-found #t)
+                   (tilde-dispatch))
+                  ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
+                   (if modifier (format:error "misplaced modifier"))
+                   (let ((num-str-beg (- format:pos 1))
+                         (num-str-end format:pos))
+                     (do ((ch (peek-next-char) (peek-next-char)))
+                         ((not (char-numeric? ch)))
+                       (next-char)
+                       (set! num-str-end (+ 1 num-str-end)))
+                     (set! params
+                           (append params
+                                   (list (string->number
+                                          (substring format-string
+                                                     num-str-beg
+                                                     num-str-end))))))
+                   (set! param-value-found #t)
+                   (tilde-dispatch))
+                  ((#\V)           ; Variable parameter from next argum.
+                   (if modifier (format:error "misplaced modifier"))
+                   (set! params (append params (list (next-arg))))
+                   (set! param-value-found #t)
+                   (tilde-dispatch))
+                  ((#\#)         ; Parameter is number of remaining args
+                   (if param-value-found (format:error "misplaced '#'"))
+                   (if modifier (format:error "misplaced modifier"))
+                   (set! params (append params (list (length (rest-args)))))
+                   (set! param-value-found #t)
+                   (tilde-dispatch))
+                  ((#\,)                ; Parameter separators
+                   (if modifier (format:error "misplaced modifier"))
+                   (if (not param-value-found)
+                       (set! params (append params '(#f)))) ; append empty paramtr
+                   (set! param-value-found #f)
+                   (tilde-dispatch))
+                  ((#\Q)                ; Inquiry messages
+                   (if (eq? modifier 'colon)
+                       (format:out-str format:version)
+                       (let ((nl (string #\newline)))
+                         (format:out-str
+                          (string-append
+                           "SLIB Common LISP format version " format:version nl
+                           "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
+                           "  please send bug reports to `lutzeb@cs.tu-berlin.de'"
+                           nl))))
+                   (anychar-dispatch))
+                  (else                 ; Unknown tilde directive
+                   (format:error "unknown control character `~c'"
+                                 (string-ref format-string (- format:pos 1))))))
+               (else (anychar-dispatch)))))) ; in case of conditional
+
+        (set! format:pos 0)
+        (set! format:arg-pos 0)
+        (anychar-dispatch)              ; start the formatting
+        (set! format:pos recursive-pos-save)
+        arg-pos))                 ; return the position in the arg. list
+
+    ;; when format:read-proof is true, format:obj->str will wrap
+    ;; result strings starting with "#<" in an extra pair of double
+    ;; quotes.
+       
+    (define format:read-proof #f)
+
+    ;; format:obj->str returns a R4RS representation as a string of
+    ;; an arbitrary scheme object.
+
+    (define (format:obj->str obj slashify)
+      (let ((res (if slashify
+                     (object->string obj)
+                     (call-with-output-string (lambda (p) (display obj p))))))
+        (if (and format:read-proof (string-prefix? "#<" res))
+            (object->string res)
+            res)))
+
+    (define format:space-ch (char->integer #\space))
+    (define format:zero-ch (char->integer #\0))
+
+    (define (format:par pars length index default name)
+      (if (> length index)
+          (let ((par (list-ref pars index)))
+            (if par
+                (if name
+                    (if (< par 0)
+                        (format:error 
+                         "~s parameter must be a positive integer" name)
+                        par)
+                    par)
+                default))
+          default))
+
+    (define (format:out-obj-padded pad-left obj slashify pars)
+      (if (null? pars)
+          (format:out-str (format:obj->str obj slashify))
+          (let ((l (length pars)))
+            (let ((mincol (format:par pars l 0 0 "mincol"))
+                  (colinc (format:par pars l 1 1 "colinc"))
+                  (minpad (format:par pars l 2 0 "minpad"))
+                  (padchar (integer->char
+                            (format:par pars l 3 format:space-ch #f)))
+                  (objstr (format:obj->str obj slashify)))
+              (if (not pad-left)
+                  (format:out-str objstr))
+              (do ((objstr-len (string-length objstr))
+                   (i minpad (+ i colinc)))
+                  ((>= (+ objstr-len i) mincol)
+                   (format:out-fill i padchar)))
+              (if pad-left
+                  (format:out-str objstr))))))
+
+    (define (format:out-num-padded modifier number pars radix)
+      (if (not (integer? number)) (format:error "argument not an integer"))
+      (let ((numstr (number->string number radix)))
+        (if (and (null? pars) (not modifier))
+            (format:out-str numstr)
+            (let ((l (length pars))
+                  (numstr-len (string-length numstr)))
+              (let ((mincol (format:par pars l 0 #f "mincol"))
+                    (padchar (integer->char
+                              (format:par pars l 1 format:space-ch #f)))
+                    (commachar (integer->char
+                                (format:par pars l 2 (char->integer #\,) #f)))
+                    (commawidth (format:par pars l 3 3 "commawidth")))
+                (if mincol
+                    (let ((numlen numstr-len)) ; calc. the output len of number
+                      (if (and (memq modifier '(at colon-at)) (>= number 0))
+                          (set! numlen (+ numlen 1)))
+                      (if (memq modifier '(colon colon-at))
+                          (set! numlen (+ (quotient (- numstr-len 
+                                                       (if (< number 0) 2 1))
+                                                    commawidth)
+                                          numlen)))
+                      (if (> mincol numlen)
+                          (format:out-fill (- mincol numlen) padchar))))
+                (if (and (memq modifier '(at colon-at))
+                         (>= number 0))
+                    (format:out-char #\+))
+                (if (memq modifier '(colon colon-at)) ; insert comma character
+                    (let ((start (remainder numstr-len commawidth))
+                          (ns (if (< number 0) 1 0)))
+                      (format:out-substr numstr 0 start)
+                      (do ((i start (+ i commawidth)))
+                          ((>= i numstr-len))
+                        (if (> i ns)
+                            (format:out-char commachar))
+                        (format:out-substr numstr i (+ i commawidth))))
+                    (format:out-str numstr)))))))
+
+    (define (format:tabulate modifier pars)
+      (let ((l (length pars)))
+        (let ((colnum (format:par pars l 0 1 "colnum"))
+              (colinc (format:par pars l 1 1 "colinc"))
+              (padch (integer->char (format:par pars l 2 format:space-ch #f))))
+          (case modifier
+            ((colon colon-at)
+             (format:error "unsupported modifier for ~~t"))
+            ((at)                       ; relative tabulation
+             (format:out-fill
+              (if (= colinc 0)
+                  colnum                ; colnum = colrel
+                  (do ((c 0 (+ c colinc))
+                       (col (+ output-col colnum)))
+                      ((>= c col)
+                       (- c output-col))))
+              padch))
+            (else                       ; absolute tabulation
+             (format:out-fill
+              (cond
+               ((< output-col colnum)
+                (- colnum output-col))
+               ((= colinc 0)
+                0)
+               (else
+                (do ((c colnum (+ c colinc)))
+                    ((>= c output-col)
+                     (- c output-col)))))
+              padch))))))
+
+
+    ;; roman numerals (from dorai@cs.rice.edu).
+
+    (define format:roman-alist
+      '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
+        (10 #\X) (5 #\V) (1 #\I)))
+
+    (define format:roman-boundary-values
+      '(100 100 10 10 1 1 #f))
+
+    (define (format:num->old-roman n)
+      (if (and (integer? n) (>= n 1))
+          (let loop ((n n)
+                     (romans format:roman-alist)
+                     (s '()))
+            (if (null? romans) (list->string (reverse s))
+                (let ((roman-val (caar romans))
+                      (roman-dgt (cadar romans)))
+                  (do ((q (quotient n roman-val) (- q 1))
+                       (s s (cons roman-dgt s)))
+                      ((= q 0)
+                       (loop (remainder n roman-val)
+                             (cdr romans) s))))))
+          (format:error "only positive integers can be romanized")))
+
+    (define (format:num->roman n)
+      (if (and (integer? n) (> n 0))
+          (let loop ((n n)
+                     (romans format:roman-alist)
+                     (boundaries format:roman-boundary-values)
+                     (s '()))
+            (if (null? romans)
+                (list->string (reverse s))
+                (let ((roman-val (caar romans))
+                      (roman-dgt (cadar romans))
+                      (bdry (car boundaries)))
+                  (let loop2 ((q (quotient n roman-val))
+                              (r (remainder n roman-val))
+                              (s s))
+                    (if (= q 0)
+                        (if (and bdry (>= r (- roman-val bdry)))
+                            (loop (remainder r bdry) (cdr romans)
+                                  (cdr boundaries)
+                                  (cons roman-dgt
+                                        (append
+                                         (cdr (assv bdry romans))
+                                         s)))
+                            (loop r (cdr romans) (cdr boundaries) s))
+                        (loop2 (- q 1) r (cons roman-dgt s)))))))
+          (format:error "only positive integers can be romanized")))
+
+    ;; cardinals & ordinals (from dorai@cs.rice.edu)
+
+    (define format:cardinal-ones-list
+      '(#f "one" "two" "three" "four" "five"
+           "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
+           "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
+           "nineteen"))
+
+    (define format:cardinal-tens-list
+      '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
+           "ninety"))
+
+    (define (format:num->cardinal999 n)
+      ;; this procedure is inspired by the Bruno Haible's CLisp
+      ;; function format-small-cardinal, which converts numbers
+      ;; in the range 1 to 999, and is used for converting each
+      ;; thousand-block in a larger number
+      (let* ((hundreds (quotient n 100))
+             (tens+ones (remainder n 100))
+             (tens (quotient tens+ones 10))
+             (ones (remainder tens+ones 10)))
+        (append
+         (if (> hundreds 0)
+             (append
+              (string->list
+               (list-ref format:cardinal-ones-list hundreds))
+              (string->list" hundred")
+              (if (> tens+ones 0) '(#\space) '()))
+             '())
+         (if (< tens+ones 20)
+             (if (> tens+ones 0)
+                 (string->list
+                  (list-ref format:cardinal-ones-list tens+ones))
+                 '())
+             (append
+              (string->list
+               (list-ref format:cardinal-tens-list tens))
+              (if (> ones 0)
+                  (cons #\-
+                        (string->list
+                         (list-ref format:cardinal-ones-list ones)))
+                  '()))))))
+
+    (define format:cardinal-thousand-block-list
+      '("" " thousand" " million" " billion" " trillion" " quadrillion"
+        " quintillion" " sextillion" " septillion" " octillion" " nonillion"
+        " decillion" " undecillion" " duodecillion" " tredecillion"
+        " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
+        " octodecillion" " novemdecillion" " vigintillion"))
+
+    (define (format:num->cardinal n)
+      (cond ((not (integer? n))
+             (format:error
+              "only integers can be converted to English cardinals"))
+            ((= n 0) "zero")
+            ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
+            (else
+             (let ((power3-word-limit
+                    (length format:cardinal-thousand-block-list)))
+               (let loop ((n n)
+                          (power3 0)
+                          (s '()))
+                 (if (= n 0)
+                     (list->string s)
+                     (let ((n-before-block (quotient n 1000))
+                           (n-after-block (remainder n 1000)))
+                       (loop n-before-block
+                             (+ power3 1)
+                             (if (> n-after-block 0)
+                                 (append
+                                  (if (> n-before-block 0)
+                                      (string->list ", ") '())
+                                  (format:num->cardinal999 n-after-block)
+                                  (if (< power3 power3-word-limit)
+                                      (string->list
+                                       (list-ref
+                                        format:cardinal-thousand-block-list
+                                        power3))
+                                      (append
+                                       (string->list " times ten to the ")
+                                       (string->list
+                                        (format:num->ordinal
+                                         (* power3 3)))
+                                       (string->list " power")))
+                                  s)
+                                 s)))))))))
+
+    (define format:ordinal-ones-list
+      '(#f "first" "second" "third" "fourth" "fifth"
+           "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
+           "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
+           "eighteenth" "nineteenth"))
+
+    (define format:ordinal-tens-list
+      '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
+           "seventieth" "eightieth" "ninetieth"))
+
+    (define (format:num->ordinal n)
+      (cond ((not (integer? n))
+             (format:error
+              "only integers can be converted to English ordinals"))
+            ((= n 0) "zeroth")
+            ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
+            (else
+             (let ((hundreds (quotient n 100))
+                   (tens+ones (remainder n 100)))
+               (string-append
+                (if (> hundreds 0)
+                    (string-append
+                     (format:num->cardinal (* hundreds 100))
+                     (if (= tens+ones 0) "th" " "))
+                    "")
+                (if (= tens+ones 0) ""
+                    (if (< tens+ones 20)
+                        (list-ref format:ordinal-ones-list tens+ones)
+                        (let ((tens (quotient tens+ones 10))
+                              (ones (remainder tens+ones 10)))
+                          (if (= ones 0)
+                              (list-ref format:ordinal-tens-list tens)
+                              (string-append
+                               (list-ref format:cardinal-tens-list tens)
+                               "-"
+                               (list-ref format:ordinal-ones-list ones))))
+                        )))))))
+
+    ;; format inf and nan.
+
+    (define (format:out-inf-nan number width digits edigits overch padch)
+      ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
+      ;; "+nan.0", suitably justified in their field.  We insist on
+      ;; printing this exact form so that the numbers can be read back in.
+      (let* ((str (number->string number))
+             (len (string-length str))
+             (dot (string-index str #\.))
+             (digits (+ (or digits 0)
+                        (if edigits (+ edigits 2) 0))))
+        (if (and width overch (< width len))
+            (format:out-fill width (integer->char overch))
+            (let* ((leftpad (if width
+                                (max (- width (max len (+ dot 1 digits))) 0)
+                                0))
+                   (rightpad (if width
+                                 (max (- width leftpad len) 0)
+                                 0))
+                   (padch (integer->char (or padch format:space-ch)))) 
+              (format:out-fill leftpad padch)
+              (format:out-str str)
+              (format:out-fill rightpad padch)))))
+
+    ;; format fixed flonums (~F)
+
+    (define (format:out-fixed modifier number pars)
+      (if (not (or (number? number) (string? number)))
+          (format:error "argument is not a number or a number string"))
+
+      (let ((l (length pars)))
+        (let ((width (format:par pars l 0 #f "width"))
+              (digits (format:par pars l 1 #f "digits"))
+              (scale (format:par pars l 2 0 #f))
+              (overch (format:par pars l 3 #f #f))
+              (padch (format:par pars l 4 format:space-ch #f)))
+
+          (cond
+           ((and (number? number)
+                 (or (inf? number) (nan? number)))
+            (format:out-inf-nan number width digits #f overch padch))
+
+           (digits
+            (format:parse-float number #t scale)
+            (if (<= (- format:fn-len format:fn-dot) digits)
+                (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+                (format:fn-round digits))
+            (if width
+                (let ((numlen (+ format:fn-len 1)))
+                  (if (or (not format:fn-pos?) (eq? modifier 'at))
+                      (set! numlen (+ numlen 1)))
+                  (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+                      (set! numlen (+ numlen 1)))
+                  (if (< numlen width)
+                      (format:out-fill (- width numlen) (integer->char padch)))
+                  (if (and overch (> numlen width))
+                      (format:out-fill width (integer->char overch))
+                      (format:fn-out modifier (> width (+ digits 1)))))
+                (format:fn-out modifier #t)))
+
+           (else
+            (format:parse-float number #t scale)
+            (format:fn-strip)
+            (if width
+                (let ((numlen (+ format:fn-len 1)))
+                  (if (or (not format:fn-pos?) (eq? modifier 'at))
+                      (set! numlen (+ numlen 1)))
+                  (if (= format:fn-dot 0)
+                      (set! numlen (+ numlen 1)))
+                  (if (< numlen width)
+                      (format:out-fill (- width numlen) (integer->char padch)))
+                  (if (> numlen width)	; adjust precision if possible
+                      (let ((dot-index (- numlen
+                                          (- format:fn-len format:fn-dot))))
+                        (if (> dot-index width)
+                            (if overch ; numstr too big for required width
+                                (format:out-fill width (integer->char overch))
+                                (format:fn-out modifier #t))
+                            (begin
+                              (format:fn-round (- width dot-index))
+                              (format:fn-out modifier #t))))
+                      (format:fn-out modifier #t)))
+                (format:fn-out modifier #t)))))))
+
+    ;; format exponential flonums (~E)
+
+    (define (format:out-expon modifier number pars)
+      (if (not (or (number? number) (string? number)))
+          (format:error "argument is not a number"))
+
+      (let ((l (length pars)))
+        (let ((width (format:par pars l 0 #f "width"))
+              (digits (format:par pars l 1 #f "digits"))
+              (edigits (format:par pars l 2 #f "exponent digits"))
+              (scale (format:par pars l 3 1 #f))
+              (overch (format:par pars l 4 #f #f))
+              (padch (format:par pars l 5 format:space-ch #f))
+              (expch (format:par pars l 6 #f #f)))
+	      
+          (cond
+           ((and (number? number)
+                 (or (inf? number) (nan? number)))
+            (format:out-inf-nan number width digits edigits overch padch))
+
+           (digits                      ; fixed precision
+
+            (let ((digits (if (> scale 0)
+                              (if (< scale (+ digits 2))
+                                  (+ (- digits scale) 1)
+                                  0)
+                              digits)))
+              (format:parse-float number #f scale)
+              (if (<= (- format:fn-len format:fn-dot) digits)
+                  (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+                  (format:fn-round digits))
+              (if width
+                  (if (and edigits overch (> format:en-len edigits))
+                      (format:out-fill width (integer->char overch))
+                      (let ((numlen (+ format:fn-len 3))) ; .E+
+                        (if (or (not format:fn-pos?) (eq? modifier 'at))
+                            (set! numlen (+ numlen 1)))
+                        (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+                            (set! numlen (+ numlen 1)))	
+                        (set! numlen
+                              (+ numlen 
+                                 (if (and edigits (>= edigits format:en-len))
+                                     edigits 
+                                     format:en-len)))
+                        (if (< numlen width)
+                            (format:out-fill (- width numlen)
+                                             (integer->char padch)))
+                        (if (and overch (> numlen width))
+                            (format:out-fill width (integer->char overch))
+                            (begin
+                              (format:fn-out modifier (> width (- numlen 1)))
+                              (format:en-out edigits expch)))))
+                  (begin
+                    (format:fn-out modifier #t)
+                    (format:en-out edigits expch)))))
+
+           (else
+            (format:parse-float number #f scale)
+            (format:fn-strip)
+            (if width
+                (if (and edigits overch (> format:en-len edigits))
+                    (format:out-fill width (integer->char overch))
+                    (let ((numlen (+ format:fn-len 3))) ; .E+
+                      (if (or (not format:fn-pos?) (eq? modifier 'at))
+                          (set! numlen (+ numlen 1)))
+                      (if (= format:fn-dot 0)
+                          (set! numlen (+ numlen 1)))
+                      (set! numlen
+                            (+ numlen
+                               (if (and edigits (>= edigits format:en-len))
+                                   edigits 
+                                   format:en-len)))
+                      (if (< numlen width)
+                          (format:out-fill (- width numlen)
+                                           (integer->char padch)))
+                      (if (> numlen width) ; adjust precision if possible
+                          (let ((f (- format:fn-len format:fn-dot))) ; fract len
+                            (if (> (- numlen f) width)
+                                (if overch ; numstr too big for required width
+                                    (format:out-fill width 
+                                                     (integer->char overch))
+                                    (begin
+                                      (format:fn-out modifier #t)
+                                      (format:en-out edigits expch)))
+                                (begin
+                                  (format:fn-round (+ (- f numlen) width))
+                                  (format:fn-out modifier #t)
+                                  (format:en-out edigits expch))))
+                          (begin
+                            (format:fn-out modifier #t)
+                            (format:en-out edigits expch)))))
+                (begin
+                  (format:fn-out modifier #t)
+                  (format:en-out edigits expch))))))))
+       
+    ;; format general flonums (~G)
+
+    (define (format:out-general modifier number pars)
+      (if (not (or (number? number) (string? number)))
+          (format:error "argument is not a number or a number string"))
+
+      (let ((l (length pars)))
+        (let ((width (if (> l 0) (list-ref pars 0) #f))
+              (digits (if (> l 1) (list-ref pars 1) #f))
+              (edigits (if (> l 2) (list-ref pars 2) #f))
+              (overch (if (> l 4) (list-ref pars 4) #f))
+              (padch (if (> l 5) (list-ref pars 5) #f)))
+          (cond
+           ((and (number? number)
+                 (or (inf? number) (nan? number)))
+            ;; FIXME: this isn't right.
+            (format:out-inf-nan number width digits edigits overch padch))
+           (else
+            (format:parse-float number #t 0)
+            (format:fn-strip)
+            (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
+                   (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
+                   (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
+                          (- (format:fn-zlead))
+                          format:fn-dot))
+                   (d (if digits
+                          digits
+                          (max format:fn-len (min n 7)))) ; q = format:fn-len
+                   (dd (- d n)))
+              (if (<= 0 dd d)
+                  (begin
+                    (format:out-fixed modifier number (list ww dd #f overch padch))
+                    (format:out-fill ee #\space)) ;~@T not implemented yet
+                  (format:out-expon modifier number pars))))))))
+
+    ;; format dollar flonums (~$)
+
+    (define (format:out-dollar modifier number pars)
+      (if (not (or (number? number) (string? number)))
+          (format:error "argument is not a number or a number string"))
+
+      (let ((l (length pars)))
+        (let ((digits (format:par pars l 0 2 "digits"))
+              (mindig (format:par pars l 1 1 "mindig"))
+              (width (format:par pars l 2 0 "width"))
+              (padch (format:par pars l 3 format:space-ch #f)))
+
+          (cond
+           ((and (number? number)
+                 (or (inf? number) (nan? number)))
+            (format:out-inf-nan number width digits #f #f padch))
+
+           (else
+            (format:parse-float number #t 0)
+            (if (<= (- format:fn-len format:fn-dot) digits)
+                (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+                (format:fn-round digits))
+            (let ((numlen (+ format:fn-len 1)))
+              (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
+                  (set! numlen (+ numlen 1)))
+              (if (and mindig (> mindig format:fn-dot))
+                  (set! numlen (+ numlen (- mindig format:fn-dot))))
+              (if (and (= format:fn-dot 0) (not mindig))
+                  (set! numlen (+ numlen 1)))
+              (if (< numlen width)
+                  (case modifier
+                    ((colon)
+                     (if (not format:fn-pos?)
+                         (format:out-char #\-))
+                     (format:out-fill (- width numlen) (integer->char padch)))
+                    ((at)
+                     (format:out-fill (- width numlen) (integer->char padch))
+                     (format:out-char (if format:fn-pos? #\+ #\-)))
+                    ((colon-at)
+                     (format:out-char (if format:fn-pos? #\+ #\-))
+                     (format:out-fill (- width numlen) (integer->char padch)))
+                    (else
+                     (format:out-fill (- width numlen) (integer->char padch))
+                     (if (not format:fn-pos?)
+                         (format:out-char #\-))))
+                  (if format:fn-pos?
+                      (if (memq modifier '(at colon-at)) (format:out-char #\+))
+                      (format:out-char #\-))))
+            (if (and mindig (> mindig format:fn-dot))
+                (format:out-fill (- mindig format:fn-dot) #\0))
+            (if (and (= format:fn-dot 0) (not mindig))
+                (format:out-char #\0))
+            (format:out-substr format:fn-str 0 format:fn-dot)
+            (format:out-char #\.)
+            (format:out-substr format:fn-str format:fn-dot format:fn-len))))))
+
+					; the flonum buffers
+
+    (define format:fn-max 400)          ; max. number of number digits
+    (define format:fn-str (make-string format:fn-max)) ; number buffer
+    (define format:fn-len 0)            ; digit length of number
+    (define format:fn-dot #f)           ; dot position of number
+    (define format:fn-pos? #t)          ; number positive?
+    (define format:en-max 10)           ; max. number of exponent digits
+    (define format:en-str (make-string format:en-max)) ; exponent buffer
+    (define format:en-len 0)            ; digit length of exponent
+    (define format:en-pos? #t)          ; exponent positive?
+
+    (define (format:parse-float num fixed? scale)
+      (let ((num-str (if (string? num)
+                         num
+                         (number->string (exact->inexact num)))))
+        (set! format:fn-pos? #t)
+        (set! format:fn-len 0)
+        (set! format:fn-dot #f)
+        (set! format:en-pos? #t)
+        (set! format:en-len 0)
+        (do ((i 0 (+ i 1))
+             (left-zeros 0)
+             (mantissa? #t)
+             (all-zeros? #t)
+             (num-len (string-length num-str))
+             (c #f))                ; current exam. character in num-str
+            ((= i num-len)
+             (if (not format:fn-dot)
+                 (set! format:fn-dot format:fn-len))
+
+             (if all-zeros?
+                 (begin
+                   (set! left-zeros 0)
+                   (set! format:fn-dot 0)
+                   (set! format:fn-len 1)))
+
+             ;; now format the parsed values according to format's need
+
+             (if fixed?
+
+                 (begin                 ; fixed format m.nnn or .nnn
+                   (if (and (> left-zeros 0) (> format:fn-dot 0))
+                       (if (> format:fn-dot left-zeros) 
+                           (begin       ; norm 0{0}nn.mm to nn.mm
+                             (format:fn-shiftleft left-zeros)
+                             (set! format:fn-dot (- format:fn-dot left-zeros))
+                             (set! left-zeros 0))
+                           (begin       ; normalize 0{0}.nnn to .nnn
+                             (format:fn-shiftleft format:fn-dot)
+                             (set! left-zeros (- left-zeros format:fn-dot))
+                             (set! format:fn-dot 0))))
+                   (if (or (not (= scale 0)) (> format:en-len 0))
+                       (let ((shift (+ scale (format:en-int))))
+                         (cond
+                          (all-zeros? #t)
+                          ((> (+ format:fn-dot shift) format:fn-len)
+                           (format:fn-zfill
+                            #f (- shift (- format:fn-len format:fn-dot)))
+                           (set! format:fn-dot format:fn-len))
+                          ((< (+ format:fn-dot shift) 0)
+                           (format:fn-zfill #t (- (- shift) format:fn-dot))
+                           (set! format:fn-dot 0))
+                          (else
+                           (if (> left-zeros 0)
+                               (if (<= left-zeros shift) ; shift always > 0 here
+                                   (format:fn-shiftleft shift) ; shift out 0s
+                                   (begin
+                                     (format:fn-shiftleft left-zeros)
+                                     (set! format:fn-dot (- shift left-zeros))))
+                               (set! format:fn-dot (+ format:fn-dot shift))))))))
+
+                 (let ((negexp          ; expon format m.nnnEee
+                        (if (> left-zeros 0)
+                            (- left-zeros format:fn-dot -1)
+                            (if (= format:fn-dot 0) 1 0))))
+                   (if (> left-zeros 0)
+                       (begin           ; normalize 0{0}.nnn to n.nn
+                         (format:fn-shiftleft left-zeros)
+                         (set! format:fn-dot 1))
+                       (if (= format:fn-dot 0)
+                           (set! format:fn-dot 1)))
+                   (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
+                                     negexp))
+                   (cond 
+                    (all-zeros?
+                     (format:en-set 0)
+                     (set! format:fn-dot 1))
+                    ((< scale 0)        ; leading zero
+                     (format:fn-zfill #t (- scale))
+                     (set! format:fn-dot 0))
+                    ((> scale format:fn-dot)
+                     (format:fn-zfill #f (- scale format:fn-dot))
+                     (set! format:fn-dot scale))
+                    (else
+                     (set! format:fn-dot scale)))))
+             #t)
+
+          ;; do body      
+          (set! c (string-ref num-str i)) ; parse the output of number->string
+          (cond                         ; which can be any valid number
+           ((char-numeric? c)           ; representation of R4RS except 
+            (if mantissa?               ; complex numbers
+                (begin
+                  (if (char=? c #\0)
+                      (if all-zeros?
+                          (set! left-zeros (+ left-zeros 1)))
+                      (begin
+                        (set! all-zeros? #f)))
+                  (string-set! format:fn-str format:fn-len c)
+                  (set! format:fn-len (+ format:fn-len 1)))
+                (begin
+                  (string-set! format:en-str format:en-len c)
+                  (set! format:en-len (+ format:en-len 1)))))
+           ((or (char=? c #\-) (char=? c #\+))
+            (if mantissa?
+                (set! format:fn-pos? (char=? c #\+))
+                (set! format:en-pos? (char=? c #\+))))
+           ((char=? c #\.)
+            (set! format:fn-dot format:fn-len))
+           ((char=? c #\e)
+            (set! mantissa? #f))
+           ((char=? c #\E)
+            (set! mantissa? #f))
+           ((char-whitespace? c) #t)
+           ((char=? c #\d) #t)          ; decimal radix prefix
+           ((char=? c #\#) #t)
+           (else
+            (format:error "illegal character `~c' in number->string" c))))))
+
+    (define (format:en-int)         ; convert exponent string to integer
+      (if (= format:en-len 0)
+          0
+          (do ((i 0 (+ i 1))
+               (n 0))
+              ((= i format:en-len) 
+               (if format:en-pos?
+                   n
+                   (- n)))
+            (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
+                                   format:zero-ch))))))
+
+    (define (format:en-set en)          ; set exponent string number
+      (set! format:en-len 0)
+      (set! format:en-pos? (>= en 0))
+      (let ((en-str (number->string en)))
+        (do ((i 0 (+ i 1))
+             (en-len (string-length en-str))
+             (c #f))
+            ((= i en-len))
+          (set! c (string-ref en-str i))
+          (if (char-numeric? c)
+              (begin
+                (string-set! format:en-str format:en-len c)
+                (set! format:en-len (+ format:en-len 1)))))))
+
+    (define (format:fn-zfill left? n) ; fill current number string with 0s
+      (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
+          (format:error "number is too long to format (enlarge format:fn-max)"))
+      (set! format:fn-len (+ format:fn-len n))
+      (if left?
+          (do ((i format:fn-len (- i 1))) ; fill n 0s to left
+              ((< i 0))
+            (string-set! format:fn-str i
+                         (if (< i n)
+                             #\0
+                             (string-ref format:fn-str (- i n)))))
+          (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
+              ((= i format:fn-len))
+            (string-set! format:fn-str i #\0))))
+
+    (define (format:fn-shiftleft n) ; shift left current number n positions
+      (if (> n format:fn-len)
+          (format:error "internal error in format:fn-shiftleft (~d,~d)"
+                        n format:fn-len))
+      (do ((i n (+ i 1)))
+          ((= i format:fn-len)
+           (set! format:fn-len (- format:fn-len n)))
+        (string-set! format:fn-str (- i n) (string-ref format:fn-str i))))
+
+    (define (format:fn-round digits)    ; round format:fn-str
+      (set! digits (+ digits format:fn-dot))
+      (do ((i digits (- i 1))		; "099",2 -> "10"
+           (c 5))                       ; "023",2 -> "02"
+          ((or (= c 0) (< i 0))         ; "999",2 -> "100"
+           (if (= c 1)			; "005",2 -> "01"
+               (begin			; carry overflow
+                 (set! format:fn-len digits)
+                 (format:fn-zfill #t 1) ; add a 1 before fn-str
+                 (string-set! format:fn-str 0 #\1)
+                 (set! format:fn-dot (+ format:fn-dot 1)))
+               (set! format:fn-len digits)))
+        (set! c (+ (- (char->integer (string-ref format:fn-str i))
+                      format:zero-ch) c))
+        (string-set! format:fn-str i (integer->char
+                                      (if (< c 10) 
+                                          (+ c format:zero-ch)
+                                          (+ (- c 10) format:zero-ch))))
+        (set! c (if (< c 10) 0 1))))
+
+    (define (format:fn-out modifier add-leading-zero?)
+      (if format:fn-pos?
+          (if (eq? modifier 'at) 
+              (format:out-char #\+))
+          (format:out-char #\-))
+      (if (= format:fn-dot 0)
+          (if add-leading-zero?
+              (format:out-char #\0))
+          (format:out-substr format:fn-str 0 format:fn-dot))
+      (format:out-char #\.)
+      (format:out-substr format:fn-str format:fn-dot format:fn-len))
+
+    (define (format:en-out edigits expch)
+      (format:out-char (if expch (integer->char expch) #\E))
+      (format:out-char (if format:en-pos? #\+ #\-))
+      (if edigits 
+          (if (< format:en-len edigits)
+              (format:out-fill (- edigits format:en-len) #\0)))
+      (format:out-substr format:en-str 0 format:en-len))
+
+    (define (format:fn-strip)           ; strip trailing zeros but one
+      (string-set! format:fn-str format:fn-len #\0)
+      (do ((i format:fn-len (- i 1)))
+          ((or (not (char=? (string-ref format:fn-str i) #\0))
+               (<= i format:fn-dot))
+           (set! format:fn-len (+ i 1)))))
+
+    (define (format:fn-zlead)           ; count leading zeros
+      (do ((i 0 (+ i 1)))
+          ((or (= i format:fn-len)
+               (not (char=? (string-ref format:fn-str i) #\0)))
+           (if (= i format:fn-len)      ; found a real zero
+               0
+               i))))
+
+
+;;; some global functions not found in SLIB
+
+    (define (string-capitalize-first str) ; "hello" -> "Hello"
+      (let ((cap-str (string-copy str))   ; "hELLO" -> "Hello"
+            (non-first-alpha #f)          ; "*hello" -> "*Hello"
+            (str-len (string-length str))) ; "hello you" -> "Hello you"
+        (do ((i 0 (+ i 1)))
+            ((= i str-len) cap-str)
+          (let ((c (string-ref str i)))
+            (if (char-alphabetic? c)
+                (if non-first-alpha
+                    (string-set! cap-str i (char-downcase c))
+                    (begin
+                      (set! non-first-alpha #t)
+                      (string-set! cap-str i (char-upcase c)))))))))
+
+    ;; Aborts the program when a formatting error occures. This is a null
+    ;; argument closure to jump to the interpreters toplevel continuation.
+
+    (define (format:abort) (error "error in format"))
+    
+    (let ((arg-pos (format:format-work format-string format-args))
+          (arg-len (length format-args)))
+      (cond
+       ((> arg-pos arg-len)
+        (set! format:arg-pos (+ arg-len 1))
+        (display format:arg-pos)
+        (format:error "~a missing argument~:p" (- arg-pos arg-len)))
+       (else
+        (if flush-output?
+            (force-output port))
+        (if destination
+            #t
+            (let ((str (get-output-string port)))
+              (close-port port)
+              str)))))))
+
+(begin-deprecated
+ (set! format
+       (let ((format format))
+         (case-lambda
+           ((destination format-string . args)
+            (if (string? destination)
+                (begin
+                  (issue-deprecation-warning
+                   "Omitting the destination on a call to format is deprecated."
+                   "Pass #f as the destination, before the format string.")
+                  (apply format #f destination format-string args))
+                (apply format destination format-string args)))
+           ((deprecated-format-string-only)
+            (issue-deprecation-warning
+             "Omitting the destination port on a call to format is deprecated."
+             "Pass #f as the destination port, before the format string.")
+            (format #f deprecated-format-string-only))))))
+
+
+;; Thanks to Shuji Narazaki
+(module-set! the-root-module 'format format)
+;;;; ftw.scm --- file system tree walk
+
+;;;; 	Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014, 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
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Two procedures are provided: `ftw' and `nftw'.
+
+;; NOTE: The following description was adapted from the GNU libc info page, w/
+;; significant modifications for a more "Schemey" interface.  Most noticible
+;; are the inlining of `struct FTW *' parameters `base' and `level' and the
+;; omission of `descriptors' parameters.
+
+;; * Types
+;;
+;;    The X/Open specification defines two procedures to process whole
+;; hierarchies of directories and the contained files.  Both procedures
+;; of this `ftw' family take as one of the arguments a callback procedure
+;; which must be of these types.
+;;
+;;  - Data Type: __ftw_proc_t
+;;           (lambda (filename statinfo flag) ...) => status
+;;
+;;      Type for callback procedures given to the `ftw' procedure.  The
+;;      first parameter is a filename, the second parameter is the
+;;      vector value as returned by calling `stat' on FILENAME.
+;;
+;;      The last parameter is a symbol giving more information about
+;;      FILENAM.  It can have one of the following values:
+;;
+;;     `regular'
+;;           The current item is a normal file or files which do not fit
+;;           into one of the following categories.  This means
+;;           especially special files, sockets etc.
+;;
+;;     `directory'
+;;           The current item is a directory.
+;;
+;;     `invalid-stat'
+;;           The `stat' call to fill the object pointed to by the second
+;;           parameter failed and so the information is invalid.
+;;
+;;     `directory-not-readable'
+;;           The item is a directory which cannot be read.
+;;
+;;     `symlink'
+;;           The item is a symbolic link.  Since symbolic links are
+;;           normally followed seeing this value in a `ftw' callback
+;;           procedure means the referenced file does not exist.  The
+;;           situation for `nftw' is different.
+;;
+;;  - Data Type: __nftw_proc_t
+;;           (lambda (filename statinfo flag base level) ...) => status
+;;
+;;      The first three arguments have the same as for the
+;;      `__ftw_proc_t' type.  A difference is that for the third
+;;      argument some additional values are defined to allow finer
+;;      differentiation:
+;;
+;;     `directory-processed'
+;;           The current item is a directory and all subdirectories have
+;;           already been visited and reported.  This flag is returned
+;;           instead of `directory' if the `depth' flag is given to
+;;           `nftw' (see below).
+;;
+;;     `stale-symlink'
+;;           The current item is a stale symbolic link.  The file it
+;;           points to does not exist.
+;;
+;;      The last two parameters are described below.  They contain
+;;      information to help interpret FILENAME and give some information
+;;      about current state of the traversal of the directory hierarchy.
+;;
+;;     `base'
+;;           The value specifies which part of the filename argument
+;;           given in the first parameter to the callback procedure is
+;;           the name of the file.  The rest of the string is the path
+;;           to locate the file.  This information is especially
+;;           important if the `chdir' flag for `nftw' was set since then
+;;           the current directory is the one the current item is found
+;;           in.
+;;
+;;     `level'
+;;           While processing the directory the procedures tracks how
+;;           many directories have been examined to find the current
+;;           item.  This nesting level is 0 for the item given starting
+;;           item (file or directory) and is incremented by one for each
+;;           entered directory.
+;;
+;; * Procedure: (ftw filename proc . options)
+;;   Do a file system tree walk starting at FILENAME using PROC.
+;;
+;;   The `ftw' procedure calls the callback procedure given in the
+;;   parameter PROC for every item which is found in the directory
+;;   specified by FILENAME and all directories below.  The procedure
+;;   follows symbolic links if necessary but does not process an item
+;;   twice.  If FILENAME names no directory this item is the only
+;;   object reported by calling the callback procedure.
+;;
+;;   The filename given to the callback procedure is constructed by
+;;   taking the FILENAME parameter and appending the names of all
+;;   passed directories and then the local file name.  So the
+;;   callback procedure can use this parameter to access the file.
+;;   Before the callback procedure is called `ftw' calls `stat' for
+;;   this file and passes the information up to the callback
+;;   procedure.  If this `stat' call was not successful the failure is
+;;   indicated by setting the flag argument of the callback procedure
+;;   to `invalid-stat'.  Otherwise the flag is set according to the
+;;   description given in the description of `__ftw_proc_t' above.
+;;
+;;   The callback procedure is expected to return non-#f to indicate
+;;   that no error occurred and the processing should be continued.
+;;   If an error occurred in the callback procedure or the call to
+;;   `ftw' shall return immediately the callback procedure can return
+;;   #f.  This is the only correct way to stop the procedure.  The
+;;   program must not use `throw' or similar techniques to continue
+;;   the program in another place.  [Can we relax this? --ttn]
+;;
+;;   The return value of the `ftw' procedure is #t if all callback
+;;   procedure calls returned #t and all actions performed by the
+;;   `ftw' succeeded.  If some procedure call failed (other than
+;;   calling `stat' on an item) the procedure returns #f.  If a
+;;   callback procedure returns a value other than #t this value is
+;;   returned as the return value of `ftw'.
+;;
+;; * Procedure: (nftw filename proc . control-flags)
+;;   Do a new-style file system tree walk starting at FILENAME using PROC.
+;;   Various optional CONTROL-FLAGS alter the default behavior.
+;;
+;;   The `nftw' procedures works like the `ftw' procedures.  It calls
+;;   the callback procedure PROC for all items it finds in the
+;;   directory FILENAME and below.
+;;
+;;   The differences are that for one the callback procedure is of a
+;;   different type.  It takes also `base' and `level' parameters as
+;;   described above.
+;;
+;;   The second difference is that `nftw' takes additional optional
+;;   arguments which are zero or more of the following symbols:
+;;
+;;   physical'
+;;        While traversing the directory symbolic links are not
+;;        followed.  I.e., if this flag is given symbolic links are
+;;        reported using the `symlink' value for the type parameter
+;;        to the callback procedure.  Please note that if this flag is
+;;        used the appearance of `symlink' in a callback procedure
+;;        does not mean the referenced file does not exist.  To
+;;        indicate this the extra value `stale-symlink' exists.
+;;
+;;   mount'
+;;        The callback procedure is only called for items which are on
+;;        the same mounted file system as the directory given as the
+;;        FILENAME parameter to `nftw'.
+;;
+;;   chdir'
+;;        If this flag is given the current working directory is
+;;        changed to the directory containing the reported object
+;;        before the callback procedure is called.
+;;
+;;   depth'
+;;        If this option is given the procedure visits first all files
+;;        and subdirectories before the callback procedure is called
+;;        for the directory itself (depth-first processing).  This
+;;        also means the type flag given to the callback procedure is
+;;        `directory-processed' and not `directory'.
+;;
+;;   The return value is computed in the same way as for `ftw'.
+;;   `nftw' returns #t if no failure occurred in `nftw' and all
+;;   callback procedure call return values are also #t.  For internal
+;;   errors such as memory problems the error `ftw-error' is thrown.
+;;   If the return value of a callback invocation is not #t this
+;;   very same value is returned.
+
+;;; Code:
+
+(define-module (ice-9 ftw)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 vlist)
+  #\use-module (srfi srfi-1)
+  #\autoload   (ice-9 i18n)   (string-locale<?)
+  #\export (ftw nftw
+            file-system-fold
+            file-system-tree
+            scandir))
+
+(define (directory-files dir)
+  (let ((dir-stream (opendir dir)))
+    (let loop ((new (readdir dir-stream))
+               (acc '()))
+      (if (eof-object? new)
+	  (begin
+	    (closedir dir-stream)
+	    acc)
+          (loop (readdir dir-stream)
+                (if (or (string=? "."  new)             ;;; ignore
+                        (string=? ".." new))            ;;; ignore
+                    acc
+                    (cons new acc)))))))
+
+(define (pathify . nodes)
+  (let loop ((nodes nodes)
+             (result ""))
+    (if (null? nodes)
+        (or (and (string=? "" result) "")
+            (substring result 1 (string-length result)))
+        (loop (cdr nodes) (string-append result "/" (car nodes))))))
+
+(define (abs? filename)
+  (char=? #\/ (string-ref filename 0)))
+
+;; `visited?-proc' returns a test procedure VISITED? which when called as
+;; (VISITED? stat-obj) returns #f the first time a distinct file is seen,
+;; then #t on any subsequent sighting of it.
+;;
+;; stat:dev and stat:ino together uniquely identify a file (see "Attribute
+;; Meanings" in the glibc manual).  Often there'll be just one dev, and
+;; usually there's just a handful mounted, so the strategy here is a small
+;; hash table indexed by dev, containing hash tables indexed by ino.
+;;
+;; It'd be possible to make a pair (dev . ino) and use that as the key to a
+;; single hash table.  It'd use an extra pair for every file visited, but
+;; might be a little faster if it meant less scheme code.
+;;
+(define (visited?-proc size)
+  (let ((dev-hash (make-hash-table 7)))
+    (lambda (s)
+      (and s
+	   (let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
+		 (ino      (stat:ino s)))
+	     (or ino-hash
+		 (begin
+		   (set! ino-hash (make-hash-table size))
+		   (hashv-set! dev-hash (stat:dev s) ino-hash)))
+	     (or (hashv-ref ino-hash ino)
+		 (begin
+		   (hashv-set! ino-hash ino #t)
+		   #f)))))))
+
+(define (stat-dir-readable?-proc uid gid)
+  (let ((uid (getuid))
+        (gid (getgid)))
+    (lambda (s)
+      (let* ((perms (stat:perms s))
+             (perms-bit-set? (lambda (mask)
+                               (not (= 0 (logand mask perms))))))
+        (or (zero? uid)
+            (and (= uid (stat:uid s))
+                 (perms-bit-set? #o400))
+            (and (= gid (stat:gid s))
+                 (perms-bit-set? #o040))
+            (perms-bit-set? #o004))))))
+
+(define (stat&flag-proc dir-readable? . control-flags)
+  (let* ((directory-flag (if (memq 'depth control-flags)
+                             'directory-processed
+                             'directory))
+         (stale-symlink-flag (if (memq 'nftw-style control-flags)
+                                 'stale-symlink
+                                 'symlink))
+         (physical? (memq 'physical control-flags))
+         (easy-flag (lambda (s)
+                      (let ((type (stat:type s)))
+                        (if (eq? 'directory type)
+                            (if (dir-readable? s)
+                                directory-flag
+                                'directory-not-readable)
+                            'regular)))))
+    (lambda (name)
+      (let ((s (false-if-exception (lstat name))))
+        (cond ((not s)
+               (values s 'invalid-stat))
+              ((eq? 'symlink (stat:type s))
+               (let ((s-follow (false-if-exception (stat name))))
+                 (cond ((not s-follow)
+                        (values s stale-symlink-flag))
+                       ((and s-follow physical?)
+                        (values s 'symlink))
+                       ((and s-follow (not physical?))
+                        (values s-follow (easy-flag s-follow))))))
+              (else (values s (easy-flag s))))))))
+
+(define (clean name)
+  (let ((last-char-index (1- (string-length name))))
+    (if (char=? #\/ (string-ref name last-char-index))
+        (substring name 0 last-char-index)
+        name)))
+
+(define (ftw filename proc . options)
+  (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
+                                        (else 211))))
+         (stat&flag (stat&flag-proc
+                     (stat-dir-readable?-proc (getuid) (getgid)))))
+    (letrec ((go (lambda (fullname)
+                   (call-with-values (lambda () (stat&flag fullname))
+                     (lambda (s flag)
+                       (or (visited? s)
+                           (let ((ret (proc fullname s flag))) ; callback
+                             (or (eq? #t ret)
+                                 (throw 'ftw-early-exit ret))
+                             (and (eq? 'directory flag)
+                                  (for-each
+                                   (lambda (child)
+                                     (go (pathify fullname child)))
+                                   (directory-files fullname)))
+                             #t)))))))
+      (catch 'ftw-early-exit
+             (lambda () (go (clean filename)))
+             (lambda (key val) val)))))
+
+(define (nftw filename proc . control-flags)
+  (let* ((od (getcwd))                  ; orig dir
+         (odev (let ((s (false-if-exception (lstat filename))))
+                 (if s (stat:dev s) -1)))
+         (same-dev? (if (memq 'mount control-flags)
+                        (lambda (s) (= (stat:dev s) odev))
+                        (lambda (s) #t)))
+         (base-sub (lambda (name base) (substring name 0 base)))
+         (maybe-cd (if (memq 'chdir control-flags)
+                       (if (abs? filename)
+                           (lambda (fullname base)
+                             (or (= 0 base)
+                                 (chdir (base-sub fullname base))))
+                           (lambda (fullname base)
+                             (chdir
+                              (pathify od (base-sub fullname base)))))
+                       (lambda (fullname base) #t)))
+         (maybe-cd-back (if (memq 'chdir control-flags)
+                            (lambda () (chdir od))
+                            (lambda () #t)))
+         (depth-first? (memq 'depth control-flags))
+         (visited? (visited?-proc
+                    (cond ((memq 'hash-size control-flags) => cadr)
+                          (else 211))))
+         (has-kids? (if depth-first?
+                        (lambda (flag) (eq? flag 'directory-processed))
+                        (lambda (flag) (eq? flag 'directory))))
+         (stat&flag (apply stat&flag-proc
+                           (stat-dir-readable?-proc (getuid) (getgid))
+                           (cons 'nftw-style control-flags))))
+    (letrec ((go (lambda (fullname base level)
+                   (call-with-values (lambda () (stat&flag fullname))
+                     (lambda (s flag)
+                       (letrec ((self (lambda ()
+                                        (maybe-cd fullname base)
+                                        ;; the callback
+                                        (let ((ret (proc fullname s flag
+                                                         base level)))
+                                          (maybe-cd-back)
+                                          (or (eq? #t ret)
+                                              (throw 'nftw-early-exit ret)))))
+                                (kids (lambda ()
+                                        (and (has-kids? flag)
+                                             (for-each
+                                              (lambda (child)
+                                                (go (pathify fullname child)
+                                                    (1+ (string-length
+                                                         fullname))
+                                                    (1+ level)))
+                                              (directory-files fullname))))))
+                         (or (visited? s)
+                             (not (same-dev? s))
+                             (if depth-first?
+                                 (begin (kids) (self))
+                                 (begin (self) (kids)))))))
+                   #t)))
+      (let ((ret (catch 'nftw-early-exit
+                        (lambda () (go (clean filename) 0 0))
+                        (lambda (key val) val))))
+        (chdir od)
+        ret))))
+
+
+;;;
+;;; `file-system-fold' & co.
+;;;
+
+(define-syntax-rule (errno-if-exception expr)
+  (catch 'system-error
+    (lambda ()
+      expr)
+    (lambda args
+      (system-error-errno args))))
+
+(define* (file-system-fold enter? leaf down up skip error init file-name
+                           #\optional (stat lstat))
+  "Traverse the directory at FILE-NAME, recursively.  Enter
+sub-directories only when (ENTER? PATH STAT RESULT) returns true.  When
+a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is
+the path of the sub-directory and STAT the result of (stat PATH); when
+it is left, call (UP PATH STAT RESULT).  For each file in a directory,
+call (LEAF PATH STAT RESULT).  When ENTER? returns false, call (SKIP
+PATH STAT RESULT).  When an `opendir' or STAT call raises an exception,
+call (ERROR PATH STAT ERRNO RESULT), with ERRNO being the operating
+system error number that was raised.
+
+Return the result of these successive applications.
+When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned.
+The optional STAT parameter defaults to `lstat'."
+
+  (define (mark v s)
+    (vhash-cons (cons (stat:dev s) (stat:ino s)) #t v))
+
+  (define (visited? v s)
+    (vhash-assoc (cons (stat:dev s) (stat:ino s)) v))
+
+  (let loop ((name     file-name)
+             (path     "")
+             (dir-stat (errno-if-exception (stat file-name)))
+             (result   init)
+             (visited  vlist-null))
+
+    (define full-name
+      (if (string=? path "")
+          name
+          (string-append path "/" name)))
+
+    (cond
+     ((integer? dir-stat)
+      ;; FILE-NAME is not readable.
+      (error full-name #f dir-stat result))
+     ((visited? visited dir-stat)
+      (values result visited))
+     ((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time
+      (if (enter? full-name dir-stat result)
+          (let ((dir     (errno-if-exception (opendir full-name)))
+                (visited (mark visited dir-stat)))
+            (cond
+             ((directory-stream? dir)
+              (let liip ((entry   (readdir dir))
+                         (result  (down full-name dir-stat result))
+                         (subdirs '()))
+                (cond ((eof-object? entry)
+                       (begin
+                         (closedir dir)
+                         (let ((r+v
+                                (fold (lambda (subdir result+visited)
+                                        (call-with-values
+                                            (lambda ()
+                                              (loop (car subdir)
+                                                    full-name
+                                                    (cdr subdir)
+                                                    (car result+visited)
+                                                    (cdr result+visited)))
+                                          cons))
+                                      (cons result visited)
+                                      subdirs)))
+                           (values (up full-name dir-stat (car r+v))
+                                   (cdr r+v)))))
+                      ((or (string=? entry ".")
+                           (string=? entry ".."))
+                       (liip (readdir dir)
+                             result
+                             subdirs))
+                      (else
+                       (let* ((child (string-append full-name "/" entry))
+                              (st    (errno-if-exception (stat child))))
+                         (if (integer? st) ; CHILD is a dangling symlink?
+                             (liip (readdir dir)
+                                   (error child #f st result)
+                                   subdirs)
+                             (if (eq? (stat:type st) 'directory)
+                                 (liip (readdir dir)
+                                       result
+                                       (alist-cons entry st subdirs))
+                                 (liip (readdir dir)
+                                       (leaf child st result)
+                                       subdirs))))))))
+             (else
+              ;; Directory FULL-NAME not readable, but it is stat'able.
+              (values (error full-name dir-stat dir result)
+                      visited))))
+          (values (skip full-name dir-stat result)
+                  (mark visited dir-stat))))
+     (else
+      ;; Caller passed a FILE-NAME that names a flat file, not a directory.
+      (leaf full-name dir-stat result)))))
+
+(define* (file-system-tree file-name
+                           #\optional (enter? (lambda (n s) #t))
+                                      (stat lstat))
+  "Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is
+the result of (STAT FILE-NAME) and CHILDREN are similar structures for
+each file contained in FILE-NAME when it designates a directory.  The
+optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should
+return true to allow recursion into directory NAME; the default value is
+a procedure that always returns #t.  When a directory does not match
+ENTER?, it nonetheless appears in the resulting tree, only with zero
+children.  The optional STAT parameter defaults to `lstat'.  Return #f
+when FILE-NAME is not readable."
+  (define (enter?* name stat result)
+    (enter? name stat))
+  (define (leaf name stat result)
+    (match result
+      (((siblings ...) rest ...)
+       (cons (alist-cons (basename name) (cons stat '()) siblings)
+             rest))))
+  (define (down name stat result)
+    (cons '() result))
+  (define (up name stat result)
+    (match result
+      (((children ...) (siblings ...) rest ...)
+       (cons (alist-cons (basename name) (cons stat children)
+                         siblings)
+             rest))))
+  (define skip                   ; keep an entry for skipped directories
+    leaf)
+  (define (error name stat errno result)
+    (if (string=? name file-name)
+        result
+        (leaf name stat result)))
+
+  (match (file-system-fold enter?* leaf down up skip error '(())
+                           file-name stat)
+    (((tree)) tree)
+    ((())     #f)))                            ; FILE-NAME is unreadable
+
+(define* (scandir name #\optional (select? (const #t))
+                                  (entry<? string-locale<?))
+  "Return the list of the names of files contained in directory NAME
+that match predicate SELECT? (by default, all files.)  The returned list
+of file names is sorted according to ENTRY<?, which defaults to
+`string-locale<?'.  Return #f when NAME is unreadable or is not a
+directory."
+
+  ;; This procedure is implemented in terms of 'readdir' instead of
+  ;; 'file-system-fold' to avoid the extra 'stat' call that the latter
+  ;; makes for each entry.
+
+  (define (opendir* directory)
+    (catch 'system-error
+      (lambda ()
+        (opendir directory))
+      (const #f)))
+
+  (and=> (opendir* name)
+         (lambda (stream)
+           (let loop ((entry  (readdir stream))
+                      (files   '()))
+             (if (eof-object? entry)
+                 (begin
+                   (closedir stream)
+                   (sort files entry<?))
+                 (loop (readdir stream)
+                       (if (select? entry)
+                           (cons entry files)
+                           files)))))))
+
+;;; ftw.scm ends here
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010, 2011, 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 futures)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (srfi srfi-11)
+  #\use-module (ice-9 q)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 control)
+  #\export (future make-future future? touch))
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; Commentary:
+;;;
+;;; This module provides an implementation of futures, a mechanism for
+;;; fine-grain parallelism.  Futures were first described by Henry Baker
+;;; in ``The Incremental Garbage Collection of Processes'', 1977, and
+;;; then implemented in MultiLisp (an implicit variant thereof, i.e.,
+;;; without `touch'.)
+;;;
+;;; This modules uses a fixed thread pool, normally one per CPU core.
+;;; Futures are off-loaded to these threads, when they are idle.
+;;;
+;;; Code:
+
+
+;;;
+;;; Futures.
+;;;
+
+(define-record-type <future>
+  (%make-future thunk state mutex completion)
+  future?
+  (thunk        future-thunk  set-future-thunk!)
+  (state        future-state  set-future-state!)  ; done | started | queued
+  (result       future-result set-future-result!)
+  (mutex        future-mutex)
+  (completion   future-completion))               ; completion cond. var.
+
+(set-record-type-printer!
+ <future>
+ (lambda (future port)
+   (simple-format port "#<future ~a ~a ~s>"
+                  (number->string (object-address future) 16)
+                  (future-state future)
+                  (future-thunk future))))
+
+(define (make-future thunk)
+  "Return a new future for THUNK.  Execution may start at any point
+concurrently, or it can start at the time when the returned future is
+touched."
+  (create-workers!)
+  (let ((future (%make-future thunk 'queued
+                              (make-mutex) (make-condition-variable))))
+    (register-future! future)
+    future))
+
+
+;;;
+;;; Future queues.
+;;;
+
+;; Global queue of pending futures.
+;; TODO: Use per-worker queues to reduce contention.
+(define %futures (make-q))
+
+;; Lock for %FUTURES and %FUTURES-WAITING.
+(define %futures-mutex (make-mutex))
+(define %futures-available (make-condition-variable))
+
+;; A mapping of nested futures to futures waiting for them to complete.
+(define %futures-waiting '())
+
+;; Nesting level of futures.  Incremented each time a future is touched
+;; from within a future.
+(define %nesting-level (make-parameter 0))
+
+;; Maximum nesting level.  The point is to avoid stack overflows when
+;; nested futures are executed on the same stack.  See
+;; <http://bugs.gnu.org/13188>.
+(define %max-nesting-level 200)
+
+(define-syntax-rule (with-mutex m e0 e1 ...)
+  ;; Copied from (ice-9 threads) to avoid circular dependency.
+  (let ((x m))
+    (dynamic-wind
+      (lambda () (lock-mutex x))
+      (lambda () (begin e0 e1 ...))
+      (lambda () (unlock-mutex x)))))
+
+(define %future-prompt
+  ;; The prompt futures abort to when they want to wait for another
+  ;; future.
+  (make-prompt-tag))
+
+
+(define (register-future! future)
+  ;; Register FUTURE as being processable.
+  (lock-mutex %futures-mutex)
+  (enq! %futures future)
+  (signal-condition-variable %futures-available)
+  (unlock-mutex %futures-mutex))
+
+(define (process-future! future)
+  "Process FUTURE.  When FUTURE completes, return #t and update its
+result; otherwise, when FUTURE touches a nested future that has not
+completed yet, then suspend it and return #f.  Suspending a future
+consists in capturing its continuation, marking it as `queued', and
+adding it to the waiter queue."
+  (let/ec return
+    (let* ((suspend
+            (lambda (cont future-to-wait)
+              ;; FUTURE wishes to wait for the completion of FUTURE-TO-WAIT.
+              ;; At this point, FUTURE is unlocked and in `started' state,
+              ;; and FUTURE-TO-WAIT is unlocked.
+              (with-mutex %futures-mutex
+                (with-mutex (future-mutex future)
+                  (set-future-thunk! future cont)
+                  (set-future-state! future 'queued))
+
+                (with-mutex (future-mutex future-to-wait)
+                  ;; If FUTURE-TO-WAIT completed in the meantime, then
+                  ;; reschedule FUTURE directly; otherwise, add it to the
+                  ;; waiter queue.
+                  (if (eq? 'done (future-state future-to-wait))
+                      (begin
+                        (enq! %futures future)
+                        (signal-condition-variable %futures-available))
+                      (set! %futures-waiting
+                            (alist-cons future-to-wait future
+                                        %futures-waiting))))
+
+                (return #f))))
+           (thunk (lambda ()
+                    (call-with-prompt %future-prompt
+                                      (lambda ()
+                                        (parameterize ((%nesting-level
+                                                        (1+ (%nesting-level))))
+                                          ((future-thunk future))))
+                                      suspend))))
+      (set-future-result! future
+                          (catch #t
+                            (lambda ()
+                              (call-with-values thunk
+                                (lambda results
+                                  (lambda ()
+                                    (apply values results)))))
+                            (lambda args
+                              (lambda ()
+                                (apply throw args)))))
+      #t)))
+
+(define (process-one-future)
+  "Attempt to pick one future from the queue and process it."
+  ;; %FUTURES-MUTEX must be locked on entry, and is locked on exit.
+  (or (q-empty? %futures)
+      (let ((future (deq! %futures)))
+        (lock-mutex (future-mutex future))
+        (case (future-state future)
+          ((done started)
+           ;; Nothing to do.
+           (unlock-mutex (future-mutex future)))
+          (else
+           ;; Do the actual work.
+
+           ;; We want to release %FUTURES-MUTEX so that other workers can
+           ;; progress.  However, to avoid deadlocks, we have to unlock
+           ;; FUTURE as well, to preserve lock ordering.
+           (unlock-mutex (future-mutex future))
+           (unlock-mutex %futures-mutex)
+
+           (lock-mutex (future-mutex future))
+           (if (eq? (future-state future) 'queued) ; lost the race?
+               (begin                          ; no, so let's process it
+                 (set-future-state! future 'started)
+                 (unlock-mutex (future-mutex future))
+
+                 (let ((done? (process-future! future)))
+                   (when done?
+                     (with-mutex %futures-mutex
+                       (with-mutex (future-mutex future)
+                         (set-future-state! future 'done)
+                         (notify-completion future))))))
+               (unlock-mutex (future-mutex future))) ; yes
+
+           (lock-mutex %futures-mutex))))))
+
+(define (process-futures)
+  "Continuously process futures from the queue."
+  (lock-mutex %futures-mutex)
+  (let loop ()
+    (when (q-empty? %futures)
+      (wait-condition-variable %futures-available
+                               %futures-mutex))
+
+    (process-one-future)
+    (loop)))
+
+(define (notify-completion future)
+  "Notify futures and callers waiting that FUTURE completed."
+  ;; FUTURE and %FUTURES-MUTEX are locked.
+  (broadcast-condition-variable (future-completion future))
+  (let-values (((waiting remaining)
+                (partition (match-lambda          ; TODO: optimize
+                            ((waitee . _)
+                             (eq? waitee future)))
+                           %futures-waiting)))
+    (set! %futures-waiting remaining)
+    (for-each (match-lambda
+               ((_ . waiter)
+                (enq! %futures waiter)))
+              waiting)))
+
+(define (touch future)
+  "Return the result of FUTURE, computing it if not already done."
+  (define (work)
+    ;; Do some work while waiting for FUTURE to complete.
+    (lock-mutex %futures-mutex)
+    (if (q-empty? %futures)
+        (begin
+          (unlock-mutex %futures-mutex)
+          (with-mutex (future-mutex future)
+            (unless (eq? 'done (future-state future))
+              (wait-condition-variable (future-completion future)
+                                       (future-mutex future)))))
+        (begin
+          (process-one-future)
+          (unlock-mutex %futures-mutex))))
+
+  (let loop ()
+    (lock-mutex (future-mutex future))
+    (case (future-state future)
+      ((done)
+       (unlock-mutex (future-mutex future)))
+      ((started)
+       (unlock-mutex (future-mutex future))
+       (if (> (%nesting-level) 0)
+           (abort-to-prompt %future-prompt future)
+           (begin
+             (work)
+             (loop))))
+      (else                                       ; queued
+       (unlock-mutex (future-mutex future))
+       (if (> (%nesting-level) %max-nesting-level)
+           (abort-to-prompt %future-prompt future)
+           (work))
+       (loop))))
+  ((future-result future)))
+
+
+;;;
+;;; Workers.
+;;;
+
+(define %worker-count
+  (if (provided? 'threads)
+      (- (current-processor-count) 1)
+      0))
+
+;; A dock of workers that stay here forever.
+
+;; TODO
+;; 1. Allow the pool to be shrunk, as in libgomp (though that we'd
+;;    need semaphores, which aren't yet in libguile!).
+;; 2. Provide a `worker-count' fluid.
+(define %workers '())
+
+(define (%create-workers!)
+  (with-mutex
+   %futures-mutex
+   ;; Setting 'create-workers!' to a no-op is an optimization, but it is
+   ;; still possible for '%create-workers!' to be called more than once
+   ;; from different threads.  Therefore, to avoid creating %workers more
+   ;; than once (and thus creating too many threads), we check to make
+   ;; sure %workers is empty within the critical section.
+   (when (null? %workers)
+     (set! %workers
+           (unfold (lambda (i) (>= i %worker-count))
+                   (lambda (i) (call-with-new-thread process-futures))
+                   1+
+                   0))
+     (set! create-workers! (lambda () #t)))))
+
+(define create-workers!
+  (lambda () (%create-workers!)))
+
+
+;;;
+;;; Syntax.
+;;;
+
+(define-syntax-rule (future body)
+  "Return a new future for BODY."
+  (make-future (lambda () body)))
+
+;;; Local Variables:
+;;; eval: (put 'with-mutex 'scheme-indent-function 1)
+;;; End:
+;;; gap-buffer.scm --- String buffer that supports point
+
+;;;	Copyright (C) 2002, 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
+;;;
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; A gap buffer is a structure that models a string but allows relatively
+;; efficient insertion of text somewhere in the middle.  The insertion
+;; location is called `point' with minimum value 1, and a maximum value of the
+;; length of the string (which is not fixed).
+;;
+;; Specifically, we allocate a continuous buffer of characters that is
+;; composed of the BEFORE, the GAP and the AFTER (reading L->R), like so:
+;;
+;;                          +--- POINT
+;;                          v
+;;    +--------------------+--------------------+--------------------+
+;;    |       BEFORE       |        GAP         |       AFTER        |
+;;    +--------------------+--------------------+--------------------+
+;;
+;;     <----- bef-sz ----->|<----- gap-sz ----->|<----- aft-sz ----->
+;;
+;;     <-------------------|       usr-sz       |------------------->
+;;
+;;     <-------------------------- all-sz -------------------------->
+;;
+;; This diagram also shows how the different sizes are computed, and the
+;; location of POINT.  Note that the user-visible buffer size `usr-sz' does
+;; NOT include the GAP, while the allocation `all-sz' DOES.
+;;
+;; The consequence of this arrangement is that "moving point" is simply a
+;; matter of kicking characters across the GAP, while insertion can be viewed
+;; as filling up the gap, increasing `bef-sz' and decreasing `gap-sz'.  When
+;; `gap-sz' falls below some threshold, we reallocate with a larger `all-sz'.
+;;
+;; In the implementation, we actually keep track of the AFTER start offset
+;; `aft-ofs' since it is used more often than `gap-sz'.  In fact, most of the
+;; variables in the diagram are for conceptualization only.
+;;
+;; A gap buffer port is a soft port (see Guile manual) that wraps a gap
+;; buffer.  Character and string writes, as well as character reads, are
+;; supported.  Flushing and closing are not supported.
+;;
+;; These procedures are exported:
+;;   (gb? OBJ)
+;;   (make-gap-buffer . INIT)
+;;   (gb-point GB)
+;;   (gb-point-min GB)
+;;   (gb-point-max GB)
+;;   (gb-insert-string! GB STRING)
+;;   (gb-insert-char! GB CHAR)
+;;   (gb-delete-char! GB COUNT)
+;;   (gb-goto-char GB LOCATION)
+;;   (gb->string GB)
+;;   (gb-filter! GB STRING-PROC)
+;;   (gb->lines GB)
+;;   (gb-filter-lines! GB LINES-PROC)
+;;   (make-gap-buffer-port GB)
+;;
+;; INIT is an optional port or a string.  COUNT and LOCATION are integers.
+;; STRING-PROC is a procedure that takes and returns a string.  LINES-PROC is
+;; a procedure that takes and returns a list of strings, each representing a
+;; line of text (newlines are stripped and added back automatically).
+;;
+;; (The term and concept of "gap buffer" are borrowed from Emacs.  We will
+;; gladly return them when libemacs.so is available. ;-)
+;;
+;; Notes:
+;; - overrun errors are suppressed silently
+
+;;; Code:
+
+(define-module (ice-9 gap-buffer)
+  \:autoload (srfi srfi-13) (string-join)
+  \:export (gb?
+           make-gap-buffer
+           gb-point
+           gb-point-min
+           gb-point-max
+           gb-insert-string!
+           gb-insert-char!
+           gb-delete-char!
+           gb-erase!
+           gb-goto-char
+           gb->string
+           gb-filter!
+           gb->lines
+           gb-filter-lines!
+           make-gap-buffer-port))
+
+(define gap-buffer
+  (make-record-type 'gap-buffer
+                    '(s                 ; the buffer, a string
+                      all-sz            ; total allocation
+                      gap-ofs           ; GAP starts, aka (1- point)
+                      aft-ofs           ; AFTER starts
+                      )))
+
+(define gb? (record-predicate gap-buffer))
+
+(define s\:       (record-accessor gap-buffer 's))
+(define all-sz\:  (record-accessor gap-buffer 'all-sz))
+(define gap-ofs\: (record-accessor gap-buffer 'gap-ofs))
+(define aft-ofs\: (record-accessor gap-buffer 'aft-ofs))
+
+(define s!       (record-modifier gap-buffer 's))
+(define all-sz!  (record-modifier gap-buffer 'all-sz))
+(define gap-ofs! (record-modifier gap-buffer 'gap-ofs))
+(define aft-ofs! (record-modifier gap-buffer 'aft-ofs))
+
+;; todo: expose
+(define default-initial-allocation 128)
+(define default-chunk-size 128)
+(define default-realloc-threshold 32)
+
+(define (round-up n)
+  (* default-chunk-size (+ 1 (quotient n default-chunk-size))))
+
+(define new (record-constructor gap-buffer '()))
+
+(define (realloc gb inc)
+  (let* ((old-s   (s\: gb))
+         (all-sz  (all-sz\: gb))
+         (new-sz  (+ all-sz inc))
+         (gap-ofs (gap-ofs\: gb))
+         (aft-ofs (aft-ofs\: gb))
+         (new-s   (make-string new-sz))
+         (new-aft-ofs (+ aft-ofs inc)))
+    (substring-move! old-s 0 gap-ofs new-s 0)
+    (substring-move! old-s aft-ofs all-sz new-s new-aft-ofs)
+    (s! gb new-s)
+    (all-sz! gb new-sz)
+    (aft-ofs! gb new-aft-ofs)))
+
+(define (make-gap-buffer . init)        ; port/string
+  (let ((gb (new)))
+    (cond ((null? init)
+           (s! gb (make-string default-initial-allocation))
+           (all-sz! gb default-initial-allocation)
+           (gap-ofs! gb 0)
+           (aft-ofs! gb default-initial-allocation))
+          (else (let ((jam! (lambda (string len)
+                              (let ((alloc (round-up len)))
+                                (s! gb (make-string alloc))
+                                (all-sz! gb alloc)
+                                (substring-move! string 0 len (s\: gb) 0)
+                                (gap-ofs! gb len)
+                                (aft-ofs! gb alloc))))
+                      (v (car init)))
+                  (cond ((port? v)
+                         (let ((next (lambda () (read-char v))))
+                           (let loop ((c (next)) (acc '()) (len 0))
+                             (if (eof-object? c)
+                                 (jam! (list->string (reverse acc)) len)
+                                 (loop (next) (cons c acc) (1+ len))))))
+                        ((string? v)
+                         (jam! v (string-length v)))
+                        (else (error "bad init type"))))))
+    gb))
+
+(define (gb-point gb)
+  (1+ (gap-ofs\: gb)))
+
+(define (gb-point-min gb) 1)            ; no narrowing (for now)
+
+(define (gb-point-max gb)
+  (1+ (- (all-sz\: gb) (- (aft-ofs\: gb) (gap-ofs\: gb)))))
+
+(define (insert-prep gb len)
+  (let* ((gap-ofs (gap-ofs\: gb))
+         (aft-ofs (aft-ofs\: gb))
+         (slack (- (- aft-ofs gap-ofs) len)))
+    (and (< slack default-realloc-threshold)
+         (realloc gb (round-up (- slack))))
+    gap-ofs))
+
+(define (gb-insert-string! gb string)
+  (let* ((len (string-length string))
+         (gap-ofs (insert-prep gb len)))
+    (substring-move! string 0 len (s\: gb) gap-ofs)
+    (gap-ofs! gb (+ gap-ofs len))))
+
+(define (gb-insert-char! gb char)
+  (let ((gap-ofs (insert-prep gb 1)))
+    (string-set! (s\: gb) gap-ofs char)
+    (gap-ofs! gb (+ gap-ofs 1))))
+
+(define (gb-delete-char! gb count)
+  (cond ((< count 0)                    ; backwards
+         (gap-ofs! gb (max 0 (+ (gap-ofs\: gb) count))))
+        ((> count 0)                    ; forwards
+         (aft-ofs! gb (min (all-sz\: gb) (+ (aft-ofs\: gb) count))))
+        ((= count 0)                    ; do nothing
+         #t)))
+
+(define (gb-erase! gb)
+  (gap-ofs! gb 0)
+  (aft-ofs! gb (all-sz\: gb)))
+
+(define (point++n! gb n s gap-ofs aft-ofs) ; n>0; warning: reckless
+  (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
+  (gap-ofs! gb (+ gap-ofs n))
+  (aft-ofs! gb (+ aft-ofs n)))
+
+(define (point+-n! gb n s gap-ofs aft-ofs) ; n<0; warning: reckless
+  (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
+  (gap-ofs! gb (+ gap-ofs n))
+  (aft-ofs! gb (+ aft-ofs n)))
+
+(define (gb-goto-char gb new-point)
+  (let ((pmax (gb-point-max gb)))
+    (or (and (< new-point 1)    (gb-goto-char gb 1))
+        (and (> new-point pmax) (gb-goto-char gb pmax))
+        (let ((delta (- new-point (gb-point gb))))
+          (or (= delta 0)
+              ((if (< delta 0)
+                   point+-n!
+                   point++n!)
+               gb delta (s\: gb) (gap-ofs\: gb) (aft-ofs\: gb))))))
+  new-point)
+
+(define (gb->string gb)
+  (let ((s (s\: gb)))
+    (string-append (substring s 0 (gap-ofs\: gb))
+                   (substring s (aft-ofs\: gb)))))
+
+(define (gb-filter! gb string-proc)
+  (let ((new (string-proc (gb->string gb))))
+    (gb-erase! gb)
+    (gb-insert-string! gb new)))
+
+(define (gb->lines gb)
+  (let ((str (gb->string gb)))
+    (let loop ((start 0) (acc '()))
+      (cond ((string-index str #\newline start)
+             => (lambda (w)
+                  (loop (1+ w) (cons (substring str start w) acc))))
+            (else (reverse (cons (substring str start) acc)))))))
+
+(define (gb-filter-lines! gb lines-proc)
+  (let ((new-lines (lines-proc (gb->lines gb))))
+    (gb-erase! gb)
+    (gb-insert-string! gb (string-join new-lines #\newline))))
+
+(define (make-gap-buffer-port gb)
+  (or (gb? gb)
+      (error "not a gap-buffer:" gb))
+  (make-soft-port
+   (vector
+    (lambda (c) (gb-insert-char! gb c))
+    (lambda (s) (gb-insert-string! gb s))
+    #f
+    (lambda () (let ((gap-ofs (gap-ofs\: gb))
+                     (aft-ofs (aft-ofs\: gb)))
+                 (if (= aft-ofs (all-sz\: gb))
+                     #f
+                     (let* ((s (s\: gb))
+                            (c (string-ref s aft-ofs)))
+                       (string-set! s gap-ofs c)
+                       (gap-ofs! gb (1+ gap-ofs))
+                       (aft-ofs! gb (1+ aft-ofs))
+                       c))))
+    #f)
+   "rw"))
+
+;;; gap-buffer.scm ends here
+;;; Copyright (C) 1998, 2001, 2006, 2009, 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: Russ McManus (rewritten by Thien-Thi Nguyen)
+
+;;; Commentary:
+
+;;; This module implements some complex command line option parsing, in
+;;; the spirit of the GNU C library function `getopt_long'.  Both long
+;;; and short options are supported.
+;;;
+;;; The theory is that people should be able to constrain the set of
+;;; options they want to process using a grammar, rather than some arbitrary
+;;; structure.  The grammar makes the option descriptions easy to read.
+;;;
+;;; `getopt-long' is a procedure for parsing command-line arguments in a
+;;; manner consistent with other GNU programs.  `option-ref' is a procedure
+;;; that facilitates processing of the `getopt-long' return value.
+
+;;; (getopt-long ARGS GRAMMAR)
+;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
+;;;
+;;; ARGS should be a list of strings.  Its first element should be the
+;;; name of the program; subsequent elements should be the arguments
+;;; that were passed to the program on the command line.  The
+;;; `program-arguments' procedure returns a list of this form.
+;;;
+;;; GRAMMAR is a list of the form:
+;;; ((OPTION (PROPERTY VALUE) ...) ...)
+;;;
+;;; Each OPTION should be a symbol.  `getopt-long' will accept a
+;;; command-line option named `--OPTION'.
+;;; Each option can have the following (PROPERTY VALUE) pairs:
+;;;
+;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
+;;;		equivalent to `--OPTION'.  This is how to specify traditional
+;;;		Unix-style flags.
+;;;   (required? BOOL) --- If BOOL is true, the option is required.
+;;;		getopt-long will raise an error if it is not found in ARGS.
+;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
+;;;		it is #f, it does not; and if it is the symbol
+;;;		`optional', the option may appear in ARGS with or
+;;;		without a value.
+;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
+;;;		specified `(value #t)' for this option), then getopt
+;;;		will apply FUNC to the value, and throw an exception
+;;;		if it returns #f.  FUNC should be a procedure which
+;;;		accepts a string and returns a boolean value; you may
+;;;		need to use quasiquotes to get it into GRAMMAR.
+;;;
+;;; The (PROPERTY VALUE) pairs may occur in any order, but each
+;;; property may occur only once.  By default, options do not have
+;;; single-character equivalents, are not required, and do not take
+;;; values.
+;;;
+;;; In ARGS, single-character options may be combined, in the usual
+;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
+;;; accepts values, then it must be the last option in the
+;;; combination; the value is the next argument.  So, for example, using
+;;; the following grammar:
+;;;      ((apples    (single-char #\a))
+;;;       (blimps    (single-char #\b) (value #t))
+;;;       (catalexis (single-char #\c) (value #t)))
+;;; the following argument lists would be acceptable:
+;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
+;;;                                         for "blimps" and "catalexis")
+;;;    ("-ab" "bang" "-c" "couth")         (same)
+;;;    ("-ac" "couth" "-b" "bang")         (same)
+;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
+;;;                                         last option in its combination)
+;;;
+;;; If an option's value is optional, then `getopt-long' decides
+;;; whether it has a value by looking at what follows it in ARGS.  If
+;;; the next element is does not appear to be an option itself, then
+;;; that element is the option's value.
+;;;
+;;; The value of a long option can appear as the next element in ARGS,
+;;; or it can follow the option name, separated by an `=' character.
+;;; Thus, using the same grammar as above, the following argument lists
+;;; are equivalent:
+;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
+;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
+;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
+;;;
+;;; If the option "--" appears in ARGS, argument parsing stops there;
+;;; subsequent arguments are returned as ordinary arguments, even if
+;;; they resemble options.  So, in the argument list:
+;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
+;;; `getopt-long' will recognize the `apples' option as having the
+;;; value "Granny Smith", but it will not recognize the `blimp'
+;;; option; it will return the strings "--blimp" and "Goodyear" as
+;;; ordinary argument strings.
+;;;
+;;; The `getopt-long' function returns the parsed argument list as an
+;;; assocation list, mapping option names --- the symbols from GRAMMAR
+;;; --- onto their values, or #t if the option does not accept a value.
+;;; Unused options do not appear in the alist.
+;;;
+;;; All arguments that are not the value of any option are returned
+;;; as a list, associated with the empty list.
+;;;
+;;; `getopt-long' throws an exception if:
+;;; - it finds an unrecognized property in GRAMMAR
+;;; - the value of the `single-char' property is not a character
+;;; - it finds an unrecognized option in ARGS
+;;; - a required option is omitted
+;;; - an option that requires an argument doesn't get one
+;;; - an option that doesn't accept an argument does get one (this can
+;;;   only happen using the long option `--opt=value' syntax)
+;;; - an option predicate fails
+;;;
+;;; So, for example:
+;;;
+;;; (define grammar
+;;;   `((lockfile-dir (required? #t)
+;;;                   (value #t)
+;;;                   (single-char #\k)
+;;;                   (predicate ,file-is-directory?))
+;;;     (verbose (required? #f)
+;;;              (single-char #\v)
+;;;              (value #f))
+;;;     (x-includes (single-char #\x))
+;;;     (rnet-server (single-char #\y)
+;;;                  (predicate ,string?))))
+;;;
+;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
+;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
+;;;                grammar)
+;;; => ((() "foo1" "-fred" "foo2" "foo3")
+;;; 	(rnet-server . "lamprod")
+;;; 	(x-includes . "/usr/include")
+;;; 	(lockfile-dir . "/tmp")
+;;; 	(verbose . #t))
+
+;;; (option-ref OPTIONS KEY DEFAULT)
+;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
+;;; found.  The value is either a string or `#t'.
+;;;
+;;; For example, using the `getopt-long' return value from above:
+;;;
+;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
+;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
+
+;;; Code:
+
+(define-module (ice-9 getopt-long)
+  #\use-module ((ice-9 common-list) #\select (remove-if-not))
+  #\use-module (srfi srfi-9)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 optargs)
+  #\export (getopt-long option-ref))
+
+(define %program-name (make-fluid "guile"))
+(define (program-name)
+  (fluid-ref %program-name))
+
+(define (fatal-error fmt . args)
+  (format (current-error-port) "~a: " (program-name))
+  (apply format (current-error-port) fmt args)
+  (newline (current-error-port))
+  (exit 1))
+
+(define-record-type option-spec
+  (%make-option-spec name required? option-spec->single-char predicate value-policy)
+  option-spec?
+  (name
+   option-spec->name set-option-spec-name!)
+  (required?
+   option-spec->required? set-option-spec-required?!)
+  (option-spec->single-char
+   option-spec->single-char set-option-spec-single-char!)
+  (predicate
+   option-spec->predicate set-option-spec-predicate!)
+  (value-policy
+   option-spec->value-policy set-option-spec-value-policy!))
+
+(define (make-option-spec name)
+  (%make-option-spec name #f #f #f #f))
+
+(define (parse-option-spec desc)
+  (let ((spec (make-option-spec (symbol->string (car desc)))))
+    (for-each (match-lambda
+               (('required? val)
+                (set-option-spec-required?! spec val))
+               (('value val)
+                (set-option-spec-value-policy! spec val))
+               (('single-char val)
+                (or (char? val)
+                    (error "`single-char' value must be a char!"))
+                (set-option-spec-single-char! spec val))
+               (('predicate pred)
+                (set-option-spec-predicate!
+                 spec (lambda (name val)
+                        (or (not val)
+                            (pred val)
+                            (fatal-error "option predicate failed: --~a"
+                                         name)))))
+               ((prop val)
+                (error "invalid getopt-long option property:" prop)))
+              (cdr desc))
+    spec))
+
+(define (split-arg-list argument-list)
+  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
+  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
+  (let loop ((yes '()) (no argument-list))
+    (cond ((null? no)               (cons (reverse yes) no))
+	  ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
+	  (else (loop (cons (car no) yes) (cdr no))))))
+
+(define short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
+(define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
+(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
+
+(define (looks-like-an-option string)
+  (or (regexp-exec short-opt-rx string)
+      (regexp-exec long-opt-with-value-rx string)
+      (regexp-exec long-opt-no-value-rx string)))
+
+(define (process-options specs argument-ls stop-at-first-non-option)
+  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
+  ;; FOUND is an unordered list of option specs for found options, while ETC
+  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
+  ;; options nor their values.
+  (let ((idx (map (lambda (spec)
+                    (cons (option-spec->name spec) spec))
+                  specs))
+        (sc-idx (map (lambda (spec)
+                       (cons (make-string 1 (option-spec->single-char spec))
+                             spec))
+                     (remove-if-not option-spec->single-char specs))))
+    (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
+      (define (eat! spec ls)
+        (cond
+         ((eq? 'optional (option-spec->value-policy spec))
+          (if (or (null? ls)
+                  (looks-like-an-option (car ls)))
+              (loop (- unclumped 1) ls (acons spec #t found) etc)
+              (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
+         ((eq? #t (option-spec->value-policy spec))
+          (if (or (null? ls)
+                  (looks-like-an-option (car ls)))
+              (fatal-error "option must be specified with argument: --~a"
+                           (option-spec->name spec))
+              (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
+         (else
+          (loop (- unclumped 1) ls (acons spec #t found) etc))))
+      
+      (match argument-ls
+        (()
+         (cons found (reverse etc)))
+        ((opt . rest)
+         (cond
+          ((regexp-exec short-opt-rx opt)
+           => (lambda (match)
+                (if (> unclumped 0)
+                    ;; Next option is known not to be clumped.
+                    (let* ((c (match:substring match 1))
+                           (spec (or (assoc-ref sc-idx c)
+                                     (fatal-error "no such option: -~a" c))))
+                      (eat! spec rest))
+                    ;; Expand a clumped group of short options.
+                    (let* ((extra (match:substring match 2))
+                           (unclumped-opts
+                            (append (map (lambda (c)
+                                           (string-append "-" (make-string 1 c)))
+                                         (string->list
+                                          (match:substring match 1)))
+                                    (if (string=? "" extra) '() (list extra)))))
+                      (loop (length unclumped-opts)
+                            (append unclumped-opts rest)
+                            found
+                            etc)))))
+          ((regexp-exec long-opt-no-value-rx opt)
+           => (lambda (match)
+                (let* ((opt (match:substring match 1))
+                       (spec (or (assoc-ref idx opt)
+                                 (fatal-error "no such option: --~a" opt))))
+                  (eat! spec rest))))
+          ((regexp-exec long-opt-with-value-rx opt)
+           => (lambda (match)
+                (let* ((opt (match:substring match 1))
+                       (spec (or (assoc-ref idx opt)
+                                 (fatal-error "no such option: --~a" opt))))
+                  (if (option-spec->value-policy spec)
+                      (eat! spec (cons (match:substring match 2) rest))
+                      (fatal-error "option does not support argument: --~a"
+                                   opt)))))
+          ((and stop-at-first-non-option
+                (<= unclumped 0))
+           (cons found (append (reverse etc) argument-ls)))
+          (else
+           (loop (- unclumped 1) rest found (cons opt etc)))))))))
+
+(define* (getopt-long program-arguments option-desc-list
+                      #\key stop-at-first-non-option)
+  "Process options, handling both long and short options, similar to
+the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
+similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
+list of option descriptions.  Each option description must satisfy the
+following grammar:
+
+    <option-spec>           :: (<name> . <attribute-ls>)
+    <attribute-ls>          :: (<attribute> . <attribute-ls>)
+                               | ()
+    <attribute>             :: <required-attribute>
+                               | <arg-required-attribute>
+                               | <single-char-attribute>
+                               | <predicate-attribute>
+                               | <value-attribute>
+    <required-attribute>    :: (required? <boolean>)
+    <single-char-attribute> :: (single-char <char>)
+    <value-attribute>       :: (value #t)
+                               (value #f)
+                               (value optional)
+    <predicate-attribute>   :: (predicate <1-ary-function>)
+
+    The procedure returns an alist of option names and values.  Each
+option name is a symbol.  The option value will be '#t' if no value
+was specified.  There is a special item in the returned alist with a
+key of the empty list, (): the list of arguments that are not options
+or option values.
+    By default, options are not required, and option values are not
+required.  By default, single character equivalents are not supported;
+if you want to allow the user to use single character options, you need
+to add a `single-char' clause to the option description."
+  (with-fluids ((%program-name (car program-arguments)))
+    (let* ((specifications (map parse-option-spec option-desc-list))
+           (pair (split-arg-list (cdr program-arguments)))
+           (split-ls (car pair))
+           (non-split-ls (cdr pair))
+           (found/etc (process-options specifications split-ls
+                                       stop-at-first-non-option))
+           (found (car found/etc))
+           (rest-ls (append (cdr found/etc) non-split-ls)))
+      (for-each (lambda (spec)
+                  (let ((name (option-spec->name spec))
+                        (val (assq-ref found spec)))
+                    (and (option-spec->required? spec)
+                         (or val
+                             (fatal-error "option must be specified: --~a"
+                                          name)))
+                    (let ((pred (option-spec->predicate spec)))
+                      (and pred (pred name val)))))
+                specifications)
+      (for-each (lambda (spec+val)
+                  (set-car! spec+val
+                            (string->symbol (option-spec->name (car spec+val)))))
+                found)
+      (cons (cons '() rest-ls) found))))
+
+(define (option-ref options key default)
+  "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
+The value is either a string or `#t'."
+  (or (assq-ref options key) default))
+
+;;; getopt-long.scm ends here
+;;;; hash-table.scm --- Additional hash table procedures
+;;;; Copyright (C) 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 hash-table)
+  #\export (alist->hash-table
+            alist->hashq-table
+            alist->hashv-table
+            alist->hashx-table))
+
+(define-syntax-rule (define-alist-converter name hash-set-proc)
+  (define (name alist)
+    "Convert ALIST into a hash table."
+    (let ((table (make-hash-table)))
+      (for-each (lambda (pair)
+                  (hash-set-proc table (car pair) (cdr pair)))
+                (reverse alist))
+      table)))
+
+(define-alist-converter alist->hash-table hash-set!)
+(define-alist-converter alist->hashq-table hashq-set!)
+(define-alist-converter alist->hashv-table hashv-set!)
+
+(define (alist->hashx-table hash assoc alist)
+  "Convert ALIST into a hash table with custom HASH and ASSOC
+procedures."
+  (let ((table (make-hash-table)))
+    (for-each (lambda (pair)
+                (hashx-set! hash assoc table (car pair) (cdr pair)))
+              (reverse alist))
+    table))
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 1995, 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 hcons)
+  \:export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle
+	   hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons
+	   hashq-conser make-gc-buffer))
+
+
+;;; {Eq? hash-consing}
+;;;
+;;; A hash conser maintains a private universe of pairs s.t. if 
+;;; two cons calls pass eq? arguments, the pairs returned are eq?.
+;;;
+;;; A hash conser does not contribute life to the pairs it returns.
+;;;
+
+(define (hashq-cons-hash pair n)
+  (modulo (logxor (hashq (car pair) 4194303)
+		  (hashq (cdr pair) 4194303))
+	  n))
+
+(define (hashq-cons-assoc key l)
+  (and (not (null? l))
+       (or (and (pair? l)		; If not a pair, use its cdr?
+		(pair? (car l))
+		(pair? (caar l))
+		(eq? (car key) (caaar l))
+		(eq? (cdr key) (cdaar l))
+		(car l))
+	   (hashq-cons-assoc key (cdr l)))))
+
+(define (hashq-cons-get-handle table key)
+  (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key))
+
+(define (hashq-cons-create-handle! table key init)
+  (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
+
+(define (hashq-cons-ref table key)
+  (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
+
+(define (hashq-cons-set! table key val)
+  (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
+
+(define (hashq-cons table a d)
+  (car (hashq-cons-create-handle! table (cons a d) #f)))
+
+(define (hashq-conser hash-tab-or-size)
+  (let ((table (if (vector? hash-tab-or-size)
+		   hash-tab-or-size
+		   (make-doubly-weak-hash-table hash-tab-or-size))))
+    (lambda (a d) (hashq-cons table a d))))
+
+
+
+
+(define (make-gc-buffer n)
+  (let ((ring (make-list n #f)))
+    (append! ring ring)
+    (lambda (next)
+      (set-car! ring next)
+      (set! ring (cdr ring))
+      next)))
+;;;; 	Copyright (C) 2000, 2001, 2004, 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
+;;;; 
+
+;;;; A simple value history support
+
+(define-module (ice-9 history)
+  #\export (value-history-enabled? enable-value-history! disable-value-history!
+            clear-value-history!))
+
+(define-module* '(value-history))
+
+(define *value-history-enabled?* #f)
+(define (value-history-enabled?)
+  *value-history-enabled?*)
+
+(define (use-value-history x)
+  (module-use! (current-module)
+	       (resolve-interface '(value-history))))
+
+(define save-value-history
+  (let ((count 0)
+	(history (resolve-module '(value-history))))
+    (lambda (v)
+      (if (not (unspecified? v))
+	  (let* ((c (1+ count))
+		 (s (string->symbol (simple-format #f "$~A" c))))
+	    (simple-format #t "~A = " s)
+	    (module-define! history s v)
+	    (module-export! history (list s))
+	    (set! count c))))))
+
+(define (enable-value-history!)
+  (if (not (value-history-enabled?))
+      (begin
+        (add-hook! before-eval-hook use-value-history)
+        (add-hook! before-print-hook save-value-history)
+        (set! *value-history-enabled?* #t))))
+
+(define (disable-value-history!)
+  (if (value-history-enabled?)
+      (begin
+        (remove-hook! before-eval-hook use-value-history)
+        (remove-hook! before-print-hook save-value-history)
+        (set! *value-history-enabled?* #f))))
+
+(define (clear-value-history!)
+  (let ((history (resolve-module '(value-history))))
+    (hash-clear! (module-obarray history))
+    (hash-clear! (module-obarray (module-public-interface history)))))
+
+(enable-value-history!)
+;;;; i18n.scm --- internationalization support    -*- coding: utf-8 -*-
+
+;;;;	Copyright (C) 2006, 2007, 2009, 2010, 2012,
+;;;;      2017 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 module provides a number of routines that support
+;;; internationalization (e.g., locale-dependent text collation, character
+;;; mapping, etc.).  It also defines `locale' objects, representing locale
+;;; settings, that may be passed around to most of these procedures.
+;;;
+
+;;; Code:
+
+(define-module (ice-9 i18n)
+  \:use-module (ice-9 optargs)
+  \:export (;; `locale' type
+           make-locale locale?
+           %global-locale
+
+           ;; text collation
+           string-locale<? string-locale>?
+           string-locale-ci<? string-locale-ci>? string-locale-ci=?
+
+           char-locale<? char-locale>?
+           char-locale-ci<? char-locale-ci>? char-locale-ci=?
+
+           ;; character mapping
+           char-locale-downcase char-locale-upcase char-locale-titlecase
+           string-locale-downcase string-locale-upcase string-locale-titlecase
+
+           ;; reading numbers
+           locale-string->integer locale-string->inexact
+
+           ;; charset/encoding
+           locale-encoding
+
+           ;; days and months
+           locale-day-short locale-day locale-month-short locale-month
+
+           ;; date and time
+           locale-am-string locale-pm-string
+           locale-date+time-format locale-date-format locale-time-format
+           locale-time+am/pm-format
+           locale-era locale-era-year
+           locale-era-date-format locale-era-date+time-format
+           locale-era-time-format
+
+           ;; monetary
+           locale-currency-symbol
+           locale-monetary-decimal-point locale-monetary-thousands-separator
+           locale-monetary-grouping locale-monetary-fractional-digits
+           locale-currency-symbol-precedes-positive?
+           locale-currency-symbol-precedes-negative?
+           locale-positive-separated-by-space?
+           locale-negative-separated-by-space?
+           locale-monetary-positive-sign locale-monetary-negative-sign
+           locale-positive-sign-position locale-negative-sign-position
+           monetary-amount->locale-string
+
+           ;; number formatting
+           locale-digit-grouping locale-decimal-point
+           locale-thousands-separator
+           number->locale-string
+
+           ;; miscellaneous
+           locale-yes-regexp locale-no-regexp))
+
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_i18n"))
+
+
+;;;
+;;; Charset/encoding.
+;;;
+
+(define (locale-encoding . locale)
+  (apply nl-langinfo CODESET locale))
+
+
+;;;
+;;; Months and days.
+;;;
+
+;; Helper macro: Define a procedure named NAME that maps its argument to
+;; NL-ITEMS.  Gnulib guarantees that these items are available.
+(define-macro (define-vector-langinfo-mapping name nl-items)
+  (let* ((item-count (length nl-items))
+         (defines   `(define %nl-items (vector #f ,@nl-items)))
+         (make-body (lambda (result)
+                      `(if (and (integer? item) (exact? item))
+                           (if (and (>= item 1) (<= item ,item-count))
+                               ,result
+                               (throw 'out-of-range "out of range" item))
+                           (throw 'wrong-type-arg "wrong argument type" item)))))
+    `(define (,name item . locale)
+       ,defines
+       ,(make-body '(apply nl-langinfo (vector-ref %nl-items item) locale)))))
+
+
+(define-vector-langinfo-mapping locale-day-short
+  (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7))
+
+(define-vector-langinfo-mapping locale-day
+  (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7))
+
+(define-vector-langinfo-mapping locale-month-short
+  (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
+   ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12))
+
+(define-vector-langinfo-mapping locale-month
+  (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12))
+
+
+
+;;;
+;;; Date and time.
+;;;
+
+;; Define a procedure NAME that gets langinfo item ITEM.  Gnulib's
+;; `nl_langinfo' does not guarantee that all these items are supported
+;; (for instance, `GROUPING' is lacking on Darwin and Gnulib provides no
+;; replacement), so use DEFAULT as the default value when ITEM is not
+;; available.
+(define-macro (define-simple-langinfo-mapping name item default)
+  (let ((body (if (defined? item)
+                  `(apply nl-langinfo ,item locale)
+                  default)))
+    `(define (,name . locale)
+       ,body)))
+
+(define-simple-langinfo-mapping locale-am-string
+  AM_STR "AM")
+(define-simple-langinfo-mapping locale-pm-string
+  PM_STR "PM")
+(define-simple-langinfo-mapping locale-date+time-format
+  D_T_FMT "%a %b %e %H:%M:%S %Y")
+(define-simple-langinfo-mapping locale-date-format
+  D_FMT   "%m/%d/%y")
+(define-simple-langinfo-mapping locale-time-format
+  T_FMT   "%H:%M:%S")
+(define-simple-langinfo-mapping locale-time+am/pm-format
+  T_FMT_AMPM "%I:%M:%S %p")
+(define-simple-langinfo-mapping locale-era
+  ERA        "")
+(define-simple-langinfo-mapping locale-era-year
+  ERA_YEAR   "")
+(define-simple-langinfo-mapping locale-era-date+time-format
+  ERA_D_T_FMT "")
+(define-simple-langinfo-mapping locale-era-date-format
+  ERA_D_FMT   "")
+(define-simple-langinfo-mapping locale-era-time-format
+  ERA_T_FMT   "")
+
+
+
+;;;
+;;; Monetary information.
+;;;
+
+;; Define a procedure NAME that gets item LOCAL-ITEM or INTL-ITEM,
+;; depending on whether the caller asked for the international version
+;; or not.  Since Gnulib's `nl_langinfo' module doesn't guarantee that
+;; all these items are available, use DEFAULT/LOCAL and DEFAULT/INTL as
+;; default values when the system does not support them.
+(define-macro (define-monetary-langinfo-mapping name local-item intl-item
+                                                default/local default/intl)
+  (let ((body
+         (let ((intl  (if (defined? intl-item)
+                          `(apply nl-langinfo ,intl-item locale)
+                          default/intl))
+               (local (if (defined? local-item)
+                          `(apply nl-langinfo ,local-item locale)
+                          default/local)))
+           `(if intl? ,intl ,local))))
+
+    `(define (,name intl? . locale)
+       ,body)))
+
+;; FIXME: How can we use ALT_DIGITS?
+(define-monetary-langinfo-mapping locale-currency-symbol
+  CRNCYSTR           INT_CURR_SYMBOL
+  "-"                "")
+(define-monetary-langinfo-mapping locale-monetary-fractional-digits
+  FRAC_DIGITS        INT_FRAC_DIGITS
+  2                  2)
+
+(define-simple-langinfo-mapping locale-monetary-positive-sign
+  POSITIVE_SIGN        "+")
+(define-simple-langinfo-mapping locale-monetary-negative-sign
+  NEGATIVE_SIGN        "-")
+(define-simple-langinfo-mapping locale-monetary-decimal-point
+  MON_DECIMAL_POINT    "")
+(define-simple-langinfo-mapping locale-monetary-thousands-separator
+  MON_THOUSANDS_SEP    "")
+(define-simple-langinfo-mapping locale-monetary-digit-grouping
+  MON_GROUPING         '())
+
+(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
+  P_CS_PRECEDES       INT_P_CS_PRECEDES
+  #t                  #t)
+(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
+  N_CS_PRECEDES       INT_N_CS_PRECEDES
+  #t                  #t)
+
+
+(define-monetary-langinfo-mapping locale-positive-separated-by-space?
+  ;; Whether a space should be inserted between a positive amount and the
+  ;; currency symbol.
+  P_SEP_BY_SPACE      INT_P_SEP_BY_SPACE
+  #t                  #t)
+(define-monetary-langinfo-mapping locale-negative-separated-by-space?
+  ;; Whether a space should be inserted between a negative amount and the
+  ;; currency symbol.
+  N_SEP_BY_SPACE      INT_N_SEP_BY_SPACE
+  #t                  #t)
+
+(define-monetary-langinfo-mapping locale-positive-sign-position
+  ;; Position of the positive sign wrt. currency symbol and quantity in a
+  ;; monetary amount.
+  P_SIGN_POSN         INT_P_SIGN_POSN
+  'unspecified        'unspecified)
+(define-monetary-langinfo-mapping locale-negative-sign-position
+  ;; Position of the negative sign wrt. currency symbol and quantity in a
+  ;; monetary amount.
+  N_SIGN_POSN         INT_N_SIGN_POSN
+  'unspecified        'unspecified)
+
+
+(define (integer->string number)
+  "Return a string representing NUMBER, an integer, written in base 10."
+  (define (digit->char digit)
+    (integer->char (+ digit (char->integer #\0))))
+
+  (if (zero? number)
+      "0"
+      (let loop ((number number)
+                 (digits '()))
+        (if (zero? number)
+            (list->string digits)
+            (loop (quotient number 10)
+                  (cons (digit->char (modulo number 10))
+                        digits))))))
+
+(define (number-decimal-string number digit-count)
+  "Return a string representing the decimal part of NUMBER.  When
+DIGIT-COUNT is an integer, return exactly DIGIT-COUNT digits; when
+DIGIT-COUNT is #t, return as many decimals as necessary, up to an
+arbitrary limit."
+  (define max-decimals
+    5)
+
+  ;; XXX: This is brute-force and could be improved by following one of
+  ;; the "Printing Floating-Point Numbers Quickly and Accurately"
+  ;; papers.
+  (if (integer? digit-count)
+      (let ((number (* (expt 10 digit-count)
+                       (- number (floor number)))))
+        (string-pad (integer->string (round (inexact->exact number)))
+                    digit-count
+                    #\0))
+      (let loop ((decimals 0))
+        (let ((number\' (* number (expt 10 decimals))))
+          (if (or (= number\' (floor number\'))
+                  (>= decimals max-decimals))
+              (let* ((fraction (- number\'
+                                  (* (floor number)
+                                     (expt 10 decimals))))
+                     (str      (integer->string
+                                (round (inexact->exact fraction)))))
+                (if (zero? fraction)
+                    ""
+                    str))
+              (loop (+ decimals 1)))))))
+
+(define (%number-integer-part int grouping separator)
+  ;; Process INT (a string denoting a number's integer part) and return a new
+  ;; string with digit grouping and separators according to GROUPING (a list,
+  ;; potentially circular) and SEPARATOR (a string).
+
+  ;; Process INT from right to left.
+  (let loop ((int      int)
+             (grouping grouping)
+             (result   '()))
+    (cond ((string=? int "") (apply string-append result))
+          ((null? grouping)  (apply string-append int result))
+          (else
+           (let* ((len (string-length int))
+                  (cut (min (car grouping) len)))
+             (loop (substring int 0 (- len cut))
+                   (cdr grouping)
+                   (let ((sub (substring int (- len cut) len)))
+                     (if (> len cut)
+                         (cons* separator sub result)
+                         (cons sub result)))))))))
+
+(define (add-monetary-sign+currency amount figure intl? locale)
+  ;; Add a sign and currency symbol around FIGURE.  FIGURE should be a
+  ;; formatted unsigned amount (a string) representing AMOUNT.
+  (let* ((positive? (> amount 0))
+         (sign
+          (cond ((> amount 0) (locale-monetary-positive-sign locale))
+                ((< amount 0) (locale-monetary-negative-sign locale))
+                (else         "")))
+         (currency (locale-currency-symbol intl? locale))
+         (currency-precedes?
+          (if positive?
+              locale-currency-symbol-precedes-positive?
+              locale-currency-symbol-precedes-negative?))
+         (separated?
+          (if positive?
+              locale-positive-separated-by-space?
+              locale-negative-separated-by-space?))
+         (sign-position
+          (if positive?
+              locale-positive-sign-position
+              locale-negative-sign-position))
+         (currency-space
+          (if (separated? intl? locale) " " ""))
+         (append-currency
+          (lambda (amt)
+            (if (currency-precedes? intl? locale)
+                (string-append currency currency-space amt)
+                (string-append amt currency-space currency)))))
+
+    (case (sign-position intl? locale)
+      ((parenthesize)
+       (string-append "(" (append-currency figure) ")"))
+      ((sign-before)
+       (string-append sign (append-currency figure)))
+      ((sign-after unspecified)
+       ;; following glibc's recommendation for `unspecified'.
+       (if (currency-precedes? intl? locale)
+           (string-append currency currency-space sign figure)
+           (string-append figure currency-space currency sign)))
+      ((sign-before-currency-symbol)
+       (if (currency-precedes? intl? locale)
+           (string-append sign currency currency-space figure)
+           (string-append figure currency-space sign currency))) ;; unlikely
+      ((sign-after-currency-symbol)
+       (if (currency-precedes? intl? locale)
+           (string-append currency sign currency-space figure)
+           (string-append figure currency-space currency sign)))
+      (else
+       (error "unsupported sign position" (sign-position intl? locale))))))
+
+
+(define* (monetary-amount->locale-string amount intl?
+                                         #\optional (locale %global-locale))
+  "Convert @var{amount} (an inexact) into a string according to the cultural
+conventions of either @var{locale} (a locale object) or the current locale.
+If @var{intl?} is true, then the international monetary format for the given
+locale is used."
+
+  (let* ((fraction-digits
+          (or (locale-monetary-fractional-digits intl? locale) 2))
+         (decimal-part
+          (lambda (dec)
+            (if (or (string=? dec "") (eq? 0 fraction-digits))
+                ""
+                (string-append (locale-monetary-decimal-point locale)
+                               (if (< fraction-digits (string-length dec))
+                                   (substring dec 0 fraction-digits)
+                                   dec)))))
+
+         (int       (integer->string (inexact->exact
+                                      (floor (abs amount)))))
+         (dec       (decimal-part
+                     (number-decimal-string (abs amount)
+                                            fraction-digits)))
+         (grouping  (locale-monetary-digit-grouping locale))
+         (separator (locale-monetary-thousands-separator locale)))
+
+      (add-monetary-sign+currency amount
+                                  (string-append
+                                   (%number-integer-part int grouping
+                                                         separator)
+                                   dec)
+                                  intl? locale)))
+
+
+
+;;;
+;;; Number formatting.
+;;;
+
+(define-simple-langinfo-mapping locale-digit-grouping
+  GROUPING             '())
+(define-simple-langinfo-mapping locale-decimal-point
+  RADIXCHAR            ".")
+(define-simple-langinfo-mapping locale-thousands-separator
+  THOUSEP              "")
+
+(define* (number->locale-string number
+                                #\optional (fraction-digits #t)
+                                           (locale %global-locale))
+  "Convert @var{number} (an inexact) into a string according to the cultural
+conventions of either @var{locale} (a locale object) or the current locale.
+By default, print as many fractional digits as necessary, up to an upper bound.
+Optionally, @var{fraction-digits} may be bound to an integer specifying the
+number of fractional digits to be displayed."
+
+  (let* ((sign
+          (cond ((> number 0) "")
+                ((< number 0) "-")
+                (else         "")))
+         (decimal-part
+          (lambda (dec)
+            (if (or (string=? dec "") (eq? 0 fraction-digits))
+                ""
+                (string-append (locale-decimal-point locale)
+                               (if (and (integer? fraction-digits)
+                                        (< fraction-digits
+                                           (string-length dec)))
+                                   (substring dec 0 fraction-digits)
+                                   dec))))))
+
+    (let* ((int       (integer->string (inexact->exact
+                                        (floor (abs number)))))
+           (dec       (decimal-part
+                       (number-decimal-string (abs number)
+                                              fraction-digits)))
+           (grouping  (locale-digit-grouping locale))
+           (separator (locale-thousands-separator locale)))
+
+      (string-append sign
+                     (%number-integer-part int grouping separator)
+                     dec))))
+
+
+;;;
+;;; Miscellaneous.
+;;;
+
+(define-simple-langinfo-mapping locale-yes-regexp
+  YESEXPR              "^[yY]")
+(define-simple-langinfo-mapping locale-no-regexp
+  NOEXPR               "^[nN]")
+
+;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
+
+;;; i18n.scm ends here
+;;; Encoding and decoding byte representations of strings
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (ice-9 iconv)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\use-module ((ice-9 rdelim) #\select (read-string))
+  #\export (string->bytevector
+            bytevector->string
+            call-with-encoded-output-string))
+
+;; Like call-with-output-string, but actually closes the port.
+(define (call-with-output-string* proc)
+  (let ((port (open-output-string)))
+    (proc port)
+    (let ((str (get-output-string port)))
+      (close-port port)
+      str)))
+
+(define (call-with-output-bytevector* proc)
+  (call-with-values (lambda () (open-bytevector-output-port))
+    (lambda (port get-bytevector)
+      (proc port)
+      (let ((bv (get-bytevector)))
+        (close-port port)
+        bv))))
+
+(define* (call-with-encoded-output-string encoding proc
+                                          #\optional
+                                          (conversion-strategy 'error))
+  "Call PROC on a fresh port.  Encode the resulting string as a
+bytevector according to ENCODING, and return the bytevector."
+  (if (and (string-ci=? encoding "utf-8")
+           (eq? conversion-strategy 'error))
+      ;; I don't know why, but this appears to be faster; at least for
+      ;; serving examples/debug-sxml.scm (1464 reqs/s versus 850
+      ;; reqs/s).
+      (string->utf8 (call-with-output-string* proc))
+      (call-with-output-bytevector*
+       (lambda (port)
+         (set-port-encoding! port encoding)
+         (if conversion-strategy
+             (set-port-conversion-strategy! port conversion-strategy))
+         (proc port)))))
+
+;; TODO: Provide C implementations that call scm_from_stringn and
+;; friends?
+
+(define* (string->bytevector str encoding
+                             #\optional (conversion-strategy 'error))
+  "Encode STRING according to ENCODING, which should be a string naming
+a character encoding, like \"utf-8\"."
+  (if (and (string-ci=? encoding "utf-8")
+           (eq? conversion-strategy 'error))
+      (string->utf8 str)
+      (call-with-encoded-output-string
+       encoding
+       (lambda (port)
+         (display str port))
+       conversion-strategy)))
+
+(define* (bytevector->string bv encoding
+                             #\optional (conversion-strategy 'error))
+  "Decode the string represented by BV.  The bytes in the bytevector
+will be interpreted according to ENCODING, which should be a string
+naming a character encoding, like \"utf-8\"."
+  (if (and (string-ci=? encoding "utf-8")
+           (eq? conversion-strategy 'error))
+      (utf8->string bv)
+      (let ((p (open-bytevector-input-port bv)))
+        (set-port-encoding! p encoding)
+        (if conversion-strategy
+            (set-port-conversion-strategy! p conversion-strategy))
+        (let ((res (read-string p)))
+          (close-port p)
+          (if (eof-object? res)
+              ""
+              res)))))
+;;; 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))
+
+
+;;;; 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?))
+;;; -*- 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
+               (error "what" type val))))))))))
+
+(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)))
+;;;; 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
+;;; 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))
+;;; -*- 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")
+;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*-
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;;> @example-import[(srfi 9)]
+
+;;> This is a full superset of the popular @hyperlink[
+;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
+;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
+;;> and thus preserving hygiene.
+
+;;> The most notable extensions are the ability to use @emph{non-linear}
+;;> patterns - patterns in which the same identifier occurs multiple
+;;> times, tail patterns after ellipsis, and the experimental tree patterns.
+
+;;> @subsubsection{Patterns}
+
+;;> Patterns are written to look like the printed representation of
+;;> the objects they match.  The basic usage is
+
+;;> @scheme{(match expr (pat body ...) ...)}
+
+;;> where the result of @var{expr} is matched against each pattern in
+;;> turn, and the corresponding body is evaluated for the first to
+;;> succeed.  Thus, a list of three elements matches a list of three
+;;> elements.
+
+;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
+
+;;> If no patterns match an error is signalled.
+
+;;> Identifiers will match anything, and make the corresponding
+;;> binding available in the body.
+
+;;> @example{(match (list 1 2 3) ((a b c) b))}
+
+;;> If the same identifier occurs multiple times, the first instance
+;;> will match anything, but subsequent instances must match a value
+;;> which is @scheme{equal?} to the first.
+
+;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
+
+;;> The special identifier @scheme{_} matches anything, no matter how
+;;> many times it is used, and does not bind the result in the body.
+
+;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
+
+;;> To match a literal identifier (or list or any other literal), use
+;;> @scheme{quote}.
+
+;;> @example{(match 'a ('b 1) ('a 2))}
+
+;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
+;;> be used to quote a mostly literally matching object with selected
+;;> parts unquoted.
+
+;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
+
+;;> Often you want to match any number of a repeated pattern.  Inside
+;;> a list pattern you can append @scheme{...} after an element to
+;;> match zero or more of that pattern (like a regexp Kleene star).
+
+;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
+;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
+
+;;> Pattern variables matched inside the repeated pattern are bound to
+;;> a list of each matching instance in the body.
+
+;;> @example{(match (list 1 2) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3) ((a b c ...) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
+
+;;> More than one @scheme{...} may not be used in the same list, since
+;;> this would require exponential backtracking in the general case.
+;;> However, @scheme{...} need not be the final element in the list,
+;;> and may be succeeded by a fixed number of patterns.
+
+;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
+;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
+
+;;> @scheme{___} is provided as an alias for @scheme{...} when it is
+;;> inconvenient to use the ellipsis (as in a syntax-rules template).
+
+;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
+;;> that it matches one or more repetitions (like a regexp "+").
+
+;;> @example{(match (list 1 2) ((a b c ..1) c))}
+;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
+
+;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
+;;> can be used to group and negate patterns analogously to their
+;;> Scheme counterparts.
+
+;;> The @scheme{and} operator ensures that all subpatterns match.
+;;> This operator is often used with the idiom @scheme{(and x pat)} to
+;;> bind @var{x} to the entire value that matches @var{pat}
+;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
+;;> conjunction with @scheme{not} patterns to match a general case
+;;> with certain exceptions.
+
+;;> @example{(match 1 ((and) #t))}
+;;> @example{(match 1 ((and x) x))}
+;;> @example{(match 1 ((and x 1) x))}
+
+;;> The @scheme{or} operator ensures that at least one subpattern
+;;> matches.  If the same identifier occurs in different subpatterns,
+;;> it is matched independently.  All identifiers from all subpatterns
+;;> are bound if the @scheme{or} operator matches, but the binding is
+;;> only defined for identifiers from the subpattern which matched.
+
+;;> @example{(match 1 ((or) #t) (else #f))}
+;;> @example{(match 1 ((or x) x))}
+;;> @example{(match 1 ((or x 2) x))}
+
+;;> The @scheme{not} operator succeeds if the given pattern doesn't
+;;> match.  None of the identifiers used are available in the body.
+
+;;> @example{(match 1 ((not 2) #t))}
+
+;;> The more general operator @scheme{?} can be used to provide a
+;;> predicate.  The usage is @scheme{(? predicate pat ...)} where
+;;> @var{predicate} is a Scheme expression evaluating to a predicate
+;;> called on the value to match, and any optional patterns after the
+;;> predicate are then matched as in an @scheme{and} pattern.
+
+;;> @example{(match 1 ((? odd? x) x))}
+
+;;> The field operator @scheme{=} is used to extract an arbitrary
+;;> field and match against it.  It is useful for more complex or
+;;> conditional destructuring that can't be more directly expressed in
+;;> the pattern syntax.  The usage is @scheme{(= field pat)}, where
+;;> @var{field} can be any expression, and should result in a
+;;> procedure of one argument, which is applied to the value to match
+;;> to generate a new value to match against @var{pat}.
+
+;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
+;;> to @scheme{(x . y)}, except it will result in an immediate error
+;;> if the value isn't a pair.
+
+;;> @example{(match '(1 . 2) ((= car x) x))}
+;;> @example{(match 4 ((= sqrt x) x))}
+
+;;> The record operator @scheme{$} is used as a concise way to match
+;;> records defined by SRFI-9 (or SRFI-99).  The usage is
+;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
+;;> type descriptor specified as the first argument to
+;;> @scheme{define-record-type}, and each @var{field} is a subpattern
+;;> matched against the fields of the record in order.  Not all fields
+;;> must be present.
+
+;;> @example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     (($ employee n t) (list t n))))
+;;> }
+
+;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
+;;> identifier to the setter and getter of a field, respectively.  The
+;;> setter is a procedure of one argument, which mutates the field to
+;;> that argument.  The getter is a procedure of no arguments which
+;;> returns the current value of the field.
+
+;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
+;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
+
+;;> The new operator @scheme{***} can be used to search a tree for
+;;> subpatterns.  A pattern of the form @scheme{(x *** y)} represents
+;;> the subpattern @var{y} located somewhere in a tree where the path
+;;> from the current object to @var{y} can be seen as a list of the
+;;> form @scheme{(x ...)}.  @var{y} can immediately match the current
+;;> object in which case the path is the empty list.  In a sense it's
+;;> a 2-dimensional version of the @scheme{...} pattern.
+
+;;> As a common case the pattern @scheme{(_ *** y)} can be used to
+;;> search for @var{y} anywhere in a tree, regardless of the path
+;;> used.
+
+;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
+;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Notes
+
+;; The implementation is a simple generative pattern matcher - each
+;; pattern is expanded into the required tests, calling a failure
+;; continuation if the tests fail.  This makes the logic easy to
+;; follow and extend, but produces sub-optimal code in cases where you
+;; have many similar clauses due to repeating the same tests.
+;; Nonetheless a smart compiler should be able to remove the redundant
+;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
+;; performance hit.
+
+;; The original version was written on 2006/11/29 and described in the
+;; following Usenet post:
+;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
+;; and is still available at
+;;   http://synthcode.com/scheme/match-simple.scm
+;; It's just 80 lines for the core MATCH, and an extra 40 lines for
+;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
+;;
+;; A variant of this file which uses COND-EXPAND in a few places for
+;; performance can be found at
+;;   http://synthcode.com/scheme/match-cond-expand.scm
+;;
+;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
+;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
+;;              the pattern (thanks to Stefan Israelsson Tampe)
+;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
+;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
+;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
+;; 2009/11/25 - adding `***' tree search patterns
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipse patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
+;;              (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; force compile-time syntax errors with useful messages
+
+(define-syntax match-syntax-error
+  (syntax-rules ()
+    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> @subsubsection{Syntax}
+
+;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
+;;> (match expr (pattern (=> failure) . body) ...)}}
+
+;;> The result of @var{expr} is matched against each @var{pattern} in
+;;> turn, according to the pattern rules described in the previous
+;;> section, until the the first @var{pattern} matches.  When a match is
+;;> found, the corresponding @var{body}s are evaluated in order,
+;;> and the result of the last expression is returned as the result
+;;> of the entire @scheme{match}.  If a @var{failure} is provided,
+;;> then it is bound to a procedure of no arguments which continues,
+;;> processing at the next @var{pattern}.  If no @var{pattern} matches,
+;;> an error is signalled.
+
+;; The basic interface.  MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable `v',
+;; and passes it on to MATCH-NEXT.  It's a constant throughout the
+;; code below that the binding `v' is a direct variable reference, not
+;; an expression.
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (let ((v atom))
+       (match-next v (atom (set! atom)) (pat . body) ...)))
+    ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.  `g+s' is a list of two elements, the get! and set!
+;; expressions respectively.
+
+(define-syntax match-next
+  (syntax-rules (=>)
+    ;; no more clauses, the match failed
+    ((match-next v g+s)
+     ;; Here we wrap error within a double set of parentheses, so that
+     ;; the call to 'error' won't be in tail position.  This allows the
+     ;; backtrace to show the source location of the failing match form.
+     ((error 'match "no matching pattern" v)))
+    ;; named failure continuation
+    ((match-next v g+s (pat (=> failure) . body) . rest)
+     (let ((failure (lambda () (match-next v g+s . rest))))
+       ;; match-one analyzes the pattern for us
+       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
+    ;; anonymous failure continuation, give it a dummy name
+    ((match-next v g+s (pat . body) . rest)
+     (match-next v g+s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+  (syntax-rules ()
+    ;; If it's a list of two or more values, check to see if the
+    ;; second one is an ellipse and handle accordingly, otherwise go
+    ;; to MATCH-TWO.
+    ((match-one v (p q . r) g+s sk fk i)
+     (match-check-ellipse
+      q
+      (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
+      (match-two v (p q . r) g+s sk fk i)))
+    ;; Go directly to MATCH-TWO.
+    ((match-one . x)
+     (match-two . x))))
+
+;; This is the guts of the pattern matcher.  We are passed a lot of
+;; information in the form:
+;;
+;;   (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; usually abbreviated
+;;
+;;   (match-two v p g+s sk fk i)
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+  (syntax-rules (_ ___ \.\.1 *** quote quasiquote ? $ = and or not set! get!)
+    ((match-two v () g+s (sk ...) fk i)
+     (if (null? v) (sk ... i) fk))
+    ((match-two v (quote p) g+s (sk ...) fk i)
+     (if (equal? v 'p) (sk ... i) fk))
+    ((match-two v (quasiquote p) . x)
+     (match-quasiquote v p . x))
+    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
+    ((match-two v (and p q ...) g+s sk fk i)
+     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
+    ((match-two v (or) g+s sk fk i) fk)
+    ((match-two v (or p) . x)
+     (match-one v p . x))
+    ((match-two v (or p ...) g+s sk fk i)
+     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
+    ((match-two v (not p) g+s (sk ...) fk i)
+     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+    ((match-two v (get! getter) (g s) (sk ...) fk i)
+     (let ((getter (lambda () g))) (sk ... i)))
+    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
+     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+    ((match-two v (? pred . p) g+s sk fk i)
+     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
+    ((match-two v (= proc p) . x)
+     (let ((w (proc v))) (match-one w p . x)))
+    ((match-two v (p ___ . r) g+s sk fk i)
+     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
+    ((match-two v (p) g+s sk fk i)
+     (if (and (pair? v) (null? (cdr v)))
+         (let ((w (car v)))
+           (match-one w p ((car v) (set-car! v)) sk fk i))
+         fk))
+    ((match-two v (p *** q) g+s sk fk i)
+     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
+    ((match-two v (p *** . q) g+s sk fk i)
+     (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v (p \.\.1) g+s sk fk i)
+     (if (pair? v)
+         (match-one v (p ___) g+s sk fk i)
+         fk))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (p . q) g+s sk fk i)
+     (if (pair? v)
+         (let ((w (car v)) (x (cdr v)))
+           (match-one w p ((car v) (set-car! v))
+                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
+                      fk
+                      i))
+         fk))
+    ((match-two v #(p ...) g+s . x)
+     (match-vector v 0 () (p ...) . x))
+    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
+    ;; Not a pair or vector or special literal, test to see if it's a
+    ;; new symbol, in which case we just bind it, or if it's an
+    ;; already bound symbol or some other literal, in which case we
+    ;; compare it with EQUAL?.
+    ((match-two v x g+s (sk ...) fk (id ...))
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (id ...)
+             ((new-sym? x sk2 fk2) sk2)
+             ((new-sym? y sk2 fk2) fk2))))
+       (new-sym? random-sym-to-match
+                 (let ((x v)) (sk ... (id ... x)))
+                 (if (equal? v x) (sk ... (id ...)) fk))))
+    ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+  (syntax-rules (unquote unquote-splicing quasiquote)
+    ((_ v (unquote p) g+s sk fk i)
+     (match-one v p g+s sk fk i))
+    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
+     (if (pair? v)
+       (match-one v
+                  (p . tmp)
+                  (match-quasiquote tmp rest g+s sk fk)
+                  fk
+                  i)
+       fk))
+    ((_ v (quasiquote p) g+s sk fk i . depth)
+     (match-quasiquote v p g+s sk fk i #f . depth))
+    ((_ v (unquote p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (p . q) g+s sk fk i . depth)
+     (if (pair? v)
+       (let ((w (car v)) (x (cdr v)))
+         (match-quasiquote
+          w p g+s
+          (match-quasiquote-step x q g+s sk fk depth)
+          fk i . depth))
+       fk))
+    ((_ v #(elt ...) g+s sk fk i . depth)
+     (if (vector? v)
+       (let ((ls (vector->list v)))
+         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
+       fk))
+    ((_ v x g+s sk fk i . depth)
+     (match-one v 'x g+s sk fk i))))
+
+(define-syntax match-quasiquote-step
+  (syntax-rules ()
+    ((match-quasiquote-step x q g+s sk fk depth i)
+     (match-quasiquote x q g+s sk fk i . depth))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; Takes two values and just expands into the first.
+(define-syntax match-drop-ids
+  (syntax-rules ()
+    ((_ expr ids ...) expr)))
+
+(define-syntax match-tuck-ids
+  (syntax-rules ()
+    ((_ (letish args (expr ...)) ids ...)
+     (letish args (expr ... ids ...)))))
+
+(define-syntax match-drop-first-arg
+  (syntax-rules ()
+    ((_ arg expr) expr)))
+
+;; To expand an OR group we try each clause in succession, passing the
+;; first that succeeds to the success continuation.  On failure for
+;; any clause, we just try the next clause, finally resorting to the
+;; failure continuation fk if all clauses fail.  The only trick is
+;; that we want to unify the identifiers, so that the success
+;; continuation can refer to a variable from any of the OR clauses.
+
+(define-syntax match-gen-or
+  (syntax-rules ()
+    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
+     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+  (syntax-rules ()
+    ((_ v () g+s sk fk . x)
+     ;; no OR clauses, call the failure continuation
+     fk)
+    ((_ v (p) . x)
+     ;; last (or only) OR clause, just expand normally
+     (match-one v p . x))
+    ((_ v (p . q) g+s sk fk i)
+     ;; match one and try the remaining on failure
+     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+       (match-one v p g+s sk (fk2) i)))
+    ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists.
+
+;; Look at the body of the simple case - it's just a named let loop,
+;; matching each element in turn to the same pattern.  The only trick
+;; is that we want to keep track of the lists of each extracted id, so
+;; when the loop recurses we cons the ids onto their respective list
+;; variables, and on success we bind the ids (what the user input and
+;; expects to see in the success body) to the reversed accumulated
+;; list IDs.
+
+(define-syntax match-gen-ellipses
+  (syntax-rules ()
+    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
+     (match-check-identifier p
+       ;; simplest case equivalent to (p ...), just bind the list
+       (let ((p v))
+         (if (list? p)
+             (sk ... i)
+             fk))
+       ;; simple case, match all elements of the list
+       (let loop ((ls v) (id-ls '()) ...)
+         (cond
+           ((null? ls)
+            (let ((id (reverse id-ls)) ...) (sk ... i)))
+           ((pair? ls)
+            (let ((w (car ls)))
+              (match-one w p ((car ls) (set-car! ls))
+                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+                         fk i)))
+           (else
+            fk)))))
+    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+     ;; general case, trailing patterns to match, keep track of the
+     ;; remaining list length so we don't need any backtracking
+     (match-verify-no-ellipses
+      r
+      (let* ((tail-len (length 'r))
+             (ls v)
+             (len (and (list? ls) (length ls))))
+        (if (or (not len) (< len tail-len))
+            fk
+            (let loop ((ls ls) (n len) (id-ls '()) ...)
+              (cond
+                ((= n tail-len)
+                 (let ((id (reverse id-ls)) ...)
+                   (match-one ls r (#f #f) (sk ...) fk i)))
+                ((pair? ls)
+                 (let ((w (car ls)))
+                   (match-one w p ((car ls) (set-car! ls))
+                              (match-drop-ids
+                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+                              fk
+                              i)))
+                (else
+                 fk)))))))))
+
+;; This is just a safety check.  Although unlike syntax-rules we allow
+;; trailing patterns after an ellipses, we explicitly disable multiple
+;; ellipses at the same level.  This is because in the general case
+;; such patterns are exponential in the number of ellipses, and we
+;; don't want to make it easy to construct very expensive operations
+;; with simple looking patterns.  For example, it would be O(n^2) for
+;; patterns like (a ... b ...) because we must consider every trailing
+;; element for every possible break for the leading "a ...".
+
+(define-syntax match-verify-no-ellipses
+  (syntax-rules ()
+    ((_ (x . y) sk)
+     (match-check-ellipse
+      x
+      (match-syntax-error
+       "multiple ellipse patterns not allowed at same level")
+      (match-verify-no-ellipses y sk)))
+    ((_ () sk)
+     sk)
+    ((_ x sk)
+     (match-syntax-error "dotted tail not allowed after ellipse" x))))
+
+;; To implement the tree search, we use two recursive procedures.  TRY
+;; attempts to match Y once, and on success it calls the normal SK on
+;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
+;; call NEXT which first checks if the current value is a list
+;; beginning with X, then calls TRY on each remaining element of the
+;; list.  Since TRY will recursively call NEXT again on failure, this
+;; effects a full depth-first search.
+;;
+;; The failure continuation throughout is a jump to the next step in
+;; the tree search, initialized with the original failure continuation
+;; FK.
+
+(define-syntax match-gen-search
+  (syntax-rules ()
+    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
+     (letrec ((try (lambda (w fail id-ls ...)
+                     (match-one w q g+s
+                                (match-tuck-ids
+                                 (let ((id (reverse id-ls)) ...)
+                                   sk))
+                                (next w fail id-ls ...) i)))
+              (next (lambda (w fail id-ls ...)
+                      (if (not (pair? w))
+                          (fail)
+                          (let ((u (car w)))
+                            (match-one
+                             u p ((car w) (set-car! w))
+                             (match-drop-ids
+                              ;; accumulate the head variables from
+                              ;; the p pattern, and loop over the tail
+                              (let ((id-ls (cons id id-ls)) ...)
+                                (let lp ((ls (cdr w)))
+                                  (if (pair? ls)
+                                      (try (car ls)
+                                           (lambda () (lp (cdr ls)))
+                                           id-ls ...)
+                                      (fail)))))
+                             (fail) i))))))
+       ;; the initial id-ls binding here is a dummy to get the right
+       ;; number of '()s
+       (let ((id-ls '()) ...)
+         (try v (lambda () fk) id-ls ...))))))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+  (syntax-rules (___)
+    ((_ v n pats (p q) . x)
+     (match-check-ellipse q
+                          (match-gen-vector-ellipses v n pats p . x)
+                          (match-vector-two v n pats (p q) . x)))
+    ((_ v n pats (p ___) sk fk i)
+     (match-gen-vector-ellipses v n pats p sk fk i))
+    ((_ . x)
+     (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) () sk fk i)
+     (if (vector? v)
+         (let ((len (vector-length v)))
+           (if (= len n)
+               (match-vector-step v ((pat index) ...) sk fk i)
+               fk))
+         fk))
+    ((_ v n (pats ...) (p . q) . x)
+     (match-vector v (+ n 1) (pats ... (p n)) q . x))))
+
+(define-syntax match-vector-step
+  (syntax-rules ()
+    ((_ v () (sk ...) fk i) (sk ... i))
+    ((_ v ((pat index) . rest) sk fk i)
+     (let ((w (vector-ref v index)))
+       (match-one w pat ((vector-ref v index) (vector-set! v index))
+                  (match-vector-step v rest sk fk)
+                  fk i)))))
+
+;; With a vector ellipse pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-gen-vector-ellipses
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) p sk fk i)
+     (if (vector? v)
+       (let ((len (vector-length v)))
+         (if (>= len n)
+           (match-vector-step v ((pat index) ...)
+                              (match-vector-tail v p n len sk fk)
+                              fk i)
+           fk))
+       fk))))
+
+(define-syntax match-vector-tail
+  (syntax-rules ()
+    ((_ v p n len sk fk i)
+     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+  (syntax-rules ()
+    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+     (let loop ((j n) (id-ls '()) ...)
+       (if (>= j len)
+         (let ((id (reverse id-ls)) ...) (sk ... i))
+         (let ((w (vector-ref v j)))
+           (match-one w p ((vector-ref v j) (vetor-set! v j))
+                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+                      fk i)))))))
+
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... i))))
+
+;; Extract all identifiers in a pattern.  A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and non-pattern forms (such as the predicate expression in ?
+;; patterns), and also ignore previously bound identifiers.
+;;
+;; Calls the continuation with all new vars as a list of the form
+;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
+;; pair with the original variable (e.g. it's used in the ellipse
+;; generation for list variables).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+  (syntax-rules (_ ___ \.\.1 *** ? $ = quote quasiquote and or not get! set!)
+    ((match-extract-vars (? pred . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars ($ rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (= proc p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (quote x) (k ...) i v)
+     (k ... v))
+    ((match-extract-vars (quasiquote x) k i v)
+     (match-extract-quasiquote-vars x k i v (#t)))
+    ((match-extract-vars (and . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (or . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (not . p) . x)
+     (match-extract-vars p . x))
+    ;; A non-keyword pair, expand the CAR with a continuation to
+    ;; expand the CDR.
+    ((match-extract-vars (p q . r) k i v)
+     (match-check-ellipse
+      q
+      (match-extract-vars (p . r) k i v)
+      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+    ((match-extract-vars (p . q) k i v)
+     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+    ((match-extract-vars #(p ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars _ (k ...) i v)    (k ... v))
+    ((match-extract-vars ___ (k ...) i v)  (k ... v))
+    ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ((match-extract-vars \.\.1 (k ...) i v)  (k ... v))
+    ;; This is the main part, the only place where we might add a new
+    ;; var if it's an unbound symbol.
+    ((match-extract-vars p (k ...) (i ...) v)
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (i ...)
+             ((new-sym? p sk fk) sk)
+             ((new-sym? any sk fk) fk))))
+       (new-sym? random-sym-to-match
+                 (k ... ((p p-ls) . v))
+                 (k ... v))))
+    ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+  (syntax-rules ()
+    ((_ p k i v ((v2 v2-ls) ...))
+     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+    ))
+
+(define-syntax match-extract-quasiquote-vars
+  (syntax-rules (quasiquote unquote unquote-splicing)
+    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+     (match-extract-quasiquote-vars x k i v (#t . d)))
+    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+     (match-extract-quasiquote-vars (unquote x) k i v d))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+     (match-extract-vars x k i v))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+     (match-extract-quasiquote-vars x k i v d))
+    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+     (match-extract-quasiquote-vars
+      x
+      (match-extract-quasiquote-vars-step y k i v d) i ()))
+    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+     (match-extract-quasiquote-vars (x ...) k i v d))
+    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+     (k ... v))
+    ))
+
+(define-syntax match-extract-quasiquote-vars-step
+  (syntax-rules ()
+    ((_ x k i v d ((v2 v2-ls) ...))
+     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+;;> Shortcut for @scheme{lambda} + @scheme{match}.  Creates a
+;;> procedure of one argument, and matches that argument against each
+;;> clause.
+
+(define-syntax match-lambda
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
+
+;;> Similar to @scheme{match-lambda}.  Creates a procedure of any
+;;> number of arguments, and matches the argument list against each
+;;> clause.
+
+(define-syntax match-lambda*
+  (syntax-rules ()
+    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
+
+;;> Matches each var to the corresponding expression, and evaluates
+;;> the body with all match variables in scope.  Raises an error if
+;;> any of the expressions fail to match.  Syntax analogous to named
+;;> let can also be used for recursive functions which match on their
+;;> arguments as in @scheme{match-lambda*}.
+
+(define-syntax match-let
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper let () () ((var value) ...) . body))
+    ((_ loop ((var init) ...) . body)
+     (match-named-let loop ((var init) ...) . body))))
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
+;;> matches and binds the variables with all match variables in scope.
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ ((var value) ...) . body)
+     (match-let/helper letrec () () ((var value) ...) . body))))
+
+(define-syntax match-let/helper
+  (syntax-rules ()
+    ((_ let ((var expr) ...) () () . body)
+     (let ((var expr) ...) . body))
+    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+     (let ((var expr) ...)
+       (match-let* ((pat tmp) ...)
+         . body)))
+    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
+
+(define-syntax match-named-let
+  (syntax-rules ()
+    ((_ loop ((pat expr var) ...) () . body)
+     (let loop ((var expr) ...)
+       (match-let ((pat var) ...)
+         . body)))
+    ((_ loop (v ...) ((pat expr) . rest) . body)
+     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
+
+;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
+;;> matches and binds the variables in sequence, with preceding match
+;;> variables in scope.
+
+(define-syntax match-let*
+  (syntax-rules ()
+    ((_ () . body)
+     (begin . body))
+    ((_ ((pat expr) . rest) . body)
+     (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Otherwise COND-EXPANDed bits.
+
+;; This *should* work, but doesn't :(
+;;   (define-syntax match-check-ellipse
+;;     (syntax-rules (...)
+;;       ((_ ... sk fk) sk)
+;;       ((_ x sk fk) fk)))
+
+;; This is a little more complicated, and introduces a new let-syntax,
+;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
+;; originally came up with the idea.
+(define-syntax match-check-ellipse
+  (syntax-rules ()
+    ;; these two aren't necessary but provide fast-case failures
+    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
+    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
+    ;; matching an atom
+    ((match-check-ellipse id success-k failure-k)
+     (let-syntax ((ellipse? (syntax-rules ()
+                              ;; iff `id' is `...' here then this will
+                              ;; match a list of any length
+                              ((ellipse? (foo id) sk fk) sk)
+                              ((ellipse? other sk fk) fk))))
+       ;; this list of three elements will only many the (foo id) list
+       ;; above if `id' is `...'
+       (ellipse? (a b c) success-k failure-k)))))
+
+
+;; This is portable but can be more efficient with non-portable
+;; extensions.  This trick was originally discovered by Oleg Kiselyov.
+
+(define-syntax match-check-identifier
+  (syntax-rules ()
+    ;; fast-case failures, lists and vectors are not identifiers
+    ((_ (x . y) success-k failure-k) failure-k)
+    ((_ #(x ...) success-k failure-k) failure-k)
+    ;; x is an atom
+    ((_ x success-k failure-k)
+     (let-syntax
+         ((sym?
+           (syntax-rules ()
+             ;; if the symbol `abracadabra' matches x, then x is a
+             ;; symbol
+             ((sym? x sk fk) sk)
+             ;; otherwise x is a non-symbol datum
+             ((sym? y sk fk) fk))))
+       (sym? abracadabra success-k failure-k)))))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2005, 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
+;;;; 
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
+(define (gethostbyaddr addr) (gethost addr))
+(define (gethostbyname name) (gethost name))
+
+(define (getnetbyaddr addr) (getnet addr))
+(define (getnetbyname name) (getnet name))
+
+(define (getprotobyname name) (getproto name))
+(define (getprotobynumber addr) (getproto addr))
+
+(define (getservbyname name proto) (getserv name proto))
+(define (getservbyport port proto) (getserv port proto))
+
+(define (sethostent . stayopen) 
+  (if (pair? stayopen)
+      (sethost (car stayopen))
+      (sethost #f)))
+(define (setnetent . stayopen) 
+  (if (pair? stayopen)
+      (setnet (car stayopen))
+      (setnet #f)))
+(define (setprotoent . stayopen) 
+  (if (pair? stayopen)
+      (setproto (car stayopen))
+      (setproto #f)))
+(define (setservent . stayopen) 
+  (if (pair? stayopen)
+      (setserv (car stayopen))
+      (setserv #f)))
+
+(define (gethostent) (gethost))
+(define (getnetent) (getnet))
+(define (getprotoent) (getproto))
+(define (getservent) (getserv))
+
+(define (endhostent) (sethost))
+(define (endnetent) (setnet))
+(define (endprotoent) (setproto))
+(define (endservent) (setserv))
+
+(define (hostent:name obj) (vector-ref obj 0))
+(define (hostent:aliases obj) (vector-ref obj 1))
+(define (hostent:addrtype obj) (vector-ref obj 2))
+(define (hostent:length obj) (vector-ref obj 3))
+(define (hostent:addr-list obj) (vector-ref obj 4))
+
+(define (netent:name obj) (vector-ref obj 0))
+(define (netent:aliases obj) (vector-ref obj 1))
+(define (netent:addrtype obj) (vector-ref obj 2))
+(define (netent:net obj) (vector-ref obj 3))
+
+(define (protoent:name obj) (vector-ref obj 0))
+(define (protoent:aliases obj) (vector-ref obj 1))
+(define (protoent:proto obj) (vector-ref obj 2))
+
+(define (servent:name obj) (vector-ref obj 0))
+(define (servent:aliases obj) (vector-ref obj 1))
+(define (servent:port obj) (vector-ref obj 2))
+(define (servent:proto obj) (vector-ref obj 3))
+
+(define (sockaddr:fam obj) (vector-ref obj 0))
+(define (sockaddr:path obj) (vector-ref obj 1))
+(define (sockaddr:addr obj) (vector-ref obj 1))
+(define (sockaddr:port obj) (vector-ref obj 2))
+(define (sockaddr:flowinfo obj) (vector-ref obj 3))
+(define (sockaddr:scopeid obj) (vector-ref obj 4))
+
+(define (addrinfo:flags obj) (vector-ref obj 0))
+(define (addrinfo:fam obj) (vector-ref obj 1))
+(define (addrinfo:socktype obj) (vector-ref obj 2))
+(define (addrinfo:protocol obj) (vector-ref obj 3))
+(define (addrinfo:addr obj) (vector-ref obj 4))
+(define (addrinfo:canonname obj) (vector-ref obj 5))
+;;;; 	Copyright (C) 2000, 2001, 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
+;;;; 
+
+;;;; The null environment - only syntactic bindings
+
+(define-module (ice-9 null)
+  \:re-export-syntax (define quote lambda if set!
+	
+		     cond case and or
+		      
+		     let let* letrec
+	   
+		     begin do
+	   
+		     delay
+	   
+		     quasiquote
+	   
+		     define-syntax
+		     let-syntax letrec-syntax))
+;;;; Occam-like channels
+
+;;; 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 occam-channel)
+  #\use-module (oop goops)
+  #\use-module (ice-9 threads)
+  #\export-syntax (alt
+		   ;; macro use:
+		   oc:lock oc:unlock oc:consequence
+		   oc:immediate-dispatch oc:late-dispatch oc:first-channel
+		   oc:set-handshake-channel oc:unset-handshake-channel)
+  #\export (make-channel
+	    ?
+	    !
+	    make-timer
+	    ;; macro use:
+	    handshake-channel mutex
+	    sender-waiting?
+	    immediate-receive late-receive
+	    )
+  )
+
+(define no-data '(no-data))
+(define receiver-waiting '(receiver-waiting))
+
+(define-class <channel> ())
+
+(define-class <data-channel> (<channel>)
+  (handshake-channel #\accessor handshake-channel)
+  (data #\accessor data #\init-value no-data)
+  (cv #\accessor cv #\init-form (make-condition-variable))
+  (mutex #\accessor mutex #\init-form (make-mutex)))
+
+(define-method (initialize (ch <data-channel>) initargs)
+  (next-method)
+  (set! (handshake-channel ch) ch))
+
+(define-method (make-channel)
+  (make <data-channel>))
+
+(define-method (sender-waiting? (ch <data-channel>))
+  (not (eq? (data ch) no-data)))
+
+(define-method (receiver-waiting? (ch <data-channel>))
+  (eq? (data ch) receiver-waiting))
+
+(define-method (immediate-receive (ch <data-channel>))
+  (signal-condition-variable (cv ch))
+  (let ((res (data ch)))
+    (set! (data ch) no-data)
+    res))
+
+(define-method (late-receive (ch <data-channel>))
+  (let ((res (data ch)))
+    (set! (data ch) no-data)
+    res))
+
+(define-method (? (ch <data-channel>))
+  (lock-mutex (mutex ch))
+  (let ((res (cond ((receiver-waiting? ch)
+		    (unlock-mutex (mutex ch))
+		    (scm-error 'misc-error '?
+			       "another process is already receiving on ~A"
+			       (list ch) #f))
+		   ((sender-waiting? ch)
+		    (immediate-receive ch))
+		   (else
+		    (set! (data ch) receiver-waiting)
+		    (wait-condition-variable (cv ch) (mutex ch))
+		    (late-receive ch)))))
+    (unlock-mutex (mutex ch))
+    res))
+
+(define-method (! (ch <data-channel>))
+  (! ch *unspecified*))
+
+(define-method (! (ch <data-channel>) (x <top>))
+  (lock-mutex (mutex (handshake-channel ch)))
+  (cond ((receiver-waiting? ch)
+	 (set! (data ch) x)
+	 (signal-condition-variable (cv (handshake-channel ch))))
+	((sender-waiting? ch)
+	 (unlock-mutex (mutex (handshake-channel ch)))
+	 (scm-error 'misc-error '! "another process is already sending on ~A"
+		    (list ch) #f))
+	(else
+	 (set! (data ch) x)
+	 (wait-condition-variable (cv ch) (mutex ch))))
+  (unlock-mutex (mutex (handshake-channel ch))))
+
+;;; Add protocols?
+
+(define-class <port-channel> (<channel>)
+  (port #\accessor port #\init-keyword #\port))
+
+(define-method (make-channel (port <port>))
+  (make <port-channel> #\port port))
+
+(define-method (? (ch <port-channel>))
+  (read (port ch)))
+
+(define-method (! (ch <port-channel>))
+  (write (port ch)))
+
+(define-class <timer-channel> (<channel>))
+
+(define the-timer (make <timer-channel>))
+
+(define timer-cv (make-condition-variable))
+(define timer-mutex (make-mutex))
+
+(define (make-timer)
+  the-timer)
+
+(define (timeofday->us t)
+  (+ (* 1000000 (car t)) (cdr t)))
+
+(define (us->timeofday n)
+  (cons (quotient n 1000000)
+	(remainder n 1000000)))
+
+(define-method (? (ch <timer-channel>))
+  (timeofday->us (gettimeofday)))
+
+(define-method (? (ch <timer-channel>) (t <integer>))
+  (lock-mutex timer-mutex)
+  (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
+  (unlock-mutex timer-mutex))
+
+;;; (alt CLAUSE ...)
+;;;
+;;; CLAUSE ::= ((? CH) FORM ...)
+;;;            | (EXP (? CH) FORM ...)
+;;;            | (EXP FORM ...)
+;;;
+;;; where FORM ... can be => (lambda (x) ...)
+;;;
+;;; *fixme* Currently only handles <data-channel>:s
+;;;
+
+(define-syntax oc:lock
+  (syntax-rules (?)
+    ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
+    ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
+    ((_ (exp form ...)) #f)))
+
+(define-syntax oc:unlock
+  (syntax-rules (?)
+    ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
+    ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
+    ((_ (exp form ...)) #f)))
+
+(define-syntax oc:consequence
+  (syntax-rules (=>)
+    ((_ data) data)
+    ((_ data => (lambda (x) e1 e2 ...))
+     (let ((x data)) e1 e2 ...))
+    ((_ data e1 e2 ...)
+     (begin data e1 e2 ...))))
+
+(define-syntax oc:immediate-dispatch
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     ((sender-waiting? ch)
+      (oc:consequence (immediate-receive ch) e1 ...)))
+    ((_ (exp (? ch) e1 ...))
+     ((and exp (sender-waiting? ch))
+      (oc:consequence (immediate-receive ch) e1 ...)))
+    ((_ (exp e1 ...))
+     (exp e1 ...))))
+
+(define-syntax oc:late-dispatch
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     ((sender-waiting? ch)
+      (oc:consequence (late-receive ch) e1 ...)))
+    ((_ (exp (? ch) e1 ...))
+     ((and exp (sender-waiting? ch))
+      (oc:consequence (late-receive ch) e1 ...)))
+    ((_ (exp e1 ...))
+     (#f))))
+
+(define-syntax oc:first-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...) c2 ...)
+     ch)
+    ((_ (exp (? ch) e1 ...) c2 ...)
+     ch)
+    ((_ c1 c2 ...)
+     (first-channel c2 ...))))
+
+(define-syntax oc:set-handshake-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...) handshake)
+     (set! (handshake-channel ch) handshake))
+    ((_ (exp (? ch) e1 ...) handshake)
+     (and exp (set! (handshake-channel ch) handshake)))
+    ((_ (exp e1 ...) handshake)
+     #f)))
+
+(define-syntax oc:unset-handshake-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     (set! (handshake-channel ch) ch))
+    ((_ (exp (? ch) e1 ...))
+     (and exp (set! (handshake-channel ch) ch)))
+    ((_ (exp e1 ...))
+     #f)))
+
+(define-syntax alt
+  (lambda (x)
+    (define (else-clause? x)
+      (syntax-case x (else)
+	((_) #f)
+	((_ (else e1 e2 ...)) #t)
+	((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
+    
+    (syntax-case x (else)
+      ((_ c1 c2 ...)
+       (else-clause? x)
+       (syntax (begin
+		 (oc:lock c1)
+		 (oc:lock c2) ...
+		 (let ((res (cond (oc:immediate-dispatch c1)
+				  (oc:immediate-dispatch c2) ...)))
+		   (oc:unlock c1)
+		   (oc:unlock c2) ...
+		   res))))
+      ((_ c1 c2 ...)
+       (syntax (begin
+		 (oc:lock c1)
+		 (oc:lock c2) ...
+		 (let ((res (cond (oc:immediate-dispatch c1)
+				  (oc:immediate-dispatch c2) ...
+				  (else (let ((ch (oc:first-channel c1 c2 ...)))
+					  (oc:set-handshake-channel c1 ch)
+					  (oc:set-handshake-channel c2 ch) ...
+					  (wait-condition-variable (cv ch)
+								   (mutex ch))
+					  (oc:unset-handshake-channel c1)
+					  (oc:unset-handshake-channel c2) ...
+					  (cond (oc:late-dispatch c1)
+						(oc:late-dispatch c2) ...))))))
+		   (oc:unlock c1)
+		   (oc:unlock c2) ...
+		   res)))))))
+;;;; optargs.scm -- support for optional arguments
+;;;;
+;;;; 	Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
+
+
+
+;;; Commentary:
+
+;;; {Optional Arguments}
+;;;
+;;; The C interface for creating Guile procedures has a very handy
+;;; "optional argument" feature. This module attempts to provide
+;;; similar functionality for procedures defined in Scheme with
+;;; a convenient and attractive syntax.
+;;;
+;;; exported macros are:
+;;;   let-optional
+;;;   let-optional*
+;;;   let-keywords
+;;;   let-keywords*
+;;;   lambda*
+;;;   define*
+;;;   define*-public
+;;;   defmacro*
+;;;   defmacro*-public
+;;;
+;;;
+;;; Summary of the lambda* extended parameter list syntax (brackets
+;;; are used to indicate grouping only):
+;;;
+;;; ext-param-list ::= [identifier]* [#\optional [ext-var-decl]+]?
+;;;   [#\key [ext-var-decl]+ [#\allow-other-keys]?]?
+;;;   [[#\rest identifier]|[. identifier]]?
+;;;
+;;; ext-var-decl ::= identifier | ( identifier expression )
+;;;
+;;; The characters `*', `+' and `?' are not to be taken literally; they
+;;; mean respectively, zero or more occurences, one or more occurences,
+;;; and one or zero occurences.
+;;;
+
+;;; Code:
+
+(define-module (ice-9 optargs)
+  #\use-module (system base pmatch)
+  #\re-export (lambda* define*)
+  #\export (let-optional
+            let-optional*
+            let-keywords
+            let-keywords*
+            define*-public
+            defmacro*
+            defmacro*-public))
+
+;; let-optional rest-arg (binding ...) . body
+;; let-optional* rest-arg (binding ...) . body
+;;   macros used to bind optional arguments
+;;
+;; These two macros give you an optional argument interface that is
+;; very "Schemey" and introduces no fancy syntax. They are compatible
+;; with the scsh macros of the same name, but are slightly
+;; extended. Each of binding may be of one of the forms <var> or
+;; (<var> <default-value>). rest-arg should be the rest-argument of
+;; the procedures these are used from. The items in rest-arg are
+;; sequentially bound to the variable namess are given. When rest-arg
+;; runs out, the remaining vars are bound either to the default values
+;; or to `#f' if no default value was specified. rest-arg remains
+;; bound to whatever may have been left of rest-arg.
+;;
+
+(define (vars&inits bindings)
+  (let lp ((bindings bindings) (vars '()) (inits '()))
+    (syntax-case bindings ()
+      (()
+       (values (reverse vars) (reverse inits)))
+      (((v init) . rest) (identifier? #'v)
+       (lp #'rest (cons #'v vars) (cons #'init inits)))
+      ((v . rest) (identifier? #'v)
+       (lp #'rest (cons #'v vars) (cons #'#f inits))))))
+
+(define-syntax let-optional
+  (lambda (x)
+    (syntax-case x ()
+      ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+       (call-with-values (lambda () (vars&inits #'(binding ...)))
+         (lambda (vars inits)
+           (with-syntax ((n (length vars))
+                         (n+1 (1+ (length vars)))
+                         (vars (append vars (list #'rest-arg)))
+                         ((t ...) (generate-temporaries vars))
+                         ((i ...) inits))
+             #'(let ((t (lambda vars i))
+                     ...)
+                 (apply (lambda vars b0 b1 ...)
+                        (or (parse-lambda-case '(0 n n n+1 #f '())
+                                               (list t ...)
+                                               rest-arg)
+                            (error "sth" rest-arg)))))))))))
+
+(define-syntax let-optional*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+       (call-with-values (lambda () (vars&inits #'(binding ...)))
+         (lambda (vars inits)
+           (with-syntax ((n (length vars))
+                         (n+1 (1+ (length vars)))
+                         (vars (append vars (list #'rest-arg)))
+                         ((i ...) inits))
+             #'(apply (lambda vars b0 b1 ...)
+                      (or (parse-lambda-case '(0 n n n+1 #f '())
+                                             (list (lambda vars i) ...)
+                                             rest-arg)
+                          (error "sth" rest-arg))))))))))
+
+
+;; let-keywords rest-arg allow-other-keys? (binding ...) . body
+;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
+;;   macros used to bind keyword arguments
+;;
+;; These macros pick out keyword arguments from rest-arg, but do not
+;; modify it. This is consistent at least with Common Lisp, which
+;; duplicates keyword args in the rest arg. More explanation of what
+;; keyword arguments in a lambda list look like can be found below in
+;; the documentation for lambda*.  Bindings can have the same form as
+;; for let-optional. If allow-other-keys? is false, an error will be
+;; thrown if anything that looks like a keyword argument but does not
+;; match a known keyword parameter will result in an error.
+;;
+
+
+(define-syntax let-keywords
+  (lambda (x)
+    (syntax-case x ()
+      ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+       (call-with-values (lambda () (vars&inits #'(binding ...)))
+         (lambda (vars inits)
+           (with-syntax ((n (length vars))
+                         (vars vars)
+                         (ivars (generate-temporaries vars))
+                         ((kw ...) (map symbol->keyword
+                                        (map syntax->datum vars)))
+                         ((idx ...) (iota (length vars)))
+                         ((t ...) (generate-temporaries vars))
+                         ((i ...) inits))
+             #'(let ((t (lambda ivars i))
+                     ...)
+                 (apply (lambda vars b0 b1 ...)
+                        (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+                                               (list t ...)
+                                               rest-arg)
+                            (error "sth" rest-arg))))))))
+      ((_ rest-arg aok (binding ...) b0 b1 ...)
+       #'(let ((r rest-arg))
+           (let-keywords r aok (binding ...) b0 b1 ...))))))
+
+(define-syntax let-keywords*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+       (call-with-values (lambda () (vars&inits #'(binding ...)))
+         (lambda (vars inits)
+           (with-syntax ((n (length vars))
+                         (vars vars)
+                         ((kw ...) (map symbol->keyword
+                                        (map syntax->datum vars)))
+                         ((idx ...) (iota (length vars)))
+                         ((i ...) inits))
+             #'(apply (lambda vars b0 b1 ...)
+                      (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+                                             (list (lambda vars i) ...)
+                                             rest-arg)
+                          (error "sth" rest-arg)))))))
+      ((_ rest-arg aok (binding ...) b0 b1 ...)
+       #'(let ((r rest-arg))
+           (let-keywords* r aok (binding ...) b0 b1 ...))))))
+
+;; lambda* args . body
+;;   lambda extended for optional and keyword arguments
+;;
+;; lambda* creates a procedure that takes optional arguments. These
+;; are specified by putting them inside brackets at the end of the
+;; paramater list, but before any dotted rest argument. For example,
+;;   (lambda* (a b #\optional c d . e) '())
+;; creates a procedure with fixed arguments a and b, optional arguments c
+;; and d, and rest argument e. If the optional arguments are omitted
+;; in a call, the variables for them are bound to `#f'.
+;;
+;; lambda* can also take keyword arguments. For example, a procedure
+;; defined like this:
+;;   (lambda* (#\key xyzzy larch) '())
+;; can be called with any of the argument lists (#\xyzzy 11)
+;; (#\larch 13) (#\larch 42 #\xyzzy 19) (). Whichever arguments
+;; are given as keywords are bound to values.
+;;
+;; Optional and keyword arguments can also be given default values
+;; which they take on when they are not present in a call, by giving a
+;; two-item list in place of an optional argument, for example in:
+;;   (lambda* (foo #\optional (bar 42) #\key (baz 73)) (list foo bar baz))
+;; foo is a fixed argument, bar is an optional argument with default
+;; value 42, and baz is a keyword argument with default value 73.
+;; Default value expressions are not evaluated unless they are needed
+;; and until the procedure is called.
+;;
+;; lambda* now supports two more special parameter list keywords.
+;;
+;; lambda*-defined procedures now throw an error by default if a
+;; keyword other than one of those specified is found in the actual
+;; passed arguments. However, specifying #\allow-other-keys
+;; immediately after the keyword argument declarations restores the
+;; previous behavior of ignoring unknown keywords. lambda* also now
+;; guarantees that if the same keyword is passed more than once, the
+;; last one passed is the one that takes effect. For example,
+;;   ((lambda* (#\key (heads 0) (tails 0)) (display (list heads tails)))
+;;    #\heads 37 #\tails 42 #\heads 99)
+;; would result in (99 47) being displayed.
+;;
+;; #\rest is also now provided as a synonym for the dotted syntax rest
+;; argument. The argument lists (a . b) and (a #\rest b) are equivalent in
+;; all respects to lambda*. This is provided for more similarity to DSSSL,
+;; MIT-Scheme and Kawa among others, as well as for refugees from other
+;; Lisp dialects.
+
+
+;; define* args . body
+;; define*-public args . body
+;;   define and define-public extended for optional and keyword arguments
+;;
+;; define* and define*-public support optional arguments with
+;; a similar syntax to lambda*. Some examples:
+;;   (define* (x y #\optional a (z 3) #\key w . u) (display (list y z u)))
+;; defines a procedure x with a fixed argument y, an optional agument
+;; a, another optional argument z with default value 3, a keyword argument w,
+;; and a rest argument u.
+;;
+;; Of course, define*[-public] also supports #\rest and #\allow-other-keys
+;; in the same way as lambda*.
+
+(define-syntax define*-public
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (id . args) b0 b1 ...)
+       #'(define-public id (lambda* args b0 b1 ...)))
+      ((_ id val) (identifier? #'id)
+       #'(define-public id val)))))
+
+
+;; defmacro* name args . body
+;; defmacro*-public args . body
+;;   defmacro and defmacro-public extended for optional and keyword arguments
+;;
+;; These are just like defmacro and defmacro-public except that they
+;; take lambda*-style extended paramter lists, where #\optional,
+;; #\key, #\allow-other-keys and #\rest are allowed with the usual
+;; semantics. Here is an example of a macro with an optional argument:
+;;   (defmacro* transmogrify (a #\optional b)
+
+(define-syntax defmacro*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ id args doc b0 b1 ...) (string? (syntax->datum #'doc))
+       #'(define-macro id doc (lambda* args b0 b1 ...)))
+      ((_ id args b0 b1 ...) 
+       #'(define-macro id #f (lambda* args b0 b1 ...))))))
+(define-syntax-rule (defmacro*-public id args b0 b1 ...)
+  (begin
+    (defmacro* id args b0 b1 ...)
+    (export-syntax id)))
+
+;;; Support for optional & keyword args with the interpreter.
+(define *uninitialized* (list 'uninitialized))
+(define (parse-lambda-case spec inits args)
+  (pmatch spec
+    ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+     (define (req args prev tail n)
+       (cond
+        ((zero? n)
+         (if prev (set-cdr! prev '()))
+         (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
+           (opt (if prev (append! args slots-tail) slots-tail)
+                slots-tail tail nopt inits)))
+        ((null? tail)
+         #f) ;; fail
+        (else
+         (req args tail (cdr tail) (1- n)))))
+     (define (opt slots slots-tail args-tail n inits)
+       (cond
+        ((zero? n)
+         (rest-or-key slots slots-tail args-tail inits rest-idx))
+        ((null? args-tail)
+         (set-car! slots-tail (apply (car inits) slots))
+         (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
+        (else
+         (set-car! slots-tail (car args-tail))
+         (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
+     (define (rest-or-key slots slots-tail args-tail inits rest-idx)
+       (cond
+        (rest-idx
+         ;; it has to be this way, vars are allocated in this order
+         (set-car! slots-tail args-tail)
+         (if (pair? kw-indices)
+             (permissive-keys slots (cdr slots-tail) args-tail inits)
+             (rest-or-key slots (cdr slots-tail) '() inits #f)))
+        ((pair? kw-indices)
+         ;; fail early here, because once we're in keyword land we throw
+         ;; errors instead of failing
+         (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
+              (key slots slots-tail args-tail inits)))
+        ((pair? args-tail)
+         #f) ;; fail
+        (else
+         slots)))
+     (define (permissive-keys slots slots-tail args-tail inits)
+       (cond
+        ((null? args-tail)
+         (if (null? inits)
+             slots
+             (begin
+               (if (eq? (car slots-tail) *uninitialized*)
+                   (set-car! slots-tail (apply (car inits) slots)))
+               (permissive-keys slots (cdr slots-tail) '() (cdr inits)))))
+        ((not (keyword? (car args-tail)))
+         (permissive-keys slots slots-tail (cdr args-tail) inits))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              (assq-ref kw-indices (car args-tail)))
+         => (lambda (i)
+              (list-set! slots i (cadr args-tail))
+              (permissive-keys slots slots-tail (cddr args-tail) inits)))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              allow-other-keys?)
+         (permissive-keys slots slots-tail (cddr args-tail) inits))
+        (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
+                         '() args-tail))))
+     (define (key slots slots-tail args-tail inits)
+       (cond
+        ((null? args-tail)
+         (if (null? inits)
+             slots
+             (begin
+               (if (eq? (car slots-tail) *uninitialized*)
+                   (set-car! slots-tail (apply (car inits) slots)))
+               (key slots (cdr slots-tail) '() (cdr inits)))))
+        ((not (keyword? (car args-tail)))
+         (if rest-idx
+             ;; no error checking, everything goes to the rest..
+             (key slots slots-tail '() inits)
+             (scm-error 'keyword-argument-error #f "Invalid keyword"
+                        '() args-tail)))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              (assq-ref kw-indices (car args-tail)))
+         => (lambda (i)
+              (list-set! slots i (cadr args-tail))
+              (key slots slots-tail (cddr args-tail) inits)))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              allow-other-keys?)
+         (key slots slots-tail (cddr args-tail) inits))
+        (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
+                         '() args-tail))))
+     (let ((args (list-copy args)))
+       (req args #f args nreq)))
+    (else (error "unexpected spec" spec))))
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 1996, 2001, 2006, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+(define-module  (ice-9 poe)
+  \:use-module (ice-9 hcons)
+  \:export (pure-funcq perfect-funcq))
+
+
+
+
+;;; {Pure Functions}
+;;; 
+;;; A pure function (of some sort) is characterized by two equality
+;;; relations: one on argument lists and one on return values.
+;;; A pure function is one that when applied to equal arguments lists
+;;; yields equal results.
+;;;
+;;; If the equality relationship on return values can be eq?, it may make
+;;; sense to cache values returned by the function.  Choosing the right
+;;; equality relation on arguments is tricky.
+;;;
+
+
+;;; {pure-funcq}
+;;;
+;;; The simplest case of pure functions are those in which results
+;;; are only certainly eq? if all of the arguments are.  These functions
+;;; are called "pure-funcq", for obvious reasons.
+;;;
+
+
+(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
+(define funcq-buffer (make-gc-buffer 256))
+
+(define (funcq-hash arg-list n)
+  (let ((it (let loop ((x 0)
+		       (arg-list arg-list))
+	      (if (null? arg-list)
+		  (modulo x n)
+		  (loop (logior x (hashq (car arg-list) 4194303))
+			(cdr arg-list))))))
+    it))
+
+;; return true if lists X and Y are the same length and each element is `eq?'
+(define (eq?-list x y)
+  (if (null? x)
+      (null? y)
+      (and (not (null? y))
+	   (eq? (car x) (car y))
+	   (eq?-list (cdr x) (cdr y)))))
+
+(define (funcq-assoc arg-list alist)
+  (if (null? alist)
+      #f
+      (if (eq?-list arg-list (caar alist))
+	  (car alist)
+	  (funcq-assoc arg-list (cdr alist)))))
+
+
+(define not-found (list 'not-found))
+
+
+(define (pure-funcq base-func)
+  (lambda args
+    (let* ((key (cons base-func args))
+           (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
+      (if (not (eq? cached not-found))
+	  (begin
+	    (funcq-buffer key)
+	    cached)
+	    
+	  (let ((val (apply base-func args)))
+	    (funcq-buffer key)
+	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
+	    val)))))
+
+
+
+;;; {Perfect funq}
+;;;
+;;; A pure funq may sometimes forget its past but a perfect
+;;; funcq never does.
+;;;
+
+(define (perfect-funcq size base-func)
+  (define funcq-memo (make-hash-table size))
+
+  (lambda args
+    (let* ((key (cons base-func args))
+           (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
+      (if (not (eq? cached not-found))
+	  (begin
+	    (funcq-buffer key)
+	    cached)
+	    
+	  (let ((val (apply base-func args)))
+	    (funcq-buffer key)
+	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
+	    val)))))
+;; poll
+
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+(define-module (ice-9 poll)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (rnrs bytevectors)
+  #\export (make-empty-poll-set
+            poll-set?
+            poll-set-nfds
+            poll-set-find-port
+            poll-set-port
+            poll-set-events
+            set-poll-set-events!
+            poll-set-revents
+            set-poll-set-revents!
+            poll-set-add!
+            poll-set-remove!
+            poll))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_poll"))
+
+(if (not (= %sizeof-struct-pollfd 8))
+    (error "Unexpected struct pollfd size" %sizeof-struct-pollfd))
+
+(if (defined? 'POLLIN)
+    (export POLLIN))
+
+(if (defined? 'POLLPRI)
+    (export POLLPRI))
+
+(if (defined? 'POLLOUT)
+    (export POLLOUT))
+
+(if (defined? 'POLLRDHUP)
+    (export POLLRDHUP))
+
+(if (defined? 'POLLERR)
+    (export POLLERR))
+
+(if (defined? 'POLLHUP)
+    (export POLLHUP))
+
+(if (defined? 'POLLNVAL)
+    (export POLLNVAL))
+
+
+(define-record-type <poll-set>
+  (make-poll-set pollfds nfds ports)
+  poll-set?
+  (pollfds pset-pollfds set-pset-pollfds!)
+  (nfds poll-set-nfds set-pset-nfds!)
+  (ports pset-ports set-pset-ports!)
+  )
+
+(define-syntax-rule (pollfd-offset n)
+  (* n 8))
+
+(define* (make-empty-poll-set #\optional (pre-allocated 4))
+  (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)
+                 0
+                 (make-vector pre-allocated #f)))
+
+(define (pset-size set)
+  (vector-length (pset-ports set)))
+
+(define (ensure-pset-size! set size)
+  (let ((prev (pset-size set)))
+    (if (< prev size)
+        (let lp ((new prev))
+          (if (< new size)
+              (lp (* new 2))
+              (let ((old-pollfds (pset-pollfds set))
+                    (nfds (poll-set-nfds set))
+                    (old-ports (pset-ports set))
+                    (new-pollfds (make-bytevector (pollfd-offset new) 0))
+                    (new-ports (make-vector new #f)))
+                (bytevector-copy! old-pollfds 0 new-pollfds 0
+                                  (pollfd-offset nfds))
+                (vector-move-left! old-ports 0 nfds new-ports 0)
+                (set-pset-pollfds! set new-pollfds)
+                (set-pset-ports! set new-ports)))))))
+
+(define (poll-set-find-port set port)
+  (let lp ((i 0))
+    (if (< i (poll-set-nfds set))
+        (if (equal? (vector-ref (pset-ports set) i) port)
+            i
+            (lp (1+ i)))
+        #f)))
+
+(define (poll-set-port set idx)
+  (if (< idx (poll-set-nfds set))
+      (vector-ref (pset-ports set) idx)
+      (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-events set idx)
+  (if (< idx (poll-set-nfds set))
+      (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4))
+      (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-events! set idx events)
+  (if (< idx (poll-set-nfds set))
+      (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4)
+                                  events)
+      (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-revents set idx)
+  (if (< idx (poll-set-nfds set))
+      (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6))
+      (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-revents! set idx revents)
+  (if (< idx (poll-set-nfds set))
+      (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6)
+                                  revents)
+      (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-add! set fd-or-port events)
+  (let* ((idx (poll-set-nfds set))
+         (off (pollfd-offset idx))
+         (fd (if (integer? fd-or-port)
+                 fd-or-port
+                 (port->fdes fd-or-port))))
+
+    (if (port? fd-or-port)
+        ;; As we store the port in the fdset, there is no need to
+        ;; increment the revealed count to prevent the fd from being
+        ;; closed by a gc'd port.
+        (release-port-handle fd-or-port))
+
+    (ensure-pset-size! set (1+ idx))
+    (bytevector-s32-native-set! (pset-pollfds set) off fd)
+    (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events)
+    (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents
+    (vector-set! (pset-ports set) idx fd-or-port)
+    (set-pset-nfds! set (1+ idx))))
+
+(define (poll-set-remove! set idx)
+  (if (not (< idx (poll-set-nfds set)))
+      (error "poll set index out of bounds" set idx))
+  (let ((nfds (poll-set-nfds set))
+        (off (pollfd-offset idx))
+        (port (vector-ref (pset-ports set) idx)))
+    (vector-move-left! (pset-ports set) (1+ idx) nfds
+                       (pset-ports set) idx)
+    (vector-set! (pset-ports set) (1- nfds) #f)
+    (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx))
+                      (pset-pollfds set) off
+                      (- (pollfd-offset nfds) (pollfd-offset (1+ idx))))
+    ;; zero the struct pollfd all at once
+    (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0)
+    (set-pset-nfds! set (1- nfds))
+    port))
+
+(define* (poll poll-set #\optional (timeout -1))
+  (primitive-poll (pset-pollfds poll-set)
+                  (poll-set-nfds poll-set)
+                  (pset-ports poll-set)
+                  timeout))
+;; popen emulation, for non-stdio based ports.
+
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 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 popen)
+  \:use-module (ice-9 threads)
+  \:use-module (srfi srfi-9)
+  \:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
+	   open-output-pipe open-input-output-pipe))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_popen"))
+
+(define-record-type <pipe-info>
+  (make-pipe-info pid)
+  pipe-info?
+  (pid pipe-info-pid set-pipe-info-pid!))
+
+(define (make-rw-port read-port write-port)
+  (make-soft-port
+   (vector
+    (lambda (c) (write-char c write-port))
+    (lambda (s) (display s write-port))
+    (lambda () (force-output write-port))
+    (lambda () (read-char read-port))
+    (lambda () (close-port read-port) (close-port write-port)))
+   "r+"))
+
+;; a guardian to ensure the cleanup is done correctly when
+;; an open pipe is gc'd or a close-port is used.
+(define pipe-guardian (make-guardian))
+
+;; a weak hash-table to store the process ids.
+;; XXX use of this table is deprecated.  It is no longer used here, and
+;; is populated for backward compatibility only (since it is exported).
+(define port/pid-table (make-weak-key-hash-table 31))
+(define port/pid-table-mutex (make-mutex))
+
+(define (open-pipe* mode command . args)
+  "Executes the program @var{command} with optional arguments
+@var{args} (all strings) in a subprocess.
+A port to the process (based on pipes) is created and returned.
+@var{mode} specifies whether an input, an output or an input-output
+port to the process is created: it should be the value of
+@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
+  (call-with-values (lambda ()
+                      (apply open-process mode command args))
+    (lambda (read-port write-port pid)
+      (let ((port (or (and read-port write-port
+                           (make-rw-port read-port write-port))
+                      read-port
+                      write-port
+                      (%make-void-port mode)))
+            (pipe-info (make-pipe-info pid)))
+
+        ;; Guard the pipe-info instead of the port, so that we can still
+        ;; call 'waitpid' even if 'close-port' is called (which clears
+        ;; the port entry).
+        (pipe-guardian pipe-info)
+        (%set-port-property! port 'popen-pipe-info pipe-info)
+
+        ;; XXX populate port/pid-table for backward compatibility.
+        (with-mutex port/pid-table-mutex
+          (hashq-set! port/pid-table port pid))
+
+        port))))
+
+(define (open-pipe command mode)
+  "Executes the shell command @var{command} (a string) in a subprocess.
+A port to the process (based on pipes) is created and returned.
+@var{mode} specifies whether an input, an output or an input-output
+port to the process is created: it should be the value of
+@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
+  (open-pipe* mode "/bin/sh" "-c" command))
+
+(define (fetch-pipe-info port)
+  (%port-property port 'popen-pipe-info))
+
+(define (close-process port pid)
+  (close-port port)
+  (cdr (waitpid pid)))
+
+(define (close-pipe p)
+  "Closes the pipe created by @code{open-pipe}, then waits for the process
+to terminate and returns its status value, @xref{Processes, waitpid}, for
+information on how to interpret this value."
+  (let ((pipe-info (fetch-pipe-info p)))
+    (unless pipe-info
+      (error "close-pipe: port not created by (ice-9 popen)"))
+    (let ((pid (pipe-info-pid pipe-info)))
+      (unless pid
+        (error "close-pipe: pid has already been cleared"))
+      ;; clear the pid to avoid repeated calls to 'waitpid'.
+      (set-pipe-info-pid! pipe-info #f)
+      (close-process p pid))))
+
+(define (reap-pipes)
+  (let loop ()
+    (let ((pipe-info (pipe-guardian)))
+      (when pipe-info
+        (let ((pid (pipe-info-pid pipe-info)))
+          ;; maybe 'close-pipe' was already called.
+          (when pid
+            ;; clean up without reporting errors.  also avoids blocking
+            ;; the process: if the child isn't ready to be collected,
+            ;; puts it back into the guardian's live list so it can be
+            ;; tried again the next time the cleanup runs.
+            (catch 'system-error
+              (lambda ()
+                (let ((pid/status (waitpid pid WNOHANG)))
+                  (if (zero? (car pid/status))
+                      (pipe-guardian pipe-info) ; not ready for collection
+                      (set-pipe-info-pid! pipe-info #f))))
+              (lambda args #f))))
+        (loop)))))
+
+(add-hook! after-gc-hook reap-pipes)
+
+(define (open-input-pipe command)
+  "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
+  (open-pipe command OPEN_READ))
+
+(define (open-output-pipe command)
+  "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
+  (open-pipe command OPEN_WRITE))
+
+(define (open-input-output-pipe command)
+  "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
+  (open-pipe command OPEN_BOTH))
+
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 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
+;;;; 
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
+(define (stat:dev f) (vector-ref f 0))
+(define (stat:ino f) (vector-ref f 1))
+(define (stat:mode f) (vector-ref f 2))
+(define (stat:nlink f) (vector-ref f 3))
+(define (stat:uid f) (vector-ref f 4))
+(define (stat:gid f) (vector-ref f 5))
+(define (stat:rdev f) (vector-ref f 6))
+(define (stat:size f) (vector-ref f 7))
+(define (stat:atime f) (vector-ref f 8))
+(define (stat:mtime f) (vector-ref f 9))
+(define (stat:ctime f) (vector-ref f 10))
+(define (stat:blksize f) (vector-ref f 11))
+(define (stat:blocks f) (vector-ref f 12))
+(define (stat:atimensec f) (vector-ref f 15))
+(define (stat:mtimensec f) (vector-ref f 16))
+(define (stat:ctimensec f) (vector-ref f 17))
+
+;; derived from stat mode.
+(define (stat:type f) (vector-ref f 13))
+(define (stat:perms f) (vector-ref f 14))
+
+(define (passwd:name obj) (vector-ref obj 0))
+(define (passwd:passwd obj) (vector-ref obj 1))
+(define (passwd:uid obj) (vector-ref obj 2))
+(define (passwd:gid obj) (vector-ref obj 3))
+(define (passwd:gecos obj) (vector-ref obj 4))
+(define (passwd:dir obj) (vector-ref obj 5))
+(define (passwd:shell obj) (vector-ref obj 6))
+
+(define (group:name obj) (vector-ref obj 0))
+(define (group:passwd obj) (vector-ref obj 1))
+(define (group:gid obj) (vector-ref obj 2))
+(define (group:mem obj) (vector-ref obj 3))
+
+(define (utsname:sysname obj) (vector-ref obj 0))
+(define (utsname:nodename obj) (vector-ref obj 1))
+(define (utsname:release obj) (vector-ref obj 2))
+(define (utsname:version obj) (vector-ref obj 3))
+(define (utsname:machine obj) (vector-ref obj 4))
+
+(define (getpwent) (getpw))
+(define (setpwent) (setpw #t))
+(define (endpwent) (setpw))
+
+(define (getpwnam name) (getpw name))
+(define (getpwuid uid) (getpw uid))
+
+(define (getgrent) (getgr))
+(define (setgrent) (setgr #t))
+(define (endgrent) (setgr))
+
+(define (getgrnam name) (getgr name))
+(define (getgrgid id) (getgr id))
+;;;; -*- coding: utf-8; mode: scheme -*-
+;;;;
+;;;; 	Copyright (C) 2001, 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
+;;;; 
+(define-module (ice-9 pretty-print)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-1)
+  #\use-module (rnrs bytevectors)
+  #\export (pretty-print
+            truncated-print))
+
+
+;; From SLIB.
+
+;;"genwrite.scm" generic write used by pretty-print and truncated-print.
+;; Copyright (c) 1991, Marc Feeley
+;; Author: Marc Feeley (feeley@iro.umontreal.ca)
+;; Distribution restrictions: none
+
+(define genwrite:newline-str (make-string 1 #\newline))
+
+(define (generic-write
+         obj display? width max-expr-width per-line-prefix output)
+
+  (define (read-macro? l)
+    (define (length1? l) (and (pair? l) (null? (cdr l))))
+    (let ((head (car l)) (tail (cdr l)))
+      (case head
+        ((quote quasiquote unquote unquote-splicing) (length1? tail))
+        (else                                        #f))))
+
+  (define (read-macro-body l)
+    (cadr l))
+
+  (define (read-macro-prefix l)
+    (let ((head (car l)))
+      (case head
+        ((quote)            "'")
+        ((quasiquote)       "`")
+        ((unquote)          ",")
+        ((unquote-splicing) ",@"))))
+
+  (define (out str col)
+    (and col (output str) (+ col (string-length str))))
+
+  (define (wr obj col)
+    (let loop ((obj obj)
+               (col col))
+      (match obj
+        (((or 'quote 'quasiquote 'unquote 'unquote-splicing) body)
+         (wr body (out (read-macro-prefix obj) col)))
+        ((head . (rest ...))
+         ;; A proper list: do our own list printing so as to catch read
+         ;; macros that appear in the middle of the list.
+         (let ((col (loop head (out "(" col))))
+           (out ")"
+                (fold (lambda (i col)
+                        (loop i (out " " col)))
+                      col rest))))
+        (_
+         (out (object->string obj (if display? display write)) col)))))
+
+  (define (pp obj col)
+
+    (define (spaces n col)
+      (if (> n 0)
+        (if (> n 7)
+          (spaces (- n 8) (out "        " col))
+          (out (substring "        " 0 n) col))
+        col))
+
+    (define (indent to col)
+      (and col
+           (if (< to col)
+             (and (out genwrite:newline-str col)
+		  (out per-line-prefix 0)
+		  (spaces to 0))
+             (spaces (- to col) col))))
+
+    (define (pr obj col extra pp-pair)
+      (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+        (let ((result '())
+              (left (min (+ (- (- width col) extra) 1) max-expr-width)))
+          (generic-write obj display? #f max-expr-width ""
+            (lambda (str)
+              (set! result (cons str result))
+              (set! left (- left (string-length str)))
+              (> left 0)))
+          (if (> left 0) ; all can be printed on one line
+            (out (reverse-string-append result) col)
+            (if (pair? obj)
+              (pp-pair obj col extra)
+              (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+        (wr obj col)))
+
+    (define (pp-expr expr col extra)
+      (if (read-macro? expr)
+        (pr (read-macro-body expr)
+            (out (read-macro-prefix expr) col)
+            extra
+            pp-expr)
+        (let ((head (car expr)))
+          (if (symbol? head)
+            (let ((proc (style head)))
+              (if proc
+                (proc expr col extra)
+                (if (> (string-length (symbol->string head))
+                       max-call-head-width)
+                  (pp-general expr col extra #f #f #f pp-expr)
+                  (pp-call expr col extra pp-expr))))
+            (pp-list expr col extra pp-expr)))))
+
+    ; (head item1
+    ;       item2
+    ;       item3)
+    (define (pp-call expr col extra pp-item)
+      (let ((col* (wr (car expr) (out "(" col))))
+        (and col
+             (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+
+    ; (item1
+    ;  item2
+    ;  item3)
+    (define (pp-list l col extra pp-item)
+      (let ((col (out "(" col)))
+        (pp-down l col col extra pp-item)))
+
+    (define (pp-down l col1 col2 extra pp-item)
+      (let loop ((l l) (col col1))
+        (and col
+             (cond ((pair? l)
+                    (let ((rest (cdr l)))
+                      (let ((extra (if (null? rest) (+ extra 1) 0)))
+                        (loop rest
+                              (pr (car l) (indent col2 col) extra pp-item)))))
+                   ((null? l)
+                    (out ")" col))
+                   (else
+                    (out ")"
+                         (pr l
+                             (indent col2 (out "." (indent col2 col)))
+                             (+ extra 1)
+                             pp-item)))))))
+
+    (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
+
+      (define (tail1 rest col1 col2 col3)
+        (if (and pp-1 (pair? rest))
+          (let* ((val1 (car rest))
+                 (rest (cdr rest))
+                 (extra (if (null? rest) (+ extra 1) 0)))
+            (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+          (tail2 rest col1 col2 col3)))
+
+      (define (tail2 rest col1 col2 col3)
+        (if (and pp-2 (pair? rest))
+          (let* ((val1 (car rest))
+                 (rest (cdr rest))
+                 (extra (if (null? rest) (+ extra 1) 0)))
+            (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+          (tail3 rest col1 col2)))
+
+      (define (tail3 rest col1 col2)
+        (pp-down rest col2 col1 extra pp-3))
+
+      (let* ((head (car expr))
+             (rest (cdr expr))
+             (col* (wr head (out "(" col))))
+        (if (and named? (pair? rest))
+          (let* ((name (car rest))
+                 (rest (cdr rest))
+                 (col** (wr name (out " " col*))))
+            (tail1 rest (+ col indent-general) col** (+ col** 1)))
+          (tail1 rest (+ col indent-general) col* (+ col* 1)))))
+
+    (define (pp-expr-list l col extra)
+      (pp-list l col extra pp-expr))
+
+    (define (pp-LAMBDA expr col extra)
+      (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+    (define (pp-IF expr col extra)
+      (pp-general expr col extra #f pp-expr #f pp-expr))
+
+    (define (pp-COND expr col extra)
+      (pp-call expr col extra pp-expr-list))
+
+    (define (pp-CASE expr col extra)
+      (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+    (define (pp-AND expr col extra)
+      (pp-call expr col extra pp-expr))
+
+    (define (pp-LET expr col extra)
+      (let* ((rest (cdr expr))
+             (named? (and (pair? rest) (symbol? (car rest)))))
+        (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+    (define (pp-BEGIN expr col extra)
+      (pp-general expr col extra #f #f #f pp-expr))
+
+    (define (pp-DO expr col extra)
+      (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+    (define (pp-SYNTAX-CASE expr col extra)
+      (pp-general expr col extra #t pp-expr-list #f pp-expr))
+
+    ; define formatting style (change these to suit your style)
+
+    (define indent-general 2)
+
+    (define max-call-head-width 5)
+
+    (define (style head)
+      (case head
+        ((lambda lambda* let* letrec define define* define-public
+                 define-syntax let-syntax letrec-syntax with-syntax)
+                                     pp-LAMBDA)
+        ((if set!)                   pp-IF)
+        ((cond)                      pp-COND)
+        ((case)                      pp-CASE)
+        ((and or)                    pp-AND)
+        ((let)                       pp-LET)
+        ((begin)                     pp-BEGIN)
+        ((do)                        pp-DO)
+        ((syntax-rules)              pp-LAMBDA)
+        ((syntax-case)               pp-SYNTAX-CASE)
+        (else                        #f)))
+
+    (pr obj col 0 pp-expr))
+
+  (out per-line-prefix 0)
+  (if width
+    (out genwrite:newline-str (pp obj 0))
+    (wr obj 0))
+  ;; Return `unspecified'
+  (if #f #f))
+
+; (reverse-string-append l) = (apply string-append (reverse l))
+
+(define (reverse-string-append l)
+
+  (define (rev-string-append l i)
+    (if (pair? l)
+      (let* ((str (car l))
+             (len (string-length str))
+             (result (rev-string-append (cdr l) (+ i len))))
+        (let loop ((j 0) (k (- (- (string-length result) i) len)))
+          (if (< j len)
+            (begin
+              (string-set! result k (string-ref str j))
+              (loop (+ j 1) (+ k 1)))
+            result)))
+      (make-string i)))
+
+  (rev-string-append l 0))
+
+(define* (pretty-print obj #\optional port*
+                       #\key 
+                       (port (or port* (current-output-port)))
+                       (width 79)
+                       (max-expr-width 50)
+                       (display? #f)
+                       (per-line-prefix ""))
+  "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
+the current output port.  Formatting can be controlled by a number of
+keyword arguments: Each line in the output is preceded by the string
+PER-LINE-PREFIX, which is empty by default.  The output lines will be
+at most WIDTH characters wide; the default is 79.  If DISPLAY? is
+true, display rather than write representation will be used.
+
+Instead of with a keyword argument, you can also specify the output
+port directly after OBJ, like (pretty-print OBJ PORT)."
+  (generic-write obj display?
+		 (- width (string-length per-line-prefix))
+                 max-expr-width
+		 per-line-prefix
+		 (lambda (s) (display s port) #t)))
+
+
+;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
+;; genwrite.scm.
+(define* (truncated-print x #\optional port*
+                          #\key
+                          (port (or port* (current-output-port)))
+                          (width 79)
+                          (display? #f)
+                          (breadth-first? #f))
+  "Print @var{x}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
+@code{write}, though that behavior can be overriden via the
+@var{display?} keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expression of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+\"ration\" the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument."
+
+  ;; Make sure string ports are created with the right encoding.
+  (with-fluids ((%default-port-encoding (port-encoding port)))
+
+    (define ellipsis
+      ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
+      ;; on the encoding of PORT.
+      (let ((e "…"))
+        (catch 'encoding-error
+          (lambda ()
+            (with-fluids ((%default-port-conversion-strategy 'error))
+              (with-output-to-string
+                (lambda ()
+                  (display e)))))
+          (lambda (key . args)
+            "..."))))
+
+    (let ((ellipsis-width (string-length ellipsis)))
+
+      (define (print-sequence x width len ref next)
+        (let lp ((x x)
+                 (width width)
+                 (i 0))
+          (if (> i 0)
+              (display #\space))
+          (cond
+           ((= i len)) ; catches 0-length case
+           ((and (= i (1- len)) (or (zero? i) (> width 1)))
+            (print (ref x i) (if (zero? i) width (1- width))))
+           ((<= width (+ 1 ellipsis-width))
+            (display ellipsis))
+           (else
+            (let ((str
+                   (with-fluids ((%default-port-encoding (port-encoding port)))
+                     (with-output-to-string
+                           (lambda ()
+                             (print (ref x i)
+                                    (if breadth-first?
+                                        (max 1
+                                             (1- (floor (/ width (- len i)))))
+                                        (- width (+ 1 ellipsis-width)))))))))
+              (display str)
+              (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+      (define (print-tree x width)
+        ;; width is >= the width of # . #, which is 5
+        (let lp ((x x)
+                 (width width))
+          (cond
+           ((or (not (pair? x)) (<= width 4))
+            (display ". ")
+            (print x (- width 2)))
+           (else
+            ;; width >= 5
+            (let ((str (with-output-to-string
+                         (lambda ()
+                           (print (car x)
+                                  (if breadth-first?
+                                      (floor (/ (- width 3) 2))
+                                      (- width 4)))))))
+              (display str)
+              (display " ")
+              (lp (cdr x) (- width 1 (string-length str))))))))
+
+      (define (truncate-string str width)
+        ;; width is < (string-length str)
+        (let lp ((fixes '(("#<" . ">")
+                          ("#(" . ")")
+                          ("(" . ")")
+                          ("\"" . "\""))))
+          (cond
+           ((null? fixes)
+            "#")
+           ((and (string-prefix? (caar fixes) str)
+                 (string-suffix? (cdar fixes) str)
+                 (>= (string-length str)
+                     width
+                     (+ (string-length (caar fixes))
+                        (string-length (cdar fixes))
+                        ellipsis-width)))
+            (format #f "~a~a~a~a"
+                    (caar fixes)
+                    (substring str (string-length (caar fixes))
+                               (- width (string-length (cdar fixes))
+                                  ellipsis-width))
+                    ellipsis
+                    (cdar fixes)))
+           (else
+            (lp (cdr fixes))))))
+
+      (define (print x width)
+        (cond
+         ((<= width 0)
+          (error "expected a positive width" width))
+         ((list? x)
+          (cond
+           ((>= width (+ 2 ellipsis-width))
+            (display "(")
+            (print-sequence x (- width 2) (length x)
+                            (lambda (x i) (car x)) cdr)
+            (display ")"))
+           (else
+            (display "#"))))
+         ((vector? x)
+          (cond
+           ((>= width (+ 3 ellipsis-width))
+            (display "#(")
+            (print-sequence x (- width 3) (vector-length x)
+                            vector-ref identity)
+            (display ")"))
+           (else
+            (display "#"))))
+         ((bytevector? x)
+          (cond
+           ((>= width 9)
+            (format #t  "#~a(" (array-type x))
+            (print-sequence x (- width 6) (array-length x)
+                            array-ref identity)
+            (display ")"))
+           (else
+            (display "#"))))
+         ((pair? x)
+          (cond
+           ((>= width (+ 4 ellipsis-width))
+            (display "(")
+            (print-tree x (- width 2))
+            (display ")"))
+           (else
+            (display "#"))))
+         (else
+          (let* ((str (with-output-to-string
+                        (lambda () (if display? (display x) (write x)))))
+                 (len (string-length str)))
+            (display (if (<= (string-length str) width)
+                         str
+                         (truncate-string str width)))))))
+
+      (with-output-to-port port
+        (lambda ()
+          (print x width))))))
+(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
+(if #f #f)
+
+(letrec*
+  ((make-void
+     (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
+   (make-const
+     (lambda (src exp)
+       (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
+   (make-primitive-ref
+     (lambda (src name)
+       (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
+   (make-lexical-ref
+     (lambda (src name gensym)
+       (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
+   (make-lexical-set
+     (lambda (src name gensym exp)
+       (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
+   (make-module-ref
+     (lambda (src mod name public?)
+       (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
+   (make-module-set
+     (lambda (src mod name public? exp)
+       (make-struct
+         (vector-ref %expanded-vtables 6)
+         0
+         src
+         mod
+         name
+         public?
+         exp)))
+   (make-toplevel-ref
+     (lambda (src name)
+       (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
+   (make-toplevel-set
+     (lambda (src name exp)
+       (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
+   (make-toplevel-define
+     (lambda (src name exp)
+       (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
+   (make-conditional
+     (lambda (src test consequent alternate)
+       (make-struct
+         (vector-ref %expanded-vtables 10)
+         0
+         src
+         test
+         consequent
+         alternate)))
+   (make-application
+     (lambda (src proc args)
+       (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
+   (make-sequence
+     (lambda (src exps)
+       (make-struct (vector-ref %expanded-vtables 12) 0 src exps)))
+   (make-lambda
+     (lambda (src meta body)
+       (make-struct (vector-ref %expanded-vtables 13) 0 src meta body)))
+   (make-lambda-case
+     (lambda (src req opt rest kw inits gensyms body alternate)
+       (make-struct
+         (vector-ref %expanded-vtables 14)
+         0
+         src
+         req
+         opt
+         rest
+         kw
+         inits
+         gensyms
+         body
+         alternate)))
+   (make-let
+     (lambda (src names gensyms vals body)
+       (make-struct
+         (vector-ref %expanded-vtables 15)
+         0
+         src
+         names
+         gensyms
+         vals
+         body)))
+   (make-letrec
+     (lambda (src in-order? names gensyms vals body)
+       (make-struct
+         (vector-ref %expanded-vtables 16)
+         0
+         src
+         in-order?
+         names
+         gensyms
+         vals
+         body)))
+   (make-dynlet
+     (lambda (src fluids vals body)
+       (make-struct
+         (vector-ref %expanded-vtables 17)
+         0
+         src
+         fluids
+         vals
+         body)))
+   (lambda?
+     (lambda (x)
+       (and (struct? x)
+            (eq? (struct-vtable x) (vector-ref %expanded-vtables 13)))))
+   (lambda-meta (lambda (x) (struct-ref x 1)))
+   (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
+   (top-level-eval-hook (lambda (x mod) (primitive-eval x)))
+   (local-eval-hook (lambda (x mod) (primitive-eval x)))
+   (session-id
+     (let ((v (module-variable (current-module) 'syntax-session-id)))
+       (lambda () ((variable-ref v)))))
+   (put-global-definition-hook
+     (lambda (symbol type val)
+       (module-define!
+         (current-module)
+         symbol
+         (make-syntax-transformer symbol type val))))
+   (get-global-definition-hook
+     (lambda (symbol module)
+       (if (and (not module) (current-module))
+         (warn "module system is booted, we should have a module" symbol))
+       (let ((v (module-variable
+                  (if module (resolve-module (cdr module)) (current-module))
+                  symbol)))
+         (and v
+              (variable-bound? v)
+              (let ((val (variable-ref v)))
+                (and (macro? val)
+                     (macro-type val)
+                     (cons (macro-type val) (macro-binding val))))))))
+   (decorate-source
+     (lambda (e s)
+       (if (and s (supports-source-properties? e))
+         (set-source-properties! e s))
+       e))
+   (maybe-name-value!
+     (lambda (name val)
+       (if (lambda? val)
+         (let ((meta (lambda-meta val)))
+           (if (not (assq 'name meta))
+             (set-lambda-meta! val (acons 'name name meta)))))))
+   (build-void (lambda (source) (make-void source)))
+   (build-application
+     (lambda (source fun-exp arg-exps)
+       (make-application source fun-exp arg-exps)))
+   (build-conditional
+     (lambda (source test-exp then-exp else-exp)
+       (make-conditional source test-exp then-exp else-exp)))
+   (build-dynlet
+     (lambda (source fluids vals body)
+       (make-dynlet source fluids vals body)))
+   (build-lexical-reference
+     (lambda (type source name var) (make-lexical-ref source name var)))
+   (build-lexical-assignment
+     (lambda (source name var exp)
+       (maybe-name-value! name exp)
+       (make-lexical-set source name var exp)))
+   (analyze-variable
+     (lambda (mod var modref-cont bare-cont)
+       (if (not mod)
+         (bare-cont var)
+         (let ((kind (car mod)) (mod (cdr mod)))
+           (let ((key kind))
+             (cond ((memv key '(public)) (modref-cont mod var #t))
+                   ((memv key '(private))
+                    (if (not (equal? mod (module-name (current-module))))
+                      (modref-cont mod var #f)
+                      (bare-cont var)))
+                   ((memv key '(bare)) (bare-cont var))
+                   ((memv key '(hygiene))
+                    (if (and (not (equal? mod (module-name (current-module))))
+                             (module-variable (resolve-module mod) var))
+                      (modref-cont mod var #f)
+                      (bare-cont var)))
+                   (else (syntax-violation #f "bad module kind" var mod))))))))
+   (build-global-reference
+     (lambda (source var mod)
+       (analyze-variable
+         mod
+         var
+         (lambda (mod var public?) (make-module-ref source mod var public?))
+         (lambda (var) (make-toplevel-ref source var)))))
+   (build-global-assignment
+     (lambda (source var exp mod)
+       (maybe-name-value! var exp)
+       (analyze-variable
+         mod
+         var
+         (lambda (mod var public?)
+           (make-module-set source mod var public? exp))
+         (lambda (var) (make-toplevel-set source var exp)))))
+   (build-global-definition
+     (lambda (source var exp)
+       (maybe-name-value! var exp)
+       (make-toplevel-define source var exp)))
+   (build-simple-lambda
+     (lambda (src req rest vars meta exp)
+       (make-lambda
+         src
+         meta
+         (make-lambda-case src req #f rest #f '() vars exp #f))))
+   (build-case-lambda
+     (lambda (src meta body) (make-lambda src meta body)))
+   (build-lambda-case
+     (lambda (src req opt rest kw inits vars body else-case)
+       (make-lambda-case src req opt rest kw inits vars body else-case)))
+   (build-primref
+     (lambda (src name)
+       (if (equal? (module-name (current-module)) '(guile))
+         (make-toplevel-ref src name)
+         (make-module-ref src '(guile) name #f))))
+   (build-data (lambda (src exp) (make-const src exp)))
+   (build-sequence
+     (lambda (src exps)
+       (if (null? (cdr exps)) (car exps) (make-sequence src exps))))
+   (build-let
+     (lambda (src ids vars val-exps body-exp)
+       (for-each maybe-name-value! ids val-exps)
+       (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
+   (build-named-let
+     (lambda (src ids vars val-exps body-exp)
+       (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
+         (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
+           (maybe-name-value! f-name proc)
+           (for-each maybe-name-value! ids val-exps)
+           (make-letrec
+             src
+             #f
+             (list f-name)
+             (list f)
+             (list proc)
+             (build-application
+               src
+               (build-lexical-reference 'fun src f-name f)
+               val-exps))))))
+   (build-letrec
+     (lambda (src in-order? ids vars val-exps body-exp)
+       (if (null? vars)
+         body-exp
+         (begin
+           (for-each maybe-name-value! ids val-exps)
+           (make-letrec src in-order? ids vars val-exps body-exp)))))
+   (make-syntax-object
+     (lambda (expression wrap module)
+       (vector 'syntax-object expression wrap module)))
+   (syntax-object?
+     (lambda (x)
+       (and (vector? x)
+            (= (vector-length x) 4)
+            (eq? (vector-ref x 0) 'syntax-object))))
+   (syntax-object-expression (lambda (x) (vector-ref x 1)))
+   (syntax-object-wrap (lambda (x) (vector-ref x 2)))
+   (syntax-object-module (lambda (x) (vector-ref x 3)))
+   (set-syntax-object-expression!
+     (lambda (x update) (vector-set! x 1 update)))
+   (set-syntax-object-wrap!
+     (lambda (x update) (vector-set! x 2 update)))
+   (set-syntax-object-module!
+     (lambda (x update) (vector-set! x 3 update)))
+   (source-annotation
+     (lambda (x)
+       (let ((props (source-properties
+                      (if (syntax-object? x) (syntax-object-expression x) x))))
+         (and (pair? props) props))))
+   (extend-env
+     (lambda (labels bindings r)
+       (if (null? labels)
+         r
+         (extend-env
+           (cdr labels)
+           (cdr bindings)
+           (cons (cons (car labels) (car bindings)) r)))))
+   (extend-var-env
+     (lambda (labels vars r)
+       (if (null? labels)
+         r
+         (extend-var-env
+           (cdr labels)
+           (cdr vars)
+           (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
+   (macros-only-env
+     (lambda (r)
+       (if (null? r)
+         '()
+         (let ((a (car r)))
+           (if (memq (cadr a) '(macro ellipsis))
+             (cons a (macros-only-env (cdr r)))
+             (macros-only-env (cdr r)))))))
+   (lookup
+     (lambda (x r mod)
+       (let ((t (assq x r)))
+         (cond (t (cdr t))
+               ((symbol? x) (or (get-global-definition-hook x mod) '(global)))
+               (else '(displaced-lexical))))))
+   (global-extend
+     (lambda (type sym val) (put-global-definition-hook sym type val)))
+   (nonsymbol-id?
+     (lambda (x)
+       (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
+   (id? (lambda (x)
+          (if (symbol? x)
+            #t
+            (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
+   (id-sym-name&marks
+     (lambda (x w)
+       (if (syntax-object? x)
+         (values
+           (syntax-object-expression x)
+           (join-marks (car w) (car (syntax-object-wrap x))))
+         (values x (car w)))))
+   (gen-label (lambda () (symbol->string (module-gensym "l"))))
+   (gen-labels
+     (lambda (ls)
+       (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
+   (make-ribcage
+     (lambda (symnames marks labels)
+       (vector 'ribcage symnames marks labels)))
+   (ribcage?
+     (lambda (x)
+       (and (vector? x)
+            (= (vector-length x) 4)
+            (eq? (vector-ref x 0) 'ribcage))))
+   (ribcage-symnames (lambda (x) (vector-ref x 1)))
+   (ribcage-marks (lambda (x) (vector-ref x 2)))
+   (ribcage-labels (lambda (x) (vector-ref x 3)))
+   (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update)))
+   (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
+   (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
+   (anti-mark
+     (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
+   (extend-ribcage!
+     (lambda (ribcage id label)
+       (set-ribcage-symnames!
+         ribcage
+         (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
+       (set-ribcage-marks!
+         ribcage
+         (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
+       (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
+   (make-binding-wrap
+     (lambda (ids labels w)
+       (if (null? ids)
+         w
+         (cons (car w)
+               (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec)))
+                       (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+                         (let f ((ids ids) (i 0))
+                           (if (not (null? ids))
+                             (call-with-values
+                               (lambda () (id-sym-name&marks (car ids) w))
+                               (lambda (symname marks)
+                                 (vector-set! symnamevec i symname)
+                                 (vector-set! marksvec i marks)
+                                 (f (cdr ids) (+ i 1))))))
+                         (make-ribcage symnamevec marksvec labelvec)))
+                     (cdr w))))))
+   (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
+   (join-wraps
+     (lambda (w1 w2)
+       (let ((m1 (car w1)) (s1 (cdr w1)))
+         (if (null? m1)
+           (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2))))
+           (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2)))))))
+   (join-marks (lambda (m1 m2) (smart-append m1 m2)))
+   (same-marks?
+     (lambda (x y)
+       (or (eq? x y)
+           (and (not (null? x))
+                (not (null? y))
+                (eq? (car x) (car y))
+                (same-marks? (cdr x) (cdr y))))))
+   (id-var-name
+     (lambda (id w)
+       (letrec*
+         ((search
+            (lambda (sym subst marks)
+              (if (null? subst)
+                (values #f marks)
+                (let ((fst (car subst)))
+                  (if (eq? fst 'shift)
+                    (search sym (cdr subst) (cdr marks))
+                    (let ((symnames (ribcage-symnames fst)))
+                      (if (vector? symnames)
+                        (search-vector-rib sym subst marks symnames fst)
+                        (search-list-rib sym subst marks symnames fst))))))))
+          (search-list-rib
+            (lambda (sym subst marks symnames ribcage)
+              (let f ((symnames symnames) (i 0))
+                (cond ((null? symnames) (search sym (cdr subst) marks))
+                      ((and (eq? (car symnames) sym)
+                            (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+                       (values (list-ref (ribcage-labels ribcage) i) marks))
+                      (else (f (cdr symnames) (+ i 1)))))))
+          (search-vector-rib
+            (lambda (sym subst marks symnames ribcage)
+              (let ((n (vector-length symnames)))
+                (let f ((i 0))
+                  (cond ((= i n) (search sym (cdr subst) marks))
+                        ((and (eq? (vector-ref symnames i) sym)
+                              (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+                         (values (vector-ref (ribcage-labels ribcage) i) marks))
+                        (else (f (+ i 1)))))))))
+         (cond ((symbol? id) (or (search id (cdr w) (car w)) id))
+               ((syntax-object? id)
+                (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id)))
+                  (let ((marks (join-marks (car w) (car w1))))
+                    (call-with-values
+                      (lambda () (search id (cdr w) marks))
+                      (lambda (new-id marks) (or new-id (search id (cdr w1) marks) id))))))
+               (else (syntax-violation 'id-var-name "invalid id" id))))))
+   (locally-bound-identifiers
+     (lambda (w mod)
+       (letrec*
+         ((scan (lambda (subst results)
+                  (if (null? subst)
+                    results
+                    (let ((fst (car subst)))
+                      (if (eq? fst 'shift)
+                        (scan (cdr subst) results)
+                        (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst)))
+                          (if (vector? symnames)
+                            (scan-vector-rib subst symnames marks results)
+                            (scan-list-rib subst symnames marks results))))))))
+          (scan-list-rib
+            (lambda (subst symnames marks results)
+              (let f ((symnames symnames) (marks marks) (results results))
+                (if (null? symnames)
+                  (scan (cdr subst) results)
+                  (f (cdr symnames)
+                     (cdr marks)
+                     (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod)
+                           results))))))
+          (scan-vector-rib
+            (lambda (subst symnames marks results)
+              (let ((n (vector-length symnames)))
+                (let f ((i 0) (results results))
+                  (if (= i n)
+                    (scan (cdr subst) results)
+                    (f (+ i 1)
+                       (cons (wrap (vector-ref symnames i)
+                                   (anti-mark (cons (vector-ref marks i) subst))
+                                   mod)
+                             results))))))))
+         (scan (cdr w) '()))))
+   (resolve-identifier
+     (lambda (id w r mod)
+       (letrec*
+         ((resolve-global
+            (lambda (var mod)
+              (let ((b (or (get-global-definition-hook var mod) '(global))))
+                (if (eq? (car b) 'global)
+                  (values 'global var mod)
+                  (values (car b) (cdr b) mod)))))
+          (resolve-lexical
+            (lambda (label mod)
+              (let ((b (or (assq-ref r label) '(displaced-lexical))))
+                (values (car b) (cdr b) mod)))))
+         (let ((n (id-var-name id w)))
+           (cond ((symbol? n)
+                  (resolve-global
+                    n
+                    (if (syntax-object? id) (syntax-object-module id) mod)))
+                 ((string? n)
+                  (resolve-lexical
+                    n
+                    (if (syntax-object? id) (syntax-object-module id) mod)))
+                 (else (error "unexpected id-var-name" id w n)))))))
+   (transformer-environment
+     (make-fluid
+       (lambda (k)
+         (error "called outside the dynamic extent of a syntax transformer"))))
+   (with-transformer-environment
+     (lambda (k) ((fluid-ref transformer-environment) k)))
+   (free-id=?
+     (lambda (i j)
+       (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression x) x))
+                 (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
+            (eq? (id-var-name i '(())) (id-var-name j '(()))))))
+   (bound-id=?
+     (lambda (i j)
+       (if (and (syntax-object? i) (syntax-object? j))
+         (and (eq? (syntax-object-expression i) (syntax-object-expression j))
+              (same-marks?
+                (car (syntax-object-wrap i))
+                (car (syntax-object-wrap j))))
+         (eq? i j))))
+   (valid-bound-ids?
+     (lambda (ids)
+       (and (let all-ids? ((ids ids))
+              (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
+            (distinct-bound-ids? ids))))
+   (distinct-bound-ids?
+     (lambda (ids)
+       (let distinct? ((ids ids))
+         (or (null? ids)
+             (and (not (bound-id-member? (car ids) (cdr ids)))
+                  (distinct? (cdr ids)))))))
+   (bound-id-member?
+     (lambda (x list)
+       (and (not (null? list))
+            (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
+   (wrap (lambda (x w defmod)
+           (cond ((and (null? (car w)) (null? (cdr w))) x)
+                 ((syntax-object? x)
+                  (make-syntax-object
+                    (syntax-object-expression x)
+                    (join-wraps w (syntax-object-wrap x))
+                    (syntax-object-module x)))
+                 ((null? x) x)
+                 (else (make-syntax-object x w defmod)))))
+   (source-wrap
+     (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
+   (expand-sequence
+     (lambda (body r w s mod)
+       (build-sequence
+         s
+         (let dobody ((body body) (r r) (w w) (mod mod))
+           (if (null? body)
+             '()
+             (let ((first (expand (car body) r w mod)))
+               (cons first (dobody (cdr body) r w mod))))))))
+   (expand-top-sequence
+     (lambda (body r w s m esew mod)
+       (letrec*
+         ((scan (lambda (body r w s m esew mod exps)
+                  (if (null? body)
+                    exps
+                    (call-with-values
+                      (lambda ()
+                        (call-with-values
+                          (lambda ()
+                            (let ((e (car body)))
+                              (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
+                          (lambda (type value form e w s mod)
+                            (let ((key type))
+                              (cond ((memv key '(begin-form))
+                                     (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_))))
+                                       (if tmp-1
+                                         (apply (lambda () exps) tmp-1)
+                                         (let ((tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
+                                           (if tmp-1
+                                             (apply (lambda (e1 e2) (scan (cons e1 e2) r w s m esew mod exps))
+                                                    tmp-1)
+                                             (syntax-violation
+                                               #f
+                                               "source expression failed to match any pattern"
+                                               tmp))))))
+                                    ((memv key '(local-syntax-form))
+                                     (expand-local-syntax
+                                       value
+                                       e
+                                       r
+                                       w
+                                       s
+                                       mod
+                                       (lambda (body r w s mod) (scan body r w s m esew mod exps))))
+                                    ((memv key '(eval-when-form))
+                                     (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+                                       (if tmp
+                                         (apply (lambda (x e1 e2)
+                                                  (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+                                                    (cond ((eq? m 'e)
+                                                           (if (memq 'eval when-list)
+                                                             (scan body
+                                                                   r
+                                                                   w
+                                                                   s
+                                                                   (if (memq 'expand when-list) 'c&e 'e)
+                                                                   '(eval)
+                                                                   mod
+                                                                   exps)
+                                                             (begin
+                                                               (if (memq 'expand when-list)
+                                                                 (top-level-eval-hook
+                                                                   (expand-top-sequence body r w s 'e '(eval) mod)
+                                                                   mod))
+                                                               (values exps))))
+                                                          ((memq 'load when-list)
+                                                           (cond ((or (memq 'compile when-list)
+                                                                      (memq 'expand when-list)
+                                                                      (and (eq? m 'c&e) (memq 'eval when-list)))
+                                                                  (scan body r w s 'c&e '(compile load) mod exps))
+                                                                 ((memq m '(c c&e))
+                                                                  (scan body r w s 'c '(load) mod exps))
+                                                                 (else (values exps))))
+                                                          ((or (memq 'compile when-list)
+                                                               (memq 'expand when-list)
+                                                               (and (eq? m 'c&e) (memq 'eval when-list)))
+                                                           (top-level-eval-hook
+                                                             (expand-top-sequence body r w s 'e '(eval) mod)
+                                                             mod)
+                                                           (values exps))
+                                                          (else (values exps)))))
+                                                tmp)
+                                         (syntax-violation
+                                           #f
+                                           "source expression failed to match any pattern"
+                                           tmp-1))))
+                                    ((memv key '(define-syntax-form define-syntax-parameter-form))
+                                     (let ((n (id-var-name value w)) (r (macros-only-env r)))
+                                       (let ((key m))
+                                         (cond ((memv key '(c))
+                                                (cond ((memq 'compile esew)
+                                                       (let ((e (expand-install-global n (expand e r w mod))))
+                                                         (top-level-eval-hook e mod)
+                                                         (if (memq 'load esew) (values (cons e exps)) (values exps))))
+                                                      ((memq 'load esew)
+                                                       (values
+                                                         (cons (expand-install-global n (expand e r w mod)) exps)))
+                                                      (else (values exps))))
+                                               ((memv key '(c&e))
+                                                (let ((e (expand-install-global n (expand e r w mod))))
+                                                  (top-level-eval-hook e mod)
+                                                  (values (cons e exps))))
+                                               (else
+                                                (if (memq 'eval esew)
+                                                  (top-level-eval-hook
+                                                    (expand-install-global n (expand e r w mod))
+                                                    mod))
+                                                (values exps))))))
+                                    ((memv key '(define-form))
+                                     (let* ((n (id-var-name value w)) (type (car (lookup n r mod))) (key type))
+                                       (cond ((memv key '(global core macro module-ref))
+                                              (if (and (memq m '(c c&e))
+                                                       (not (module-local-variable (current-module) n))
+                                                       (current-module))
+                                                (let ((old (module-variable (current-module) n)))
+                                                  (if (and (variable? old)
+                                                           (variable-bound? old)
+                                                           (not (macro? (variable-ref old))))
+                                                    (module-define! (current-module) n (variable-ref old))
+                                                    (module-add! (current-module) n (make-undefined-variable)))))
+                                              (values
+                                                (cons (if (eq? m 'c&e)
+                                                        (let ((x (build-global-definition s n (expand e r w mod))))
+                                                          (top-level-eval-hook x mod)
+                                                          x)
+                                                        (lambda () (build-global-definition s n (expand e r w mod))))
+                                                      exps)))
+                                             ((memv key '(displaced-lexical))
+                                              (syntax-violation
+                                                #f
+                                                "identifier out of context"
+                                                (source-wrap form w s mod)
+                                                (wrap value w mod)))
+                                             (else
+                                              (syntax-violation
+                                                #f
+                                                "cannot define keyword at top level"
+                                                (source-wrap form w s mod)
+                                                (wrap value w mod))))))
+                                    (else
+                                     (values
+                                       (cons (if (eq? m 'c&e)
+                                               (let ((x (expand-expr type value form e r w s mod)))
+                                                 (top-level-eval-hook x mod)
+                                                 x)
+                                               (lambda () (expand-expr type value form e r w s mod)))
+                                             exps))))))))
+                      (lambda (exps) (scan (cdr body) r w s m esew mod exps)))))))
+         (call-with-values
+           (lambda () (scan body r w s m esew mod '()))
+           (lambda (exps)
+             (if (null? exps)
+               (build-void s)
+               (build-sequence
+                 s
+                 (let lp ((in exps) (out '()))
+                   (if (null? in)
+                     out
+                     (let ((e (car in)))
+                       (lp (cdr in) (cons (if (procedure? e) (e) e) out))))))))))))
+   (expand-install-global
+     (lambda (name e)
+       (build-global-definition
+         #f
+         name
+         (build-application
+           #f
+           (build-primref #f 'make-syntax-transformer)
+           (list (build-data #f name) (build-data #f 'macro) e)))))
+   (parse-when-list
+     (lambda (e when-list)
+       (let ((result (strip when-list '(()))))
+         (let lp ((l result))
+           (cond ((null? l) result)
+                 ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
+                 (else (syntax-violation 'eval-when "invalid situation" e (car l))))))))
+   (syntax-type
+     (lambda (e r w s rib mod for-car?)
+       (cond ((symbol? e)
+              (let* ((n (id-var-name e w))
+                     (b (lookup n r mod))
+                     (type (car b))
+                     (key type))
+                (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod))
+                      ((memv key '(global)) (values type n e e w s mod))
+                      ((memv key '(macro))
+                       (if for-car?
+                         (values type (cdr b) e e w s mod)
+                         (syntax-type
+                           (expand-macro (cdr b) e r w s rib mod)
+                           r
+                           '(())
+                           s
+                           rib
+                           mod
+                           #f)))
+                      (else (values type (cdr b) e e w s mod)))))
+             ((pair? e)
+              (let ((first (car e)))
+                (call-with-values
+                  (lambda () (syntax-type first r w s rib mod #t))
+                  (lambda (ftype fval fform fe fw fs fmod)
+                    (let ((key ftype))
+                      (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
+                            ((memv key '(global))
+                             (values 'global-call (make-syntax-object fval w fmod) e e w s mod))
+                            ((memv key '(macro))
+                             (syntax-type
+                               (expand-macro fval e r w s rib mod)
+                               r
+                               '(())
+                               s
+                               rib
+                               mod
+                               for-car?))
+                            ((memv key '(module-ref))
+                             (call-with-values
+                               (lambda () (fval e r w))
+                               (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
+                            ((memv key '(core)) (values 'core-form fval e e w s mod))
+                            ((memv key '(local-syntax))
+                             (values 'local-syntax-form fval e e w s mod))
+                            ((memv key '(begin)) (values 'begin-form #f e e w s mod))
+                            ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod))
+                            ((memv key '(define))
+                             (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
+                               (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1))
+                                 (apply (lambda (name val) (values 'define-form name e val w s mod))
+                                        tmp-1)
+                                 (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any))))
+                                   (if (and tmp-1
+                                            (apply (lambda (name args e1 e2)
+                                                     (and (id? name) (valid-bound-ids? (lambda-var-list args))))
+                                                   tmp-1))
+                                     (apply (lambda (name args e1 e2)
+                                              (values
+                                                'define-form
+                                                (wrap name w mod)
+                                                (wrap e w mod)
+                                                (decorate-source
+                                                  (cons '#(syntax-object lambda ((top)) (hygiene guile))
+                                                        (wrap (cons args (cons e1 e2)) w mod))
+                                                  s)
+                                                '(())
+                                                s
+                                                mod))
+                                            tmp-1)
+                                     (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
+                                       (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1))
+                                         (apply (lambda (name)
+                                                  (values
+                                                    'define-form
+                                                    (wrap name w mod)
+                                                    (wrap e w mod)
+                                                    '(#(syntax-object if ((top)) (hygiene guile)) #f #f)
+                                                    '(())
+                                                    s
+                                                    mod))
+                                                tmp-1)
+                                         (syntax-violation
+                                           #f
+                                           "source expression failed to match any pattern"
+                                           tmp))))))))
+                            ((memv key '(define-syntax))
+                             (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+                               (if (and tmp (apply (lambda (name val) (id? name)) tmp))
+                                 (apply (lambda (name val) (values 'define-syntax-form name e val w s mod))
+                                        tmp)
+                                 (syntax-violation
+                                   #f
+                                   "source expression failed to match any pattern"
+                                   tmp-1))))
+                            ((memv key '(define-syntax-parameter))
+                             (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+                               (if (and tmp (apply (lambda (name val) (id? name)) tmp))
+                                 (apply (lambda (name val)
+                                          (values 'define-syntax-parameter-form name e val w s mod))
+                                        tmp)
+                                 (syntax-violation
+                                   #f
+                                   "source expression failed to match any pattern"
+                                   tmp-1))))
+                            (else (values 'call #f e e w s mod))))))))
+             ((syntax-object? e)
+              (syntax-type
+                (syntax-object-expression e)
+                r
+                (join-wraps w (syntax-object-wrap e))
+                (or (source-annotation e) s)
+                rib
+                (or (syntax-object-module e) mod)
+                for-car?))
+             ((self-evaluating? e) (values 'constant #f e e w s mod))
+             (else (values 'other #f e e w s mod)))))
+   (expand
+     (lambda (e r w mod)
+       (call-with-values
+         (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+         (lambda (type value form e w s mod)
+           (expand-expr type value form e r w s mod)))))
+   (expand-expr
+     (lambda (type value form e r w s mod)
+       (let ((key type))
+         (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value))
+               ((memv key '(core core-form)) (value e r w s mod))
+               ((memv key '(module-ref))
+                (call-with-values
+                  (lambda () (value e r w))
+                  (lambda (e r w s mod) (expand e r w mod))))
+               ((memv key '(lexical-call))
+                (expand-application
+                  (let ((id (car e)))
+                    (build-lexical-reference
+                      'fun
+                      (source-annotation id)
+                      (if (syntax-object? id) (syntax->datum id) id)
+                      value))
+                  e
+                  r
+                  w
+                  s
+                  mod))
+               ((memv key '(global-call))
+                (expand-application
+                  (build-global-reference
+                    (source-annotation (car e))
+                    (if (syntax-object? value) (syntax-object-expression value) value)
+                    (if (syntax-object? value) (syntax-object-module value) mod))
+                  e
+                  r
+                  w
+                  s
+                  mod))
+               ((memv key '(constant))
+                (build-data s (strip (source-wrap e w s mod) '(()))))
+               ((memv key '(global)) (build-global-reference s value mod))
+               ((memv key '(call))
+                (expand-application (expand (car e) r w mod) e r w s mod))
+               ((memv key '(begin-form))
+                (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
+                  (if tmp-1
+                    (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod))
+                           tmp-1)
+                    (let ((tmp-1 ($sc-dispatch tmp '(_))))
+                      (if tmp-1
+                        (apply (lambda ()
+                                 (if (include-deprecated-features)
+                                   (begin
+                                     (issue-deprecation-warning
+                                       "Sequences of zero expressions are deprecated.  Use *unspecified*.")
+                                     (expand-void))
+                                   (syntax-violation
+                                     #f
+                                     "sequence of zero expressions"
+                                     (source-wrap e w s mod))))
+                               tmp-1)
+                        (syntax-violation
+                          #f
+                          "source expression failed to match any pattern"
+                          tmp))))))
+               ((memv key '(local-syntax-form))
+                (expand-local-syntax value e r w s mod expand-sequence))
+               ((memv key '(eval-when-form))
+                (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+                  (if tmp
+                    (apply (lambda (x e1 e2)
+                             (let ((when-list (parse-when-list e x)))
+                               (if (memq 'eval when-list)
+                                 (expand-sequence (cons e1 e2) r w s mod)
+                                 (expand-void))))
+                           tmp)
+                    (syntax-violation
+                      #f
+                      "source expression failed to match any pattern"
+                      tmp-1))))
+               ((memv key
+                      '(define-form define-syntax-form define-syntax-parameter-form))
+                (syntax-violation
+                  #f
+                  "definition in expression context, where definitions are not allowed,"
+                  (source-wrap form w s mod)))
+               ((memv key '(syntax))
+                (syntax-violation
+                  #f
+                  "reference to pattern variable outside syntax form"
+                  (source-wrap e w s mod)))
+               ((memv key '(displaced-lexical))
+                (syntax-violation
+                  #f
+                  "reference to identifier outside its scope"
+                  (source-wrap e w s mod)))
+               (else
+                (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
+   (expand-application
+     (lambda (x e r w s mod)
+       (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
+         (if tmp
+           (apply (lambda (e0 e1)
+                    (build-application s x (map (lambda (e) (expand e r w mod)) e1)))
+                  tmp)
+           (syntax-violation
+             #f
+             "source expression failed to match any pattern"
+             tmp-1)))))
+   (expand-macro
+     (lambda (p e r w s rib mod)
+       (letrec*
+         ((rebuild-macro-output
+            (lambda (x m)
+              (cond ((pair? x)
+                     (decorate-source
+                       (cons (rebuild-macro-output (car x) m)
+                             (rebuild-macro-output (cdr x) m))
+                       s))
+                    ((syntax-object? x)
+                     (let ((w (syntax-object-wrap x)))
+                       (let ((ms (car w)) (ss (cdr w)))
+                         (if (and (pair? ms) (eq? (car ms) #f))
+                           (make-syntax-object
+                             (syntax-object-expression x)
+                             (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
+                             (syntax-object-module x))
+                           (make-syntax-object
+                             (decorate-source (syntax-object-expression x) s)
+                             (cons (cons m ms)
+                                   (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
+                             (syntax-object-module x))))))
+                    ((vector? x)
+                     (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
+                       (let loop ((i 0))
+                         (if (= i n)
+                           (begin (if #f #f) v)
+                           (begin
+                             (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
+                             (loop (+ i 1)))))))
+                    ((symbol? x)
+                     (syntax-violation
+                       #f
+                       "encountered raw symbol in macro output"
+                       (source-wrap e w (cdr w) mod)
+                       x))
+                    (else (decorate-source x s))))))
+         (with-fluids
+           ((transformer-environment (lambda (k) (k e r w s rib mod))))
+           (rebuild-macro-output
+             (p (source-wrap e (anti-mark w) s mod))
+             (module-gensym "m"))))))
+   (expand-body
+     (lambda (body outer-form r w mod)
+       (let* ((r (cons '("placeholder" placeholder) r))
+              (ribcage (make-ribcage '() '() '()))
+              (w (cons (car w) (cons ribcage (cdr w)))))
+         (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+                     (ids '())
+                     (labels '())
+                     (var-ids '())
+                     (vars '())
+                     (vals '())
+                     (bindings '()))
+           (if (null? body)
+             (syntax-violation #f "no expressions in body" outer-form)
+             (let ((e (cdar body)) (er (caar body)))
+               (call-with-values
+                 (lambda ()
+                   (syntax-type e er '(()) (source-annotation e) ribcage mod #f))
+                 (lambda (type value form e w s mod)
+                   (let ((key type))
+                     (cond ((memv key '(define-form))
+                            (let ((id (wrap value w mod)) (label (gen-label)))
+                              (let ((var (gen-var id)))
+                                (extend-ribcage! ribcage id label)
+                                (parse (cdr body)
+                                       (cons id ids)
+                                       (cons label labels)
+                                       (cons id var-ids)
+                                       (cons var vars)
+                                       (cons (cons er (wrap e w mod)) vals)
+                                       (cons (cons 'lexical var) bindings)))))
+                           ((memv key '(define-syntax-form define-syntax-parameter-form))
+                            (let ((id (wrap value w mod))
+                                  (label (gen-label))
+                                  (trans-r (macros-only-env er)))
+                              (extend-ribcage! ribcage id label)
+                              (set-cdr!
+                                r
+                                (extend-env
+                                  (list label)
+                                  (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
+                                  (cdr r)))
+                              (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+                           ((memv key '(begin-form))
+                            (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+                              (if tmp
+                                (apply (lambda (e1)
+                                         (parse (let f ((forms e1))
+                                                  (if (null? forms)
+                                                    (cdr body)
+                                                    (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
+                                                ids
+                                                labels
+                                                var-ids
+                                                vars
+                                                vals
+                                                bindings))
+                                       tmp)
+                                (syntax-violation
+                                  #f
+                                  "source expression failed to match any pattern"
+                                  tmp-1))))
+                           ((memv key '(local-syntax-form))
+                            (expand-local-syntax
+                              value
+                              e
+                              er
+                              w
+                              s
+                              mod
+                              (lambda (forms er w s mod)
+                                (parse (let f ((forms forms))
+                                         (if (null? forms)
+                                           (cdr body)
+                                           (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
+                                       ids
+                                       labels
+                                       var-ids
+                                       vars
+                                       vals
+                                       bindings))))
+                           ((null? ids)
+                            (build-sequence
+                              #f
+                              (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
+                                   (cons (cons er (source-wrap e w s mod)) (cdr body)))))
+                           (else
+                            (if (not (valid-bound-ids? ids))
+                              (syntax-violation
+                                #f
+                                "invalid or duplicate identifier in definition"
+                                outer-form))
+                            (set-cdr! r (extend-env labels bindings (cdr r)))
+                            (build-letrec
+                              #f
+                              #t
+                              (reverse (map syntax->datum var-ids))
+                              (reverse vars)
+                              (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
+                              (build-sequence
+                                #f
+                                (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
+                                     (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
+   (expand-local-syntax
+     (lambda (rec? e r w s mod k)
+       (let* ((tmp e)
+              (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+         (if tmp
+           (apply (lambda (id val e1 e2)
+                    (let ((ids id))
+                      (if (not (valid-bound-ids? ids))
+                        (syntax-violation #f "duplicate bound keyword" e)
+                        (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
+                          (k (cons e1 e2)
+                             (extend-env
+                               labels
+                               (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
+                                 (map (lambda (x)
+                                        (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+                                      val))
+                               r)
+                             new-w
+                             s
+                             mod)))))
+                  tmp)
+           (syntax-violation
+             #f
+             "bad local syntax definition"
+             (source-wrap e w s mod))))))
+   (eval-local-transformer
+     (lambda (expanded mod)
+       (let ((p (local-eval-hook expanded mod)))
+         (if (procedure? p)
+           p
+           (syntax-violation #f "nonprocedure transformer" p)))))
+   (expand-void (lambda () (build-void #f)))
+   (ellipsis?
+     (lambda (e r mod)
+       (and (nonsymbol-id? e)
+            (let* ((id (make-syntax-object
+                         '#{ $sc-ellipsis }
+                         (syntax-object-wrap e)
+                         (syntax-object-module e)))
+                   (n (id-var-name id '(())))
+                   (b (lookup n r mod)))
+              (if (eq? (car b) 'ellipsis)
+                (bound-id=? e (cdr b))
+                (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))
+   (lambda-formals
+     (lambda (orig-args)
+       (letrec*
+         ((req (lambda (args rreq)
+                 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+                   (if tmp-1
+                     (apply (lambda () (check (reverse rreq) #f)) tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                       (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+                         (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+                         (let ((tmp-1 (list tmp)))
+                           (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+                             (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
+                             (let ((else tmp))
+                               (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
+          (check (lambda (req rest)
+                   (if (distinct-bound-ids? (if rest (cons rest req) req))
+                     (values req #f rest #f)
+                     (syntax-violation
+                       'lambda
+                       "duplicate identifier in argument list"
+                       orig-args)))))
+         (req orig-args '()))))
+   (expand-simple-lambda
+     (lambda (e r w s mod req rest meta body)
+       (let* ((ids (if rest (append req (list rest)) req))
+              (vars (map gen-var ids))
+              (labels (gen-labels ids)))
+         (build-simple-lambda
+           s
+           (map syntax->datum req)
+           (and rest (syntax->datum rest))
+           vars
+           meta
+           (expand-body
+             body
+             (source-wrap e w s mod)
+             (extend-var-env labels vars r)
+             (make-binding-wrap ids labels w)
+             mod)))))
+   (lambda*-formals
+     (lambda (orig-args)
+       (letrec*
+         ((req (lambda (args rreq)
+                 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+                   (if tmp-1
+                     (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                       (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+                         (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+                         (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                           (if (and tmp-1
+                                    (apply (lambda (a b) (eq? (syntax->datum a) #\optional)) tmp-1))
+                             (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
+                             (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                               (if (and tmp-1
+                                        (apply (lambda (a b) (eq? (syntax->datum a) #\key)) tmp-1))
+                                 (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
+                                 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+                                   (if (and tmp-1
+                                            (apply (lambda (a b) (eq? (syntax->datum a) #\rest)) tmp-1))
+                                     (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
+                                     (let ((tmp-1 (list tmp)))
+                                       (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+                                         (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
+                                         (let ((else tmp))
+                                           (syntax-violation
+                                             'lambda*
+                                             "invalid argument list"
+                                             orig-args
+                                             args))))))))))))))))
+          (opt (lambda (args req ropt)
+                 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+                   (if tmp-1
+                     (apply (lambda () (check req (reverse ropt) #f '())) tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                       (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+                         (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
+                         (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+                           (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
+                             (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
+                                    tmp-1)
+                             (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                               (if (and tmp-1
+                                        (apply (lambda (a b) (eq? (syntax->datum a) #\key)) tmp-1))
+                                 (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
+                                 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+                                   (if (and tmp-1
+                                            (apply (lambda (a b) (eq? (syntax->datum a) #\rest)) tmp-1))
+                                     (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1)
+                                     (let ((tmp-1 (list tmp)))
+                                       (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+                                         (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1)
+                                         (let ((else tmp))
+                                           (syntax-violation
+                                             'lambda*
+                                             "invalid optional argument list"
+                                             orig-args
+                                             args))))))))))))))))
+          (key (lambda (args req opt rkey)
+                 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+                   (if tmp-1
+                     (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                       (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+                         (apply (lambda (a b)
+                                  (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
+                                    (key b req opt (cons (cons k (cons a '(#f))) rkey))))
+                                tmp-1)
+                         (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+                           (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
+                             (apply (lambda (a init b)
+                                      (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
+                                        (key b req opt (cons (list k a init) rkey))))
+                                    tmp-1)
+                             (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
+                               (if (and tmp-1
+                                        (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
+                                               tmp-1))
+                                 (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
+                                        tmp-1)
+                                 (let ((tmp-1 ($sc-dispatch tmp '(any))))
+                                   (if (and tmp-1
+                                            (apply (lambda (aok) (eq? (syntax->datum aok) #\allow-other-keys))
+                                                   tmp-1))
+                                     (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
+                                            tmp-1)
+                                     (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
+                                       (if (and tmp-1
+                                                (apply (lambda (aok a b)
+                                                         (and (eq? (syntax->datum aok) #\allow-other-keys)
+                                                              (eq? (syntax->datum a) #\rest)))
+                                                       tmp-1))
+                                         (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
+                                                tmp-1)
+                                         (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                                           (if (and tmp-1
+                                                    (apply (lambda (aok r)
+                                                             (and (eq? (syntax->datum aok) #\allow-other-keys) (id? r)))
+                                                           tmp-1))
+                                             (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
+                                                    tmp-1)
+                                             (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+                                               (if (and tmp-1
+                                                        (apply (lambda (a b) (eq? (syntax->datum a) #\rest)) tmp-1))
+                                                 (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
+                                                        tmp-1)
+                                                 (let ((tmp-1 (list tmp)))
+                                                   (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+                                                     (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
+                                                            tmp-1)
+                                                     (let ((else tmp))
+                                                       (syntax-violation
+                                                         'lambda*
+                                                         "invalid keyword argument list"
+                                                         orig-args
+                                                         args))))))))))))))))))))))
+          (rest (lambda (args req opt kw)
+                  (let* ((tmp-1 args) (tmp (list tmp-1)))
+                    (if (and tmp (apply (lambda (r) (id? r)) tmp))
+                      (apply (lambda (r) (check req opt r kw)) tmp)
+                      (let ((else tmp-1))
+                        (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
+          (check (lambda (req opt rest kw)
+                   (if (distinct-bound-ids?
+                         (append
+                           req
+                           (map car opt)
+                           (if rest (list rest) '())
+                           (if (pair? kw) (map cadr (cdr kw)) '())))
+                     (values req opt rest kw)
+                     (syntax-violation
+                       'lambda*
+                       "duplicate identifier in argument list"
+                       orig-args)))))
+         (req orig-args '()))))
+   (expand-lambda-case
+     (lambda (e r w s mod get-formals clauses)
+       (letrec*
+         ((parse-req
+            (lambda (req opt rest kw body)
+              (let ((vars (map gen-var req)) (labels (gen-labels req)))
+                (let ((r* (extend-var-env labels vars r))
+                      (w* (make-binding-wrap req labels w)))
+                  (parse-opt
+                    (map syntax->datum req)
+                    opt
+                    rest
+                    kw
+                    body
+                    (reverse vars)
+                    r*
+                    w*
+                    '()
+                    '())))))
+          (parse-opt
+            (lambda (req opt rest kw body vars r* w* out inits)
+              (cond ((pair? opt)
+                     (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
+                       (if tmp
+                         (apply (lambda (id i)
+                                  (let* ((v (gen-var id))
+                                         (l (gen-labels (list v)))
+                                         (r** (extend-var-env l (list v) r*))
+                                         (w** (make-binding-wrap (list id) l w*)))
+                                    (parse-opt
+                                      req
+                                      (cdr opt)
+                                      rest
+                                      kw
+                                      body
+                                      (cons v vars)
+                                      r**
+                                      w**
+                                      (cons (syntax->datum id) out)
+                                      (cons (expand i r* w* mod) inits))))
+                                tmp)
+                         (syntax-violation
+                           #f
+                           "source expression failed to match any pattern"
+                           tmp-1))))
+                    (rest
+                     (let* ((v (gen-var rest))
+                            (l (gen-labels (list v)))
+                            (r* (extend-var-env l (list v) r*))
+                            (w* (make-binding-wrap (list rest) l w*)))
+                       (parse-kw
+                         req
+                         (and (pair? out) (reverse out))
+                         (syntax->datum rest)
+                         (if (pair? kw) (cdr kw) kw)
+                         body
+                         (cons v vars)
+                         r*
+                         w*
+                         (and (pair? kw) (car kw))
+                         '()
+                         inits)))
+                    (else
+                     (parse-kw
+                       req
+                       (and (pair? out) (reverse out))
+                       #f
+                       (if (pair? kw) (cdr kw) kw)
+                       body
+                       vars
+                       r*
+                       w*
+                       (and (pair? kw) (car kw))
+                       '()
+                       inits)))))
+          (parse-kw
+            (lambda (req opt rest kw body vars r* w* aok out inits)
+              (if (pair? kw)
+                (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
+                  (if tmp
+                    (apply (lambda (k id i)
+                             (let* ((v (gen-var id))
+                                    (l (gen-labels (list v)))
+                                    (r** (extend-var-env l (list v) r*))
+                                    (w** (make-binding-wrap (list id) l w*)))
+                               (parse-kw
+                                 req
+                                 opt
+                                 rest
+                                 (cdr kw)
+                                 body
+                                 (cons v vars)
+                                 r**
+                                 w**
+                                 aok
+                                 (cons (list (syntax->datum k) (syntax->datum id) v) out)
+                                 (cons (expand i r* w* mod) inits))))
+                           tmp)
+                    (syntax-violation
+                      #f
+                      "source expression failed to match any pattern"
+                      tmp-1)))
+                (parse-body
+                  req
+                  opt
+                  rest
+                  (and (or aok (pair? out)) (cons aok (reverse out)))
+                  body
+                  (reverse vars)
+                  r*
+                  w*
+                  (reverse inits)
+                  '()))))
+          (parse-body
+            (lambda (req opt rest kw body vars r* w* inits meta)
+              (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
+                (if (and tmp-1
+                         (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
+                                tmp-1))
+                  (apply (lambda (docstring e1 e2)
+                           (parse-body
+                             req
+                             opt
+                             rest
+                             kw
+                             (cons e1 e2)
+                             vars
+                             r*
+                             w*
+                             inits
+                             (append meta (list (cons 'documentation (syntax->datum docstring))))))
+                         tmp-1)
+                  (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
+                    (if tmp-1
+                      (apply (lambda (k v e1 e2)
+                               (parse-body
+                                 req
+                                 opt
+                                 rest
+                                 kw
+                                 (cons e1 e2)
+                                 vars
+                                 r*
+                                 w*
+                                 inits
+                                 (append meta (syntax->datum (map cons k v)))))
+                             tmp-1)
+                      (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
+                        (if tmp-1
+                          (apply (lambda (e1 e2)
+                                   (values
+                                     meta
+                                     req
+                                     opt
+                                     rest
+                                     kw
+                                     inits
+                                     vars
+                                     (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
+                                 tmp-1)
+                          (syntax-violation
+                            #f
+                            "source expression failed to match any pattern"
+                            tmp))))))))))
+         (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
+           (if tmp-1
+             (apply (lambda () (values '() #f)) tmp-1)
+             (let ((tmp-1 ($sc-dispatch
+                            tmp
+                            '((any any . each-any) . #(each (any any . each-any))))))
+               (if tmp-1
+                 (apply (lambda (args e1 e2 args* e1* e2*)
+                          (call-with-values
+                            (lambda () (get-formals args))
+                            (lambda (req opt rest kw)
+                              (call-with-values
+                                (lambda () (parse-req req opt rest kw (cons e1 e2)))
+                                (lambda (meta req opt rest kw inits vars body)
+                                  (call-with-values
+                                    (lambda ()
+                                      (expand-lambda-case
+                                        e
+                                        r
+                                        w
+                                        s
+                                        mod
+                                        get-formals
+                                        (map (lambda (tmp-bde397a-a85 tmp-bde397a-a84 tmp-bde397a-a83)
+                                               (cons tmp-bde397a-a83 (cons tmp-bde397a-a84 tmp-bde397a-a85)))
+                                             e2*
+                                             e1*
+                                             args*)))
+                                    (lambda (meta* else*)
+                                      (values
+                                        (append meta meta*)
+                                        (build-lambda-case s req opt rest kw inits vars body else*)))))))))
+                        tmp-1)
+                 (syntax-violation
+                   #f
+                   "source expression failed to match any pattern"
+                   tmp))))))))
+   (strip (lambda (x w)
+            (if (memq 'top (car w))
+              x
+              (let f ((x x))
+                (cond ((syntax-object? x)
+                       (strip (syntax-object-expression x) (syntax-object-wrap x)))
+                      ((pair? x)
+                       (let ((a (f (car x))) (d (f (cdr x))))
+                         (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
+                      ((vector? x)
+                       (let* ((old (vector->list x)) (new (map f old)))
+                         (let lp ((l1 old) (l2 new))
+                           (cond ((null? l1) x)
+                                 ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
+                                 (else (list->vector new))))))
+                      (else x))))))
+   (gen-var
+     (lambda (id)
+       (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+         (module-gensym (symbol->string id)))))
+   (lambda-var-list
+     (lambda (vars)
+       (let lvl ((vars vars) (ls '()) (w '(())))
+         (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+               ((id? vars) (cons (wrap vars w #f) ls))
+               ((null? vars) ls)
+               ((syntax-object? vars)
+                (lvl (syntax-object-expression vars)
+                     ls
+                     (join-wraps w (syntax-object-wrap vars))))
+               (else (cons vars ls)))))))
+  (global-extend 'local-syntax 'letrec-syntax #t)
+  (global-extend 'local-syntax 'let-syntax #f)
+  (global-extend
+    'core
+    'syntax-parameterize
+    (lambda (e r w s mod)
+      (let* ((tmp e)
+             (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+        (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
+          (apply (lambda (var val e1 e2)
+                   (let ((names (map (lambda (x) (id-var-name x w)) var)))
+                     (for-each
+                       (lambda (id n)
+                         (let ((key (car (lookup n r mod))))
+                           (if (memv key '(displaced-lexical))
+                             (syntax-violation
+                               'syntax-parameterize
+                               "identifier out of context"
+                               e
+                               (source-wrap id w s mod)))))
+                       var
+                       names)
+                     (expand-body
+                       (cons e1 e2)
+                       (source-wrap e w s mod)
+                       (extend-env
+                         names
+                         (let ((trans-r (macros-only-env r)))
+                           (map (lambda (x)
+                                  (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+                                val))
+                         r)
+                       w
+                       mod)))
+                 tmp)
+          (syntax-violation
+            'syntax-parameterize
+            "bad syntax"
+            (source-wrap e w s mod))))))
+  (global-extend
+    'core
+    'quote
+    (lambda (e r w s mod)
+      (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
+        (if tmp
+          (apply (lambda (e) (build-data s (strip e w))) tmp)
+          (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
+  (global-extend
+    'core
+    'syntax
+    (letrec*
+      ((gen-syntax
+         (lambda (src e r maps ellipsis? mod)
+           (if (id? e)
+             (let* ((label (id-var-name e '(()))) (b (lookup label r mod)))
+               (cond ((eq? (car b) 'syntax)
+                      (call-with-values
+                        (lambda ()
+                          (let ((var.lev (cdr b)))
+                            (gen-ref src (car var.lev) (cdr var.lev) maps)))
+                        (lambda (var maps) (values (list 'ref var) maps))))
+                     ((ellipsis? e r mod)
+                      (syntax-violation 'syntax "misplaced ellipsis" src))
+                     (else (values (list 'quote e) maps))))
+             (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
+               (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
+                 (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
+                        tmp-1)
+                 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+                   (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1))
+                     (apply (lambda (x dots y)
+                              (let f ((y y)
+                                      (k (lambda (maps)
+                                           (call-with-values
+                                             (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
+                                             (lambda (x maps)
+                                               (if (null? (car maps))
+                                                 (syntax-violation 'syntax "extra ellipsis" src)
+                                                 (values (gen-map x (car maps)) (cdr maps))))))))
+                                (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
+                                  (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
+                                    (apply (lambda (dots y)
+                                             (f y
+                                                (lambda (maps)
+                                                  (call-with-values
+                                                    (lambda () (k (cons '() maps)))
+                                                    (lambda (x maps)
+                                                      (if (null? (car maps))
+                                                        (syntax-violation 'syntax "extra ellipsis" src)
+                                                        (values (gen-mappend x (car maps)) (cdr maps))))))))
+                                           tmp)
+                                    (call-with-values
+                                      (lambda () (gen-syntax src y r maps ellipsis? mod))
+                                      (lambda (y maps)
+                                        (call-with-values
+                                          (lambda () (k maps))
+                                          (lambda (x maps) (values (gen-append x y) maps)))))))))
+                            tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                       (if tmp-1
+                         (apply (lambda (x y)
+                                  (call-with-values
+                                    (lambda () (gen-syntax src x r maps ellipsis? mod))
+                                    (lambda (x maps)
+                                      (call-with-values
+                                        (lambda () (gen-syntax src y r maps ellipsis? mod))
+                                        (lambda (y maps) (values (gen-cons x y) maps))))))
+                                tmp-1)
+                         (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
+                           (if tmp
+                             (apply (lambda (e1 e2)
+                                      (call-with-values
+                                        (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
+                                        (lambda (e maps) (values (gen-vector e) maps))))
+                                    tmp)
+                             (values (list 'quote e) maps))))))))))))
+       (gen-ref
+         (lambda (src var level maps)
+           (cond ((= level 0) (values var maps))
+                 ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
+                 (else
+                  (call-with-values
+                    (lambda () (gen-ref src var (- level 1) (cdr maps)))
+                    (lambda (outer-var outer-maps)
+                      (let ((b (assq outer-var (car maps))))
+                        (if b
+                          (values (cdr b) maps)
+                          (let ((inner-var (gen-var 'tmp)))
+                            (values
+                              inner-var
+                              (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
+       (gen-mappend
+         (lambda (e map-env)
+           (list 'apply '(primitive append) (gen-map e map-env))))
+       (gen-map
+         (lambda (e map-env)
+           (let ((formals (map cdr map-env))
+                 (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
+             (cond ((eq? (car e) 'ref) (car actuals))
+                   ((and-map
+                      (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+                      (cdr e))
+                    (cons 'map
+                          (cons (list 'primitive (car e))
+                                (map (let ((r (map cons formals actuals)))
+                                       (lambda (x) (cdr (assq (cadr x) r))))
+                                     (cdr e)))))
+                   (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
+       (gen-cons
+         (lambda (x y)
+           (let ((key (car y)))
+             (cond ((memv key '(quote))
+                    (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
+                          ((eq? (cadr y) '()) (list 'list x))
+                          (else (list 'cons x y))))
+                   ((memv key '(list)) (cons 'list (cons x (cdr y))))
+                   (else (list 'cons x y))))))
+       (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
+       (gen-vector
+         (lambda (x)
+           (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
+                 ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
+                 (else (list 'list->vector x)))))
+       (regen (lambda (x)
+                (let ((key (car x)))
+                  (cond ((memv key '(ref))
+                         (build-lexical-reference 'value #f (cadr x) (cadr x)))
+                        ((memv key '(primitive)) (build-primref #f (cadr x)))
+                        ((memv key '(quote)) (build-data #f (cadr x)))
+                        ((memv key '(lambda))
+                         (if (list? (cadr x))
+                           (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
+                           (error "how did we get here" x)))
+                        (else
+                         (build-application #f (build-primref #f (car x)) (map regen (cdr x)))))))))
+      (lambda (e r w s mod)
+        (let* ((e (source-wrap e w s mod))
+               (tmp e)
+               (tmp ($sc-dispatch tmp '(_ any))))
+          (if tmp
+            (apply (lambda (x)
+                     (call-with-values
+                       (lambda () (gen-syntax e x r '() ellipsis? mod))
+                       (lambda (e maps) (regen e))))
+                   tmp)
+            (syntax-violation 'syntax "bad `syntax' form" e))))))
+  (global-extend
+    'core
+    'lambda
+    (lambda (e r w s mod)
+      (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+        (if tmp
+          (apply (lambda (args e1 e2)
+                   (call-with-values
+                     (lambda () (lambda-formals args))
+                     (lambda (req opt rest kw)
+                       (let lp ((body (cons e1 e2)) (meta '()))
+                         (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
+                           (if (and tmp
+                                    (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
+                                           tmp))
+                             (apply (lambda (docstring e1 e2)
+                                      (lp (cons e1 e2)
+                                          (append meta (list (cons 'documentation (syntax->datum docstring))))))
+                                    tmp)
+                             (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
+                               (if tmp
+                                 (apply (lambda (k v e1 e2)
+                                          (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
+                                        tmp)
+                                 (expand-simple-lambda e r w s mod req rest meta body)))))))))
+                 tmp)
+          (syntax-violation 'lambda "bad lambda" e)))))
+  (global-extend
+    'core
+    'lambda*
+    (lambda (e r w s mod)
+      (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+        (if tmp
+          (apply (lambda (args e1 e2)
+                   (call-with-values
+                     (lambda ()
+                       (expand-lambda-case
+                         e
+                         r
+                         w
+                         s
+                         mod
+                         lambda*-formals
+                         (list (cons args (cons e1 e2)))))
+                     (lambda (meta lcase) (build-case-lambda s meta lcase))))
+                 tmp)
+          (syntax-violation 'lambda "bad lambda*" e)))))
+  (global-extend
+    'core
+    'case-lambda
+    (lambda (e r w s mod)
+      (letrec*
+        ((build-it
+           (lambda (meta clauses)
+             (call-with-values
+               (lambda () (expand-lambda-case e r w s mod lambda-formals clauses))
+               (lambda (meta* lcase)
+                 (build-case-lambda s (append meta meta*) lcase))))))
+        (let* ((tmp-1 e)
+               (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+          (if tmp
+            (apply (lambda (args e1 e2)
+                     (build-it
+                       '()
+                       (map (lambda (tmp-bde397a-c50 tmp-bde397a-c4f tmp-bde397a-c4e)
+                              (cons tmp-bde397a-c4e (cons tmp-bde397a-c4f tmp-bde397a-c50)))
+                            e2
+                            e1
+                            args)))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
+              (if (and tmp
+                       (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
+                              tmp))
+                (apply (lambda (docstring args e1 e2)
+                         (build-it
+                           (list (cons 'documentation (syntax->datum docstring)))
+                           (map (lambda (tmp-bde397a-c66 tmp-bde397a-c65 tmp-bde397a-c64)
+                                  (cons tmp-bde397a-c64 (cons tmp-bde397a-c65 tmp-bde397a-c66)))
+                                e2
+                                e1
+                                args)))
+                       tmp)
+                (syntax-violation 'case-lambda "bad case-lambda" e))))))))
+  (global-extend
+    'core
+    'case-lambda*
+    (lambda (e r w s mod)
+      (letrec*
+        ((build-it
+           (lambda (meta clauses)
+             (call-with-values
+               (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses))
+               (lambda (meta* lcase)
+                 (build-case-lambda s (append meta meta*) lcase))))))
+        (let* ((tmp-1 e)
+               (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+          (if tmp
+            (apply (lambda (args e1 e2)
+                     (build-it
+                       '()
+                       (map (lambda (tmp-bde397a-c86 tmp-bde397a-c85 tmp-bde397a-c84)
+                              (cons tmp-bde397a-c84 (cons tmp-bde397a-c85 tmp-bde397a-c86)))
+                            e2
+                            e1
+                            args)))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
+              (if (and tmp
+                       (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
+                              tmp))
+                (apply (lambda (docstring args e1 e2)
+                         (build-it
+                           (list (cons 'documentation (syntax->datum docstring)))
+                           (map (lambda (tmp-bde397a-c9c tmp-bde397a-c9b tmp-bde397a-c9a)
+                                  (cons tmp-bde397a-c9a (cons tmp-bde397a-c9b tmp-bde397a-c9c)))
+                                e2
+                                e1
+                                args)))
+                       tmp)
+                (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
+  (global-extend
+    'core
+    'with-ellipsis
+    (lambda (e r w s mod)
+      (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+        (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
+          (apply (lambda (dots e1 e2)
+                   (let ((id (if (symbol? dots)
+                               '#{ $sc-ellipsis }
+                               (make-syntax-object
+                                 '#{ $sc-ellipsis }
+                                 (syntax-object-wrap dots)
+                                 (syntax-object-module dots)))))
+                     (let ((ids (list id))
+                           (labels (list (gen-label)))
+                           (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
+                       (let ((nw (make-binding-wrap ids labels w))
+                             (nr (extend-env labels bindings r)))
+                         (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
+                 tmp)
+          (syntax-violation
+            'with-ellipsis
+            "bad syntax"
+            (source-wrap e w s mod))))))
+  (global-extend
+    'core
+    'let
+    (letrec*
+      ((expand-let
+         (lambda (e r w s mod constructor ids vals exps)
+           (if (not (valid-bound-ids? ids))
+             (syntax-violation 'let "duplicate bound variable" e)
+             (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+               (let ((nw (make-binding-wrap ids labels w))
+                     (nr (extend-var-env labels new-vars r)))
+                 (constructor
+                   s
+                   (map syntax->datum ids)
+                   new-vars
+                   (map (lambda (x) (expand x r w mod)) vals)
+                   (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
+      (lambda (e r w s mod)
+        (let* ((tmp-1 e)
+               (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
+          (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+            (apply (lambda (id val e1 e2)
+                     (expand-let e r w s mod build-let id val (cons e1 e2)))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
+              (if (and tmp
+                       (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
+                (apply (lambda (f id val e1 e2)
+                         (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
+                       tmp)
+                (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
+  (global-extend
+    'core
+    'letrec
+    (lambda (e r w s mod)
+      (let* ((tmp e)
+             (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+        (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+          (apply (lambda (id val e1 e2)
+                   (let ((ids id))
+                     (if (not (valid-bound-ids? ids))
+                       (syntax-violation 'letrec "duplicate bound variable" e)
+                       (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+                         (let ((w (make-binding-wrap ids labels w))
+                               (r (extend-var-env labels new-vars r)))
+                           (build-letrec
+                             s
+                             #f
+                             (map syntax->datum ids)
+                             new-vars
+                             (map (lambda (x) (expand x r w mod)) val)
+                             (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
+                 tmp)
+          (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
+  (global-extend
+    'core
+    'letrec*
+    (lambda (e r w s mod)
+      (let* ((tmp e)
+             (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+        (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+          (apply (lambda (id val e1 e2)
+                   (let ((ids id))
+                     (if (not (valid-bound-ids? ids))
+                       (syntax-violation 'letrec* "duplicate bound variable" e)
+                       (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+                         (let ((w (make-binding-wrap ids labels w))
+                               (r (extend-var-env labels new-vars r)))
+                           (build-letrec
+                             s
+                             #t
+                             (map syntax->datum ids)
+                             new-vars
+                             (map (lambda (x) (expand x r w mod)) val)
+                             (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
+                 tmp)
+          (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
+  (global-extend
+    'core
+    'set!
+    (lambda (e r w s mod)
+      (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+        (if (and tmp (apply (lambda (id val) (id? id)) tmp))
+          (apply (lambda (id val)
+                   (let ((n (id-var-name id w))
+                         (id-mod (if (syntax-object? id) (syntax-object-module id) mod)))
+                     (let* ((b (lookup n r id-mod)) (key (car b)))
+                       (cond ((memv key '(lexical))
+                              (build-lexical-assignment
+                                s
+                                (syntax->datum id)
+                                (cdr b)
+                                (expand val r w mod)))
+                             ((memv key '(global))
+                              (build-global-assignment s n (expand val r w mod) id-mod))
+                             ((memv key '(macro))
+                              (let ((p (cdr b)))
+                                (if (procedure-property p 'variable-transformer)
+                                  (expand (expand-macro p e r w s #f mod) r '(()) mod)
+                                  (syntax-violation
+                                    'set!
+                                    "not a variable transformer"
+                                    (wrap e w mod)
+                                    (wrap id w id-mod)))))
+                             ((memv key '(displaced-lexical))
+                              (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
+                             (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+                 tmp)
+          (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
+            (if tmp
+              (apply (lambda (head tail val)
+                       (call-with-values
+                         (lambda () (syntax-type head r '(()) #f #f mod #t))
+                         (lambda (type value formform ee ww ss modmod)
+                           (let ((key type))
+                             (if (memv key '(module-ref))
+                               (let ((val (expand val r w mod)))
+                                 (call-with-values
+                                   (lambda () (value (cons head tail) r w))
+                                   (lambda (e r w s* mod)
+                                     (let* ((tmp-1 e) (tmp (list tmp-1)))
+                                       (if (and tmp (apply (lambda (e) (id? e)) tmp))
+                                         (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
+                                                tmp)
+                                         (syntax-violation
+                                           #f
+                                           "source expression failed to match any pattern"
+                                           tmp-1))))))
+                               (build-application
+                                 s
+                                 (expand
+                                   (list '#(syntax-object setter ((top)) (hygiene guile)) head)
+                                   r
+                                   w
+                                   mod)
+                                 (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
+                     tmp)
+              (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
+  (global-extend
+    'module-ref
+    '@
+    (lambda (e r w)
+      (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+        (if (and tmp
+                 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
+          (apply (lambda (mod id)
+                   (values
+                     (syntax->datum id)
+                     r
+                     '((top))
+                     #f
+                     (syntax->datum
+                       (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
+                 tmp)
+          (syntax-violation
+            #f
+            "source expression failed to match any pattern"
+            tmp-1)))))
+  (global-extend
+    'module-ref
+    '@@
+    (lambda (e r w)
+      (letrec*
+        ((remodulate
+           (lambda (x mod)
+             (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
+                   ((syntax-object? x)
+                    (make-syntax-object
+                      (remodulate (syntax-object-expression x) mod)
+                      (syntax-object-wrap x)
+                      mod))
+                   ((vector? x)
+                    (let* ((n (vector-length x)) (v (make-vector n)))
+                      (let loop ((i 0))
+                        (if (= i n)
+                          (begin (if #f #f) v)
+                          (begin
+                            (vector-set! v i (remodulate (vector-ref x i) mod))
+                            (loop (+ i 1)))))))
+                   (else x)))))
+        (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+          (if (and tmp
+                   (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
+            (apply (lambda (mod id)
+                     (values
+                       (syntax->datum id)
+                       r
+                       '((top))
+                       #f
+                       (syntax->datum
+                         (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+                   tmp)
+            (let ((tmp ($sc-dispatch
+                         tmp-1
+                         '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
+                             each-any
+                             any))))
+              (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
+                (apply (lambda (mod exp)
+                         (let ((mod (syntax->datum
+                                      (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+                           (values (remodulate exp mod) r w (source-annotation exp) mod)))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1))))))))
+  (global-extend
+    'core
+    'if
+    (lambda (e r w s mod)
+      (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
+        (if tmp-1
+          (apply (lambda (test then)
+                   (build-conditional
+                     s
+                     (expand test r w mod)
+                     (expand then r w mod)
+                     (build-void #f)))
+                 tmp-1)
+          (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
+            (if tmp-1
+              (apply (lambda (test then else)
+                       (build-conditional
+                         s
+                         (expand test r w mod)
+                         (expand then r w mod)
+                         (expand else r w mod)))
+                     tmp-1)
+              (syntax-violation
+                #f
+                "source expression failed to match any pattern"
+                tmp)))))))
+  (global-extend
+    'core
+    'with-fluids
+    (lambda (e r w s mod)
+      (let* ((tmp-1 e)
+             (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
+        (if tmp
+          (apply (lambda (fluid val b b*)
+                   (build-dynlet
+                     s
+                     (map (lambda (x) (expand x r w mod)) fluid)
+                     (map (lambda (x) (expand x r w mod)) val)
+                     (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
+                 tmp)
+          (syntax-violation
+            #f
+            "source expression failed to match any pattern"
+            tmp-1)))))
+  (global-extend 'begin 'begin '())
+  (global-extend 'define 'define '())
+  (global-extend 'define-syntax 'define-syntax '())
+  (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
+  (global-extend 'eval-when 'eval-when '())
+  (global-extend
+    'core
+    'syntax-case
+    (letrec*
+      ((convert-pattern
+         (lambda (pattern keys ellipsis?)
+           (letrec*
+             ((cvt* (lambda (p* n ids)
+                      (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
+                        (if tmp
+                          (apply (lambda (x y)
+                                   (call-with-values
+                                     (lambda () (cvt* y n ids))
+                                     (lambda (y ids)
+                                       (call-with-values
+                                         (lambda () (cvt x n ids))
+                                         (lambda (x ids) (values (cons x y) ids))))))
+                                 tmp)
+                          (cvt p* n ids)))))
+              (v-reverse
+                (lambda (x)
+                  (let loop ((r '()) (x x))
+                    (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
+              (cvt (lambda (p n ids)
+                     (if (id? p)
+                       (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
+                             ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
+                              (values '_ ids))
+                             (else (values 'any (cons (cons p n) ids))))
+                       (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
+                         (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
+                           (apply (lambda (x dots)
+                                    (call-with-values
+                                      (lambda () (cvt x (+ n 1) ids))
+                                      (lambda (p ids)
+                                        (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
+                                  tmp-1)
+                           (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+                             (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
+                               (apply (lambda (x dots ys)
+                                        (call-with-values
+                                          (lambda () (cvt* ys n ids))
+                                          (lambda (ys ids)
+                                            (call-with-values
+                                              (lambda () (cvt x (+ n 1) ids))
+                                              (lambda (x ids)
+                                                (call-with-values
+                                                  (lambda () (v-reverse ys))
+                                                  (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
+                                      tmp-1)
+                               (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                                 (if tmp-1
+                                   (apply (lambda (x y)
+                                            (call-with-values
+                                              (lambda () (cvt y n ids))
+                                              (lambda (y ids)
+                                                (call-with-values
+                                                  (lambda () (cvt x n ids))
+                                                  (lambda (x ids) (values (cons x y) ids))))))
+                                          tmp-1)
+                                   (let ((tmp-1 ($sc-dispatch tmp '())))
+                                     (if tmp-1
+                                       (apply (lambda () (values '() ids)) tmp-1)
+                                       (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
+                                         (if tmp-1
+                                           (apply (lambda (x)
+                                                    (call-with-values
+                                                      (lambda () (cvt x n ids))
+                                                      (lambda (p ids) (values (vector 'vector p) ids))))
+                                                  tmp-1)
+                                           (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
+             (cvt pattern 0 '()))))
+       (build-dispatch-call
+         (lambda (pvars exp y r mod)
+           (let ((ids (map car pvars)) (levels (map cdr pvars)))
+             (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+               (build-application
+                 #f
+                 (build-primref #f 'apply)
+                 (list (build-simple-lambda
+                         #f
+                         (map syntax->datum ids)
+                         #f
+                         new-vars
+                         '()
+                         (expand
+                           exp
+                           (extend-env
+                             labels
+                             (map (lambda (var level) (cons 'syntax (cons var level)))
+                                  new-vars
+                                  (map cdr pvars))
+                             r)
+                           (make-binding-wrap ids labels '(()))
+                           mod))
+                       y))))))
+       (gen-clause
+         (lambda (x keys clauses r pat fender exp mod)
+           (call-with-values
+             (lambda ()
+               (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
+             (lambda (p pvars)
+               (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
+                      (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+                     ((not (distinct-bound-ids? (map car pvars)))
+                      (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+                     (else
+                      (let ((y (gen-var 'tmp)))
+                        (build-application
+                          #f
+                          (build-simple-lambda
+                            #f
+                            (list 'tmp)
+                            #f
+                            (list y)
+                            '()
+                            (let ((y (build-lexical-reference 'value #f 'tmp y)))
+                              (build-conditional
+                                #f
+                                (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
+                                  (if tmp
+                                    (apply (lambda () y) tmp)
+                                    (build-conditional
+                                      #f
+                                      y
+                                      (build-dispatch-call pvars fender y r mod)
+                                      (build-data #f #f))))
+                                (build-dispatch-call pvars exp y r mod)
+                                (gen-syntax-case x keys clauses r mod))))
+                          (list (if (eq? p 'any)
+                                  (build-application #f (build-primref #f 'list) (list x))
+                                  (build-application
+                                    #f
+                                    (build-primref #f '$sc-dispatch)
+                                    (list x (build-data #f p)))))))))))))
+       (gen-syntax-case
+         (lambda (x keys clauses r mod)
+           (if (null? clauses)
+             (build-application
+               #f
+               (build-primref #f 'syntax-violation)
+               (list (build-data #f #f)
+                     (build-data #f "source expression failed to match any pattern")
+                     x))
+             (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
+               (if tmp
+                 (apply (lambda (pat exp)
+                          (if (and (id? pat)
+                                   (and-map
+                                     (lambda (x) (not (free-id=? pat x)))
+                                     (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
+                            (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
+                              (expand exp r '(()) mod)
+                              (let ((labels (list (gen-label))) (var (gen-var pat)))
+                                (build-application
+                                  #f
+                                  (build-simple-lambda
+                                    #f
+                                    (list (syntax->datum pat))
+                                    #f
+                                    (list var)
+                                    '()
+                                    (expand
+                                      exp
+                                      (extend-env labels (list (cons 'syntax (cons var 0))) r)
+                                      (make-binding-wrap (list pat) labels '(()))
+                                      mod))
+                                  (list x))))
+                            (gen-clause x keys (cdr clauses) r pat #t exp mod)))
+                        tmp)
+                 (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
+                   (if tmp
+                     (apply (lambda (pat fender exp)
+                              (gen-clause x keys (cdr clauses) r pat fender exp mod))
+                            tmp)
+                     (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
+      (lambda (e r w s mod)
+        (let* ((e (source-wrap e w s mod))
+               (tmp-1 e)
+               (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
+          (if tmp
+            (apply (lambda (val key m)
+                     (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
+                       (let ((x (gen-var 'tmp)))
+                         (build-application
+                           s
+                           (build-simple-lambda
+                             #f
+                             (list 'tmp)
+                             #f
+                             (list x)
+                             '()
+                             (gen-syntax-case
+                               (build-lexical-reference 'value #f 'tmp x)
+                               key
+                               m
+                               r
+                               mod))
+                           (list (expand val r '(()) mod))))
+                       (syntax-violation 'syntax-case "invalid literals list" e)))
+                   tmp)
+            (syntax-violation
+              #f
+              "source expression failed to match any pattern"
+              tmp-1))))))
+  (set! macroexpand
+    (lambda* (x #\optional (m 'e) (esew '(eval)))
+      (expand-top-sequence
+        (list x)
+        '()
+        '((top))
+        #f
+        m
+        esew
+        (cons 'hygiene (module-name (current-module))))))
+  (set! identifier? (lambda (x) (nonsymbol-id? x)))
+  (set! datum->syntax
+    (lambda (id datum)
+      (make-syntax-object
+        datum
+        (syntax-object-wrap id)
+        (syntax-object-module id))))
+  (set! syntax->datum (lambda (x) (strip x '(()))))
+  (set! syntax-source (lambda (x) (source-annotation x)))
+  (set! generate-temporaries
+    (lambda (ls)
+      (let ((x ls))
+        (if (not (list? x))
+          (syntax-violation 'generate-temporaries "invalid argument" x)))
+      (let ((mod (cons 'hygiene (module-name (current-module)))))
+        (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls))))
+  (set! free-identifier=?
+    (lambda (x y)
+      (let ((x x))
+        (if (not (nonsymbol-id? x))
+          (syntax-violation 'free-identifier=? "invalid argument" x)))
+      (let ((x y))
+        (if (not (nonsymbol-id? x))
+          (syntax-violation 'free-identifier=? "invalid argument" x)))
+      (free-id=? x y)))
+  (set! bound-identifier=?
+    (lambda (x y)
+      (let ((x x))
+        (if (not (nonsymbol-id? x))
+          (syntax-violation 'bound-identifier=? "invalid argument" x)))
+      (let ((x y))
+        (if (not (nonsymbol-id? x))
+          (syntax-violation 'bound-identifier=? "invalid argument" x)))
+      (bound-id=? x y)))
+  (set! syntax-violation
+    (lambda* (who message form #\optional (subform #f))
+      (let ((x who))
+        (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
+          (syntax-violation 'syntax-violation "invalid argument" x)))
+      (let ((x message))
+        (if (not (string? x))
+          (syntax-violation 'syntax-violation "invalid argument" x)))
+      (throw 'syntax-error
+             who
+             message
+             (or (source-annotation subform) (source-annotation form))
+             (strip form '(()))
+             (and subform (strip subform '(()))))))
+  (letrec*
+    ((syntax-module
+       (lambda (id)
+         (let ((x id))
+           (if (not (nonsymbol-id? x))
+             (syntax-violation 'syntax-module "invalid argument" x)))
+         (cdr (syntax-object-module id))))
+     (syntax-local-binding
+       (lambda (id)
+         (let ((x id))
+           (if (not (nonsymbol-id? x))
+             (syntax-violation 'syntax-local-binding "invalid argument" x)))
+         (with-transformer-environment
+           (lambda (e r w s rib mod)
+             (letrec*
+               ((strip-anti-mark
+                  (lambda (w)
+                    (let ((ms (car w)) (s (cdr w)))
+                      (if (and (pair? ms) (eq? (car ms) #f))
+                        (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+                        (cons ms (if rib (cons rib s) s)))))))
+               (call-with-values
+                 (lambda ()
+                   (resolve-identifier
+                     (syntax-object-expression id)
+                     (strip-anti-mark (syntax-object-wrap id))
+                     r
+                     (syntax-object-module id)))
+                 (lambda (type value mod)
+                   (let ((key type))
+                     (cond ((memv key '(lexical)) (values 'lexical value))
+                           ((memv key '(macro)) (values 'macro value))
+                           ((memv key '(syntax)) (values 'pattern-variable value))
+                           ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
+                           ((memv key '(global)) (values 'global (cons value (cdr mod))))
+                           ((memv key '(ellipsis))
+                            (values
+                              'ellipsis
+                              (make-syntax-object
+                                (syntax-object-expression value)
+                                (anti-mark (syntax-object-wrap value))
+                                (syntax-object-module value))))
+                           (else (values 'other #f)))))))))))
+     (syntax-locally-bound-identifiers
+       (lambda (id)
+         (let ((x id))
+           (if (not (nonsymbol-id? x))
+             (syntax-violation
+               'syntax-locally-bound-identifiers
+               "invalid argument"
+               x)))
+         (locally-bound-identifiers
+           (syntax-object-wrap id)
+           (syntax-object-module id)))))
+    (define! 'syntax-module syntax-module)
+    (define! 'syntax-local-binding syntax-local-binding)
+    (define!
+      'syntax-locally-bound-identifiers
+      syntax-locally-bound-identifiers))
+  (letrec*
+    ((match-each
+       (lambda (e p w mod)
+         (cond ((pair? e)
+                (let ((first (match (car e) p w '() mod)))
+                  (and first
+                       (let ((rest (match-each (cdr e) p w mod)))
+                         (and rest (cons first rest))))))
+               ((null? e) '())
+               ((syntax-object? e)
+                (match-each
+                  (syntax-object-expression e)
+                  p
+                  (join-wraps w (syntax-object-wrap e))
+                  (syntax-object-module e)))
+               (else #f))))
+     (match-each+
+       (lambda (e x-pat y-pat z-pat w r mod)
+         (let f ((e e) (w w))
+           (cond ((pair? e)
+                  (call-with-values
+                    (lambda () (f (cdr e) w))
+                    (lambda (xr* y-pat r)
+                      (if r
+                        (if (null? y-pat)
+                          (let ((xr (match (car e) x-pat w '() mod)))
+                            (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
+                          (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
+                        (values #f #f #f)))))
+                 ((syntax-object? e)
+                  (f (syntax-object-expression e)
+                     (join-wraps w (syntax-object-wrap e))))
+                 (else (values '() y-pat (match e z-pat w r mod)))))))
+     (match-each-any
+       (lambda (e w mod)
+         (cond ((pair? e)
+                (let ((l (match-each-any (cdr e) w mod)))
+                  (and l (cons (wrap (car e) w mod) l))))
+               ((null? e) '())
+               ((syntax-object? e)
+                (match-each-any
+                  (syntax-object-expression e)
+                  (join-wraps w (syntax-object-wrap e))
+                  mod))
+               (else #f))))
+     (match-empty
+       (lambda (p r)
+         (cond ((null? p) r)
+               ((eq? p '_) r)
+               ((eq? p 'any) (cons '() r))
+               ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+               ((eq? p 'each-any) (cons '() r))
+               (else
+                (let ((key (vector-ref p 0)))
+                  (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
+                        ((memv key '(each+))
+                         (match-empty
+                           (vector-ref p 1)
+                           (match-empty
+                             (reverse (vector-ref p 2))
+                             (match-empty (vector-ref p 3) r))))
+                        ((memv key '(free-id atom)) r)
+                        ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
+     (combine
+       (lambda (r* r)
+         (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
+     (match*
+       (lambda (e p w r mod)
+         (cond ((null? p) (and (null? e) r))
+               ((pair? p)
+                (and (pair? e)
+                     (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
+               ((eq? p 'each-any)
+                (let ((l (match-each-any e w mod))) (and l (cons l r))))
+               (else
+                (let ((key (vector-ref p 0)))
+                  (cond ((memv key '(each))
+                         (if (null? e)
+                           (match-empty (vector-ref p 1) r)
+                           (let ((l (match-each e (vector-ref p 1) w mod)))
+                             (and l
+                                  (let collect ((l l))
+                                    (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
+                        ((memv key '(each+))
+                         (call-with-values
+                           (lambda ()
+                             (match-each+
+                               e
+                               (vector-ref p 1)
+                               (vector-ref p 2)
+                               (vector-ref p 3)
+                               w
+                               r
+                               mod))
+                           (lambda (xr* y-pat r)
+                             (and r
+                                  (null? y-pat)
+                                  (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
+                        ((memv key '(free-id))
+                         (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
+                        ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
+                        ((memv key '(vector))
+                         (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
+     (match (lambda (e p w r mod)
+              (cond ((not r) #f)
+                    ((eq? p '_) r)
+                    ((eq? p 'any) (cons (wrap e w mod) r))
+                    ((syntax-object? e)
+                     (match*
+                       (syntax-object-expression e)
+                       p
+                       (join-wraps w (syntax-object-wrap e))
+                       r
+                       (syntax-object-module e)))
+                    (else (match* e p w r mod))))))
+    (set! $sc-dispatch
+      (lambda (e p)
+        (cond ((eq? p 'any) (list e))
+              ((eq? p '_) '())
+              ((syntax-object? e)
+               (match*
+                 (syntax-object-expression e)
+                 p
+                 (syntax-object-wrap e)
+                 '()
+                 (syntax-object-module e)))
+              (else (match* e p '(()) '() #f)))))))
+
+(define with-syntax
+  (make-syntax-transformer
+    'with-syntax
+    'macro
+    (lambda (x)
+      (let ((tmp x))
+        (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
+          (if tmp-1
+            (apply (lambda (e1 e2)
+                     (cons '#(syntax-object let ((top)) (hygiene guile))
+                           (cons '() (cons e1 e2))))
+                   tmp-1)
+            (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
+              (if tmp-1
+                (apply (lambda (out in e1 e2)
+                         (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+                               in
+                               '()
+                               (list out
+                                     (cons '#(syntax-object let ((top)) (hygiene guile))
+                                           (cons '() (cons e1 e2))))))
+                       tmp-1)
+                (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+                  (if tmp-1
+                    (apply (lambda (out in e1 e2)
+                             (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+                                   (cons '#(syntax-object list ((top)) (hygiene guile)) in)
+                                   '()
+                                   (list out
+                                         (cons '#(syntax-object let ((top)) (hygiene guile))
+                                               (cons '() (cons e1 e2))))))
+                           tmp-1)
+                    (syntax-violation
+                      #f
+                      "source expression failed to match any pattern"
+                      tmp)))))))))))
+
+(define syntax-error
+  (make-syntax-transformer
+    'syntax-error
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+          (if (if tmp
+                (apply (lambda (keyword operands message arg)
+                         (string? (syntax->datum message)))
+                       tmp)
+                #f)
+            (apply (lambda (keyword operands message arg)
+                     (syntax-violation
+                       (syntax->datum keyword)
+                       (string-join
+                         (cons (syntax->datum message)
+                               (map (lambda (x) (object->string (syntax->datum x))) arg)))
+                       (if (syntax->datum keyword) (cons keyword operands) #f)))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
+              (if (if tmp
+                    (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
+                    #f)
+                (apply (lambda (message arg)
+                         (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+                               (cons '(#f) (cons message arg))))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1)))))))))
+
+(define syntax-rules
+  (make-syntax-transformer
+    'syntax-rules
+    'macro
+    (lambda (xx)
+      (letrec*
+        ((expand-clause
+           (lambda (clause)
+             (let ((tmp-1 clause))
+               (let ((tmp ($sc-dispatch
+                            tmp-1
+                            '((any . any)
+                              (#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
+                               any
+                               .
+                               each-any)))))
+                 (if (if tmp
+                       (apply (lambda (keyword pattern message arg)
+                                (string? (syntax->datum message)))
+                              tmp)
+                       #f)
+                   (apply (lambda (keyword pattern message arg)
+                            (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                  (list '#(syntax-object syntax ((top)) (hygiene guile))
+                                        (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+                                              (cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                                    (cons message arg))))))
+                          tmp)
+                   (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
+                     (if tmp
+                       (apply (lambda (keyword pattern template)
+                                (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                      (list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
+                              tmp)
+                       (syntax-violation
+                         #f
+                         "source expression failed to match any pattern"
+                         tmp-1))))))))
+         (expand-syntax-rules
+           (lambda (dots keys docstrings clauses)
+             (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
+               (let ((tmp ($sc-dispatch
+                            tmp-1
+                            '(each-any each-any #(each ((any . any) any)) each-any))))
+                 (if tmp
+                   (apply (lambda (k docstring keyword pattern template clause)
+                            (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
+                                             (cons '(#(syntax-object x ((top)) (hygiene guile)))
+                                                   (append
+                                                     docstring
+                                                     (list (vector
+                                                             '(#(syntax-object macro-type ((top)) (hygiene guile))
+                                                               .
+                                                               #(syntax-object syntax-rules ((top)) (hygiene guile)))
+                                                             (cons '#(syntax-object patterns ((top)) (hygiene guile))
+                                                                   pattern))
+                                                           (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
+                                                                 (cons '#(syntax-object x ((top)) (hygiene guile))
+                                                                       (cons k clause)))))))))
+                              (let ((form tmp))
+                                (if dots
+                                  (let ((tmp dots))
+                                    (let ((dots tmp))
+                                      (list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
+                                            dots
+                                            form)))
+                                  form))))
+                          tmp)
+                   (syntax-violation
+                     #f
+                     "source expression failed to match any pattern"
+                     tmp-1)))))))
+        (let ((tmp xx))
+          (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
+            (if tmp-1
+              (apply (lambda (k keyword pattern template)
+                       (expand-syntax-rules
+                         #f
+                         k
+                         '()
+                         (map (lambda (tmp-bde397a-10fd tmp-bde397a-10fc tmp-bde397a-10fb)
+                                (list (cons tmp-bde397a-10fb tmp-bde397a-10fc) tmp-bde397a-10fd))
+                              template
+                              pattern
+                              keyword)))
+                     tmp-1)
+              (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
+                (if (if tmp-1
+                      (apply (lambda (k docstring keyword pattern template)
+                               (string? (syntax->datum docstring)))
+                             tmp-1)
+                      #f)
+                  (apply (lambda (k docstring keyword pattern template)
+                           (expand-syntax-rules
+                             #f
+                             k
+                             (list docstring)
+                             (map (lambda (tmp-bde397a-2 tmp-bde397a-1 tmp-bde397a)
+                                    (list (cons tmp-bde397a tmp-bde397a-1) tmp-bde397a-2))
+                                  template
+                                  pattern
+                                  keyword)))
+                         tmp-1)
+                  (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
+                    (if (if tmp-1
+                          (apply (lambda (dots k keyword pattern template) (identifier? dots))
+                                 tmp-1)
+                          #f)
+                      (apply (lambda (dots k keyword pattern template)
+                               (expand-syntax-rules
+                                 dots
+                                 k
+                                 '()
+                                 (map (lambda (tmp-bde397a-112f tmp-bde397a-112e tmp-bde397a-112d)
+                                        (list (cons tmp-bde397a-112d tmp-bde397a-112e) tmp-bde397a-112f))
+                                      template
+                                      pattern
+                                      keyword)))
+                             tmp-1)
+                      (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
+                        (if (if tmp-1
+                              (apply (lambda (dots k docstring keyword pattern template)
+                                       (if (identifier? dots) (string? (syntax->datum docstring)) #f))
+                                     tmp-1)
+                              #f)
+                          (apply (lambda (dots k docstring keyword pattern template)
+                                   (expand-syntax-rules
+                                     dots
+                                     k
+                                     (list docstring)
+                                     (map (lambda (tmp-bde397a-114e tmp-bde397a-114d tmp-bde397a-114c)
+                                            (list (cons tmp-bde397a-114c tmp-bde397a-114d) tmp-bde397a-114e))
+                                          template
+                                          pattern
+                                          keyword)))
+                                 tmp-1)
+                          (syntax-violation
+                            #f
+                            "source expression failed to match any pattern"
+                            tmp))))))))))))))
+
+(define define-syntax-rule
+  (make-syntax-transformer
+    'define-syntax-rule
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
+          (if tmp
+            (apply (lambda (name pattern template)
+                     (list '#(syntax-object define-syntax ((top)) (hygiene guile))
+                           name
+                           (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
+                                 '()
+                                 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
+                                       template))))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
+              (if (if tmp
+                    (apply (lambda (name pattern docstring template)
+                             (string? (syntax->datum docstring)))
+                           tmp)
+                    #f)
+                (apply (lambda (name pattern docstring template)
+                         (list '#(syntax-object define-syntax ((top)) (hygiene guile))
+                               name
+                               (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
+                                     '()
+                                     docstring
+                                     (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
+                                           template))))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1)))))))))
+
+(define let*
+  (make-syntax-transformer
+    'let*
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
+          (if (if tmp
+                (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
+                #f)
+            (apply (lambda (let* x v e1 e2)
+                     (let f ((bindings (map list x v)))
+                       (if (null? bindings)
+                         (cons '#(syntax-object let ((top)) (hygiene guile))
+                               (cons '() (cons e1 e2)))
+                         (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
+                           (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+                             (if tmp
+                               (apply (lambda (body binding)
+                                        (list '#(syntax-object let ((top)) (hygiene guile))
+                                              (list binding)
+                                              body))
+                                      tmp)
+                               (syntax-violation
+                                 #f
+                                 "source expression failed to match any pattern"
+                                 tmp-1)))))))
+                   tmp)
+            (syntax-violation
+              #f
+              "source expression failed to match any pattern"
+              tmp-1)))))))
+
+(define quasiquote
+  (make-syntax-transformer
+    'quasiquote
+    'macro
+    (letrec*
+      ((quasi (lambda (p lev)
+                (let ((tmp p))
+                  (let ((tmp-1 ($sc-dispatch
+                                 tmp
+                                 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
+                    (if tmp-1
+                      (apply (lambda (p)
+                               (if (= lev 0)
+                                 (list "value" p)
+                                 (quasicons
+                                   '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+                                   (quasi (list p) (- lev 1)))))
+                             tmp-1)
+                      (let ((tmp-1 ($sc-dispatch
+                                     tmp
+                                     '(#(free-id #(syntax-object quasiquote ((top)) (hygiene guile))) any))))
+                        (if tmp-1
+                          (apply (lambda (p)
+                                   (quasicons
+                                     '("quote" #(syntax-object quasiquote ((top)) (hygiene guile)))
+                                     (quasi (list p) (+ lev 1))))
+                                 tmp-1)
+                          (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+                            (if tmp-1
+                              (apply (lambda (p q)
+                                       (let ((tmp-1 p))
+                                         (let ((tmp ($sc-dispatch
+                                                      tmp-1
+                                                      '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
+                                                        .
+                                                        each-any))))
+                                           (if tmp
+                                             (apply (lambda (p)
+                                                      (if (= lev 0)
+                                                        (quasilist*
+                                                          (map (lambda (tmp-bde397a-11b3)
+                                                                 (list "value" tmp-bde397a-11b3))
+                                                               p)
+                                                          (quasi q lev))
+                                                        (quasicons
+                                                          (quasicons
+                                                            '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+                                                            (quasi p (- lev 1)))
+                                                          (quasi q lev))))
+                                                    tmp)
+                                             (let ((tmp ($sc-dispatch
+                                                          tmp-1
+                                                          '(#(free-id
+                                                              #(syntax-object unquote-splicing ((top)) (hygiene guile)))
+                                                            .
+                                                            each-any))))
+                                               (if tmp
+                                                 (apply (lambda (p)
+                                                          (if (= lev 0)
+                                                            (quasiappend
+                                                              (map (lambda (tmp-bde397a-11b8)
+                                                                     (list "value" tmp-bde397a-11b8))
+                                                                   p)
+                                                              (quasi q lev))
+                                                            (quasicons
+                                                              (quasicons
+                                                                '("quote"
+                                                                  #(syntax-object
+                                                                    unquote-splicing
+                                                                    ((top))
+                                                                    (hygiene guile)))
+                                                                (quasi p (- lev 1)))
+                                                              (quasi q lev))))
+                                                        tmp)
+                                                 (quasicons (quasi p lev) (quasi q lev))))))))
+                                     tmp-1)
+                              (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
+                                (if tmp-1
+                                  (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
+                                  (let ((p tmp)) (list "quote" p)))))))))))))
+       (vquasi
+         (lambda (p lev)
+           (let ((tmp p))
+             (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+               (if tmp-1
+                 (apply (lambda (p q)
+                          (let ((tmp-1 p))
+                            (let ((tmp ($sc-dispatch
+                                         tmp-1
+                                         '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
+                                           .
+                                           each-any))))
+                              (if tmp
+                                (apply (lambda (p)
+                                         (if (= lev 0)
+                                           (quasilist*
+                                             (map (lambda (tmp-bde397a-11ce) (list "value" tmp-bde397a-11ce)) p)
+                                             (vquasi q lev))
+                                           (quasicons
+                                             (quasicons
+                                               '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+                                               (quasi p (- lev 1)))
+                                             (vquasi q lev))))
+                                       tmp)
+                                (let ((tmp ($sc-dispatch
+                                             tmp-1
+                                             '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
+                                               .
+                                               each-any))))
+                                  (if tmp
+                                    (apply (lambda (p)
+                                             (if (= lev 0)
+                                               (quasiappend
+                                                 (map (lambda (tmp-bde397a-11d3) (list "value" tmp-bde397a-11d3)) p)
+                                                 (vquasi q lev))
+                                               (quasicons
+                                                 (quasicons
+                                                   '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
+                                                   (quasi p (- lev 1)))
+                                                 (vquasi q lev))))
+                                           tmp)
+                                    (quasicons (quasi p lev) (vquasi q lev))))))))
+                        tmp-1)
+                 (let ((tmp-1 ($sc-dispatch tmp '())))
+                   (if tmp-1
+                     (apply (lambda () '("quote" ())) tmp-1)
+                     (syntax-violation
+                       #f
+                       "source expression failed to match any pattern"
+                       tmp))))))))
+       (quasicons
+         (lambda (x y)
+           (let ((tmp-1 (list x y)))
+             (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+               (if tmp
+                 (apply (lambda (x y)
+                          (let ((tmp y))
+                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+                              (if tmp-1
+                                (apply (lambda (dy)
+                                         (let ((tmp x))
+                                           (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
+                                             (if tmp
+                                               (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
+                                               (if (null? dy) (list "list" x) (list "list*" x y))))))
+                                       tmp-1)
+                                (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
+                                  (if tmp-1
+                                    (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
+                                    (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
+                                      (if tmp
+                                        (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
+                                        (list "list*" x y)))))))))
+                        tmp)
+                 (syntax-violation
+                   #f
+                   "source expression failed to match any pattern"
+                   tmp-1))))))
+       (quasiappend
+         (lambda (x y)
+           (let ((tmp y))
+             (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
+               (if tmp
+                 (apply (lambda ()
+                          (if (null? x)
+                            '("quote" ())
+                            (if (null? (cdr x))
+                              (car x)
+                              (let ((tmp-1 x))
+                                (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                  (if tmp
+                                    (apply (lambda (p) (cons "append" p)) tmp)
+                                    (syntax-violation
+                                      #f
+                                      "source expression failed to match any pattern"
+                                      tmp-1)))))))
+                        tmp)
+                 (if (null? x)
+                   y
+                   (let ((tmp-1 (list x y)))
+                     (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
+                       (if tmp
+                         (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
+                         (syntax-violation
+                           #f
+                           "source expression failed to match any pattern"
+                           tmp-1))))))))))
+       (quasilist*
+         (lambda (x y)
+           (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
+       (quasivector
+         (lambda (x)
+           (let ((tmp x))
+             (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
+               (if tmp
+                 (apply (lambda (x) (list "quote" (list->vector x))) tmp)
+                 (let f ((y x)
+                         (k (lambda (ls)
+                              (let ((tmp-1 ls))
+                                (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                  (if tmp
+                                    (apply (lambda (t-bde397a-121c) (cons "vector" t-bde397a-121c)) tmp)
+                                    (syntax-violation
+                                      #f
+                                      "source expression failed to match any pattern"
+                                      tmp-1)))))))
+                   (let ((tmp y))
+                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
+                       (if tmp-1
+                         (apply (lambda (y)
+                                  (k (map (lambda (tmp-bde397a) (list "quote" tmp-bde397a)) y)))
+                                tmp-1)
+                         (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+                           (if tmp-1
+                             (apply (lambda (y) (k y)) tmp-1)
+                             (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+                               (if tmp-1
+                                 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
+                                 (let ((else tmp))
+                                   (let ((tmp x))
+                                     (let ((t-bde397a tmp)) (list "list->vector" t-bde397a)))))))))))))))))
+       (emit (lambda (x)
+               (let ((tmp x))
+                 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+                   (if tmp-1
+                     (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
+                            tmp-1)
+                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+                       (if tmp-1
+                         (apply (lambda (x)
+                                  (let ((tmp-1 (map emit x)))
+                                    (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                      (if tmp
+                                        (apply (lambda (t-bde397a)
+                                                 (cons '#(syntax-object list ((top)) (hygiene guile)) t-bde397a))
+                                               tmp)
+                                        (syntax-violation
+                                          #f
+                                          "source expression failed to match any pattern"
+                                          tmp-1)))))
+                                tmp-1)
+                         (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+                           (if tmp-1
+                             (apply (lambda (x y)
+                                      (let f ((x* x))
+                                        (if (null? x*)
+                                          (emit y)
+                                          (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
+                                            (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+                                              (if tmp
+                                                (apply (lambda (t-bde397a-125a t-bde397a)
+                                                         (list '#(syntax-object cons ((top)) (hygiene guile))
+                                                               t-bde397a-125a
+                                                               t-bde397a))
+                                                       tmp)
+                                                (syntax-violation
+                                                  #f
+                                                  "source expression failed to match any pattern"
+                                                  tmp-1)))))))
+                                    tmp-1)
+                             (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
+                               (if tmp-1
+                                 (apply (lambda (x)
+                                          (let ((tmp-1 (map emit x)))
+                                            (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                              (if tmp
+                                                (apply (lambda (t-bde397a)
+                                                         (cons '#(syntax-object append ((top)) (hygiene guile))
+                                                               t-bde397a))
+                                                       tmp)
+                                                (syntax-violation
+                                                  #f
+                                                  "source expression failed to match any pattern"
+                                                  tmp-1)))))
+                                        tmp-1)
+                                 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
+                                   (if tmp-1
+                                     (apply (lambda (x)
+                                              (let ((tmp-1 (map emit x)))
+                                                (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                                  (if tmp
+                                                    (apply (lambda (t-bde397a)
+                                                             (cons '#(syntax-object vector ((top)) (hygiene guile))
+                                                                   t-bde397a))
+                                                           tmp)
+                                                    (syntax-violation
+                                                      #f
+                                                      "source expression failed to match any pattern"
+                                                      tmp-1)))))
+                                            tmp-1)
+                                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
+                                       (if tmp-1
+                                         (apply (lambda (x)
+                                                  (let ((tmp (emit x)))
+                                                    (let ((t-bde397a-127e tmp))
+                                                      (list '#(syntax-object list->vector ((top)) (hygiene guile))
+                                                            t-bde397a-127e))))
+                                                tmp-1)
+                                         (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
+                                           (if tmp-1
+                                             (apply (lambda (x) x) tmp-1)
+                                             (syntax-violation
+                                               #f
+                                               "source expression failed to match any pattern"
+                                               tmp)))))))))))))))))))
+      (lambda (x)
+        (let ((tmp-1 x))
+          (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+            (if tmp
+              (apply (lambda (e) (emit (quasi e 0))) tmp)
+              (syntax-violation
+                #f
+                "source expression failed to match any pattern"
+                tmp-1))))))))
+
+(define include
+  (make-syntax-transformer
+    'include
+    'macro
+    (lambda (x)
+      (letrec*
+        ((read-file
+           (lambda (fn dir k)
+             (let ((p (open-input-file
+                        (if (absolute-file-name? fn)
+                          fn
+                          (if dir
+                            (in-vicinity dir fn)
+                            (syntax-violation
+                              'include
+                              "relative file name only allowed when the include form is in a file"
+                              x))))))
+               (let ((enc (file-encoding p)))
+                 (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
+                 (let f ((x (read p)) (result '()))
+                   (if (eof-object? x)
+                     (begin (close-input-port p) (reverse result))
+                     (f (read p) (cons (datum->syntax k x) result)))))))))
+        (let ((src (syntax-source x)))
+          (let ((file (if src (assq-ref src 'filename) #f)))
+            (let ((dir (if (string? file) (dirname file) #f)))
+              (let ((tmp-1 x))
+                (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+                  (if tmp
+                    (apply (lambda (k filename)
+                             (let ((fn (syntax->datum filename)))
+                               (let ((tmp-1 (read-file fn dir filename)))
+                                 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                                   (if tmp
+                                     (apply (lambda (exp)
+                                              (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
+                                            tmp)
+                                     (syntax-violation
+                                       #f
+                                       "source expression failed to match any pattern"
+                                       tmp-1))))))
+                           tmp)
+                    (syntax-violation
+                      #f
+                      "source expression failed to match any pattern"
+                      tmp-1)))))))))))
+
+(define include-from-path
+  (make-syntax-transformer
+    'include-from-path
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+          (if tmp
+            (apply (lambda (k filename)
+                     (let ((fn (syntax->datum filename)))
+                       (let ((tmp (datum->syntax
+                                    filename
+                                    (let ((t (%search-load-path fn)))
+                                      (if t
+                                        t
+                                        (syntax-violation
+                                          'include-from-path
+                                          "file not found in path"
+                                          x
+                                          filename))))))
+                         (let ((fn tmp))
+                           (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
+                   tmp)
+            (syntax-violation
+              #f
+              "source expression failed to match any pattern"
+              tmp-1)))))))
+
+(define unquote
+  (make-syntax-transformer
+    'unquote
+    'macro
+    (lambda (x)
+      (syntax-violation
+        'unquote
+        "expression not valid outside of quasiquote"
+        x))))
+
+(define unquote-splicing
+  (make-syntax-transformer
+    'unquote-splicing
+    'macro
+    (lambda (x)
+      (syntax-violation
+        'unquote-splicing
+        "expression not valid outside of quasiquote"
+        x))))
+
+(define make-variable-transformer
+  (lambda (proc)
+    (if (procedure? proc)
+      (let ((trans (lambda (x) (proc x))))
+        (set-procedure-property! trans 'variable-transformer #t)
+        trans)
+      (error "variable transformer not a procedure" proc))))
+
+(define identifier-syntax
+  (make-syntax-transformer
+    'identifier-syntax
+    'macro
+    (lambda (xx)
+      (let ((tmp-1 xx))
+        (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+          (if tmp
+            (apply (lambda (e)
+                     (list '#(syntax-object lambda ((top)) (hygiene guile))
+                           '(#(syntax-object x ((top)) (hygiene guile)))
+                           '#((#(syntax-object macro-type ((top)) (hygiene guile))
+                               .
+                               #(syntax-object identifier-syntax ((top)) (hygiene guile))))
+                           (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+                                 '#(syntax-object x ((top)) (hygiene guile))
+                                 '()
+                                 (list '#(syntax-object id ((top)) (hygiene guile))
+                                       '(#(syntax-object identifier? ((top)) (hygiene guile))
+                                         (#(syntax-object syntax ((top)) (hygiene guile))
+                                          #(syntax-object id ((top)) (hygiene guile))))
+                                       (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
+                                 (list '(#(syntax-object _ ((top)) (hygiene guile))
+                                         #(syntax-object x ((top)) (hygiene guile))
+                                         #(syntax-object ... ((top)) (hygiene guile)))
+                                       (list '#(syntax-object syntax ((top)) (hygiene guile))
+                                             (cons e
+                                                   '(#(syntax-object x ((top)) (hygiene guile))
+                                                     #(syntax-object ... ((top)) (hygiene guile)))))))))
+                   tmp)
+            (let ((tmp ($sc-dispatch
+                         tmp-1
+                         '(_ (any any)
+                             ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
+                              any)))))
+              (if (if tmp
+                    (apply (lambda (id exp1 var val exp2)
+                             (if (identifier? id) (identifier? var) #f))
+                           tmp)
+                    #f)
+                (apply (lambda (id exp1 var val exp2)
+                         (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
+                               (list '#(syntax-object lambda ((top)) (hygiene guile))
+                                     '(#(syntax-object x ((top)) (hygiene guile)))
+                                     '#((#(syntax-object macro-type ((top)) (hygiene guile))
+                                         .
+                                         #(syntax-object variable-transformer ((top)) (hygiene guile))))
+                                     (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+                                           '#(syntax-object x ((top)) (hygiene guile))
+                                           '(#(syntax-object set! ((top)) (hygiene guile)))
+                                           (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
+                                                 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
+                                           (list (cons id
+                                                       '(#(syntax-object x ((top)) (hygiene guile))
+                                                         #(syntax-object ... ((top)) (hygiene guile))))
+                                                 (list '#(syntax-object syntax ((top)) (hygiene guile))
+                                                       (cons exp1
+                                                             '(#(syntax-object x ((top)) (hygiene guile))
+                                                               #(syntax-object ... ((top)) (hygiene guile))))))
+                                           (list id
+                                                 (list '#(syntax-object identifier? ((top)) (hygiene guile))
+                                                       (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
+                                                 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1)))))))))
+
+(define define*
+  (make-syntax-transformer
+    'define*
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+          (if tmp
+            (apply (lambda (id args b0 b1)
+                     (list '#(syntax-object define ((top)) (hygiene guile))
+                           id
+                           (cons '#(syntax-object lambda* ((top)) (hygiene guile))
+                                 (cons args (cons b0 b1)))))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
+              (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
+                (apply (lambda (id val)
+                         (list '#(syntax-object define ((top)) (hygiene guile)) id val))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1)))))))))
+
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
+;;;;   2012, 2013, 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
+;;;; 
+
+
+;;; Portable implementation of syntax-case
+;;; Originally extracted from Chez Scheme Version 5.9f
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Copyright (c) 1992-1997 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full.  This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
+;;; to the ChangeLog distributed in the same directory as this file:
+;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
+;;; 2000-09-12, 2001-03-08
+
+;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
+;;; revision control logs corresponding to this file: 2009, 2010.
+
+;;; Modified by Mark H Weaver <mhw@netris.org> according to the Git
+;;; revision control logs corresponding to this file: 2012, 2013.
+
+
+;;; This code is based on "Syntax Abstraction in Scheme"
+;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
+;;; Lisp and Symbolic Computation 5:4, 295-326, 1992.
+;;; <http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf>
+
+
+;;; This file defines the syntax-case expander, macroexpand, and a set
+;;; of associated syntactic forms and procedures.  Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Fourth Edition (R. Kent Dybvig, MIT Press, 2009), and in the 
+;;; R6RS:
+;;;
+;;;   bound-identifier=?
+;;;   datum->syntax
+;;;   define-syntax
+;;;   syntax-parameterize
+;;;   free-identifier=?
+;;;   generate-temporaries
+;;;   identifier?
+;;;   identifier-syntax
+;;;   let-syntax
+;;;   letrec-syntax
+;;;   syntax
+;;;   syntax-case
+;;;   syntax->datum
+;;;   syntax-rules
+;;;   with-syntax
+;;;
+;;; Additionally, the expander provides definitions for a number of core
+;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
+
+;;; The remaining exports are listed below:
+;;;
+;;;   (macroexpand datum)
+;;;      if datum represents a valid expression, macroexpand returns an
+;;;      expanded version of datum in a core language that includes no
+;;;      syntactic abstractions.  The core language includes begin,
+;;;      define, if, lambda, letrec, quote, and set!.
+;;;   (eval-when situations expr ...)
+;;;      conditionally evaluates expr ... at compile-time or run-time
+;;;      depending upon situations (see the Chez Scheme System Manual,
+;;;      Revision 3, for a complete description)
+;;;   (syntax-violation who message form [subform])
+;;;      used to report errors found during expansion
+;;;   ($sc-dispatch e p)
+;;;      used by expanded code to handle syntax-case matching
+
+;;; This file is shipped along with an expanded version of itself,
+;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
+;;; compiled.  In this way, psyntax bootstraps off of an expanded
+;;; version of itself.
+
+;;; This implementation of the expander sometimes uses syntactic
+;;; abstractions when procedural abstractions would suffice.  For
+;;; example, we define top-wrap and top-marked? as
+;;;
+;;;   (define-syntax top-wrap (identifier-syntax '((top))))
+;;;   (define-syntax top-marked?
+;;;     (syntax-rules ()
+;;;       ((_ w) (memq 'top (wrap-marks w)))))
+;;;
+;;; rather than
+;;;
+;;;   (define top-wrap '((top)))
+;;;   (define top-marked?
+;;;     (lambda (w) (memq 'top (wrap-marks w))))
+;;;
+;;; On the other hand, we don't do this consistently; we define
+;;; make-wrap, wrap-marks, and wrap-subst simply as
+;;;
+;;;   (define make-wrap cons)
+;;;   (define wrap-marks car)
+;;;   (define wrap-subst cdr)
+;;;
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures.  This will be true of
+;;; Guile as well, once we implement a proper inliner.
+
+
+;;; Implementation notes:
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax object, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax.
+;;; Such objects are never copied.
+
+;;; All identifiers that don't have macro definitions and are not bound
+;;; lexically are assumed to be global variables.
+
+;;; Top-level definitions of macro-introduced identifiers are allowed.
+;;; This may not be appropriate for implementations in which the
+;;; model is that bindings are created by definitions, as opposed to
+;;; one in which initial values are assigned by definitions.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability.  As a result, it is possible to "forge" syntax objects.
+
+;;; The implementation of generate-temporaries assumes that it is
+;;; possible to generate globally unique symbols (gensyms).
+
+;;; The source location associated with incoming expressions is tracked
+;;; via the source-properties mechanism, a weak map from expression to
+;;; source information. At times the source is separated from the
+;;; expression; see the note below about "efficiency and confusion".
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name.  It
+;;; should be sufficient to recognize old representations and treat
+;;; them as not lexically bound.
+
+
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
+(let ()
+  (define-syntax define-expansion-constructors
+    (lambda (x)
+      (syntax-case x ()
+        ((_)
+         (let lp ((n 0) (out '()))
+           (if (< n (vector-length %expanded-vtables))
+               (lp (1+ n)
+                   (let* ((vtable (vector-ref %expanded-vtables n))
+                          (stem (struct-ref vtable (+ vtable-offset-user 0)))
+                          (fields (struct-ref vtable (+ vtable-offset-user 2)))
+                          (sfields (map (lambda (f) (datum->syntax x f)) fields))
+                          (ctor (datum->syntax x (symbol-append 'make- stem))))
+                     (cons #`(define (#,ctor #,@sfields)
+                               (make-struct (vector-ref %expanded-vtables #,n) 0
+                                            #,@sfields))
+                           out)))
+               #`(begin #,@(reverse out))))))))
+
+  (define-syntax define-expansion-accessors
+    (lambda (x)
+      (syntax-case x ()
+        ((_ stem field ...)
+         (let lp ((n 0))
+           (let ((vtable (vector-ref %expanded-vtables n))
+                 (stem (syntax->datum #'stem)))
+             (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
+                 #`(begin
+                     (define (#,(datum->syntax x (symbol-append stem '?)) x)
+                       (and (struct? x)
+                            (eq? (struct-vtable x)
+                                 (vector-ref %expanded-vtables #,n))))
+                     #,@(map
+                         (lambda (f)
+                           (let ((get (datum->syntax x (symbol-append stem '- f)))
+                                 (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
+                                 (idx (list-index (struct-ref vtable
+                                                              (+ vtable-offset-user 2))
+                                                  f)))
+                             #`(begin
+                                 (define (#,get x)
+                                   (struct-ref x #,idx))
+                                 (define (#,set x v)
+                                   (struct-set! x #,idx v)))))
+                         (syntax->datum #'(field ...))))
+                 (lp (1+ n)))))))))
+
+  (define-syntax define-structure
+    (lambda (x)
+      (define construct-name
+        (lambda (template-identifier . args)
+          (datum->syntax
+           template-identifier
+           (string->symbol
+            (apply string-append
+                   (map (lambda (x)
+                          (if (string? x)
+                              x
+                              (symbol->string (syntax->datum x))))
+                        args))))))
+      (syntax-case x ()
+        ((_ (name id1 ...))
+         (and-map identifier? #'(name id1 ...))
+         (with-syntax
+             ((constructor (construct-name #'name "make-" #'name))
+              (predicate (construct-name #'name #'name "?"))
+              ((access ...)
+               (map (lambda (x) (construct-name x #'name "-" x))
+                    #'(id1 ...)))
+              ((assign ...)
+               (map (lambda (x)
+                      (construct-name x "set-" #'name "-" x "!"))
+                    #'(id1 ...)))
+              (structure-length
+               (+ (length #'(id1 ...)) 1))
+              ((index ...)
+               (let f ((i 1) (ids #'(id1 ...)))
+                 (if (null? ids)
+                     '()
+                     (cons i (f (+ i 1) (cdr ids)))))))
+           #'(begin
+               (define constructor
+                 (lambda (id1 ...)
+                   (vector 'name id1 ... )))
+               (define predicate
+                 (lambda (x)
+                   (and (vector? x)
+                        (= (vector-length x) structure-length)
+                        (eq? (vector-ref x 0) 'name))))
+               (define access
+                 (lambda (x)
+                   (vector-ref x index)))
+               ...
+               (define assign
+                 (lambda (x update)
+                   (vector-set! x index update)))
+               ...))))))
+
+  (let ()
+    (define-expansion-constructors)
+    (define-expansion-accessors lambda meta)
+
+    ;; hooks to nonportable run-time helpers
+    (begin
+      (define-syntax fx+ (identifier-syntax +))
+      (define-syntax fx- (identifier-syntax -))
+      (define-syntax fx= (identifier-syntax =))
+      (define-syntax fx< (identifier-syntax <))
+
+      (define top-level-eval-hook
+        (lambda (x mod)
+          (primitive-eval x)))
+
+      (define local-eval-hook
+        (lambda (x mod)
+          (primitive-eval x)))
+    
+      ;; Capture syntax-session-id before we shove it off into a module.
+      (define session-id
+        (let ((v (module-variable (current-module) 'syntax-session-id)))
+          (lambda ()
+            ((variable-ref v)))))
+
+      (define put-global-definition-hook
+        (lambda (symbol type val)
+          (module-define! (current-module)
+                          symbol
+                          (make-syntax-transformer symbol type val))))
+    
+      (define get-global-definition-hook
+        (lambda (symbol module)
+          (if (and (not module) (current-module))
+              (warn "module system is booted, we should have a module" symbol))
+          (let ((v (module-variable (if module
+                                        (resolve-module (cdr module))
+                                        (current-module))
+                                    symbol)))
+            (and v (variable-bound? v)
+                 (let ((val (variable-ref v)))
+                   (and (macro? val) (macro-type val)
+                        (cons (macro-type val)
+                              (macro-binding val)))))))))
+
+
+    (define (decorate-source e s)
+      (if (and s (supports-source-properties? e))
+          (set-source-properties! e s))
+      e)
+
+    (define (maybe-name-value! name val)
+      (if (lambda? val)
+          (let ((meta (lambda-meta val)))
+            (if (not (assq 'name meta))
+                (set-lambda-meta! val (acons 'name name meta))))))
+
+    ;; output constructors
+    (define build-void
+      (lambda (source)
+        (make-void source)))
+
+    (define build-application
+      (lambda (source fun-exp arg-exps)
+        (make-application source fun-exp arg-exps)))
+  
+    (define build-conditional
+      (lambda (source test-exp then-exp else-exp)
+        (make-conditional source test-exp then-exp else-exp)))
+  
+    (define build-dynlet
+      (lambda (source fluids vals body)
+        (make-dynlet source fluids vals body)))
+  
+    (define build-lexical-reference
+      (lambda (type source name var)
+        (make-lexical-ref source name var)))
+  
+    (define build-lexical-assignment
+      (lambda (source name var exp)
+        (maybe-name-value! name exp)
+        (make-lexical-set source name var exp)))
+  
+    (define (analyze-variable mod var modref-cont bare-cont)
+      (if (not mod)
+          (bare-cont var)
+          (let ((kind (car mod))
+                (mod (cdr mod)))
+            (case kind
+              ((public) (modref-cont mod var #t))
+              ((private) (if (not (equal? mod (module-name (current-module))))
+                             (modref-cont mod var #f)
+                             (bare-cont var)))
+              ((bare) (bare-cont var))
+              ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+                                  (module-variable (resolve-module mod) var))
+                             (modref-cont mod var #f)
+                             (bare-cont var)))
+              (else (syntax-violation #f "bad module kind" var mod))))))
+
+    (define build-global-reference
+      (lambda (source var mod)
+        (analyze-variable
+         mod var
+         (lambda (mod var public?) 
+           (make-module-ref source mod var public?))
+         (lambda (var)
+           (make-toplevel-ref source var)))))
+
+    (define build-global-assignment
+      (lambda (source var exp mod)
+        (maybe-name-value! var exp)
+        (analyze-variable
+         mod var
+         (lambda (mod var public?) 
+           (make-module-set source mod var public? exp))
+         (lambda (var)
+           (make-toplevel-set source var exp)))))
+
+    (define build-global-definition
+      (lambda (source var exp)
+        (maybe-name-value! var exp)
+        (make-toplevel-define source var exp)))
+
+    (define build-simple-lambda
+      (lambda (src req rest vars meta exp)
+        (make-lambda src
+                     meta
+                     ;; hah, a case in which kwargs would be nice.
+                     (make-lambda-case
+                      ;; src req opt rest kw inits vars body else
+                      src req #f rest #f '() vars exp #f))))
+
+    (define build-case-lambda
+      (lambda (src meta body)
+        (make-lambda src meta body)))
+
+    (define build-lambda-case
+      ;; req := (name ...)
+      ;; opt := (name ...) | #f
+      ;; rest := name | #f
+      ;; kw := (allow-other-keys? (keyword name var) ...) | #f
+      ;; inits: (init ...)
+      ;; vars: (sym ...)
+      ;; vars map to named arguments in the following order:
+      ;;  required, optional (positional), rest, keyword.
+      ;; the body of a lambda: anything, already expanded
+      ;; else: lambda-case | #f
+      (lambda (src req opt rest kw inits vars body else-case)
+        (make-lambda-case src req opt rest kw inits vars body else-case)))
+
+    (define build-primref
+      (lambda (src name)
+        (if (equal? (module-name (current-module)) '(guile))
+            (make-toplevel-ref src name)
+            (make-module-ref src '(guile) name #f))))
+
+    (define (build-data src exp)
+      (make-const src exp))
+
+    (define build-sequence
+      (lambda (src exps)
+        (if (null? (cdr exps))
+            (car exps)
+            (make-sequence src exps))))
+
+    (define build-let
+      (lambda (src ids vars val-exps body-exp)
+        (for-each maybe-name-value! ids val-exps)
+        (if (null? vars)
+            body-exp
+            (make-let src ids vars val-exps body-exp))))
+
+    (define build-named-let
+      (lambda (src ids vars val-exps body-exp)
+        (let ((f (car vars))
+              (f-name (car ids))
+              (vars (cdr vars))
+              (ids (cdr ids)))
+          (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
+            (maybe-name-value! f-name proc)
+            (for-each maybe-name-value! ids val-exps)
+            (make-letrec
+             src #f
+             (list f-name) (list f) (list proc)
+             (build-application src (build-lexical-reference 'fun src f-name f)
+                                val-exps))))))
+
+    (define build-letrec
+      (lambda (src in-order? ids vars val-exps body-exp)
+        (if (null? vars)
+            body-exp
+            (begin
+              (for-each maybe-name-value! ids val-exps)
+              (make-letrec src in-order? ids vars val-exps body-exp)))))
+
+
+    (define-syntax-rule (build-lexical-var src id)
+      ;; Use a per-module counter instead of the global counter of
+      ;; 'gensym' so that the generated identifier is reproducible.
+      (module-gensym (symbol->string id)))
+
+    (define-structure (syntax-object expression wrap module))
+
+    (define-syntax no-source (identifier-syntax #f))
+
+    (define source-annotation
+      (lambda (x)
+        (let ((props (source-properties
+                      (if (syntax-object? x)
+                          (syntax-object-expression x)
+                          x))))
+          (and (pair? props) props))))
+
+    (define-syntax-rule (arg-check pred? e who)
+      (let ((x e))
+        (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
+
+    ;; compile-time environments
+
+    ;; wrap and environment comprise two level mapping.
+    ;;   wrap : id --> label
+    ;;   env : label --> <element>
+
+    ;; environments are represented in two parts: a lexical part and a global
+    ;; part.  The lexical part is a simple list of associations from labels
+    ;; to bindings.  The global part is implemented by
+    ;; {put,get}-global-definition-hook and associates symbols with
+    ;; bindings.
+
+    ;; global (assumed global variable) and displaced-lexical (see below)
+    ;; do not show up in any environment; instead, they are fabricated by
+    ;; lookup when it finds no other bindings.
+
+    ;; <environment>              ::= ((<label> . <binding>)*)
+
+    ;; identifier bindings include a type and a value
+
+    ;; <binding> ::= (macro . <procedure>)           macros
+    ;;               (core . <procedure>)            core forms
+    ;;               (module-ref . <procedure>)      @ or @@
+    ;;               (begin)                         begin
+    ;;               (define)                        define
+    ;;               (define-syntax)                 define-syntax
+    ;;               (define-syntax-parameter)       define-syntax-parameter
+    ;;               (local-syntax . rec?)           let-syntax/letrec-syntax
+    ;;               (eval-when)                     eval-when
+    ;;               (syntax . (<var> . <level>))    pattern variables
+    ;;               (global)                        assumed global variable
+    ;;               (lexical . <var>)               lexical variables
+    ;;               (ellipsis . <identifier>)       custom ellipsis
+    ;;               (displaced-lexical)             displaced lexicals
+    ;; <level>   ::= <nonnegative integer>
+    ;; <var>     ::= variable returned by build-lexical-var
+
+    ;; a macro is a user-defined syntactic-form.  a core is a
+    ;; system-defined syntactic form.  begin, define, define-syntax,
+    ;; define-syntax-parameter, and eval-when are treated specially
+    ;; since they are sensitive to whether the form is at top-level and
+    ;; (except for eval-when) can denote valid internal definitions.
+
+    ;; a pattern variable is a variable introduced by syntax-case and can
+    ;; be referenced only within a syntax form.
+
+    ;; any identifier for which no top-level syntax definition or local
+    ;; binding of any kind has been seen is assumed to be a global
+    ;; variable.
+
+    ;; a lexical variable is a lambda- or letrec-bound variable.
+
+    ;; an ellipsis binding is introduced by the 'with-ellipsis' special
+    ;; form.
+
+    ;; a displaced-lexical identifier is a lexical identifier removed from
+    ;; it's scope by the return of a syntax object containing the identifier.
+    ;; a displaced lexical can also appear when a letrec-syntax-bound
+    ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+    ;; a displaced lexical should never occur with properly written macros.
+
+    (define-syntax make-binding
+      (syntax-rules (quote)
+        ((_ type value) (cons type value))
+        ((_ 'type) '(type))
+        ((_ type) (cons type '()))))
+    (define-syntax-rule (binding-type x)
+      (car x))
+    (define-syntax-rule (binding-value x)
+      (cdr x))
+
+    (define-syntax null-env (identifier-syntax '()))
+
+    (define extend-env
+      (lambda (labels bindings r) 
+        (if (null? labels)
+            r
+            (extend-env (cdr labels) (cdr bindings)
+                        (cons (cons (car labels) (car bindings)) r)))))
+
+    (define extend-var-env
+      ;; variant of extend-env that forms "lexical" binding
+      (lambda (labels vars r)
+        (if (null? labels)
+            r
+            (extend-var-env (cdr labels) (cdr vars)
+                            (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
+
+    ;; we use a "macros only" environment in expansion of local macro
+    ;; definitions so that their definitions can use local macros without
+    ;; attempting to use other lexical identifiers.
+    (define macros-only-env
+      (lambda (r)
+        (if (null? r)
+            '()
+            (let ((a (car r)))
+              (if (memq (cadr a) '(macro ellipsis))
+                  (cons a (macros-only-env (cdr r)))
+                  (macros-only-env (cdr r)))))))
+
+    (define lookup
+      ;; x may be a label or a symbol
+      ;; although symbols are usually global, we check the environment first
+      ;; anyway because a temporary binding may have been established by
+      ;; fluid-let-syntax
+      (lambda (x r mod)
+        (cond
+         ((assq x r) => cdr)
+         ((symbol? x)
+          (or (get-global-definition-hook x mod) (make-binding 'global)))
+         (else (make-binding 'displaced-lexical)))))
+
+    (define global-extend
+      (lambda (type sym val)
+        (put-global-definition-hook sym type val)))
+
+
+    ;; Conceptually, identifiers are always syntax objects.  Internally,
+    ;; however, the wrap is sometimes maintained separately (a source of
+    ;; efficiency and confusion), so that symbols are also considered
+    ;; identifiers by id?.  Externally, they are always wrapped.
+
+    (define nonsymbol-id?
+      (lambda (x)
+        (and (syntax-object? x)
+             (symbol? (syntax-object-expression x)))))
+
+    (define id?
+      (lambda (x)
+        (cond
+         ((symbol? x) #t)
+         ((syntax-object? x) (symbol? (syntax-object-expression x)))
+         (else #f))))
+
+    (define-syntax-rule (id-sym-name e)
+      (let ((x e))
+        (if (syntax-object? x)
+            (syntax-object-expression x)
+            x)))
+
+    (define id-sym-name&marks
+      (lambda (x w)
+        (if (syntax-object? x)
+            (values
+             (syntax-object-expression x)
+             (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+            (values x (wrap-marks w)))))
+
+    ;; syntax object wraps
+
+    ;;      <wrap> ::= ((<mark> ...) . (<subst> ...))
+    ;;     <subst> ::= shift | <subs>
+    ;;      <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+    ;;                 | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
+
+    (define-syntax make-wrap (identifier-syntax cons))
+    (define-syntax wrap-marks (identifier-syntax car))
+    (define-syntax wrap-subst (identifier-syntax cdr))
+
+    ;; labels must be comparable with "eq?", have read-write invariance,
+    ;; and distinct from symbols.
+    (define (gen-label)
+      (symbol->string (module-gensym "l")))
+
+    (define gen-labels
+      (lambda (ls)
+        (if (null? ls)
+            '()
+            (cons (gen-label) (gen-labels (cdr ls))))))
+
+    (define-structure (ribcage symnames marks labels))
+
+    (define-syntax empty-wrap (identifier-syntax '(())))
+
+    (define-syntax top-wrap (identifier-syntax '((top))))
+
+    (define-syntax-rule (top-marked? w)
+      (memq 'top (wrap-marks w)))
+
+    ;; Marks must be comparable with "eq?" and distinct from pairs and
+    ;; the symbol top.  We do not use integers so that marks will remain
+    ;; unique even across file compiles.
+
+    (define-syntax the-anti-mark (identifier-syntax #f))
+
+    (define anti-mark
+      (lambda (w)
+        (make-wrap (cons the-anti-mark (wrap-marks w))
+                   (cons 'shift (wrap-subst w)))))
+
+    (define-syntax-rule (new-mark)
+      (module-gensym "m"))
+
+    ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+    ;; internal definitions, in which the ribcages are built incrementally
+    (define-syntax-rule (make-empty-ribcage)
+      (make-ribcage '() '() '()))
+
+    (define extend-ribcage!
+      ;; must receive ids with complete wraps
+      (lambda (ribcage id label)
+        (set-ribcage-symnames! ribcage
+                               (cons (syntax-object-expression id)
+                                     (ribcage-symnames ribcage)))
+        (set-ribcage-marks! ribcage
+                            (cons (wrap-marks (syntax-object-wrap id))
+                                  (ribcage-marks ribcage)))
+        (set-ribcage-labels! ribcage
+                             (cons label (ribcage-labels ribcage)))))
+
+    ;; make-binding-wrap creates vector-based ribcages
+    (define make-binding-wrap
+      (lambda (ids labels w)
+        (if (null? ids)
+            w
+            (make-wrap
+             (wrap-marks w)
+             (cons
+              (let ((labelvec (list->vector labels)))
+                (let ((n (vector-length labelvec)))
+                  (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+                    (let f ((ids ids) (i 0))
+                      (if (not (null? ids))
+                          (call-with-values
+                              (lambda () (id-sym-name&marks (car ids) w))
+                            (lambda (symname marks)
+                              (vector-set! symnamevec i symname)
+                              (vector-set! marksvec i marks)
+                              (f (cdr ids) (fx+ i 1))))))
+                    (make-ribcage symnamevec marksvec labelvec))))
+              (wrap-subst w))))))
+
+    (define smart-append
+      (lambda (m1 m2)
+        (if (null? m2)
+            m1
+            (append m1 m2))))
+
+    (define join-wraps
+      (lambda (w1 w2)
+        (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+          (if (null? m1)
+              (if (null? s1)
+                  w2
+                  (make-wrap
+                   (wrap-marks w2)
+                   (smart-append s1 (wrap-subst w2))))
+              (make-wrap
+               (smart-append m1 (wrap-marks w2))
+               (smart-append s1 (wrap-subst w2)))))))
+
+    (define join-marks
+      (lambda (m1 m2)
+        (smart-append m1 m2)))
+
+    (define same-marks?
+      (lambda (x y)
+        (or (eq? x y)
+            (and (not (null? x))
+                 (not (null? y))
+                 (eq? (car x) (car y))
+                 (same-marks? (cdr x) (cdr y))))))
+
+    (define id-var-name
+      (lambda (id w)
+        (define-syntax-rule (first e)
+          ;; Rely on Guile's multiple-values truncation.
+          e)
+        (define search
+          (lambda (sym subst marks)
+            (if (null? subst)
+                (values #f marks)
+                (let ((fst (car subst)))
+                  (if (eq? fst 'shift)
+                      (search sym (cdr subst) (cdr marks))
+                      (let ((symnames (ribcage-symnames fst)))
+                        (if (vector? symnames)
+                            (search-vector-rib sym subst marks symnames fst)
+                            (search-list-rib sym subst marks symnames fst))))))))
+        (define search-list-rib
+          (lambda (sym subst marks symnames ribcage)
+            (let f ((symnames symnames) (i 0))
+              (cond
+               ((null? symnames) (search sym (cdr subst) marks))
+               ((and (eq? (car symnames) sym)
+                     (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+                (values (list-ref (ribcage-labels ribcage) i) marks))
+               (else (f (cdr symnames) (fx+ i 1)))))))
+        (define search-vector-rib
+          (lambda (sym subst marks symnames ribcage)
+            (let ((n (vector-length symnames)))
+              (let f ((i 0))
+                (cond
+                 ((fx= i n) (search sym (cdr subst) marks))
+                 ((and (eq? (vector-ref symnames i) sym)
+                       (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+                  (values (vector-ref (ribcage-labels ribcage) i) marks))
+                 (else (f (fx+ i 1))))))))
+        (cond
+         ((symbol? id)
+          (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+         ((syntax-object? id)
+          (let ((id (syntax-object-expression id))
+                (w1 (syntax-object-wrap id)))
+            (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+              (call-with-values (lambda () (search id (wrap-subst w) marks))
+                (lambda (new-id marks)
+                  (or new-id
+                      (first (search id (wrap-subst w1) marks))
+                      id))))))
+         (else (syntax-violation 'id-var-name "invalid id" id)))))
+
+    ;; A helper procedure for syntax-locally-bound-identifiers, which
+    ;; itself is a helper for transformer procedures.
+    ;; `locally-bound-identifiers' returns a list of all bindings
+    ;; visible to a syntax object with the given wrap.  They are in
+    ;; order from outer to inner.
+    ;;
+    ;; The purpose of this procedure is to give a transformer procedure
+    ;; references on bound identifiers, that the transformer can then
+    ;; introduce some of them in its output.  As such, the identifiers
+    ;; are anti-marked, so that rebuild-macro-output doesn't apply new
+    ;; marks to them.
+    ;;
+    (define locally-bound-identifiers
+      (lambda (w mod)
+        (define scan
+          (lambda (subst results)
+            (if (null? subst)
+                results
+                (let ((fst (car subst)))
+                  (if (eq? fst 'shift)
+                      (scan (cdr subst) results)
+                      (let ((symnames (ribcage-symnames fst))
+                            (marks (ribcage-marks fst)))
+                        (if (vector? symnames)
+                            (scan-vector-rib subst symnames marks results)
+                            (scan-list-rib subst symnames marks results))))))))
+        (define scan-list-rib
+          (lambda (subst symnames marks results)
+            (let f ((symnames symnames) (marks marks) (results results))
+              (if (null? symnames)
+                  (scan (cdr subst) results)
+                  (f (cdr symnames) (cdr marks)
+                     (cons (wrap (car symnames)
+                                 (anti-mark (make-wrap (car marks) subst))
+                                 mod)
+                           results))))))
+        (define scan-vector-rib
+          (lambda (subst symnames marks results)
+            (let ((n (vector-length symnames)))
+              (let f ((i 0) (results results))
+                (if (fx= i n)
+                    (scan (cdr subst) results)
+                    (f (fx+ i 1)
+                       (cons (wrap (vector-ref symnames i)
+                                   (anti-mark (make-wrap (vector-ref marks i) subst))
+                                   mod)
+                             results)))))))
+        (scan (wrap-subst w) '())))
+
+    ;; Returns three values: binding type, binding value, the module (for
+    ;; resolving toplevel vars).
+    (define (resolve-identifier id w r mod)
+      (define (resolve-global var mod)
+        (let ((b (or (get-global-definition-hook var mod)
+                     (make-binding 'global))))
+          (if (eq? (binding-type b) 'global)
+              (values 'global var mod)
+              (values (binding-type b) (binding-value b) mod))))
+      (define (resolve-lexical label mod)
+        (let ((b (or (assq-ref r label)
+                     (make-binding 'displaced-lexical))))
+          (values (binding-type b) (binding-value b) mod)))
+      (let ((n (id-var-name id w)))
+        (cond
+         ((symbol? n)
+          (resolve-global n (if (syntax-object? id)
+                                (syntax-object-module id)
+                                mod)))
+         ((string? n)
+          (resolve-lexical n (if (syntax-object? id)
+                                 (syntax-object-module id)
+                                 mod)))
+         (else
+          (error "unexpected id-var-name" id w n)))))
+
+    (define transformer-environment
+      (make-fluid
+       (lambda (k)
+         (error "called outside the dynamic extent of a syntax transformer"))))
+
+    (define (with-transformer-environment k)
+      ((fluid-ref transformer-environment) k))
+
+    ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+    ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+    (define free-id=?
+      (lambda (i j)
+        (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+             (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+    ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+    ;; long as the missing portion of the wrap is common to both of the ids
+    ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+    (define bound-id=?
+      (lambda (i j)
+        (if (and (syntax-object? i) (syntax-object? j))
+            (and (eq? (syntax-object-expression i)
+                      (syntax-object-expression j))
+                 (same-marks? (wrap-marks (syntax-object-wrap i))
+                              (wrap-marks (syntax-object-wrap j))))
+            (eq? i j))))
+
+    ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+    ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+    ;; as long as the missing portion of the wrap is common to all of the
+    ;; ids.
+
+    (define valid-bound-ids?
+      (lambda (ids)
+        (and (let all-ids? ((ids ids))
+               (or (null? ids)
+                   (and (id? (car ids))
+                        (all-ids? (cdr ids)))))
+             (distinct-bound-ids? ids))))
+
+    ;; distinct-bound-ids? expects a list of ids and returns #t if there are
+    ;; no duplicates.  It is quadratic on the length of the id list; long
+    ;; lists could be sorted to make it more efficient.  distinct-bound-ids?
+    ;; may be passed unwrapped (or partially wrapped) ids as long as the
+    ;; missing portion of the wrap is common to all of the ids.
+
+    (define distinct-bound-ids?
+      (lambda (ids)
+        (let distinct? ((ids ids))
+          (or (null? ids)
+              (and (not (bound-id-member? (car ids) (cdr ids)))
+                   (distinct? (cdr ids)))))))
+
+    (define bound-id-member?
+      (lambda (x list)
+        (and (not (null? list))
+             (or (bound-id=? x (car list))
+                 (bound-id-member? x (cdr list))))))
+
+    ;; wrapping expressions and identifiers
+
+    (define wrap
+      (lambda (x w defmod)
+        (cond
+         ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+         ((syntax-object? x)
+          (make-syntax-object
+           (syntax-object-expression x)
+           (join-wraps w (syntax-object-wrap x))
+           (syntax-object-module x)))
+         ((null? x) x)
+         (else (make-syntax-object x w defmod)))))
+
+    (define source-wrap
+      (lambda (x w s defmod)
+        (wrap (decorate-source x s) w defmod)))
+
+    ;; expanding
+
+    (define expand-sequence
+      (lambda (body r w s mod)
+        (build-sequence s
+                        (let dobody ((body body) (r r) (w w) (mod mod))
+                          (if (null? body)
+                              '()
+                              (let ((first (expand (car body) r w mod)))
+                                (cons first (dobody (cdr body) r w mod))))))))
+
+    ;; At top-level, we allow mixed definitions and expressions.  Like
+    ;; expand-body we expand in two passes.
+    ;;
+    ;; First, from left to right, we expand just enough to know what
+    ;; expressions are definitions, syntax definitions, and splicing
+    ;; statements (`begin').  If we anything needs evaluating at
+    ;; expansion-time, it is expanded directly.
+    ;;
+    ;; Otherwise we collect expressions to expand, in thunks, and then
+    ;; expand them all at the end.  This allows all syntax expanders
+    ;; visible in a toplevel sequence to be visible during the
+    ;; expansions of all normal definitions and expressions in the
+    ;; sequence.
+    ;;
+    (define expand-top-sequence
+      (lambda (body r w s m esew mod)
+        (define (scan body r w s m esew mod exps)
+          (cond
+           ((null? body)
+            ;; in reversed order
+            exps)
+           (else
+            (call-with-values
+                (lambda ()
+                  (call-with-values
+                      (lambda ()
+                        (let ((e (car body)))
+                          (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
+                    (lambda (type value form e w s mod)
+                      (case type
+                        ((begin-form)
+                         (syntax-case e ()
+                           ((_) exps)
+                           ((_ e1 e2 ...)
+                            (scan #'(e1 e2 ...) r w s m esew mod exps))))
+                        ((local-syntax-form)
+                         (expand-local-syntax value e r w s mod
+                                              (lambda (body r w s mod)
+                                                (scan body r w s m esew mod exps))))
+                        ((eval-when-form)
+                         (syntax-case e ()
+                           ((_ (x ...) e1 e2 ...)
+                            (let ((when-list (parse-when-list e #'(x ...)))
+                                  (body #'(e1 e2 ...)))
+                              (cond
+                               ((eq? m 'e)
+                                (if (memq 'eval when-list)
+                                    (scan body r w s
+                                          (if (memq 'expand when-list) 'c&e 'e)
+                                          '(eval)
+                                          mod exps)
+                                    (begin
+                                      (if (memq 'expand when-list)
+                                          (top-level-eval-hook
+                                           (expand-top-sequence body r w s 'e '(eval) mod)
+                                           mod))
+                                      (values exps))))
+                               ((memq 'load when-list)
+                                (if (or (memq 'compile when-list)
+                                        (memq 'expand when-list)
+                                        (and (eq? m 'c&e) (memq 'eval when-list)))
+                                    (scan body r w s 'c&e '(compile load) mod exps)
+                                    (if (memq m '(c c&e))
+                                        (scan body r w s 'c '(load) mod exps)
+                                        (values exps))))
+                               ((or (memq 'compile when-list)
+                                    (memq 'expand when-list)
+                                    (and (eq? m 'c&e) (memq 'eval when-list)))
+                                (top-level-eval-hook
+                                 (expand-top-sequence body r w s 'e '(eval) mod)
+                                 mod)
+                                (values exps))
+                               (else
+                                (values exps)))))))
+                        ((define-syntax-form define-syntax-parameter-form)
+                         (let ((n (id-var-name value w)) (r (macros-only-env r)))
+                           (case m
+                             ((c)
+                              (if (memq 'compile esew)
+                                  (let ((e (expand-install-global n (expand e r w mod))))
+                                    (top-level-eval-hook e mod)
+                                    (if (memq 'load esew)
+                                        (values (cons e exps))
+                                        (values exps)))
+                                  (if (memq 'load esew)
+                                      (values (cons (expand-install-global n (expand e r w mod))
+                                                    exps))
+                                      (values exps))))
+                             ((c&e)
+                              (let ((e (expand-install-global n (expand e r w mod))))
+                                (top-level-eval-hook e mod)
+                                (values (cons e exps))))
+                             (else
+                              (if (memq 'eval esew)
+                                  (top-level-eval-hook
+                                   (expand-install-global n (expand e r w mod))
+                                   mod))
+                              (values exps)))))
+                        ((define-form)
+                         (let* ((n (id-var-name value w))
+                                ;; Lookup the name in the module of the define form.
+                                (type (binding-type (lookup n r mod))))
+                           (case type
+                             ((global core macro module-ref)
+                              ;; affect compile-time environment (once we have booted)
+                              (if (and (memq m '(c c&e))
+                                       (not (module-local-variable (current-module) n))
+                                       (current-module))
+                                  (let ((old (module-variable (current-module) n)))
+                                    ;; use value of the same-named imported variable, if
+                                    ;; any
+                                    (if (and (variable? old)
+                                             (variable-bound? old)
+                                             (not (macro? (variable-ref old))))
+                                        (module-define! (current-module) n (variable-ref old))
+                                        (module-add! (current-module) n (make-undefined-variable)))))
+                              (values
+                               (cons
+                                (if (eq? m 'c&e)
+                                    (let ((x (build-global-definition s n (expand e r w mod))))
+                                      (top-level-eval-hook x mod)
+                                      x)
+                                    (lambda ()
+                                      (build-global-definition s n (expand e r w mod))))
+                                exps)))
+                             ((displaced-lexical)
+                              (syntax-violation #f "identifier out of context"
+                                                (source-wrap form w s mod)
+                                                (wrap value w mod)))
+                             (else
+                              (syntax-violation #f "cannot define keyword at top level"
+                                                (source-wrap form w s mod)
+                                                (wrap value w mod))))))
+                        (else
+                         (values (cons
+                                  (if (eq? m 'c&e)
+                                      (let ((x (expand-expr type value form e r w s mod)))
+                                        (top-level-eval-hook x mod)
+                                        x)
+                                      (lambda ()
+                                        (expand-expr type value form e r w s mod)))
+                                  exps)))))))
+              (lambda (exps)
+                (scan (cdr body) r w s m esew mod exps))))))
+
+        (call-with-values (lambda ()
+                            (scan body r w s m esew mod '()))
+          (lambda (exps)
+            (if (null? exps)
+                (build-void s)
+                (build-sequence
+                 s
+                 (let lp ((in exps) (out '()))
+                   (if (null? in) out
+                       (let ((e (car in)))
+                         (lp (cdr in)
+                             (cons (if (procedure? e) (e) e) out)))))))))))
+    
+    (define expand-install-global
+      (lambda (name e)
+        (build-global-definition
+         no-source
+         name
+         (build-application
+          no-source
+          (build-primref no-source 'make-syntax-transformer)
+          (list (build-data no-source name)
+                (build-data no-source 'macro)
+                e)))))
+  
+    (define parse-when-list
+      (lambda (e when-list)
+        ;; when-list is syntax'd version of list of situations
+        (let ((result (strip when-list empty-wrap)))
+          (let lp ((l result))
+            (if (null? l)
+                result
+                (if (memq (car l) '(compile load eval expand))
+                    (lp (cdr l))
+                    (syntax-violation 'eval-when "invalid situation" e
+                                      (car l))))))))
+
+    ;; syntax-type returns seven values: type, value, form, e, w, s, and
+    ;; mod. The first two are described in the table below.
+    ;;
+    ;;    type                   value         explanation
+    ;;    -------------------------------------------------------------------
+    ;;    core                   procedure     core singleton
+    ;;    core-form              procedure     core form
+    ;;    module-ref             procedure     @ or @@ singleton
+    ;;    lexical                name          lexical variable reference
+    ;;    global                 name          global variable reference
+    ;;    begin                  none          begin keyword
+    ;;    define                 none          define keyword
+    ;;    define-syntax          none          define-syntax keyword
+    ;;    define-syntax-parameter none         define-syntax-parameter keyword
+    ;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
+    ;;    eval-when              none          eval-when keyword
+    ;;    syntax                 level         pattern variable
+    ;;    displaced-lexical      none          displaced lexical identifier
+    ;;    lexical-call           name          call to lexical variable
+    ;;    global-call            name          call to global variable
+    ;;    call                   none          any other call
+    ;;    begin-form             none          begin expression
+    ;;    define-form            id            variable definition
+    ;;    define-syntax-form     id            syntax definition
+    ;;    define-syntax-parameter-form id      syntax parameter definition
+    ;;    local-syntax-form      rec?          syntax definition
+    ;;    eval-when-form         none          eval-when form
+    ;;    constant               none          self-evaluating datum
+    ;;    other                  none          anything else
+    ;;
+    ;; form is the entire form.  For definition forms (define-form,
+    ;; define-syntax-form, and define-syntax-parameter-form), e is the
+    ;; rhs expression.  For all others, e is the entire form.  w is the
+    ;; wrap for both form and e.  s is the source for the entire form.
+    ;; mod is the module for both form and e.
+    ;;
+    ;; syntax-type expands macros and unwraps as necessary to get to one
+    ;; of the forms above.  It also parses definition forms, although
+    ;; perhaps this should be done by the consumer.
+
+    (define syntax-type
+      (lambda (e r w s rib mod for-car?)
+        (cond
+         ((symbol? e)
+          (let* ((n (id-var-name e w))
+                 (b (lookup n r mod))
+                 (type (binding-type b)))
+            (case type
+              ((lexical) (values type (binding-value b) e e w s mod))
+              ((global) (values type n e e w s mod))
+              ((macro)
+               (if for-car?
+                   (values type (binding-value b) e e w s mod)
+                   (syntax-type (expand-macro (binding-value b) e r w s rib mod)
+                                r empty-wrap s rib mod #f)))
+              (else (values type (binding-value b) e e w s mod)))))
+         ((pair? e)
+          (let ((first (car e)))
+            (call-with-values
+                (lambda () (syntax-type first r w s rib mod #t))
+              (lambda (ftype fval fform fe fw fs fmod)
+                (case ftype
+                  ((lexical)
+                   (values 'lexical-call fval e e w s mod))
+                  ((global)
+                   ;; If we got here via an (@@ ...) expansion, we need to
+                   ;; make sure the fmod information is propagated back
+                   ;; correctly -- hence this consing.
+                   (values 'global-call (make-syntax-object fval w fmod)
+                           e e w s mod))
+                  ((macro)
+                   (syntax-type (expand-macro fval e r w s rib mod)
+                                r empty-wrap s rib mod for-car?))
+                  ((module-ref)
+                   (call-with-values (lambda () (fval e r w))
+                     (lambda (e r w s mod)
+                       (syntax-type e r w s rib mod for-car?))))
+                  ((core)
+                   (values 'core-form fval e e w s mod))
+                  ((local-syntax)
+                   (values 'local-syntax-form fval e e w s mod))
+                  ((begin)
+                   (values 'begin-form #f e e w s mod))
+                  ((eval-when)
+                   (values 'eval-when-form #f e e w s mod))
+                  ((define)
+                   (syntax-case e ()
+                     ((_ name val)
+                      (id? #'name)
+                      (values 'define-form #'name e #'val w s mod))
+                     ((_ (name . args) e1 e2 ...)
+                      (and (id? #'name)
+                           (valid-bound-ids? (lambda-var-list #'args)))
+                      ;; need lambda here...
+                      (values 'define-form (wrap #'name w mod)
+                              (wrap e w mod)
+                              (decorate-source
+                               (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
+                               s)
+                              empty-wrap s mod))
+                     ((_ name)
+                      (id? #'name)
+                      (values 'define-form (wrap #'name w mod)
+                              (wrap e w mod)
+                              #'(if #f #f)
+                              empty-wrap s mod))))
+                  ((define-syntax)
+                   (syntax-case e ()
+                     ((_ name val)
+                      (id? #'name)
+                      (values 'define-syntax-form #'name e #'val w s mod))))
+                  ((define-syntax-parameter)
+                   (syntax-case e ()
+                     ((_ name val)
+                      (id? #'name)
+                      (values 'define-syntax-parameter-form #'name e #'val w s mod))))
+                  (else
+                   (values 'call #f e e w s mod)))))))
+         ((syntax-object? e)
+          (syntax-type (syntax-object-expression e)
+                       r
+                       (join-wraps w (syntax-object-wrap e))
+                       (or (source-annotation e) s) rib
+                       (or (syntax-object-module e) mod) for-car?))
+         ((self-evaluating? e) (values 'constant #f e e w s mod))
+         (else (values 'other #f e e w s mod)))))
+
+    (define expand
+      (lambda (e r w mod)
+        (call-with-values
+            (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+          (lambda (type value form e w s mod)
+            (expand-expr type value form e r w s mod)))))
+
+    (define expand-expr
+      (lambda (type value form e r w s mod)
+        (case type
+          ((lexical)
+           (build-lexical-reference 'value s e value))
+          ((core core-form)
+           ;; apply transformer
+           (value e r w s mod))
+          ((module-ref)
+           (call-with-values (lambda () (value e r w))
+             (lambda (e r w s mod)
+               (expand e r w mod))))
+          ((lexical-call)
+           (expand-application
+            (let ((id (car e)))
+              (build-lexical-reference 'fun (source-annotation id)
+                                       (if (syntax-object? id)
+                                           (syntax->datum id)
+                                           id)
+                                       value))
+            e r w s mod))
+          ((global-call)
+           (expand-application
+            (build-global-reference (source-annotation (car e))
+                                    (if (syntax-object? value)
+                                        (syntax-object-expression value)
+                                        value)
+                                    (if (syntax-object? value)
+                                        (syntax-object-module value)
+                                        mod))
+            e r w s mod))
+          ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+          ((global) (build-global-reference s value mod))
+          ((call) (expand-application (expand (car e) r w mod) e r w s mod))
+          ((begin-form)
+           (syntax-case e ()
+             ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
+             ((_)
+              (if (include-deprecated-features)
+                  (begin
+                    (issue-deprecation-warning
+                     "Sequences of zero expressions are deprecated.  Use *unspecified*.")
+                    (expand-void))
+                  (syntax-violation #f "sequence of zero expressions"
+                                    (source-wrap e w s mod))))))
+          ((local-syntax-form)
+           (expand-local-syntax value e r w s mod expand-sequence))
+          ((eval-when-form)
+           (syntax-case e ()
+             ((_ (x ...) e1 e2 ...)
+              (let ((when-list (parse-when-list e #'(x ...))))
+                (if (memq 'eval when-list)
+                    (expand-sequence #'(e1 e2 ...) r w s mod)
+                    (expand-void))))))
+          ((define-form define-syntax-form define-syntax-parameter-form)
+           (syntax-violation #f "definition in expression context, where definitions are not allowed,"
+                             (source-wrap form w s mod)))
+          ((syntax)
+           (syntax-violation #f "reference to pattern variable outside syntax form"
+                             (source-wrap e w s mod)))
+          ((displaced-lexical)
+           (syntax-violation #f "reference to identifier outside its scope"
+                             (source-wrap e w s mod)))
+          (else (syntax-violation #f "unexpected syntax"
+                                  (source-wrap e w s mod))))))
+
+    (define expand-application
+      (lambda (x e r w s mod)
+        (syntax-case e ()
+          ((e0 e1 ...)
+           (build-application s x
+                              (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+
+    ;; (What follows is my interpretation of what's going on here -- Andy)
+    ;;
+    ;; A macro takes an expression, a tree, the leaves of which are identifiers
+    ;; and datums. Identifiers are symbols along with a wrap and a module. For
+    ;; efficiency, subtrees that share wraps and modules may be grouped as one
+    ;; syntax object.
+    ;;
+    ;; Going into the expansion, the expression is given an anti-mark, which
+    ;; logically propagates to all leaves. Then, in the new expression returned
+    ;; from the transfomer, if we see an expression with an anti-mark, we know it
+    ;; pertains to the original expression; conversely, expressions without the
+    ;; anti-mark are known to be introduced by the transformer.
+    ;;
+    ;; OK, good until now. We know this algorithm does lexical scoping
+    ;; appropriately because it's widely known in the literature, and psyntax is
+    ;; widely used. But what about modules? Here we're on our own. What we do is
+    ;; to mark the module of expressions produced by a macro as pertaining to the
+    ;; module that was current when the macro was defined -- that is, free
+    ;; identifiers introduced by a macro are scoped in the macro's module, not in
+    ;; the expansion's module. Seems to work well.
+    ;;
+    ;; The only wrinkle is when we want a macro to expand to code in another
+    ;; module, as is the case for the r6rs `library' form -- the body expressions
+    ;; should be scoped relative the new module, the one defined by the macro.
+    ;; For that, use `(@@ mod-name body)'.
+    ;;
+    ;; Part of the macro output will be from the site of the macro use and part
+    ;; from the macro definition. We allow source information from the macro use
+    ;; to pass through, but we annotate the parts coming from the macro with the
+    ;; source location information corresponding to the macro use. It would be
+    ;; really nice if we could also annotate introduced expressions with the
+    ;; locations corresponding to the macro definition, but that is not yet
+    ;; possible.
+    (define expand-macro
+      (lambda (p e r w s rib mod)
+        (define rebuild-macro-output
+          (lambda (x m)
+            (cond ((pair? x)
+                   (decorate-source 
+                    (cons (rebuild-macro-output (car x) m)
+                          (rebuild-macro-output (cdr x) m))
+                    s))
+                  ((syntax-object? x)
+                   (let ((w (syntax-object-wrap x)))
+                     (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
+                       (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+                           ;; output is from original text
+                           (make-syntax-object
+                            (syntax-object-expression x)
+                            (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
+                            (syntax-object-module x))
+                           ;; output introduced by macro
+                           (make-syntax-object
+                            (decorate-source (syntax-object-expression x) s)
+                            (make-wrap (cons m ms)
+                                       (if rib
+                                           (cons rib (cons 'shift ss))
+                                           (cons 'shift ss)))
+                            (syntax-object-module x))))))
+                
+                  ((vector? x)
+                   (let* ((n (vector-length x))
+                          (v (decorate-source (make-vector n) s)))
+                     (do ((i 0 (fx+ i 1)))
+                         ((fx= i n) v)
+                       (vector-set! v i
+                                    (rebuild-macro-output (vector-ref x i) m)))))
+                  ((symbol? x)
+                   (syntax-violation #f "encountered raw symbol in macro output"
+                                     (source-wrap e w (wrap-subst w) mod) x))
+                  (else (decorate-source x s)))))
+        (with-fluids ((transformer-environment
+                       (lambda (k) (k e r w s rib mod))))
+          (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+                                (new-mark)))))
+
+    (define expand-body
+      ;; In processing the forms of the body, we create a new, empty wrap.
+      ;; This wrap is augmented (destructively) each time we discover that
+      ;; the next form is a definition.  This is done:
+      ;;
+      ;;   (1) to allow the first nondefinition form to be a call to
+      ;;       one of the defined ids even if the id previously denoted a
+      ;;       definition keyword or keyword for a macro expanding into a
+      ;;       definition;
+      ;;   (2) to prevent subsequent definition forms (but unfortunately
+      ;;       not earlier ones) and the first nondefinition form from
+      ;;       confusing one of the bound identifiers for an auxiliary
+      ;;       keyword; and
+      ;;   (3) so that we do not need to restart the expansion of the
+      ;;       first nondefinition form, which is problematic anyway
+      ;;       since it might be the first element of a begin that we
+      ;;       have just spliced into the body (meaning if we restarted,
+      ;;       we'd really need to restart with the begin or the macro
+      ;;       call that expanded into the begin, and we'd have to give
+      ;;       up allowing (begin <defn>+ <expr>+), which is itself
+      ;;       problematic since we don't know if a begin contains only
+      ;;       definitions until we've expanded it).
+      ;;
+      ;; Before processing the body, we also create a new environment
+      ;; containing a placeholder for the bindings we will add later and
+      ;; associate this environment with each form.  In processing a
+      ;; let-syntax or letrec-syntax, the associated environment may be
+      ;; augmented with local keyword bindings, so the environment may
+      ;; be different for different forms in the body.  Once we have
+      ;; gathered up all of the definitions, we evaluate the transformer
+      ;; expressions and splice into r at the placeholder the new variable
+      ;; and keyword bindings.  This allows let-syntax or letrec-syntax
+      ;; forms local to a portion or all of the body to shadow the
+      ;; definition bindings.
+      ;;
+      ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+      ;; into the body.
+      ;;
+      ;; outer-form is fully wrapped w/source
+      (lambda (body outer-form r w mod)
+        (let* ((r (cons '("placeholder" . (placeholder)) r))
+               (ribcage (make-empty-ribcage))
+               (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+          (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+                      (ids '()) (labels '())
+                      (var-ids '()) (vars '()) (vals '()) (bindings '()))
+            (if (null? body)
+                (syntax-violation #f "no expressions in body" outer-form)
+                (let ((e (cdar body)) (er (caar body)))
+                  (call-with-values
+                      (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
+                    (lambda (type value form e w s mod)
+                      (case type
+                        ((define-form)
+                         (let ((id (wrap value w mod)) (label (gen-label)))
+                           (let ((var (gen-var id)))
+                             (extend-ribcage! ribcage id label)
+                             (parse (cdr body)
+                                    (cons id ids) (cons label labels)
+                                    (cons id var-ids)
+                                    (cons var vars) (cons (cons er (wrap e w mod)) vals)
+                                    (cons (make-binding 'lexical var) bindings)))))
+                        ((define-syntax-form define-syntax-parameter-form)
+                         (let ((id (wrap value w mod))
+                               (label (gen-label))
+                               (trans-r (macros-only-env er)))
+                           (extend-ribcage! ribcage id label)
+                           ;; As required by R6RS, evaluate the right-hand-sides of internal
+                           ;; syntax definition forms and add their transformers to the
+                           ;; compile-time environment immediately, so that the newly-defined
+                           ;; keywords may be used in definition context within the same
+                           ;; lexical contour.
+                           (set-cdr! r (extend-env (list label)
+                                                   (list (make-binding 'macro
+                                                                       (eval-local-transformer
+                                                                        (expand e trans-r w mod)
+                                                                        mod)))
+                                                   (cdr r)))
+                           (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+                        ((begin-form)
+                         (syntax-case e ()
+                           ((_ e1 ...)
+                            (parse (let f ((forms #'(e1 ...)))
+                                     (if (null? forms)
+                                         (cdr body)
+                                         (cons (cons er (wrap (car forms) w mod))
+                                               (f (cdr forms)))))
+                                   ids labels var-ids vars vals bindings))))
+                        ((local-syntax-form)
+                         (expand-local-syntax value e er w s mod
+                                              (lambda (forms er w s mod)
+                                                (parse (let f ((forms forms))
+                                                         (if (null? forms)
+                                                             (cdr body)
+                                                             (cons (cons er (wrap (car forms) w mod))
+                                                                   (f (cdr forms)))))
+                                                       ids labels var-ids vars vals bindings))))
+                        (else           ; found a non-definition
+                         (if (null? ids)
+                             (build-sequence no-source
+                                             (map (lambda (x)
+                                                    (expand (cdr x) (car x) empty-wrap mod))
+                                                  (cons (cons er (source-wrap e w s mod))
+                                                        (cdr body))))
+                             (begin
+                               (if (not (valid-bound-ids? ids))
+                                   (syntax-violation
+                                    #f "invalid or duplicate identifier in definition"
+                                    outer-form))
+                               (set-cdr! r (extend-env labels bindings (cdr r)))
+                               (build-letrec no-source #t
+                                             (reverse (map syntax->datum var-ids))
+                                             (reverse vars)
+                                             (map (lambda (x)
+                                                    (expand (cdr x) (car x) empty-wrap mod))
+                                                  (reverse vals))
+                                             (build-sequence no-source
+                                                             (map (lambda (x)
+                                                                    (expand (cdr x) (car x) empty-wrap mod))
+                                                                  (cons (cons er (source-wrap e w s mod))
+                                                                        (cdr body)))))))))))))))))
+
+    (define expand-local-syntax
+      (lambda (rec? e r w s mod k)
+        (syntax-case e ()
+          ((_ ((id val) ...) e1 e2 ...)
+           (let ((ids #'(id ...)))
+             (if (not (valid-bound-ids? ids))
+                 (syntax-violation #f "duplicate bound keyword" e)
+                 (let ((labels (gen-labels ids)))
+                   (let ((new-w (make-binding-wrap ids labels w)))
+                     (k #'(e1 e2 ...)
+                        (extend-env
+                         labels
+                         (let ((w (if rec? new-w w))
+                               (trans-r (macros-only-env r)))
+                           (map (lambda (x)
+                                  (make-binding 'macro
+                                                (eval-local-transformer
+                                                 (expand x trans-r w mod)
+                                                 mod)))
+                                #'(val ...)))
+                         r)
+                        new-w
+                        s
+                        mod))))))
+          (_ (syntax-violation #f "bad local syntax definition"
+                               (source-wrap e w s mod))))))
+
+    (define eval-local-transformer
+      (lambda (expanded mod)
+        (let ((p (local-eval-hook expanded mod)))
+          (if (procedure? p)
+              p
+              (syntax-violation #f "nonprocedure transformer" p)))))
+
+    (define expand-void
+      (lambda ()
+        (build-void no-source)))
+
+    (define ellipsis?
+      (lambda (e r mod)
+        (and (nonsymbol-id? e)
+             ;; If there is a binding for the special identifier
+             ;; #{ $sc-ellipsis }# in the lexical environment of E,
+             ;; and if the associated binding type is 'ellipsis',
+             ;; then the binding's value specifies the custom ellipsis
+             ;; identifier within that lexical environment, and the
+             ;; comparison is done using 'bound-id=?'.
+             (let* ((id (make-syntax-object '#{ $sc-ellipsis }
+                                            (syntax-object-wrap e)
+                                            (syntax-object-module e)))
+                    (n (id-var-name id empty-wrap))
+                    (b (lookup n r mod)))
+               (if (eq? (binding-type b) 'ellipsis)
+                   (bound-id=? e (binding-value b))
+                   (free-id=? e #'(... ...)))))))
+
+    (define lambda-formals
+      (lambda (orig-args)
+        (define (req args rreq)
+          (syntax-case args ()
+            (()
+             (check (reverse rreq) #f))
+            ((a . b) (id? #'a)
+             (req #'b (cons #'a rreq)))
+            (r (id? #'r)
+               (check (reverse rreq) #'r))
+            (else
+             (syntax-violation 'lambda "invalid argument list" orig-args args))))
+        (define (check req rest)
+          (cond
+           ((distinct-bound-ids? (if rest (cons rest req) req))
+            (values req #f rest #f))
+           (else
+            (syntax-violation 'lambda "duplicate identifier in argument list"
+                              orig-args))))
+        (req orig-args '())))
+
+    (define expand-simple-lambda
+      (lambda (e r w s mod req rest meta body)
+        (let* ((ids (if rest (append req (list rest)) req))
+               (vars (map gen-var ids))
+               (labels (gen-labels ids)))
+          (build-simple-lambda
+           s
+           (map syntax->datum req) (and rest (syntax->datum rest)) vars
+           meta
+           (expand-body body (source-wrap e w s mod)
+                        (extend-var-env labels vars r)
+                        (make-binding-wrap ids labels w)
+                        mod)))))
+
+    (define lambda*-formals
+      (lambda (orig-args)
+        (define (req args rreq)
+          (syntax-case args ()
+            (()
+             (check (reverse rreq) '() #f '()))
+            ((a . b) (id? #'a)
+             (req #'b (cons #'a rreq)))
+            ((a . b) (eq? (syntax->datum #'a) #\optional)
+             (opt #'b (reverse rreq) '()))
+            ((a . b) (eq? (syntax->datum #'a) #\key)
+             (key #'b (reverse rreq) '() '()))
+            ((a b) (eq? (syntax->datum #'a) #\rest)
+             (rest #'b (reverse rreq) '() '()))
+            (r (id? #'r)
+               (rest #'r (reverse rreq) '() '()))
+            (else
+             (syntax-violation 'lambda* "invalid argument list" orig-args args))))
+        (define (opt args req ropt)
+          (syntax-case args ()
+            (()
+             (check req (reverse ropt) #f '()))
+            ((a . b) (id? #'a)
+             (opt #'b req (cons #'(a #f) ropt)))
+            (((a init) . b) (id? #'a)
+             (opt #'b req (cons #'(a init) ropt)))
+            ((a . b) (eq? (syntax->datum #'a) #\key)
+             (key #'b req (reverse ropt) '()))
+            ((a b) (eq? (syntax->datum #'a) #\rest)
+             (rest #'b req (reverse ropt) '()))
+            (r (id? #'r)
+               (rest #'r req (reverse ropt) '()))
+            (else
+             (syntax-violation 'lambda* "invalid optional argument list"
+                               orig-args args))))
+        (define (key args req opt rkey)
+          (syntax-case args ()
+            (()
+             (check req opt #f (cons #f (reverse rkey))))
+            ((a . b) (id? #'a)
+             (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+               (key #'b req opt (cons #'(k a #f) rkey))))
+            (((a init) . b) (id? #'a)
+             (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+               (key #'b req opt (cons #'(k a init) rkey))))
+            (((a init k) . b) (and (id? #'a)
+                                   (keyword? (syntax->datum #'k)))
+             (key #'b req opt (cons #'(k a init) rkey)))
+            ((aok) (eq? (syntax->datum #'aok) #\allow-other-keys)
+             (check req opt #f (cons #t (reverse rkey))))
+            ((aok a b) (and (eq? (syntax->datum #'aok) #\allow-other-keys)
+                            (eq? (syntax->datum #'a) #\rest))
+             (rest #'b req opt (cons #t (reverse rkey))))
+            ((aok . r) (and (eq? (syntax->datum #'aok) #\allow-other-keys)
+                            (id? #'r))
+             (rest #'r req opt (cons #t (reverse rkey))))
+            ((a b) (eq? (syntax->datum #'a) #\rest)
+             (rest #'b req opt (cons #f (reverse rkey))))
+            (r (id? #'r)
+               (rest #'r req opt (cons #f (reverse rkey))))
+            (else
+             (syntax-violation 'lambda* "invalid keyword argument list"
+                               orig-args args))))
+        (define (rest args req opt kw)
+          (syntax-case args ()
+            (r (id? #'r)
+               (check req opt #'r kw))
+            (else
+             (syntax-violation 'lambda* "invalid rest argument"
+                               orig-args args))))
+        (define (check req opt rest kw)
+          (cond
+           ((distinct-bound-ids?
+             (append req (map car opt) (if rest (list rest) '())
+                     (if (pair? kw) (map cadr (cdr kw)) '())))
+            (values req opt rest kw))
+           (else
+            (syntax-violation 'lambda* "duplicate identifier in argument list"
+                              orig-args))))
+        (req orig-args '())))
+
+    (define expand-lambda-case
+      (lambda (e r w s mod get-formals clauses)
+        (define (parse-req req opt rest kw body)
+          (let ((vars (map gen-var req))
+                (labels (gen-labels req)))
+            (let ((r* (extend-var-env labels vars r))
+                  (w* (make-binding-wrap req labels w)))
+              (parse-opt (map syntax->datum req)
+                         opt rest kw body (reverse vars) r* w* '() '()))))
+        (define (parse-opt req opt rest kw body vars r* w* out inits)
+          (cond
+           ((pair? opt)
+            (syntax-case (car opt) ()
+              ((id i)
+               (let* ((v (gen-var #'id))
+                      (l (gen-labels (list v)))
+                      (r** (extend-var-env l (list v) r*))
+                      (w** (make-binding-wrap (list #'id) l w*)))
+                 (parse-opt req (cdr opt) rest kw body (cons v vars)
+                            r** w** (cons (syntax->datum #'id) out)
+                            (cons (expand #'i r* w* mod) inits))))))
+           (rest
+            (let* ((v (gen-var rest))
+                   (l (gen-labels (list v)))
+                   (r* (extend-var-env l (list v) r*))
+                   (w* (make-binding-wrap (list rest) l w*)))
+              (parse-kw req (if (pair? out) (reverse out) #f)
+                        (syntax->datum rest)
+                        (if (pair? kw) (cdr kw) kw)
+                        body (cons v vars) r* w* 
+                        (if (pair? kw) (car kw) #f)
+                        '() inits)))
+           (else
+            (parse-kw req (if (pair? out) (reverse out) #f) #f
+                      (if (pair? kw) (cdr kw) kw)
+                      body vars r* w*
+                      (if (pair? kw) (car kw) #f)
+                      '() inits))))
+        (define (parse-kw req opt rest kw body vars r* w* aok out inits)
+          (cond
+           ((pair? kw)
+            (syntax-case (car kw) ()
+              ((k id i)
+               (let* ((v (gen-var #'id))
+                      (l (gen-labels (list v)))
+                      (r** (extend-var-env l (list v) r*))
+                      (w** (make-binding-wrap (list #'id) l w*)))
+                 (parse-kw req opt rest (cdr kw) body (cons v vars)
+                           r** w** aok
+                           (cons (list (syntax->datum #'k)
+                                       (syntax->datum #'id)
+                                       v)
+                                 out)
+                           (cons (expand #'i r* w* mod) inits))))))
+           (else
+            (parse-body req opt rest
+                        (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+                        body (reverse vars) r* w* (reverse inits) '()))))
+        (define (parse-body req opt rest kw body vars r* w* inits meta)
+          (syntax-case body ()
+            ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+             (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+                         (append meta 
+                                 `((documentation
+                                    . ,(syntax->datum #'docstring))))))
+            ((#((k . v) ...) e1 e2 ...) 
+             (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+                         (append meta (syntax->datum #'((k . v) ...)))))
+            ((e1 e2 ...)
+             (values meta req opt rest kw inits vars
+                     (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
+                                  r* w* mod)))))
+
+        (syntax-case clauses ()
+          (() (values '() #f))
+          (((args e1 e2 ...) (args* e1* e2* ...) ...)
+           (call-with-values (lambda () (get-formals #'args))
+             (lambda (req opt rest kw)
+               (call-with-values (lambda ()
+                                   (parse-req req opt rest kw #'(e1 e2 ...)))
+                 (lambda (meta req opt rest kw inits vars body)
+                   (call-with-values
+                       (lambda ()
+                         (expand-lambda-case e r w s mod get-formals
+                                             #'((args* e1* e2* ...) ...)))
+                     (lambda (meta* else*)
+                       (values
+                        (append meta meta*)
+                        (build-lambda-case s req opt rest kw inits vars
+                                           body else*))))))))))))
+
+    ;; data
+
+    ;; strips syntax-objects down to top-wrap
+    ;;
+    ;; since only the head of a list is annotated by the reader, not each pair
+    ;; in the spine, we also check for pairs whose cars are annotated in case
+    ;; we've been passed the cdr of an annotated list
+
+    (define strip
+      (lambda (x w)
+        (if (top-marked? w)
+            x
+            (let f ((x x))
+              (cond
+               ((syntax-object? x)
+                (strip (syntax-object-expression x) (syntax-object-wrap x)))
+               ((pair? x)
+                (let ((a (f (car x))) (d (f (cdr x))))
+                  (if (and (eq? a (car x)) (eq? d (cdr x)))
+                      x
+                      (cons a d))))
+               ((vector? x)
+                (let ((old (vector->list x)))
+                  (let ((new (map f old)))
+                    ;; inlined and-map with two args
+                    (let lp ((l1 old) (l2 new))
+                      (if (null? l1)
+                          x
+                          (if (eq? (car l1) (car l2))
+                              (lp (cdr l1) (cdr l2))
+                              (list->vector new)))))))
+               (else x))))))
+
+    ;; lexical variables
+
+    (define gen-var
+      (lambda (id)
+        (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+          (build-lexical-var no-source id))))
+
+    ;; appears to return a reversed list
+    (define lambda-var-list
+      (lambda (vars)
+        (let lvl ((vars vars) (ls '()) (w empty-wrap))
+          (cond
+           ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+           ((id? vars) (cons (wrap vars w #f) ls))
+           ((null? vars) ls)
+           ((syntax-object? vars)
+            (lvl (syntax-object-expression vars)
+                 ls
+                 (join-wraps w (syntax-object-wrap vars))))
+           ;; include anything else to be caught by subsequent error
+           ;; checking
+           (else (cons vars ls))))))
+
+    ;; core transformers
+
+    (global-extend 'local-syntax 'letrec-syntax #t)
+    (global-extend 'local-syntax 'let-syntax #f)
+
+    (global-extend 'core 'syntax-parameterize
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ ((var val) ...) e1 e2 ...)
+                        (valid-bound-ids? #'(var ...))
+                        (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
+                          (for-each
+                           (lambda (id n)
+                             (case (binding-type (lookup n r mod))
+                               ((displaced-lexical)
+                                (syntax-violation 'syntax-parameterize
+                                                  "identifier out of context"
+                                                  e
+                                                  (source-wrap id w s mod)))))
+                           #'(var ...)
+                           names)
+                          (expand-body
+                           #'(e1 e2 ...)
+                           (source-wrap e w s mod)
+                           (extend-env
+                            names
+                            (let ((trans-r (macros-only-env r)))
+                              (map (lambda (x)
+                                     (make-binding 'macro
+                                                   (eval-local-transformer (expand x trans-r w mod)
+                                                                           mod)))
+                                   #'(val ...)))
+                            r)
+                           w
+                           mod)))
+                       (_ (syntax-violation 'syntax-parameterize "bad syntax"
+                                            (source-wrap e w s mod))))))
+
+    (global-extend 'core 'quote
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ e) (build-data s (strip #'e w)))
+                       (_ (syntax-violation 'quote "bad syntax"
+                                            (source-wrap e w s mod))))))
+
+    (global-extend 'core 'syntax
+                   (let ()
+                     (define gen-syntax
+                       (lambda (src e r maps ellipsis? mod)
+                         (if (id? e)
+                             (let ((label (id-var-name e empty-wrap)))
+                               ;; Mod does not matter, we are looking to see if
+                               ;; the id is lexical syntax.
+                               (let ((b (lookup label r mod)))
+                                 (if (eq? (binding-type b) 'syntax)
+                                     (call-with-values
+                                         (lambda ()
+                                           (let ((var.lev (binding-value b)))
+                                             (gen-ref src (car var.lev) (cdr var.lev) maps)))
+                                       (lambda (var maps) (values `(ref ,var) maps)))
+                                     (if (ellipsis? e r mod)
+                                         (syntax-violation 'syntax "misplaced ellipsis" src)
+                                         (values `(quote ,e) maps)))))
+                             (syntax-case e ()
+                               ((dots e)
+                                (ellipsis? #'dots r mod)
+                                (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
+                               ((x dots . y)
+                                ;; this could be about a dozen lines of code, except that we
+                                ;; choose to handle #'(x ... ...) forms
+                                (ellipsis? #'dots r mod)
+                                (let f ((y #'y)
+                                        (k (lambda (maps)
+                                             (call-with-values
+                                                 (lambda ()
+                                                   (gen-syntax src #'x r
+                                                               (cons '() maps) ellipsis? mod))
+                                               (lambda (x maps)
+                                                 (if (null? (car maps))
+                                                     (syntax-violation 'syntax "extra ellipsis"
+                                                                       src)
+                                                     (values (gen-map x (car maps))
+                                                             (cdr maps))))))))
+                                  (syntax-case y ()
+                                    ((dots . y)
+                                     (ellipsis? #'dots r mod)
+                                     (f #'y
+                                        (lambda (maps)
+                                          (call-with-values
+                                              (lambda () (k (cons '() maps)))
+                                            (lambda (x maps)
+                                              (if (null? (car maps))
+                                                  (syntax-violation 'syntax "extra ellipsis" src)
+                                                  (values (gen-mappend x (car maps))
+                                                          (cdr maps))))))))
+                                    (_ (call-with-values
+                                           (lambda () (gen-syntax src y r maps ellipsis? mod))
+                                         (lambda (y maps)
+                                           (call-with-values
+                                               (lambda () (k maps))
+                                             (lambda (x maps)
+                                               (values (gen-append x y) maps)))))))))
+                               ((x . y)
+                                (call-with-values
+                                    (lambda () (gen-syntax src #'x r maps ellipsis? mod))
+                                  (lambda (x maps)
+                                    (call-with-values
+                                        (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+                                      (lambda (y maps) (values (gen-cons x y) maps))))))
+                               (#(e1 e2 ...)
+                                (call-with-values
+                                    (lambda ()
+                                      (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+                                  (lambda (e maps) (values (gen-vector e) maps))))
+                               (_ (values `(quote ,e) maps))))))
+
+                     (define gen-ref
+                       (lambda (src var level maps)
+                         (if (fx= level 0)
+                             (values var maps)
+                             (if (null? maps)
+                                 (syntax-violation 'syntax "missing ellipsis" src)
+                                 (call-with-values
+                                     (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+                                   (lambda (outer-var outer-maps)
+                                     (let ((b (assq outer-var (car maps))))
+                                       (if b
+                                           (values (cdr b) maps)
+                                           (let ((inner-var (gen-var 'tmp)))
+                                             (values inner-var
+                                                     (cons (cons (cons outer-var inner-var)
+                                                                 (car maps))
+                                                           outer-maps)))))))))))
+
+                     (define gen-mappend
+                       (lambda (e map-env)
+                         `(apply (primitive append) ,(gen-map e map-env))))
+
+                     (define gen-map
+                       (lambda (e map-env)
+                         (let ((formals (map cdr map-env))
+                               (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+                           (cond
+                            ((eq? (car e) 'ref)
+                             ;; identity map equivalence:
+                             ;; (map (lambda (x) x) y) == y
+                             (car actuals))
+                            ((and-map
+                              (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+                              (cdr e))
+                             ;; eta map equivalence:
+                             ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+                             `(map (primitive ,(car e))
+                                   ,@(map (let ((r (map cons formals actuals)))
+                                            (lambda (x) (cdr (assq (cadr x) r))))
+                                          (cdr e))))
+                            (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+                     (define gen-cons
+                       (lambda (x y)
+                         (case (car y)
+                           ((quote)
+                            (if (eq? (car x) 'quote)
+                                `(quote (,(cadr x) . ,(cadr y)))
+                                (if (eq? (cadr y) '())
+                                    `(list ,x)
+                                    `(cons ,x ,y))))
+                           ((list) `(list ,x ,@(cdr y)))
+                           (else `(cons ,x ,y)))))
+
+                     (define gen-append
+                       (lambda (x y)
+                         (if (equal? y '(quote ()))
+                             x
+                             `(append ,x ,y))))
+
+                     (define gen-vector
+                       (lambda (x)
+                         (cond
+                          ((eq? (car x) 'list) `(vector ,@(cdr x)))
+                          ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+                          (else `(list->vector ,x)))))
+
+
+                     (define regen
+                       (lambda (x)
+                         (case (car x)
+                           ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
+                           ((primitive) (build-primref no-source (cadr x)))
+                           ((quote) (build-data no-source (cadr x)))
+                           ((lambda)
+                            (if (list? (cadr x))
+                                (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
+                                (error "how did we get here" x)))
+                           (else (build-application no-source
+                                                    (build-primref no-source (car x))
+                                                    (map regen (cdr x)))))))
+
+                     (lambda (e r w s mod)
+                       (let ((e (source-wrap e w s mod)))
+                         (syntax-case e ()
+                           ((_ x)
+                            (call-with-values
+                                (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+                              (lambda (e maps) (regen e))))
+                           (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+
+    (global-extend 'core 'lambda
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ args e1 e2 ...)
+                        (call-with-values (lambda () (lambda-formals #'args))
+                          (lambda (req opt rest kw)
+                            (let lp ((body #'(e1 e2 ...)) (meta '()))
+                              (syntax-case body ()
+                                ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+                                 (lp #'(e1 e2 ...)
+                                     (append meta
+                                             `((documentation
+                                                . ,(syntax->datum #'docstring))))))
+                                ((#((k . v) ...) e1 e2 ...) 
+                                 (lp #'(e1 e2 ...)
+                                     (append meta (syntax->datum #'((k . v) ...)))))
+                                (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
+                       (_ (syntax-violation 'lambda "bad lambda" e)))))
+  
+    (global-extend 'core 'lambda*
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ args e1 e2 ...)
+                        (call-with-values
+                            (lambda ()
+                              (expand-lambda-case e r w s mod
+                                                  lambda*-formals #'((args e1 e2 ...))))
+                          (lambda (meta lcase)
+                            (build-case-lambda s meta lcase))))
+                       (_ (syntax-violation 'lambda "bad lambda*" e)))))
+
+    (global-extend 'core 'case-lambda
+                   (lambda (e r w s mod)
+                     (define (build-it meta clauses)
+                       (call-with-values
+                           (lambda ()
+                             (expand-lambda-case e r w s mod
+                                                 lambda-formals
+                                                 clauses))
+                         (lambda (meta* lcase)
+                           (build-case-lambda s (append meta meta*) lcase))))
+                     (syntax-case e ()
+                       ((_ (args e1 e2 ...) ...)
+                        (build-it '() #'((args e1 e2 ...) ...)))
+                       ((_ docstring (args e1 e2 ...) ...)
+                        (string? (syntax->datum #'docstring))
+                        (build-it `((documentation
+                                     . ,(syntax->datum #'docstring)))
+                                  #'((args e1 e2 ...) ...)))
+                       (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+
+    (global-extend 'core 'case-lambda*
+                   (lambda (e r w s mod)
+                     (define (build-it meta clauses)
+                       (call-with-values
+                           (lambda ()
+                             (expand-lambda-case e r w s mod
+                                                 lambda*-formals
+                                                 clauses))
+                         (lambda (meta* lcase)
+                           (build-case-lambda s (append meta meta*) lcase))))
+                     (syntax-case e ()
+                       ((_ (args e1 e2 ...) ...)
+                        (build-it '() #'((args e1 e2 ...) ...)))
+                       ((_ docstring (args e1 e2 ...) ...)
+                        (string? (syntax->datum #'docstring))
+                        (build-it `((documentation
+                                     . ,(syntax->datum #'docstring)))
+                                  #'((args e1 e2 ...) ...)))
+                       (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+
+    (global-extend 'core 'with-ellipsis
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ dots e1 e2 ...)
+                        (id? #'dots)
+                        (let ((id (if (symbol? #'dots)
+                                      '#{ $sc-ellipsis }
+                                      (make-syntax-object '#{ $sc-ellipsis }
+                                                          (syntax-object-wrap #'dots)
+                                                          (syntax-object-module #'dots)))))
+                          (let ((ids (list id))
+                                (labels (list (gen-label)))
+                                (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
+                            (let ((nw (make-binding-wrap ids labels w))
+                                  (nr (extend-env labels bindings r)))
+                              (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
+                       (_ (syntax-violation 'with-ellipsis "bad syntax"
+                                            (source-wrap e w s mod))))))
+
+    (global-extend 'core 'let
+                   (let ()
+                     (define (expand-let e r w s mod constructor ids vals exps)
+                       (if (not (valid-bound-ids? ids))
+                           (syntax-violation 'let "duplicate bound variable" e)
+                           (let ((labels (gen-labels ids))
+                                 (new-vars (map gen-var ids)))
+                             (let ((nw (make-binding-wrap ids labels w))
+                                   (nr (extend-var-env labels new-vars r)))
+                               (constructor s
+                                            (map syntax->datum ids)
+                                            new-vars
+                                            (map (lambda (x) (expand x r w mod)) vals)
+                                            (expand-body exps (source-wrap e nw s mod)
+                                                         nr nw mod))))))
+                     (lambda (e r w s mod)
+                       (syntax-case e ()
+                         ((_ ((id val) ...) e1 e2 ...)
+                          (and-map id? #'(id ...))
+                          (expand-let e r w s mod
+                                      build-let
+                                      #'(id ...)
+                                      #'(val ...)
+                                      #'(e1 e2 ...)))
+                         ((_ f ((id val) ...) e1 e2 ...)
+                          (and (id? #'f) (and-map id? #'(id ...)))
+                          (expand-let e r w s mod
+                                      build-named-let
+                                      #'(f id ...)
+                                      #'(val ...)
+                                      #'(e1 e2 ...)))
+                         (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
+
+
+    (global-extend 'core 'letrec
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ ((id val) ...) e1 e2 ...)
+                        (and-map id? #'(id ...))
+                        (let ((ids #'(id ...)))
+                          (if (not (valid-bound-ids? ids))
+                              (syntax-violation 'letrec "duplicate bound variable" e)
+                              (let ((labels (gen-labels ids))
+                                    (new-vars (map gen-var ids)))
+                                (let ((w (make-binding-wrap ids labels w))
+                                      (r (extend-var-env labels new-vars r)))
+                                  (build-letrec s #f
+                                                (map syntax->datum ids)
+                                                new-vars
+                                                (map (lambda (x) (expand x r w mod)) #'(val ...))
+                                                (expand-body #'(e1 e2 ...) 
+                                                             (source-wrap e w s mod) r w mod)))))))
+                       (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
+
+
+    (global-extend 'core 'letrec*
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ ((id val) ...) e1 e2 ...)
+                        (and-map id? #'(id ...))
+                        (let ((ids #'(id ...)))
+                          (if (not (valid-bound-ids? ids))
+                              (syntax-violation 'letrec* "duplicate bound variable" e)
+                              (let ((labels (gen-labels ids))
+                                    (new-vars (map gen-var ids)))
+                                (let ((w (make-binding-wrap ids labels w))
+                                      (r (extend-var-env labels new-vars r)))
+                                  (build-letrec s #t
+                                                (map syntax->datum ids)
+                                                new-vars
+                                                (map (lambda (x) (expand x r w mod)) #'(val ...))
+                                                (expand-body #'(e1 e2 ...) 
+                                                             (source-wrap e w s mod) r w mod)))))))
+                       (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
+
+
+    (global-extend 'core 'set!
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ id val)
+                        (id? #'id)
+                        (let ((n (id-var-name #'id w))
+                              ;; Lookup id in its module
+                              (id-mod (if (syntax-object? #'id)
+                                          (syntax-object-module #'id)
+                                          mod)))
+                          (let ((b (lookup n r id-mod)))
+                            (case (binding-type b)
+                              ((lexical)
+                               (build-lexical-assignment s
+                                                         (syntax->datum #'id)
+                                                         (binding-value b)
+                                                         (expand #'val r w mod)))
+                              ((global)
+                               (build-global-assignment s n (expand #'val r w mod) id-mod))
+                              ((macro)
+                               (let ((p (binding-value b)))
+                                 (if (procedure-property p 'variable-transformer)
+                                     ;; As syntax-type does, call expand-macro with
+                                     ;; the mod of the expression. Hmm.
+                                     (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
+                                     (syntax-violation 'set! "not a variable transformer"
+                                                       (wrap e w mod)
+                                                       (wrap #'id w id-mod)))))
+                              ((displaced-lexical)
+                               (syntax-violation 'set! "identifier out of context"
+                                                 (wrap #'id w mod)))
+                              (else (syntax-violation 'set! "bad set!"
+                                                      (source-wrap e w s mod)))))))
+                       ((_ (head tail ...) val)
+                        (call-with-values
+                            (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+                          (lambda (type value formform ee ww ss modmod)
+                            (case type
+                              ((module-ref)
+                               (let ((val (expand #'val r w mod)))
+                                 (call-with-values (lambda () (value #'(head tail ...) r w))
+                                   (lambda (e r w s* mod)
+                                     (syntax-case e ()
+                                       (e (id? #'e)
+                                          (build-global-assignment s (syntax->datum #'e)
+                                                                   val mod)))))))
+                              (else
+                               (build-application s
+                                                  (expand #'(setter head) r w mod)
+                                                  (map (lambda (e) (expand e r w mod))
+                                                       #'(tail ... val))))))))
+                       (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+    (global-extend 'module-ref '@
+                   (lambda (e r w)
+                     (syntax-case e ()
+                       ((_ (mod ...) id)
+                        (and (and-map id? #'(mod ...)) (id? #'id))
+                        ;; Strip the wrap from the identifier and return top-wrap
+                        ;; so that the identifier will not be captured by lexicals.
+                        (values (syntax->datum #'id) r top-wrap #f
+                                (syntax->datum
+                                 #'(public mod ...)))))))
+
+    (global-extend 'module-ref '@@
+                   (lambda (e r w)
+                     (define remodulate
+                       (lambda (x mod)
+                         (cond ((pair? x)
+                                (cons (remodulate (car x) mod)
+                                      (remodulate (cdr x) mod)))
+                               ((syntax-object? x)
+                                (make-syntax-object
+                                 (remodulate (syntax-object-expression x) mod)
+                                 (syntax-object-wrap x)
+                                 ;; hither the remodulation
+                                 mod))
+                               ((vector? x)
+                                (let* ((n (vector-length x)) (v (make-vector n)))
+                                  (do ((i 0 (fx+ i 1)))
+                                      ((fx= i n) v)
+                                    (vector-set! v i (remodulate (vector-ref x i) mod)))))
+                               (else x))))
+                     (syntax-case e (@@)
+                       ((_ (mod ...) id)
+                        (and (and-map id? #'(mod ...)) (id? #'id))
+                        ;; Strip the wrap from the identifier and return top-wrap
+                        ;; so that the identifier will not be captured by lexicals.
+                        (values (syntax->datum #'id) r top-wrap #f
+                                (syntax->datum
+                                 #'(private mod ...))))
+                       ((_ @@ (mod ...) exp)
+                        (and-map id? #'(mod ...))
+                        ;; This is a special syntax used to support R6RS library forms.
+                        ;; Unlike the syntax above, the last item is not restricted to
+                        ;; be a single identifier, and the syntax objects are kept
+                        ;; intact, with only their module changed.
+                        (let ((mod (syntax->datum #'(private mod ...))))
+                          (values (remodulate #'exp mod)
+                                  r w (source-annotation #'exp)
+                                  mod))))))
+  
+    (global-extend 'core 'if
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ test then)
+                        (build-conditional
+                         s
+                         (expand #'test r w mod)
+                         (expand #'then r w mod)
+                         (build-void no-source)))
+                       ((_ test then else)
+                        (build-conditional
+                         s
+                         (expand #'test r w mod)
+                         (expand #'then r w mod)
+                         (expand #'else r w mod))))))
+
+    (global-extend 'core 'with-fluids
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_ ((fluid val) ...) b b* ...)
+                        (build-dynlet
+                         s
+                         (map (lambda (x) (expand x r w mod)) #'(fluid ...))
+                         (map (lambda (x) (expand x r w mod)) #'(val ...))
+                         (expand-body #'(b b* ...)
+                                      (source-wrap e w s mod) r w mod))))))
+  
+    (global-extend 'begin 'begin '())
+
+    (global-extend 'define 'define '())
+
+    (global-extend 'define-syntax 'define-syntax '())
+    (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
+
+    (global-extend 'eval-when 'eval-when '())
+
+    (global-extend 'core 'syntax-case
+                   (let ()
+                     (define convert-pattern
+                       ;; accepts pattern & keys
+                       ;; returns $sc-dispatch pattern & ids
+                       (lambda (pattern keys ellipsis?)
+                         (define cvt*
+                           (lambda (p* n ids)
+                             (syntax-case p* ()
+                               ((x . y)
+                                (call-with-values
+                                     (lambda () (cvt* #'y n ids))
+                                   (lambda (y ids)
+                                     (call-with-values
+                                         (lambda () (cvt #'x n ids))
+                                       (lambda (x ids)
+                                         (values (cons x y) ids))))))
+                               (_ (cvt p* n ids)))))
+                         
+                         (define (v-reverse x)
+                           (let loop ((r '()) (x x))
+                             (if (not (pair? x))
+                                 (values r x)
+                                 (loop (cons (car x) r) (cdr x)))))
+
+                         (define cvt
+                           (lambda (p n ids)
+                             (if (id? p)
+                                 (cond
+                                  ((bound-id-member? p keys)
+                                   (values (vector 'free-id p) ids))
+                                  ((free-id=? p #'_)
+                                   (values '_ ids))
+                                  (else
+                                   (values 'any (cons (cons p n) ids))))
+                                 (syntax-case p ()
+                                   ((x dots)
+                                    (ellipsis? (syntax dots))
+                                    (call-with-values
+                                        (lambda () (cvt (syntax x) (fx+ n 1) ids))
+                                      (lambda (p ids)
+                                        (values (if (eq? p 'any) 'each-any (vector 'each p))
+                                                ids))))
+                                   ((x dots . ys)
+                                    (ellipsis? (syntax dots))
+                                    (call-with-values
+                                        (lambda () (cvt* (syntax ys) n ids))
+                                      (lambda (ys ids)
+                                        (call-with-values
+                                            (lambda () (cvt (syntax x) (+ n 1) ids))
+                                          (lambda (x ids)
+                                            (call-with-values
+                                                (lambda () (v-reverse ys))
+                                              (lambda (ys e)
+                                                (values `#(each+ ,x ,ys ,e) 
+                                                        ids))))))))
+                                   ((x . y)
+                                    (call-with-values
+                                        (lambda () (cvt (syntax y) n ids))
+                                      (lambda (y ids)
+                                        (call-with-values
+                                            (lambda () (cvt (syntax x) n ids))
+                                          (lambda (x ids)
+                                            (values (cons x y) ids))))))
+                                   (() (values '() ids))
+                                   (#(x ...)
+                                    (call-with-values
+                                        (lambda () (cvt (syntax (x ...)) n ids))
+                                      (lambda (p ids) (values (vector 'vector p) ids))))
+                                   (x (values (vector 'atom (strip p empty-wrap)) ids))))))
+                         (cvt pattern 0 '())))
+
+                     (define build-dispatch-call
+                       (lambda (pvars exp y r mod)
+                         (let ((ids (map car pvars)) (levels (map cdr pvars)))
+                           (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+                             (build-application no-source
+                                                (build-primref no-source 'apply)
+                                                (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
+                                                                           (expand exp
+                                                                                   (extend-env
+                                                                                    labels
+                                                                                    (map (lambda (var level)
+                                                                                           (make-binding 'syntax `(,var . ,level)))
+                                                                                         new-vars
+                                                                                         (map cdr pvars))
+                                                                                    r)
+                                                                                   (make-binding-wrap ids labels empty-wrap)
+                                                                                   mod))
+                                                      y))))))
+
+                     (define gen-clause
+                       (lambda (x keys clauses r pat fender exp mod)
+                         (call-with-values
+                             (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
+                           (lambda (p pvars)
+                             (cond
+                              ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
+                               (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+                              ((not (distinct-bound-ids? (map car pvars)))
+                               (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+                              (else
+                               (let ((y (gen-var 'tmp)))
+                                 ;; fat finger binding and references to temp variable y
+                                 (build-application no-source
+                                                    (build-simple-lambda no-source (list 'tmp) #f (list y) '()
+                                                                         (let ((y (build-lexical-reference 'value no-source
+                                                                                                           'tmp y)))
+                                                                           (build-conditional no-source
+                                                                                              (syntax-case fender ()
+                                                                                                (#t y)
+                                                                                                (_ (build-conditional no-source
+                                                                                                                      y
+                                                                                                                      (build-dispatch-call pvars fender y r mod)
+                                                                                                                      (build-data no-source #f))))
+                                                                                              (build-dispatch-call pvars exp y r mod)
+                                                                                              (gen-syntax-case x keys clauses r mod))))
+                                                    (list (if (eq? p 'any)
+                                                              (build-application no-source
+                                                                                 (build-primref no-source 'list)
+                                                                                 (list x))
+                                                              (build-application no-source
+                                                                                 (build-primref no-source '$sc-dispatch)
+                                                                                 (list x (build-data no-source p)))))))))))))
+
+                     (define gen-syntax-case
+                       (lambda (x keys clauses r mod)
+                         (if (null? clauses)
+                             (build-application no-source
+                                                (build-primref no-source 'syntax-violation)
+                                                (list (build-data no-source #f)
+                                                      (build-data no-source
+                                                                  "source expression failed to match any pattern")
+                                                      x))
+                             (syntax-case (car clauses) ()
+                               ((pat exp)
+                                (if (and (id? #'pat)
+                                         (and-map (lambda (x) (not (free-id=? #'pat x)))
+                                                  (cons #'(... ...) keys)))
+                                    (if (free-id=? #'pat #'_)
+                                        (expand #'exp r empty-wrap mod)
+                                        (let ((labels (list (gen-label)))
+                                              (var (gen-var #'pat)))
+                                          (build-application no-source
+                                                             (build-simple-lambda
+                                                              no-source (list (syntax->datum #'pat)) #f (list var)
+                                                              '()
+                                                              (expand #'exp
+                                                                      (extend-env labels
+                                                                                  (list (make-binding 'syntax `(,var . 0)))
+                                                                                  r)
+                                                                      (make-binding-wrap #'(pat)
+                                                                                         labels empty-wrap)
+                                                                      mod))
+                                                             (list x))))
+                                    (gen-clause x keys (cdr clauses) r
+                                                #'pat #t #'exp mod)))
+                               ((pat fender exp)
+                                (gen-clause x keys (cdr clauses) r
+                                            #'pat #'fender #'exp mod))
+                               (_ (syntax-violation 'syntax-case "invalid clause"
+                                                    (car clauses)))))))
+
+                     (lambda (e r w s mod)
+                       (let ((e (source-wrap e w s mod)))
+                         (syntax-case e ()
+                           ((_ val (key ...) m ...)
+                            (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod))))
+                                         #'(key ...))
+                                (let ((x (gen-var 'tmp)))
+                                  ;; fat finger binding and references to temp variable x
+                                  (build-application s
+                                                     (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+                                                                          (gen-syntax-case (build-lexical-reference 'value no-source
+                                                                                                                    'tmp x)
+                                                                                           #'(key ...) #'(m ...)
+                                                                                           r
+                                                                                           mod))
+                                                     (list (expand #'val r empty-wrap mod))))
+                                (syntax-violation 'syntax-case "invalid literals list" e))))))))
+
+    ;; The portable macroexpand seeds expand-top's mode m with 'e (for
+    ;; evaluating) and esew (which stands for "eval syntax expanders
+    ;; when") with '(eval).  In Chez Scheme, m is set to 'c instead of e
+    ;; if we are compiling a file, and esew is set to
+    ;; (eval-syntactic-expanders-when), which defaults to the list
+    ;; '(compile load eval).  This means that, by default, top-level
+    ;; syntactic definitions are evaluated immediately after they are
+    ;; expanded, and the expanded definitions are also residualized into
+    ;; the object file if we are compiling a file.
+    (set! macroexpand
+          (lambda* (x #\optional (m 'e) (esew '(eval)))
+            (expand-top-sequence (list x) null-env top-wrap #f m esew
+                                 (cons 'hygiene (module-name (current-module))))))
+
+    (set! identifier?
+          (lambda (x)
+            (nonsymbol-id? x)))
+
+    (set! datum->syntax
+          (lambda (id datum)
+            (make-syntax-object datum (syntax-object-wrap id)
+                                (syntax-object-module id))))
+
+    (set! syntax->datum
+          ;; accepts any object, since syntax objects may consist partially
+          ;; or entirely of unwrapped, nonsymbolic data
+          (lambda (x)
+            (strip x empty-wrap)))
+
+    (set! syntax-source
+          (lambda (x) (source-annotation x)))
+
+    (set! generate-temporaries
+          (lambda (ls)
+            (arg-check list? ls 'generate-temporaries)
+            (let ((mod (cons 'hygiene (module-name (current-module)))))
+              (map (lambda (x)
+                     (wrap (module-gensym "t") top-wrap mod))
+                   ls))))
+
+    (set! free-identifier=?
+          (lambda (x y)
+            (arg-check nonsymbol-id? x 'free-identifier=?)
+            (arg-check nonsymbol-id? y 'free-identifier=?)
+            (free-id=? x y)))
+
+    (set! bound-identifier=?
+          (lambda (x y)
+            (arg-check nonsymbol-id? x 'bound-identifier=?)
+            (arg-check nonsymbol-id? y 'bound-identifier=?)
+            (bound-id=? x y)))
+
+    (set! syntax-violation
+          (lambda* (who message form #\optional subform)
+            (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+                       who 'syntax-violation)
+            (arg-check string? message 'syntax-violation)
+            (throw 'syntax-error who message
+                   (or (source-annotation subform)
+                       (source-annotation form))
+                   (strip form empty-wrap)
+                   (and subform (strip subform empty-wrap)))))
+
+    (let ()
+      (define (syntax-module id)
+        (arg-check nonsymbol-id? id 'syntax-module)
+        (cdr (syntax-object-module id)))
+
+      (define (syntax-local-binding id)
+        (arg-check nonsymbol-id? id 'syntax-local-binding)
+        (with-transformer-environment
+         (lambda (e r w s rib mod)
+           (define (strip-anti-mark w)
+             (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+               (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+                   ;; output is from original text
+                   (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+                   ;; output introduced by macro
+                   (make-wrap ms (if rib (cons rib s) s)))))
+           (call-with-values (lambda ()
+                               (resolve-identifier
+                                (syntax-object-expression id)
+                                (strip-anti-mark (syntax-object-wrap id))
+                                r
+                                (syntax-object-module id)))
+             (lambda (type value mod)
+               (case type
+                 ((lexical) (values 'lexical value))
+                 ((macro) (values 'macro value))
+                 ((syntax) (values 'pattern-variable value))
+                 ((displaced-lexical) (values 'displaced-lexical #f))
+                 ((global) (values 'global (cons value (cdr mod))))
+                 ((ellipsis)
+                  (values 'ellipsis
+                          (make-syntax-object (syntax-object-expression value)
+                                              (anti-mark (syntax-object-wrap value))
+                                              (syntax-object-module value))))
+                 (else (values 'other #f))))))))
+
+      (define (syntax-locally-bound-identifiers id)
+        (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
+        (locally-bound-identifiers (syntax-object-wrap id)
+                                   (syntax-object-module id)))
+
+      ;; Using define! instead of set! to avoid warnings at
+      ;; compile-time, after the variables are stolen away into (system
+      ;; syntax).  See the end of boot-9.scm.
+      ;;
+      (define! 'syntax-module syntax-module)
+      (define! 'syntax-local-binding syntax-local-binding)
+      (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
+    
+    ;; $sc-dispatch expects an expression and a pattern.  If the expression
+    ;; matches the pattern a list of the matching expressions for each
+    ;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
+    ;; not work on r4rs implementations that violate the ieee requirement
+    ;; that #f and () be distinct.)
+
+    ;; The expression is matched with the pattern as follows:
+
+    ;; pattern:                           matches:
+    ;;   ()                                 empty list
+    ;;   any                                anything
+    ;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
+    ;;   each-any                           (any*)
+    ;;   #(free-id <key>)                   <key> with free-identifier=?
+    ;;   #(each <pattern>)                  (<pattern>*)
+    ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
+    ;;   #(vector <pattern>)                (list->vector <pattern>)
+    ;;   #(atom <object>)                   <object> with "equal?"
+
+    ;; Vector cops out to pair under assumption that vectors are rare.  If
+    ;; not, should convert to:
+    ;;   #(vector <pattern>*)               #(<pattern>*)
+
+    (let ()
+
+      (define match-each
+        (lambda (e p w mod)
+          (cond
+           ((pair? e)
+            (let ((first (match (car e) p w '() mod)))
+              (and first
+                   (let ((rest (match-each (cdr e) p w mod)))
+                     (and rest (cons first rest))))))
+           ((null? e) '())
+           ((syntax-object? e)
+            (match-each (syntax-object-expression e)
+                        p
+                        (join-wraps w (syntax-object-wrap e))
+                        (syntax-object-module e)))
+           (else #f))))
+
+      (define match-each+
+        (lambda (e x-pat y-pat z-pat w r mod)
+          (let f ((e e) (w w))
+            (cond
+             ((pair? e)
+              (call-with-values (lambda () (f (cdr e) w))
+                (lambda (xr* y-pat r)
+                  (if r
+                      (if (null? y-pat)
+                          (let ((xr (match (car e) x-pat w '() mod)))
+                            (if xr
+                                (values (cons xr xr*) y-pat r)
+                                (values #f #f #f)))
+                          (values
+                           '()
+                           (cdr y-pat)
+                           (match (car e) (car y-pat) w r mod)))
+                      (values #f #f #f)))))
+             ((syntax-object? e)
+              (f (syntax-object-expression e)
+                 (join-wraps w (syntax-object-wrap e))))
+             (else
+              (values '() y-pat (match e z-pat w r mod)))))))
+
+      (define match-each-any
+        (lambda (e w mod)
+          (cond
+           ((pair? e)
+            (let ((l (match-each-any (cdr e) w mod)))
+              (and l (cons (wrap (car e) w mod) l))))
+           ((null? e) '())
+           ((syntax-object? e)
+            (match-each-any (syntax-object-expression e)
+                            (join-wraps w (syntax-object-wrap e))
+                            mod))
+           (else #f))))
+
+      (define match-empty
+        (lambda (p r)
+          (cond
+           ((null? p) r)
+           ((eq? p '_) r)
+           ((eq? p 'any) (cons '() r))
+           ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+           ((eq? p 'each-any) (cons '() r))
+           (else
+            (case (vector-ref p 0)
+              ((each) (match-empty (vector-ref p 1) r))
+              ((each+) (match-empty (vector-ref p 1)
+                                    (match-empty
+                                     (reverse (vector-ref p 2))
+                                     (match-empty (vector-ref p 3) r))))
+              ((free-id atom) r)
+              ((vector) (match-empty (vector-ref p 1) r)))))))
+
+      (define combine
+        (lambda (r* r)
+          (if (null? (car r*))
+              r
+              (cons (map car r*) (combine (map cdr r*) r)))))
+
+      (define match*
+        (lambda (e p w r mod)
+          (cond
+           ((null? p) (and (null? e) r))
+           ((pair? p)
+            (and (pair? e) (match (car e) (car p) w
+                             (match (cdr e) (cdr p) w r mod)
+                             mod)))
+           ((eq? p 'each-any)
+            (let ((l (match-each-any e w mod))) (and l (cons l r))))
+           (else
+            (case (vector-ref p 0)
+              ((each)
+               (if (null? e)
+                   (match-empty (vector-ref p 1) r)
+                   (let ((l (match-each e (vector-ref p 1) w mod)))
+                     (and l
+                          (let collect ((l l))
+                            (if (null? (car l))
+                                r
+                                (cons (map car l) (collect (map cdr l)))))))))
+              ((each+)
+               (call-with-values
+                   (lambda ()
+                     (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
+                 (lambda (xr* y-pat r)
+                   (and r
+                        (null? y-pat)
+                        (if (null? xr*)
+                            (match-empty (vector-ref p 1) r)
+                            (combine xr* r))))))
+              ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
+              ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+              ((vector)
+               (and (vector? e)
+                    (match (vector->list e) (vector-ref p 1) w r mod))))))))
+
+      (define match
+        (lambda (e p w r mod)
+          (cond
+           ((not r) #f)
+           ((eq? p '_) r)
+           ((eq? p 'any) (cons (wrap e w mod) r))
+           ((syntax-object? e)
+            (match*
+             (syntax-object-expression e)
+             p
+             (join-wraps w (syntax-object-wrap e))
+             r
+             (syntax-object-module e)))
+           (else (match* e p w r mod)))))
+
+      (set! $sc-dispatch
+            (lambda (e p)
+              (cond
+               ((eq? p 'any) (list e))
+               ((eq? p '_) '())
+               ((syntax-object? e)
+                (match* (syntax-object-expression e)
+                        p (syntax-object-wrap e) '() (syntax-object-module e)))
+               (else (match* e p empty-wrap '() #f))))))))
+
+
+(define-syntax with-syntax
+   (lambda (x)
+      (syntax-case x ()
+         ((_ () e1 e2 ...)
+          #'(let () e1 e2 ...))
+         ((_ ((out in)) e1 e2 ...)
+          #'(syntax-case in ()
+              (out (let () e1 e2 ...))))
+         ((_ ((out in) ...) e1 e2 ...)
+          #'(syntax-case (list in ...) ()
+              ((out ...) (let () e1 e2 ...)))))))
+
+(define-syntax syntax-error
+  (lambda (x)
+    (syntax-case x ()
+      ;; Extended internal syntax which provides the original form
+      ;; as the first operand, for improved error reporting.
+      ((_ (keyword . operands) message arg ...)
+       (string? (syntax->datum #'message))
+       (syntax-violation (syntax->datum #'keyword)
+                         (string-join (cons (syntax->datum #'message)
+                                            (map (lambda (x)
+                                                   (object->string
+                                                    (syntax->datum x)))
+                                                 #'(arg ...))))
+                         (and (syntax->datum #'keyword)
+                              #'(keyword . operands))))
+      ;; Standard R7RS syntax
+      ((_ message arg ...)
+       (string? (syntax->datum #'message))
+       #'(syntax-error (#f) message arg ...)))))
+
+(define-syntax syntax-rules
+  (lambda (xx)
+    (define (expand-clause clause)
+      ;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
+      (syntax-case clause (syntax-error)
+        ;; If the template is a 'syntax-error' form, use the extended
+        ;; internal syntax, which adds the original form as the first
+        ;; operand for improved error reporting.
+        (((keyword . pattern) (syntax-error message arg ...))
+         (string? (syntax->datum #'message))
+         #'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
+        ;; Normal case
+        (((keyword . pattern) template)
+         #'((dummy . pattern) #'template))))
+    (define (expand-syntax-rules dots keys docstrings clauses)
+      (with-syntax
+          (((k ...) keys)
+           ((docstring ...) docstrings)
+           ((((keyword . pattern) template) ...) clauses)
+           ((clause ...) (map expand-clause clauses)))
+        (with-syntax
+            ((form #'(lambda (x)
+                       docstring ...        ; optional docstring
+                       #((macro-type . syntax-rules)
+                         (patterns pattern ...)) ; embed patterns as procedure metadata
+                       (syntax-case x (k ...)
+                         clause ...))))
+          (if dots
+              (with-syntax ((dots dots))
+                #'(with-ellipsis dots form))
+              #'form))))
+    (syntax-case xx ()
+      ((_ (k ...) ((keyword . pattern) template) ...)
+       (expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
+      ((_ (k ...) docstring ((keyword . pattern) template) ...)
+       (string? (syntax->datum #'docstring))
+       (expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
+      ((_ dots (k ...) ((keyword . pattern) template) ...)
+       (identifier? #'dots)
+       (expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
+      ((_ dots (k ...) docstring ((keyword . pattern) template) ...)
+       (and (identifier? #'dots) (string? (syntax->datum #'docstring)))
+       (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
+
+(define-syntax define-syntax-rule
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (name . pattern) template)
+       #'(define-syntax name
+           (syntax-rules ()
+             ((_ . pattern) template))))
+      ((_ (name . pattern) docstring template)
+       (string? (syntax->datum #'docstring))
+       #'(define-syntax name
+           (syntax-rules ()
+             docstring
+             ((_ . pattern) template)))))))
+
+(define-syntax let*
+  (lambda (x)
+    (syntax-case x ()
+      ((let* ((x v) ...) e1 e2 ...)
+       (and-map identifier? #'(x ...))
+       (let f ((bindings #'((x v)  ...)))
+         (if (null? bindings)
+             #'(let () e1 e2 ...)
+             (with-syntax ((body (f (cdr bindings)))
+                           (binding (car bindings)))
+               #'(let (binding) body))))))))
+
+(define-syntax quasiquote
+  (let ()
+    (define (quasi p lev)
+      (syntax-case p (unquote quasiquote)
+        ((unquote p)
+         (if (= lev 0)
+             #'("value" p)
+             (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
+        ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
+        ((p . q)
+         (syntax-case #'p (unquote unquote-splicing)
+           ((unquote p ...)
+            (if (= lev 0)
+                (quasilist* #'(("value" p) ...) (quasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+                 (quasi #'q lev))))
+           ((unquote-splicing p ...)
+            (if (= lev 0)
+                (quasiappend #'(("value" p) ...) (quasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
+                 (quasi #'q lev))))
+           (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
+        (#(x ...) (quasivector (vquasi #'(x ...) lev)))
+        (p #'("quote" p))))
+    (define (vquasi p lev)
+      (syntax-case p ()
+        ((p . q)
+         (syntax-case #'p (unquote unquote-splicing)
+           ((unquote p ...)
+            (if (= lev 0)
+                (quasilist* #'(("value" p) ...) (vquasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+                 (vquasi #'q lev))))
+           ((unquote-splicing p ...)
+            (if (= lev 0)
+                (quasiappend #'(("value" p) ...) (vquasi #'q lev))
+                (quasicons
+                 (quasicons
+                  #'("quote" unquote-splicing)
+                  (quasi #'(p ...) (- lev 1)))
+                 (vquasi #'q lev))))
+           (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
+        (() #'("quote" ()))))
+    (define (quasicons x y)
+      (with-syntax ((x x) (y y))
+        (syntax-case #'y ()
+          (("quote" dy)
+           (syntax-case #'x ()
+             (("quote" dx) #'("quote" (dx . dy)))
+             (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
+          (("list" . stuff) #'("list" x . stuff))
+          (("list*" . stuff) #'("list*" x . stuff))
+          (_ #'("list*" x y)))))
+    (define (quasiappend x y)
+      (syntax-case y ()
+        (("quote" ())
+         (cond
+          ((null? x) #'("quote" ()))
+          ((null? (cdr x)) (car x))
+          (else (with-syntax (((p ...) x)) #'("append" p ...)))))
+        (_
+         (cond
+          ((null? x) y)
+          (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
+    (define (quasilist* x y)
+      (let f ((x x))
+        (if (null? x)
+            y
+            (quasicons (car x) (f (cdr x))))))
+    (define (quasivector x)
+      (syntax-case x ()
+        (("quote" (x ...)) #'("quote" #(x ...)))
+        (_
+         (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
+           (syntax-case y ()
+             (("quote" (y ...)) (k #'(("quote" y) ...)))
+             (("list" y ...) (k #'(y ...)))
+             (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
+             (else #`("list->vector" #,x)))))))
+    (define (emit x)
+      (syntax-case x ()
+        (("quote" x) #''x)
+        (("list" x ...) #`(list #,@(map emit #'(x ...))))
+        ;; could emit list* for 3+ arguments if implementation supports
+        ;; list*
+        (("list*" x ... y)
+         (let f ((x* #'(x ...)))
+           (if (null? x*)
+               (emit #'y)
+               #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
+        (("append" x ...) #`(append #,@(map emit #'(x ...))))
+        (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
+        (("list->vector" x) #`(list->vector #,(emit #'x)))
+        (("value" x) #'x)))
+    (lambda (x)
+      (syntax-case x ()
+        ;; convert to intermediate language, combining introduced (but
+        ;; not unquoted source) quote expressions where possible and
+        ;; choosing optimal construction code otherwise, then emit
+        ;; Scheme code corresponding to the intermediate language forms.
+        ((_ e) (emit (quasi #'e 0))))))) 
+
+(define-syntax include
+  (lambda (x)
+    (define read-file
+      (lambda (fn dir k)
+        (let* ((p (open-input-file
+                   (cond ((absolute-file-name? fn)
+                          fn)
+                         (dir
+                          (in-vicinity dir fn))
+                         (else
+                          (syntax-violation
+                           'include
+                           "relative file name only allowed when the include form is in a file"
+                           x)))))
+               (enc (file-encoding p)))
+
+          ;; Choose the input encoding deterministically.
+          (set-port-encoding! p (or enc "UTF-8"))
+
+          (let f ((x (read p))
+                  (result '()))
+            (if (eof-object? x)
+                (begin
+                  (close-input-port p)
+                  (reverse result))
+                (f (read p)
+                   (cons (datum->syntax k x) result)))))))
+    (let* ((src (syntax-source x))
+           (file (and src (assq-ref src 'filename)))
+           (dir (and (string? file) (dirname file))))
+      (syntax-case x ()
+        ((k filename)
+         (let ((fn (syntax->datum #'filename)))
+           (with-syntax (((exp ...) (read-file fn dir #'filename)))
+             #'(begin exp ...))))))))
+
+(define-syntax include-from-path
+  (lambda (x)
+    (syntax-case x ()
+      ((k filename)
+       (let ((fn (syntax->datum #'filename)))
+         (with-syntax ((fn (datum->syntax
+                            #'filename
+                            (or (%search-load-path fn)
+                                (syntax-violation 'include-from-path
+                                                  "file not found in path"
+                                                  x #'filename)))))
+           #'(include fn)))))))
+
+(define-syntax unquote
+  (lambda (x)
+    (syntax-violation 'unquote
+                      "expression not valid outside of quasiquote"
+                      x)))
+
+(define-syntax unquote-splicing
+  (lambda (x)
+    (syntax-violation 'unquote-splicing
+                      "expression not valid outside of quasiquote"
+                      x)))
+
+(define (make-variable-transformer proc)
+  (if (procedure? proc)
+      (let ((trans (lambda (x)
+                     #((macro-type . variable-transformer))
+                     (proc x))))
+        (set-procedure-property! trans 'variable-transformer #t)
+        trans)
+      (error "variable transformer not a procedure" proc)))
+
+(define-syntax identifier-syntax
+  (lambda (xx)
+    (syntax-case xx (set!)
+      ((_ e)
+       #'(lambda (x)
+           #((macro-type . identifier-syntax))
+           (syntax-case x ()
+             (id
+              (identifier? #'id)
+              #'e)
+             ((_ x (... ...))
+              #'(e x (... ...))))))
+      ((_ (id exp1) ((set! var val) exp2))
+       (and (identifier? #'id) (identifier? #'var))
+       #'(make-variable-transformer
+          (lambda (x)
+            #((macro-type . variable-transformer))
+            (syntax-case x (set!)
+              ((set! var val) #'exp2)
+              ((id x (... ...)) #'(exp1 x (... ...)))
+              (id (identifier? #'id) #'exp1))))))))
+
+(define-syntax define*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (id . args) b0 b1 ...)
+       #'(define id (lambda* args b0 b1 ...)))
+      ((_ id val) (identifier? #'id)
+       #'(define id val)))))
+;;;; q.scm --- Queues
+;;;;
+;;;; 	Copyright (C) 1995, 2001, 2004, 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:
+
+;;; Q: Based on the interface to
+;;;
+;;; "queue.scm"  Queues/Stacks for Scheme
+;;;  Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
+
+;;; {Q}
+;;;
+;;; A list is just a bunch of cons pairs that follows some constrains,
+;;; right?  Association lists are the same.  Hash tables are just
+;;; vectors and association lists.  You can print them, read them,
+;;; write them as constants, pun them off as other data structures
+;;; etc. This is good.  This is lisp.  These structures are fast and
+;;; compact and easy to manipulate arbitrarily because of their
+;;; simple, regular structure and non-disjointedness (associations
+;;; being lists and so forth).
+;;;
+;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
+;;; structures in general.
+;;;
+;;; A queue is a cons pair:
+;;;		( <the-q> . <last-pair> )
+;;;
+;;; <the-q> is a list of things in the q.  New elements go at the end
+;;; of that list.
+;;;
+;;; <last-pair> is #f if the q is empty, and otherwise is the last
+;;; pair of <the-q>.
+;;;
+;;; q's print nicely, but alas, they do not read well because the
+;;; eq?-ness of <last-pair> and (last-pair <the-q>) is lost by read.
+;;;
+;;; All the functions that aren't explicitly defined to return
+;;; something else (a queue element; a boolean value) return the queue
+;;; object itself.
+
+;;; Code:
+
+(define-module (ice-9 q)
+  \:export (sync-q! make-q q? q-empty? q-empty-check q-front q-rear
+	   q-remove! q-push! enq! q-pop! deq! q-length))
+
+;;; sync-q!
+;;;   The procedure
+;;;
+;;;		(sync-q! q)
+;;;
+;;;   recomputes and resets the <last-pair> component of a queue.
+;;;
+(define (sync-q! q)
+  (set-cdr! q (if (pair? (car q)) (last-pair (car q))
+		  #f))
+  q)
+
+;;; make-q
+;;;  return a new q.
+;;;
+(define (make-q) (cons '() #f))
+
+;;; q? obj
+;;;   Return true if obj is a Q.
+;;;   An object is a queue if it is equal? to '(() . #f)
+;;;   or it is a pair P with (list? (car P))
+;;;                      and (eq? (cdr P) (last-pair (car P))).
+;;;
+(define (q? obj)
+  (and (pair? obj)
+       (if (pair? (car obj))
+	   (eq? (cdr obj) (last-pair (car obj)))
+	   (and (null? (car obj))
+		(not (cdr obj))))))
+
+;;; q-empty? obj
+;;;
+(define (q-empty? obj) (null? (car obj)))
+
+;;; q-empty-check q
+;;;  Throw a q-empty exception if Q is empty.
+(define (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
+
+;;; q-front q
+;;;  Return the first element of Q.
+(define (q-front q) (q-empty-check q) (caar q))
+
+;;; q-rear q
+;;;  Return the last element of Q.
+(define (q-rear q) (q-empty-check q) (cadr q))
+
+;;; q-remove! q obj
+;;;  Remove all occurences of obj from Q.
+(define (q-remove! q obj)
+  (set-car! q (delq! obj (car q)))
+  (sync-q! q))
+
+;;; q-push! q obj
+;;;  Add obj to the front of Q
+(define (q-push! q obj)
+  (let ((h (cons obj (car q))))
+    (set-car! q h)
+    (or (cdr q) (set-cdr! q h)))
+  q)
+
+;;; enq! q obj
+;;;  Add obj to the rear of Q
+(define (enq! q obj)
+  (let ((h (cons obj '())))
+    (if (null? (car q))
+	(set-car! q h)
+	(set-cdr! (cdr q) h))
+    (set-cdr! q h))
+  q)
+
+;;; q-pop! q
+;;;  Take the front of Q and return it.
+(define (q-pop! q)
+  (q-empty-check q)
+  (let ((it (caar q))
+	(next (cdar q)))
+    (if (null? next)
+	(set-cdr! q #f))
+    (set-car! q next)
+    it))
+
+;;; deq! q
+;;;  Take the front of Q and return it.
+(define deq! q-pop!)
+
+;;; q-length q
+;;;  Return the number of enqueued elements.
+;;;
+(define (q-length q) (length (car q)))
+
+;;; q.scm ends here
+;; Quasisyntax in terms of syntax-case.
+;;
+;; Code taken from
+;; <http://www.het.brown.edu/people/andre/macros/index.html>;
+;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
+;;
+;; 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.
+
+;;=========================================================
+;;
+;; To make nested unquote-splicing behave in a useful way,
+;; the R5RS-compatible extension of quasiquote in appendix B
+;; of the following paper is here ported to quasisyntax:
+;;
+;; Alan Bawden - Quasiquotation in Lisp
+;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
+;;
+;; The algorithm converts a quasisyntax expression to an
+;; equivalent with-syntax expression.
+;; For example:
+;;
+;; (quasisyntax (set! #,a #,b))
+;;   ==> (with-syntax ((t0 a)
+;;                     (t1 b))
+;;         (syntax (set! t0 t1)))
+;;
+;; (quasisyntax (list #,@args))
+;;   ==> (with-syntax (((t ...) args))
+;;         (syntax (list t ...)))
+;;
+;; Note that quasisyntax is expanded first, before any
+;; ellipses act.  For example:
+;;
+;; (quasisyntax (f ((b #,a) ...))
+;;   ==> (with-syntax ((t a))
+;;         (syntax (f ((b t) ...))))
+;;
+;; so that
+;;
+;; (let-syntax ((test-ellipses-over-unsyntax
+;;               (lambda (e)
+;;                 (let ((a (syntax a)))
+;;                   (with-syntax (((b ...) (syntax (1 2 3))))
+;;                     (quasisyntax
+;;                      (quote ((b #,a) ...))))))))
+;;   (test-ellipses-over-unsyntax))
+;;
+;;     ==> ((1 a) (2 a) (3 a))
+(define-syntax quasisyntax
+  (lambda (e)
+
+    ;; Expand returns a list of the form
+    ;;    [template[t/e, ...] (replacement ...)]
+    ;; Here template[t/e ...] denotes the original template
+    ;; with unquoted expressions e replaced by fresh
+    ;; variables t, followed by the appropriate ellipses
+    ;; if e is also spliced.
+    ;; The second part of the return value is the list of
+    ;; replacements, each of the form (t e) if e is just
+    ;; unquoted, or ((t ...) e) if e is also spliced.
+    ;; This will be the list of bindings of the resulting
+    ;; with-syntax expression.
+
+    (define (expand x level)
+      (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
+        ((quasisyntax e)
+         (with-syntax (((k _)     x) ;; original identifier must be copied
+                       ((e* reps) (expand (syntax e) (+ level 1))))
+           (syntax ((k e*) reps))))
+        ((unsyntax e)
+         (= level 0)
+         (with-syntax (((t) (generate-temporaries '(t))))
+           (syntax (t ((t e))))))
+        (((unsyntax e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (syntax ((t ... . r*)
+                    ((t e) ... rep ...)))))
+        (((unsyntax-splicing e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
+             (syntax ((t ... ... . r*)
+                      (((t ...) e) ... rep ...))))))
+        ((k . r)
+         (and (> level 0)
+              (identifier? (syntax k))
+              (or (free-identifier=? (syntax k) (syntax unsyntax))
+                  (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
+         (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
+           (syntax ((k . r*) reps))))
+        ((h . t)
+         (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
+                       ((t* (rep2 ...)) (expand (syntax t) level)))
+           (syntax ((h* . t*)
+                    (rep1 ... rep2 ...)))))
+        (#(e ...)
+         (with-syntax ((((e* ...) reps)
+                        (expand (vector->list (syntax #(e ...))) level)))
+           (syntax (#(e* ...) reps))))
+        (other
+         (syntax (other ())))))
+
+    (syntax-case e ()
+      ((_ template)
+       (with-syntax (((template* replacements) (expand (syntax template) 0)))
+         (syntax
+          (with-syntax replacements (syntax template*))))))))
+
+(define-syntax unsyntax
+  (lambda (e)
+    (syntax-violation 'unsyntax "Invalid expression" e)))
+
+(define-syntax unsyntax-splicing
+  (lambda (e)
+    (syntax-violation 'unsyntax "Invalid expression" e)))
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; 	Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 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
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
+
+;;;; apply and call-with-current-continuation
+
+;;; The deal with these is that they are the procedural wrappers around the
+;;; primitives of Guile's language. There are about 20 different kinds of
+;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
+;;; to preserve tail recursion.)
+;;;
+;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
+;;; case that apply is passed to apply, or we're bootstrapping, we need a
+;;; trampoline -- and here they are.
+(define (apply fun . args)
+  (@apply fun (apply:nconc2last args)))
+(define (call-with-current-continuation proc)
+  (@call-with-current-continuation proc))
+(define (call-with-values producer consumer)
+  (@call-with-values producer consumer))
+(define (dynamic-wind in thunk out)
+  "All three arguments must be 0-argument procedures.
+Guard @var{in} is called, then @var{thunk}, then
+guard @var{out}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out} is called.  If the continuation of
+the dynamic-wind is re-entered, @var{in} is called.  Thus
+@var{in} and @var{out} may be called any number of
+times.
+@lisp
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+   (call-with-current-continuation
+     (lambda (escape)
+       (let ((old-x x))
+         (dynamic-wind
+           ;; in-guard:
+           ;;
+           (lambda () (set! x 'special-binding))
+
+           ;; thunk
+           ;;
+           (lambda () (display x) (newline)
+                   (call-with-current-continuation escape)
+                   (display x) (newline)
+                   x)
+
+           ;; out-guard:
+           ;;
+           (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont  ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+  (@dynamic-wind in (thunk) out))
+
+
+;;;; Basic Port Code
+
+;;; Specifically, the parts of the low-level port code that are written in 
+;;; Scheme rather than C.
+;;;
+;;; WARNING: the parts of this interface that refer to file ports
+;;; are going away.   It would be gone already except that it is used
+;;; "internally" in a few places.
+
+
+;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
+;;; proper mode to open files in.
+;;;
+;;; If we want to support systems that do CRLF->LF translation, like
+;;; Windows, then we should have a symbol in scmconfig.h made visible
+;;; to the Scheme level that we can test here, and autoconf magic to
+;;; #define it when appropriate.  Windows will probably just have a
+;;; hand-generated scmconfig.h file.
+(define OPEN_READ "r")
+(define OPEN_WRITE "w")
+(define OPEN_BOTH "r+")
+
+(define *null-device* "/dev/null")
+
+(define (open-input-file str)
+  "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file.  If the file
+cannot be opened, an error is signalled."
+  (open-file str OPEN_READ))
+
+(define (open-output-file str)
+  "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name.  If the file cannot be opened, an error is signalled.  If a
+file with the given name already exists, the effect is unspecified."
+  (open-file str OPEN_WRITE))
+
+(define (open-io-file str) 
+  "Open file with name STR for both input and output."
+  (open-file str OPEN_BOTH))
+
+(define (call-with-input-file str proc)
+  "PROC should be a procedure of one argument, and STR should be a
+string naming a file.  The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output.  If the file cannot be opened, an error is
+signalled.  If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+  (let ((p (open-input-file str)))
+    (call-with-values
+      (lambda () (proc p))
+      (lambda vals
+        (close-input-port p)
+        (apply values vals)))))
+
+(define (call-with-output-file str proc)
+  "PROC should be a procedure of one argument, and STR should be a
+string naming a file.  The behaviour is unspecified if the file 
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output.  If the file cannot be opened, an error is
+signalled.  If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+  (let ((p (open-output-file str)))
+    (call-with-values
+      (lambda () (proc p))
+      (lambda vals
+        (close-output-port p)
+        (apply values vals)))))
+
+(define (with-input-from-port port thunk)
+  (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
+    (dynamic-wind swaports thunk swaports)))
+
+(define (with-output-to-port port thunk)
+  (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
+    (dynamic-wind swaports thunk swaports)))
+
+(define (with-error-to-port port thunk)
+  (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
+    (dynamic-wind swaports thunk swaports)))
+
+(define (with-input-from-file file thunk)
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port', 
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-input-file file
+   (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-file file thunk)
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The effect is unspecified if the file already exists. 
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port', 
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-output-file file
+   (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-file file thunk)
+  "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file.  The effect is unspecified if the file already exists. 
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port', 
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored.  Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-output-file file
+   (lambda (p) (with-error-to-port p thunk))))
+
+(define (with-input-from-string string thunk)
+  "THUNK must be a procedure of no arguments.
+The test of STRING  is opened for
+input, an input port connected to it is made, 
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed.
+Returns the values yielded by THUNK.  If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+  (call-with-input-string string
+   (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-string thunk)
+  "Calls THUNK and returns its output as a string."
+  (call-with-output-string
+   (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+  "Calls THUNK and returns its error output as a string."
+  (call-with-output-string
+   (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
+;;;; 	Copyright (C) 2000, 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
+;;;; 
+
+;;;; R5RS bindings
+
+(define-module (ice-9 r5rs)
+  \:export (scheme-report-environment
+	   ;;transcript-on
+	   ;;transcript-off
+	   )
+  \:re-export (interaction-environment
+
+	      call-with-input-file call-with-output-file
+	      with-input-from-file with-output-to-file
+	      open-input-file open-output-file
+	      close-input-port close-output-port
+
+	      load))  
+
+(module-use! (module-public-interface (current-module))
+             (resolve-interface '(ice-9 safe-r5rs)))
+
+(define scheme-report-interface (module-public-interface (current-module)))
+
+(define (scheme-report-environment n)
+  (if (not (= n 5))
+      (scm-error 'misc-error 'scheme-report-environment
+		 "~A is not a valid version"
+		 (list n)
+		 '()))
+  scheme-report-interface)
+;;; r6rs-libraries.scm --- Support for the R6RS `library' and `import' forms
+
+;;      Copyright (C) 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
+
+
+;; This file is included from boot-9.scm and assumes the existence of (and 
+;; expands into) procedures and syntactic forms defined therein.
+
+(define (resolve-r6rs-interface import-spec)
+  (define (make-custom-interface mod)
+    (let ((iface (make-module)))
+      (set-module-kind! iface 'custom-interface)
+      (set-module-name! iface (module-name mod))
+      iface))
+  (define (sym? x) (symbol? (syntax->datum x)))
+
+  (syntax-case import-spec (library only except prefix rename srfi)
+    ;; (srfi n ...) -> (srfi srfi-n ...)
+    ((library (srfi colon-n rest ... (version ...)))
+     (and (and-map sym? #'(srfi rest ...))
+          (symbol? (syntax->datum #'colon-n))
+          (eqv? (string-ref (symbol->string (syntax->datum #'colon-n)) 0) #\:))
+     (let ((srfi-n (string->symbol
+                    (string-append
+                     "srfi-"
+                     (substring (symbol->string (syntax->datum #'colon-n))
+                                1)))))
+       (resolve-r6rs-interface
+        (syntax-case #'(rest ...) ()
+          (()
+           #`(library (srfi #,srfi-n (version ...))))
+          ((name rest ...)
+           ;; SRFI 97 says that the first identifier after the colon-n
+           ;; is used for the libraries name, so it must be ignored.
+           #`(library (srfi #,srfi-n rest ... (version ...))))))))
+    
+    ((library (name name* ... (version ...)))
+     (and-map sym? #'(name name* ...))
+     (resolve-interface (syntax->datum #'(name name* ...))
+                        #\version (syntax->datum #'(version ...))))
+
+    ((library (name name* ...))
+     (and-map sym? #'(name name* ...))
+     (resolve-r6rs-interface #'(library (name name* ... ()))))
+    
+    ((only import-set identifier ...)
+     (and-map sym? #'(identifier ...))
+     (let* ((mod (resolve-r6rs-interface #'import-set))
+            (iface (make-custom-interface mod)))
+       (for-each (lambda (sym)
+                   (module-add! iface sym
+                                (or (module-local-variable mod sym)
+                                    (error "no binding `~A' in module ~A"
+                                           sym mod))))
+                 (syntax->datum #'(identifier ...)))
+       iface))
+    
+    ((except import-set identifier ...)
+     (and-map sym? #'(identifier ...))
+     (let* ((mod (resolve-r6rs-interface #'import-set))
+            (iface (make-custom-interface mod)))
+       (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
+       (for-each (lambda (sym)
+                   (if (module-local-variable iface sym)
+                       (module-remove! iface sym)
+                       (error "no binding `~A' in module ~A" sym mod)))
+                 (syntax->datum #'(identifier ...)))
+       iface))
+
+    ((prefix import-set identifier)
+     (sym? #'identifier)
+     (let* ((mod (resolve-r6rs-interface #'import-set))
+            (iface (make-custom-interface mod))
+            (pre (syntax->datum #'identifier)))
+       (module-for-each (lambda (sym var)
+                          (module-add! iface (symbol-append pre sym) var))
+                        mod)
+       iface))
+
+    ((rename import-set (from to) ...)
+     (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
+     (let* ((mod (resolve-r6rs-interface #'import-set))
+            (iface (make-custom-interface mod)))
+       (module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
+       (let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
+         (cond
+          ((null? in)
+           (for-each
+            (lambda (pair)
+              (if (module-local-variable iface (car pair))
+                  (error "duplicate binding for `~A' in module ~A"
+                         (car pair) mod)
+                  (module-add! iface (car pair) (cdr pair))))
+            out)
+           iface)
+          (else
+           (let ((var (or (module-local-variable mod (caar in))
+                          (error "no binding `~A' in module ~A"
+                                 (caar in) mod))))
+             (module-remove! iface (caar in))
+             (lp (cdr in) (acons (cdar in) var out))))))))
+    
+    ((name name* ... (version ...))
+     (and-map sym? #'(name name* ...))
+     (resolve-r6rs-interface #'(library (name name* ... (version ...)))))
+
+    ((name name* ...) 
+     (and-map sym? #'(name name* ...))
+     (resolve-r6rs-interface #'(library (name name* ... ()))))))
+
+(define-syntax library
+  (lambda (stx)
+    (define (compute-exports ifaces specs)
+      (define (re-export? sym)
+        (or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
+      (define (replace? sym)
+        (module-local-variable the-scm-module sym))
+      
+      (let lp ((specs specs) (e '()) (r '()) (x '()))
+        (syntax-case specs (rename)
+          (() (values e r x))
+          (((rename (from to) ...) . rest)
+           (and (and-map identifier? #'(from ...))
+                (and-map identifier? #'(to ...)))
+           (let lp2 ((in #'((from . to) ...)) (e e) (r r) (x x))
+             (syntax-case in ()
+               (() (lp #'rest e r x))
+               (((from . to) . in)
+                (cond
+                 ((re-export? (syntax->datum #'from))
+                  (lp2 #'in e (cons #'(from . to) r) x))
+                 ((replace? (syntax->datum #'from))
+                  (lp2 #'in e r (cons #'(from . to) x)))
+                 (else
+                  (lp2 #'in (cons #'(from . to) e) r x)))))))
+          ((id . rest)
+           (identifier? #'id)
+           (let ((sym (syntax->datum #'id)))
+             (cond
+              ((re-export? sym)
+               (lp #'rest e (cons #'id r) x))
+              ((replace? sym)
+               (lp #'rest e r (cons #'id x)))
+              (else
+               (lp #'rest (cons #'id e) r x))))))))
+
+    (syntax-case stx (export import)
+      ((_ (name name* ...)
+          (export espec ...)
+          (import ispec ...)
+          body ...)
+       (and-map identifier? #'(name name* ...))
+       ;; Add () as the version.
+       #'(library (name name* ... ())
+           (export espec ...)
+           (import ispec ...)
+           body ...))
+
+      ((_ (name name* ... (version ...))
+          (export espec ...)
+          (import ispec ...)
+	  body ...)
+       (and-map identifier? #'(name name* ...))
+       (call-with-values
+           (lambda ()
+             (compute-exports 
+              (map (lambda (im)
+                     (syntax-case im (for)
+                       ((for import-set import-level ...)
+                        (resolve-r6rs-interface #'import-set))
+                       (import-set (resolve-r6rs-interface #'import-set))))
+                   #'(ispec ...))
+              #'(espec ...)))
+         (lambda (exports re-exports replacements)
+           (with-syntax (((e ...) exports)
+                         ((r ...) re-exports)
+                         ((x ...) replacements))
+             ;; It would be nice to push the module that was current before the
+             ;; definition, and pop it after the library definition, but I
+             ;; actually can't see a way to do that. Helper procedures perhaps,
+             ;; around a fluid that is rebound in save-module-excursion? Patches
+             ;; welcome!
+             #'(begin
+                 (define-module (name name* ...)
+                   #\pure
+                   #\version (version ...))
+                 (import ispec)
+                 ...
+                 (export e ...)
+                 (re-export r ...)
+                 (export! x ...)
+                 (@@ @@ (name name* ...) body)
+                 ...))))))))
+    
+(define-syntax import
+  (lambda (stx)
+    (define (strip-for import-set)
+      (syntax-case import-set (for)
+        ((for import-set import-level ...)
+         #'import-set)
+        (import-set
+         #'import-set)))
+    (syntax-case stx ()
+      ((_ import-set ...)
+       (with-syntax (((library-reference ...) (map strip-for #'(import-set ...))))
+         #'(eval-when (expand load eval)
+             (let ((iface (resolve-r6rs-interface 'library-reference)))
+               (call-with-deferred-observers
+                 (lambda ()
+                   (module-use-interfaces! (current-module) (list iface)))))
+             ...
+             (if #f #f)))))))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2006, 2010, 2013,
+;;;;   2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+;;; This is the Scheme part of the module for delimited I/O.  It's
+;;; similar to (scsh rdelim) but somewhat incompatible.
+
+(define-module (ice-9 rdelim)
+  #\export (read-line
+            read-line!
+            read-delimited
+            read-delimited!
+            read-string
+            read-string!
+            %read-delimited!
+            %read-line
+            write-line))
+
+
+(%init-rdelim-builtins)
+
+(define* (read-line! string #\optional (port current-input-port))
+  ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+  (define scm-line-incrementors "\n")
+  (let* ((rv (%read-delimited! scm-line-incrementors
+                               string
+                               #t
+                               port))
+         (terminator (car rv))
+         (nchars (cdr rv)))
+    (cond ((and (= nchars 0)
+                (eof-object? terminator))
+           terminator)
+          ((not terminator) #f)
+          (else nchars))))
+
+(define* (read-delimited! delims buf #\optional
+                          (port (current-input-port)) (handle-delim 'trim)
+                          (start 0) (end (string-length buf)))
+  (let* ((rv (%read-delimited! delims
+                               buf
+                               (not (eq? handle-delim 'peek))
+                               port
+                               start
+                               end))
+         (terminator (car rv))
+         (nchars (cdr rv)))
+    (cond ((or (not terminator)         ; buffer filled
+               (eof-object? terminator))
+           (if (zero? nchars)
+               (if (eq? handle-delim 'split)
+                   (cons terminator terminator)
+                   terminator)
+               (if (eq? handle-delim 'split)
+                   (cons nchars terminator)
+                   nchars)))
+          (else
+           (case handle-delim
+             ((trim peek) nchars)
+             ((concat) (string-set! buf (+ nchars start) terminator)
+              (+ nchars 1))
+             ((split) (cons nchars terminator))
+             (else (error "unexpected handle-delim value: " 
+                          handle-delim)))))))
+  
+(define* (read-delimited delims #\optional (port (current-input-port))
+                         (handle-delim 'trim))
+  (let loop ((substrings '())
+             (total-chars 0)
+             (buf-size 100))		; doubled each time through.
+    (let* ((buf (make-string buf-size))
+           (rv (%read-delimited! delims
+                                 buf
+                                 (not (eq? handle-delim 'peek))
+                                 port))
+           (terminator (car rv))
+           (nchars (cdr rv))
+           (new-total (+ total-chars nchars)))
+      (cond
+       ((not terminator)
+        ;; buffer filled.
+        (loop (cons (substring buf 0 nchars) substrings)
+              new-total
+              (* buf-size 2)))
+       ((and (eof-object? terminator) (zero? new-total))
+        (if (eq? handle-delim 'split)
+            (cons terminator terminator)
+            terminator))
+       (else
+        (let ((joined
+               (string-concatenate-reverse
+                (cons (substring buf 0 nchars) substrings))))
+          (case handle-delim
+            ((concat)
+             (if (eof-object? terminator)
+                 joined
+                 (string-append joined (string terminator))))
+            ((trim peek) joined)
+            ((split) (cons joined terminator))
+            (else (error "unexpected handle-delim value: "
+                         handle-delim)))))))))
+
+(define-syntax-rule (check-arg exp message arg ...)
+  (unless exp
+    (error message arg ...)))
+
+(define (index? n)
+  (and (integer? n) (exact? n) (>= n 0)))
+
+(define* (read-string! buf #\optional
+                       (port (current-input-port))
+                       (start 0) (end (string-length buf)))
+  "Read all of the characters out of PORT and write them to BUF.
+Returns the number of characters read.
+
+This function only reads out characters from PORT if it will be able to
+write them to BUF.  That is to say, if BUF is smaller than the number of
+available characters, then BUF will be filled, and characters will be
+left in the port."
+  (check-arg (string? buf) "not a string" buf)
+  (check-arg (index? start) "bad index" start)
+  (check-arg (index? end) "bad index" end)
+  (check-arg (<= start end) "start beyond end" start end)
+  (check-arg (<= end (string-length buf)) "end beyond string length" end)
+  (let lp ((n start))
+    (if (< n end)
+        (let ((c (read-char port)))
+          (if (eof-object? c)
+              (- n start)
+              (begin
+                (string-set! buf n c)
+                (lp (1+ n)))))
+        (- n start))))
+
+(define* read-string
+  (case-lambda*
+   "Read all of the characters out of PORT and return them as a string.
+If the COUNT argument is present, treat it as a limit to the number of
+characters to read.  By default, there is no limit."
+   ((#\optional (port (current-input-port)))
+    ;; Fast path.
+    ;; This creates more garbage than using 'string-set!' as in
+    ;; 'read-string!', but currently that is faster nonetheless.
+    (let loop ((chars '()))
+      (let ((char (read-char port)))
+        (if (eof-object? char)
+            (list->string (reverse! chars))
+            (loop (cons char chars))))))
+   ((port count)
+    ;; Slower path.
+    (let loop ((chars '())
+               (total 0))
+      (let ((char (read-char port)))
+        (if (or (eof-object? char) (>= total count))
+            (list->string (reverse chars))
+            (loop (cons char chars) (+ 1 total))))))))
+
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'.  If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned.  If `concat', the string is
+;;; returned with the trailing newline intact.  If `peek', the newline
+;;; is left in the input port buffer and the string is returned.  If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+
+(define* (read-line #\optional (port (current-input-port))
+                    (handle-delim 'trim))
+  (let* ((line/delim	(%read-line port))
+	 (line		(car line/delim))
+	 (delim		(cdr line/delim)))
+    (case handle-delim
+      ((trim) line)
+      ((split) line/delim)
+      ((concat) (if (and (string? line) (char? delim))
+		    (string-append line (string delim))
+		    line))
+      ((peek) (if (char? delim)
+		  (unread-char delim port))
+	      line)
+      (else
+       (error "unexpected handle-delim value: " handle-delim)))))
+;;;; SRFI-8
+
+;;; Copyright (C) 2000, 2001, 2004, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (ice-9 receive)
+  #\export (receive))
+
+(define-syntax-rule (receive vars vals . body)
+  (call-with-values (lambda () vals)
+    (lambda vars . body)))
+
+(cond-expand-provide (current-module) '(srfi-8))
+;;;;    Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006, 2008, 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+
+;; These procedures are exported:
+;;  (match:count match)
+;;  (match:string match)
+;;  (match:prefix match)
+;;  (match:suffix match)
+;;  (regexp-match? match)
+;;  (regexp-quote string)
+;;  (match:start match . submatch-num)
+;;  (match:end match . submatch-num)
+;;  (match:substring match . submatch-num)
+;;  (string-match pattern str . start)
+;;  (regexp-substitute port match . items)
+;;  (fold-matches regexp string init proc . flags)
+;;  (list-matches regexp string . flags)
+;;  (regexp-substitute/global port regexp string . items)
+
+;;; Code:
+
+;;;; POSIX regex support functions.
+
+(define-module (ice-9 regex)
+  #\export (match:count match:string match:prefix match:suffix
+           regexp-match? regexp-quote match:start match:end match:substring
+           string-match regexp-substitute fold-matches list-matches
+           regexp-substitute/global))
+
+;; References:
+;;
+;; POSIX spec:
+;; http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html
+
+;;; FIXME:
+;;;   It is not clear what should happen if a `match' function
+;;;   is passed a `match number' which is out of bounds for the
+;;;   regexp match: return #f, or throw an error?  These routines
+;;;   throw an out-of-range error.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; These procedures are not defined in SCSH, but I found them useful.
+
+(define (match:count match)
+  (- (vector-length match) 1))
+
+(define (match:string match)
+  (vector-ref match 0))
+
+(define (match:prefix match)
+  (substring (match:string match) 0 (match:start match 0)))
+
+(define (match:suffix match)
+  (substring (match:string match) (match:end match 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; SCSH compatibility routines.
+
+(define (regexp-match? match)
+  (and (vector? match)
+       (string? (vector-ref match 0))
+       (let loop ((i 1))
+         (cond ((>= i (vector-length match)) #t)
+               ((and (pair? (vector-ref match i))
+                     (integer? (car (vector-ref match i)))
+                     (integer? (cdr (vector-ref match i))))
+                (loop (+ 1 i)))
+               (else #f)))))
+
+;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
+;; can be backslash escaped.
+;;
+;; ( ) + ? { } and | are special in regexp/extended so must be quoted.  But
+;; that can't be done with a backslash since in regexp/basic where they're
+;; not special, adding a backslash makes them become special.  Character
+;; class forms [(] etc are used instead.
+;;
+;; ) is not special when not preceded by a (, and * and ? are not special at
+;; the start of a string, but we quote all of these always, so the result
+;; can be concatenated or merged into some larger regexp.
+;;
+;; ] is not special outside a [ ] character class, so doesn't need to be
+;; quoted.
+;;
+(define (regexp-quote string)
+  (call-with-output-string
+   (lambda (p)
+     (string-for-each (lambda (c)
+                        (case c
+                          ((#\* #\. #\\ #\^ #\$ #\[)
+                           (write-char #\\ p)
+                           (write-char c p))
+                          ((#\( #\) #\+ #\? #\{ #\} #\|)
+                           (write-char #\[ p)
+                           (write-char c p)
+                           (write-char #\] p))
+                          (else
+                           (write-char c p))))
+                      string))))
+
+(define* (match:start match #\optional (n 0))
+  (let ((start (car (vector-ref match (1+ n)))))
+    (if (= start -1) #f start)))
+
+(define* (match:end match #\optional (n 0))
+  (let* ((end (cdr (vector-ref match (1+ n)))))
+    (if (= end -1) #f end)))
+
+(define* (match:substring match #\optional (n 0))
+  (let* ((start (match:start match n))
+         (end   (match:end match n)))
+    (and start end (substring (match:string match) start end))))
+
+(define (string-match pattern str . args)
+  (let ((rx (make-regexp pattern))
+        (start (if (pair? args) (car args) 0)))
+    (regexp-exec rx str start)))
+
+(define (regexp-substitute port match . items)
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+         (apply regexp-substitute p match items)))
+
+      ;; Otherwise, process each substitution argument in `items'.
+      (for-each (lambda (obj)
+                  (cond ((string? obj)   (display obj port))
+                        ((integer? obj)  (display (match:substring match obj) port))
+                        ((eq? 'pre obj)  (display (match:prefix match) port))
+                        ((eq? 'post obj) (display (match:suffix match) port))
+                        (else (error 'wrong-type-arg obj))))
+                items)))
+
+;;; If we call fold-matches, below, with a regexp that can match the
+;;; empty string, it's not obvious what "all the matches" means.  How
+;;; many empty strings are there in the string "a"?  Our answer:
+;;;
+;;;     This function applies PROC to every non-overlapping, maximal
+;;;     match of REGEXP in STRING.
+;;;
+;;; "non-overlapping": There are two non-overlapping matches of "" in
+;;; "a" --- one before the `a', and one after.  There are three
+;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
+;;; before `a' and after `b', and `q'.  The two empty strings before
+;;; and after `q' don't count, because they overlap with the match of
+;;; "q".
+;;;
+;;; "maximal": There are three distinct maximal matches of "x*" in
+;;; "axxxb": one before the `a', one covering `xxx', and one after the
+;;; `b'.  Around or within `xxx', only the match covering all three
+;;; x's counts, because the rest are not maximal.
+
+(define* (fold-matches regexp string init proc #\optional (flags 0))
+  (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp))))
+    (let loop ((start 0)
+               (value init)
+               (abuts #f))              ; True if start abuts a previous match.
+      (define bol (if (zero? start) 0 regexp/notbol))
+      (let ((m (if (> start (string-length string)) #f
+                   (regexp-exec regexp string start (logior flags bol)))))
+        (cond
+         ((not m) value)
+         ((and (= (match:start m) (match:end m)) abuts)
+          ;; We matched an empty string, but that would overlap the
+          ;; match immediately before.  Try again at a position
+          ;; further to the right.
+          (loop (+ start 1) value #f))
+         (else
+          (loop (match:end m) (proc m value) #t)))))))
+
+(define* (list-matches regexp string #\optional (flags 0))
+  (reverse! (fold-matches regexp string '() cons flags)))
+
+(define (regexp-substitute/global port regexp string . items)
+
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+         (apply regexp-substitute/global p regexp string items)))
+
+      ;; Walk the set of non-overlapping, maximal matches.
+      (let next-match ((matches (list-matches regexp string))
+                       (start 0))
+        (if (null? matches)
+            (display (substring string start) port)
+            (let ((m (car matches)))
+
+              ;; Process all of the items for this match.  Don't use
+              ;; for-each, because we need to make sure 'post at the
+              ;; end of the item list is a tail call.
+              (let next-item ((items items))
+
+                (define (do-item item)
+                  (cond
+                   ((string? item)    (display item port))
+                   ((integer? item)   (display (match:substring m item) port))
+                   ((procedure? item) (display (item m) port))
+                   ((eq? item 'pre)
+                    (display
+                     (substring string start (match:start m))
+                     port))
+                   ((eq? item 'post)
+                    (next-match (cdr matches) (match:end m)))
+                   (else (error 'wrong-type-arg item))))
+
+                (if (pair? items)
+                    (if (null? (cdr items))
+                        (do-item (car items)) ; This is a tail call.
+                        (begin
+                          (do-item (car items)) ; This is not.
+                          (next-item (cdr items)))))))))))
+;;;; runq.scm --- the runq data structure
+;;;;
+;;;; 	Copyright (C) 1996, 2001, 2006, 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+
+;;; One way to schedule parallel computations in a serial environment is
+;;; to explicitly divide each task up into small, finite execution time,
+;;; strips.  Then you interleave the execution of strips from various
+;;; tasks to achieve a kind of parallelism.  Runqs are a handy data
+;;; structure for this style of programming.
+;;;
+;;; We use thunks (nullary procedures) and lists of thunks to represent
+;;; strips.  By convention, the return value of a strip-thunk must either
+;;; be another strip or the value #f.
+;;;
+;;; A runq is a procedure that manages a queue of strips.  Called with no
+;;; arguments, it processes one strip from the queue.  Called with
+;;; arguments, the arguments form a control message for the queue.  The
+;;; first argument is a symbol which is the message selector.
+;;;
+;;; A strip is processed this way: If the strip is a thunk, the thunk is
+;;; called -- if it returns a strip, that strip is added back to the
+;;; queue.  To process a strip which is a list of thunks, the CAR of that
+;;; list is called.  After a call to that CAR, there are 0, 1, or 2 strips
+;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
+;;; original strip if that CDR is not nil.  The runq puts whichever of
+;;; these strips exist back on the queue.  (The exact order in which
+;;; strips are put back on the queue determines the scheduling behavior of
+;;; a particular queue -- it's a parameter.)
+
+;;; Code:
+
+(define-module (ice-9 runq)
+  \:use-module (ice-9 q)
+  \:export (runq-control make-void-runq make-fair-runq
+	   make-exclusive-runq make-subordinate-runq-to strip-sequence
+	   fair-strip-subtask))
+
+;;;;
+;;; 	(runq-control q msg . args)
+;;;
+;;; 		processes in the default way the control messages that
+;;; 		can be sent to a runq.  Q should be an ordinary
+;;; 		Q (see utils/q.scm).
+;;;
+;;; 		The standard runq messages are:
+;;;
+;;; 		'add! strip0 strip1...		;; to enqueue one or more strips
+;;; 		'enqueue! strip0 strip1...	;; to enqueue one or more strips
+;;; 		'push! strip0 ...		;; add strips to the front of the queue
+;;; 		'empty?				;; true if it is
+;;; 		'length				;; how many strips in the queue?
+;;; 		'kill!				;; empty the queue
+;;; 		else				;; throw 'not-understood
+;;;
+(define (runq-control q msg . args)
+  (case msg
+    ((add!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+    ((enqueue!)			(for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+    ((push!)			(for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
+    ((empty?)			(q-empty? q))
+    ((length)			(q-length q))
+    ((kill!)			(set! q (make-q)))
+    (else			(throw 'not-understood msg args))))
+
+(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
+
+;;;;
+;;; make-void-runq
+;;;
+;;; Make a runq that discards all messages except "length", for which
+;;; it returns 0.
+;;;
+(define (make-void-runq)
+  (lambda opts
+    (and opts
+	(apply-to-args opts
+	  (lambda (msg . args)
+	    (case msg
+	      ((length)		0)
+	      (else		#f)))))))
+
+;;;;
+;;; 	(make-fair-runq)
+;;;
+;;; 		Returns a runq procedure.
+;;; 		Called with no arguments, the procedure processes one strip from the queue.
+;;; 		Called with arguments, it uses runq-control.
+;;;
+;;; 		In a fair runq, if a strip returns a new strip X, X is added
+;;; 		to the end of the queue, meaning it will be the last to execute
+;;; 		of all the remaining procedures.
+;;;
+(define (make-fair-runq)
+  (letrec ((q (make-q))
+	   (self
+	    (lambda ctl
+	      (if ctl
+		  (apply runq-control q ctl)
+		  (and (not (q-empty? q))
+		       (let ((next-strip (deq! q)))
+			 (cond
+			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
+							  (and k (enq! q k))))
+			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+						(and k (enq! q k)))
+					      (if (not (null? (cdr next-strip)))
+						  (enq! q (cdr next-strip)))))
+			 self))))))
+    self))
+
+
+;;;;
+;;; 	(make-exclusive-runq)
+;;;
+;;; 		Returns a runq procedure.
+;;; 		Called with no arguments, the procedure processes one strip from the queue.
+;;; 		Called with arguments, it uses runq-control.
+;;;
+;;; 		In an exclusive runq, if a strip W returns a new strip X, X is added
+;;; 		to the front of the queue, meaning it will be the next to execute
+;;; 		of all the remaining procedures.
+;;;
+;;; 		An exception to this occurs if W was the CAR of a list of strips.
+;;; 		In that case, after the return value of W is pushed onto the front
+;;; 	 	of the queue, the CDR of the list of strips is pushed in front
+;;; 		of that (if the CDR is not nil).   This way, the rest of the thunks
+;;; 		in the list that contained W have priority over the return value of W.
+;;;
+(define (make-exclusive-runq)
+  (letrec ((q (make-q))
+	   (self
+	    (lambda ctl
+	      (if ctl
+		  (apply runq-control q ctl)
+		  (and (not (q-empty? q))
+		       (let ((next-strip (deq! q)))
+			 (cond
+			  ((procedure? next-strip)	(let ((k (run-strip next-strip)))
+							  (and k (q-push! q k))))
+			  ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+						(and k (q-push! q k)))
+					      (if (not (null? (cdr next-strip)))
+						  (q-push! q (cdr next-strip)))))
+			 self))))))
+    self))
+
+
+;;;;
+;;; 	(make-subordinate-runq-to superior basic-inferior)
+;;;
+;;; 		Returns a runq proxy for the runq basic-inferior.
+;;;
+;;; 		The proxy watches for operations on the basic-inferior that cause
+;;; 		a transition from a queue length of 0 to a non-zero length and
+;;; 		vice versa.   While the basic-inferior queue is not empty,
+;;; 		the proxy installs a task on the superior runq.  Each strip
+;;; 		of that task processes N strips from the basic-inferior where
+;;; 		N is the length of the basic-inferior queue when the proxy
+;;; 		strip is entered.  [Countless scheduling variations are possible.]
+;;;
+(define (make-subordinate-runq-to superior-runq basic-runq)
+  (let ((runq-task (cons #f #f)))
+    (set-car! runq-task
+	      (lambda ()
+		(if (basic-runq 'empty?)
+		    (set-cdr! runq-task #f)
+		    (do ((n (basic-runq 'length) (1- n)))
+			((<= n 0)		 #f)
+		      (basic-runq)))))
+    (letrec ((self
+	      (lambda ctl
+		(if (not ctl)
+		    (let ((answer (basic-runq)))
+		      (self 'empty?)
+		      answer)
+		    (begin
+		      (case (car ctl)
+			((suspend)		(set-cdr! runq-task #f))
+			(else		      	(let ((answer (apply basic-runq ctl)))
+						  (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
+						      (begin
+							(set-cdr! runq-task runq-task)
+							(superior-runq 'add! runq-task)))
+						  answer))))))))
+      self)))
+
+;;;;
+;;;	(define fork-strips (lambda args args))
+;;;		Return a strip that starts several strips in
+;;;		parallel.   If this strip is enqueued on a fair
+;;;		runq, strips of the parallel subtasks will run
+;;;		round-robin style.
+;;;
+
+
+;;;;
+;;; 	(strip-sequence . strips)
+;;;
+;;; 		Returns a new strip which is the concatenation of the argument strips.
+;;;
+(define (strip-sequence . strips)
+  (lambda ()
+    (let loop ((st (let ((a strips)) (set! strips #f) a)))
+      (and (not (null? st))
+           (let ((then ((car st))))
+             (if then
+                 (lambda () (loop (cons then (cdr st))))
+                 (lambda () (loop (cdr st)))))))))
+
+
+;;;;
+;;; 	(fair-strip-subtask . initial-strips)
+;;;
+;;; 		Returns a new strip which is the synchronos, fair,
+;;; 		parallel execution of the argument strips.
+;;;
+;;;
+;;;
+(define (fair-strip-subtask . initial-strips)
+  (let ((st (make-fair-runq)))
+    (apply st 'add! initial-strips)
+    st))
+
+;;; runq.scm ends here
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001, 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
+;;;; 
+
+
+;;; This is the Scheme part of (ice-9 rw), which is a subset of
+;;; (scsh rw).
+
+(define-module (ice-9 rw)
+  \:export (read-string!/partial write-string/partial))
+
+(%init-rw-builtins)
+;;;; 	Copyright (C) 2000, 2001, 2004, 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
+;;;; 
+
+;;;; Safe subset of R5RS bindings
+
+(define-module (ice-9 safe-r5rs)
+  \:re-export (eqv? eq? equal?
+	      number?	complex? real? rational? integer?
+	      exact? inexact?
+	      = < > <= >=
+	      zero? positive?	negative? odd? even?
+	      max min
+	      + * - /
+	      abs
+	      quotient remainder modulo
+	      gcd lcm
+	      numerator denominator
+	      rationalize
+	      floor ceiling truncate round
+	      exp log sin cos tan asin acos atan
+	      sqrt
+	      expt
+	      make-rectangular make-polar real-part imag-part magnitude angle
+	      exact->inexact inexact->exact
+	      
+	      number->string string->number
+	   
+	      boolean?
+	      not
+	   
+	      pair?
+	      cons car cdr
+	      set-car! set-cdr!
+	      caar cadr cdar cddr
+	      caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	      caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	      cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+	      null?
+	      list?
+	      list
+	      length
+	      append
+	      reverse
+	      list-tail list-ref
+	      memq memv member
+	      assq assv assoc
+	   
+	      symbol?
+	      symbol->string string->symbol
+	   
+	      char?
+	      char=? char<? char>? char<=? char>=?
+	      char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+	      char-alphabetic? char-numeric? char-whitespace?
+	      char-upper-case? char-lower-case?
+	      char->integer integer->char
+	      char-upcase
+	      char-downcase
+	   
+	      string?
+	      make-string
+	      string
+	      string-length
+	      string-ref string-set!
+	      string=? string-ci=?
+	      string<? string>? string<=? string>=?
+	      string-ci<? string-ci>? string-ci<=? string-ci>=?
+	      substring
+	      string-length
+	      string-append
+	      string->list list->string
+	      string-copy string-fill!
+	   
+	      vector?
+	      make-vector
+	      vector
+	      vector-length
+	      vector-ref vector-set!
+	      vector->list list->vector
+	      vector-fill!
+	   
+	      procedure?
+	      apply
+	      map
+	      for-each
+	      force
+	   
+	      call-with-current-continuation
+	   
+	      values
+	      call-with-values
+	      dynamic-wind
+	   
+	      eval
+
+	      input-port? output-port?
+	      current-input-port current-output-port
+	   
+	      read
+	      read-char
+	      peek-char
+	      eof-object?
+	      char-ready?
+	   
+	      write
+	      display
+	      newline
+	      write-char
+
+	      ;;transcript-on
+	      ;;transcript-off
+	      )
+
+  \:export (null-environment))
+
+(define null-interface (resolve-interface '(ice-9 null)))
+
+(module-use! (module-public-interface (current-module))
+             null-interface)
+
+(define (null-environment n)
+  (if (not (= n 5))
+      (scm-error 'misc-error 'null-environment
+		 "~A is not a valid version"
+		 (list n)
+		 '()))
+  ;; Note that we need to create a *fresh* interface
+  (let ((interface (make-module 31)))
+    (set-module-kind! interface 'interface)
+    (module-use! interface null-interface)
+    interface))
+;;;; 	Copyright (C) 2000, 2001, 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
+;;;; 
+
+;;;; Safe subset of R5RS bindings
+
+(define-module (ice-9 safe)
+  \:export (safe-environment make-safe-module))
+
+(define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs)))
+
+(define (safe-environment n)
+  (if (not (= n 5))
+      (scm-error 'misc-error 'safe-environment
+		 "~A is not a valid version"
+		 (list n)
+		 '()))
+  safe-r5rs-interface)
+
+(define (make-safe-module)
+  (make-module 1021 (list safe-r5rs-interface)))
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,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
+;;;;
+
+
+
+;;; Commentary:
+
+;;; An older approack to debugging, in which the user installs a pre-unwind
+;;; handler that saves the stack at the time of the error. The last stack can
+;;; then be debugged later.
+;;;
+
+;;; Code:
+
+(define-module (ice-9 save-stack)
+  ;; Replace deprecated root-module bindings, if present.
+  #\replace (stack-saved?
+             the-last-stack
+             save-stack))
+
+;; FIXME: stack-saved? is broken in the presence of threads.
+(define stack-saved? #f)
+
+(define the-last-stack (make-fluid))
+
+(define (save-stack . narrowing)
+  (if (not stack-saved?)
+      (begin
+        (let ((stacks (fluid-ref %stacks)))
+          (fluid-set! the-last-stack
+                      ;; (make-stack obj inner outer inner outer ...)
+                      ;;
+                      ;; In this case, cut away the make-stack frame, the
+                      ;; save-stack frame, and then narrow as specified by the
+                      ;; user, delimited by the nearest start-stack invocation,
+                      ;; if any.
+                      (apply make-stack #t
+                             2
+                             (if (pair? stacks) (cdar stacks) 0)
+                             narrowing)))
+        (set! stack-saved? #t))))
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,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
+;;;;
+
+(define-module (ice-9 scm-style-repl)
+  #\use-module (ice-9 save-stack)
+
+  #\export (scm-repl-silent
+            scm-repl-print-unspecified
+            scm-repl-verbose
+            scm-repl-prompt)
+  
+  ;; #\replace, as with deprecated code enabled these will be in the root env
+  #\replace (assert-repl-silence
+             assert-repl-print-unspecified
+             assert-repl-verbosity
+
+             default-pre-unwind-handler
+             bad-throw
+             error-catching-loop
+             error-catching-repl
+             scm-style-repl
+             handle-system-error))
+
+(define scm-repl-silent #f)
+(define (assert-repl-silence v) (set! scm-repl-silent v))
+
+(define scm-repl-print-unspecified #f)
+(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
+
+(define scm-repl-verbose #f)
+(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
+
+(define scm-repl-prompt "guile> ")
+
+
+
+;; bad-throw is the hook that is called upon a throw to a an unhandled
+;; key (unless the throw has four arguments, in which case
+;; it's usually interpreted as an error throw.)
+;; If the key has a default handler (a throw-handler-default property),
+;; it is applied to the throw.
+;;
+(define (bad-throw key . args)
+  (let ((default (symbol-property key 'throw-handler-default)))
+    (or (and default (apply default key args))
+        (apply error "unhandled-exception:" key args))))
+
+
+
+(define (default-pre-unwind-handler key . args)
+  ;; Narrow by two more frames: this one, and the throw handler.
+  (save-stack 2)
+  (apply throw key args))
+
+
+
+(define has-shown-debugger-hint? #f)
+
+(define (error-catching-loop thunk)
+  (let ((status #f)
+        (interactive #t))
+    (define (loop first)
+      (let ((next
+             (catch #t
+
+                    (lambda ()
+                      (call-with-unblocked-asyncs
+                       (lambda ()
+                         (first)
+
+                         ;; This line is needed because mark
+                         ;; doesn't do closures quite right.
+                         ;; Unreferenced locals should be
+                         ;; collected.
+                         (set! first #f)
+                         (let loop ((v (thunk)))
+                           (loop (thunk)))
+                         #f)))
+
+                    (lambda (key . args)
+                      (case key
+                        ((quit)
+                         (set! status args)
+                         #f)
+
+                        ((switch-repl)
+                         (apply throw 'switch-repl args))
+
+                        ((abort)
+                         ;; This is one of the closures that require
+                         ;; (set! first #f) above
+                         ;;
+                         (lambda ()
+                           (run-hook abort-hook)
+                           (force-output (current-output-port))
+                           (display "ABORT: "  (current-error-port))
+                           (write args (current-error-port))
+                           (newline (current-error-port))
+                           (if interactive
+                               (begin
+                                 (if (and
+                                      (not has-shown-debugger-hint?)
+                                      (not (memq 'backtrace
+                                                 (debug-options-interface)))
+                                      (stack? (fluid-ref the-last-stack)))
+                                     (begin
+                                       (newline (current-error-port))
+                                       (display
+                                        "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
+                                        (current-error-port))
+                                       (set! has-shown-debugger-hint? #t)))
+                                 (force-output (current-error-port)))
+                               (begin
+                                 (primitive-exit 1)))
+                           (set! stack-saved? #f)))
+
+                        (else
+                         ;; This is the other cons-leak closure...
+                         (lambda ()
+                           (cond ((= (length args) 4)
+                                  (apply handle-system-error key args))
+                                 (else
+                                  (apply bad-throw key args)))))))
+
+                    default-pre-unwind-handler)))
+
+        (if next (loop next) status)))
+    (set! ensure-batch-mode! (lambda ()
+                               (set! interactive #f)
+                               (restore-signals)))
+    (set! batch-mode? (lambda () (not interactive)))
+    (call-with-blocked-asyncs
+     (lambda () (loop (lambda () #t))))))
+
+(define (error-catching-repl r e p)
+  (error-catching-loop
+   (lambda ()
+     (call-with-values (lambda () (e (r)))
+       (lambda the-values (for-each p the-values))))))
+
+(define (scm-style-repl)
+  (letrec (
+           (start-gc-rt #f)
+           (start-rt #f)
+           (repl-report-start-timing (lambda ()
+                                       (set! start-gc-rt (gc-run-time))
+                                       (set! start-rt (get-internal-run-time))))
+           (repl-report (lambda ()
+                          (display ";;; ")
+                          (display (inexact->exact
+                                    (* 1000 (/ (- (get-internal-run-time) start-rt)
+                                               internal-time-units-per-second))))
+                          (display "  msec  (")
+                          (display  (inexact->exact
+                                     (* 1000 (/ (- (gc-run-time) start-gc-rt)
+                                                internal-time-units-per-second))))
+                          (display " msec in gc)\n")))
+
+           (consume-trailing-whitespace
+            (lambda ()
+              (let ((ch (peek-char)))
+                (cond
+                 ((eof-object? ch))
+                 ((or (char=? ch #\space) (char=? ch #\tab))
+                  (read-char)
+                  (consume-trailing-whitespace))
+                 ((char=? ch #\newline)
+                  (read-char))))))
+           (-read (lambda ()
+                    (let ((val
+                           (let ((prompt (cond ((string? scm-repl-prompt)
+                                                scm-repl-prompt)
+                                               ((thunk? scm-repl-prompt)
+                                                (scm-repl-prompt))
+                                               (scm-repl-prompt "> ")
+                                               (else ""))))
+                             (repl-reader prompt))))
+
+                      ;; As described in R4RS, the READ procedure updates the
+                      ;; port to point to the first character past the end of
+                      ;; the external representation of the object.  This
+                      ;; means that it doesn't consume the newline typically
+                      ;; found after an expression.  This means that, when
+                      ;; debugging Guile with GDB, GDB gets the newline, which
+                      ;; it often interprets as a "continue" command, making
+                      ;; breakpoints kind of useless.  So, consume any
+                      ;; trailing newline here, as well as any whitespace
+                      ;; before it.
+                      ;; But not if EOF, for control-D.
+                      (if (not (eof-object? val))
+                          (consume-trailing-whitespace))
+                      (run-hook after-read-hook)
+                      (if (eof-object? val)
+                          (begin
+                            (repl-report-start-timing)
+                            (if scm-repl-verbose
+                                (begin
+                                  (newline)
+                                  (display ";;; EOF -- quitting")
+                                  (newline)))
+                            (quit 0)))
+                      val)))
+
+           (-eval (lambda (sourc)
+                    (repl-report-start-timing)
+                    (run-hook before-eval-hook sourc)
+                    (let ((val (start-stack 'repl-stack
+                                            ;; If you change this procedure
+                                            ;; (primitive-eval), please also
+                                            ;; modify the repl-stack case in
+                                            ;; save-stack so that stack cutting
+                                            ;; continues to work.
+                                            (primitive-eval sourc))))
+                      (run-hook after-eval-hook sourc)
+                      val)))
+
+
+           (-print (let ((maybe-print (lambda (result)
+                                        (if (or scm-repl-print-unspecified
+                                                (not (unspecified? result)))
+                                            (begin
+                                              (write result)
+                                              (newline))))))
+                     (lambda (result)
+                       (if (not scm-repl-silent)
+                           (begin
+                             (run-hook before-print-hook result)
+                             (maybe-print result)
+                             (run-hook after-print-hook result)
+                             (if scm-repl-verbose
+                                 (repl-report))
+                             (force-output))))))
+
+           (-quit (lambda (args)
+                    (if scm-repl-verbose
+                        (begin
+                          (display ";;; QUIT executed, repl exitting")
+                          (newline)
+                          (repl-report)))
+                    args)))
+
+    (let ((status (error-catching-repl -read
+                                       -eval
+                                       -print)))
+      (-quit status))))
+
+(define (handle-system-error key . args)
+  (let ((cep (current-error-port)))
+    (cond ((not (stack? (fluid-ref the-last-stack))))
+          ((memq 'backtrace (debug-options-interface))
+           (let ((highlights (if (or (eq? key 'wrong-type-arg)
+                                     (eq? key 'out-of-range))
+                                 (list-ref args 3)
+                                 '())))
+             (run-hook before-backtrace-hook)
+             (newline cep)
+             (display "Backtrace:\n")
+             (display-backtrace (fluid-ref the-last-stack) cep
+                                #f #f highlights)
+             (newline cep)
+             (run-hook after-backtrace-hook))))
+    (run-hook before-error-hook)
+    (apply display-error (fluid-ref the-last-stack) cep args)
+    (run-hook after-error-hook)
+    (force-output cep)
+    (throw 'abort key)))
+;;;; 	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
+;;;;
+
+;;; Commentary:
+
+;; (serialize FORM1 ...) and (parallelize FORM1 ...) are useful when
+;; you don't trust the thread safety of most of your program, but
+;; where you have some section(s) of code which you consider can run
+;; in parallel to other sections.
+;;
+;; They "flag" (with dynamic extent) sections of code to be of
+;; "serial" or "parallel" nature and have the single effect of
+;; preventing a serial section from being run in parallel with any
+;; serial section (including itself).
+;;
+;; Both serialize and parallelize can be nested.  If so, the
+;; inner-most construct is in effect.
+;;
+;; NOTE 1: A serial section can run in parallel with a parallel
+;; section.
+;;
+;; NOTE 2: If a serial section S is "interrupted" by a parallel
+;; section P in the following manner: S = S1 P S2, S2 is not
+;; guaranteed to be resumed by the same thread that previously
+;; executed S1.
+;;
+;; WARNING: Spawning new threads within a serial section have
+;; undefined effects.  It is OK, though, to spawn threads in unflagged
+;; sections of code where neither serialize or parallelize is in
+;; effect.
+;;
+;; A typical usage is when Guile is used as scripting language in some
+;; application doing heavy computations.  If each thread is
+;; encapsulated with a serialize form, you can then put a parallelize
+;; form around the code performing the heavy computations (typically a
+;; C code primitive), enabling the computations to run in parallel
+;; while the scripting code runs single-threadedly.
+;; 
+
+;;; Code:
+
+(define-module (ice-9 serialize)
+  \:use-module (ice-9 threads)
+  \:export (call-with-serialization
+	   call-with-parallelization)
+  \:export-syntax (serialize
+		  parallelize))
+
+
+(define serialization-mutex (make-mutex))
+(define admin-mutex (make-mutex))
+(define owner #f)
+
+(define (call-with-serialization thunk)
+  (let ((outer-owner #f))
+    (dynamic-wind
+	(lambda ()
+	  (lock-mutex admin-mutex)
+	  (set! outer-owner owner)
+	  (if (not (eqv? outer-owner (dynamic-root)))
+	      (begin
+		(unlock-mutex admin-mutex)
+		(lock-mutex serialization-mutex)
+		(set! owner (dynamic-root)))
+	      (unlock-mutex admin-mutex)))
+	thunk
+	(lambda ()
+	  (lock-mutex admin-mutex)
+	  (if (not (eqv? outer-owner (dynamic-root)))
+	      (begin
+		(set! owner #f)
+		(unlock-mutex serialization-mutex)))
+	  (unlock-mutex admin-mutex)))))
+
+(define-macro (serialize . forms)
+  `(call-with-serialization (lambda () ,@forms)))
+
+(define (call-with-parallelization thunk)
+  (let ((outer-owner #f))
+    (dynamic-wind
+	(lambda ()
+	  (lock-mutex admin-mutex)
+	  (set! outer-owner owner)
+	  (if (eqv? outer-owner (dynamic-root))
+	      (begin
+		(set! owner #f)
+		(unlock-mutex serialization-mutex)))
+	  (unlock-mutex admin-mutex))
+	thunk
+	(lambda ()
+	  (lock-mutex admin-mutex)
+	  (if (eqv? outer-owner (dynamic-root))
+	      (begin
+		(unlock-mutex admin-mutex)
+		(lock-mutex serialization-mutex)
+		(set! owner outer-owner))
+	      (unlock-mutex admin-mutex))))))
+
+(define-macro (parallelize . forms)
+  `(call-with-parallelization (lambda () ,@forms)))
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 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 session)
+  #\use-module (ice-9 documentation)
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 match)
+  #\export (help
+            add-value-help-handler! remove-value-help-handler!
+            add-name-help-handler! remove-name-help-handler!
+            apropos-hook
+            apropos apropos-internal apropos-fold apropos-fold-accessible
+            apropos-fold-exported apropos-fold-all source arity
+            procedure-arguments
+            module-commentary))
+
+
+
+(define *value-help-handlers*
+  `(,(lambda (name value)
+       (object-documentation value))))
+
+(define (add-value-help-handler! proc)
+  "Adds a handler for performing `help' on a value.
+
+`proc' will be called as (PROC NAME VALUE). `proc' should return #t to
+indicate that it has performed help, a string to override the default
+object documentation, or #f to try the other handlers, potentially
+falling back on the normal behavior for `help'."
+  (set! *value-help-handlers* (cons proc *value-help-handlers*)))
+
+(define (remove-value-help-handler! proc)
+  "Removes a handler for performing `help' on a value."
+  (set! *value-help-handlers* (delete! proc *value-help-handlers*)))
+
+(define (try-value-help name value)
+  (or-map (lambda (proc) (proc name value)) *value-help-handlers*))
+
+
+(define *name-help-handlers* '())
+
+(define (add-name-help-handler! proc)
+  "Adds a handler for performing `help' on a name.
+
+`proc' will be called with the unevaluated name as its argument. That is
+to say, when the user calls `(help FOO)', the name is FOO, exactly as
+the user types it.
+
+`proc' should return #t to indicate that it has performed help, a string
+to override the default object documentation, or #f to try the other
+handlers, potentially falling back on the normal behavior for `help'."
+  (set! *name-help-handlers* (cons proc *name-help-handlers*)))
+
+(define (remove-name-help-handler! proc)
+  "Removes a handler for performing `help' on a name."
+  (set! *name-help-handlers* (delete! proc *name-help-handlers*)))
+
+(define (try-name-help name)
+  (or-map (lambda (proc) (proc name)) *name-help-handlers*))
+
+
+;;; Documentation
+;;;
+(define-macro (help . exp)
+  "(help [NAME])
+Prints useful information.  Try `(help)'."
+  (cond ((not (= (length exp) 1))
+         (help-usage)
+         '(begin))
+        ((not (provided? 'regex))
+         (display "`help' depends on the `regex' feature.
+You don't seem to have regular expressions installed.\n")
+         '(begin))
+        (else
+         (let ((name (car exp))
+               (not-found (lambda (type x)
+                            (simple-format #t "No ~A found for ~A\n"
+                                           type x))))
+           (cond
+            
+            ;; User-specified
+            ((try-name-help name)
+             => (lambda (x) (if (not (eq? x #t)) (display x))))
+
+            ;; SYMBOL
+            ((symbol? name)
+             (help-doc name
+                       (simple-format
+                        #f "^~A$"
+                        (regexp-quote (symbol->string name)))))
+            
+            ;; "STRING"
+            ((string? name)
+             (help-doc name name))
+
+            ;; (unquote SYMBOL)
+            ((and (list? name)
+                  (= (length name) 2)
+                  (eq? (car name) 'unquote))
+             (let ((doc (try-value-help (cadr name)
+                                        (module-ref (current-module)
+                                                    (cadr name)))))
+               (cond ((not doc) (not-found 'documentation (cadr name)))
+                     ((eq? doc #t)) ;; pass
+                     (else (write-line doc)))))
+
+            ;; (quote SYMBOL)
+            ((and (list? name)
+                  (= (length name) 2)
+                  (eq? (car name) 'quote)
+                  (symbol? (cadr name)))
+             (cond ((search-documentation-files (cadr name))
+                    => write-line)
+                   (else (not-found 'documentation (cadr name)))))
+
+            ;; (SYM1 SYM2 ...)
+            ((and (list? name)
+                  (and-map symbol? name)
+                  (not (null? name))
+                  (not (eq? (car name) 'quote)))
+             (cond ((module-commentary name)
+                    => (lambda (doc)
+                         (display name) (write-line " commentary:")
+                         (write-line doc)))
+                   (else (not-found 'commentary name))))
+
+            ;; unrecognized
+            (else
+             (help-usage)))
+           '(begin)))))
+
+(define (module-filename name)          ; fixme: better way? / done elsewhere?
+  (let* ((name (map symbol->string name))
+         (reverse-name (reverse name))
+	 (leaf (car reverse-name))
+	 (dir-hint-module-name (reverse (cdr reverse-name)))
+	 (dir-hint (apply string-append
+                          (map (lambda (elt)
+                                 (string-append elt "/"))
+                               dir-hint-module-name))))
+    (%search-load-path (in-vicinity dir-hint leaf))))
+
+(define (module-commentary name)
+  (cond ((module-filename name) => file-commentary)
+        (else #f)))
+
+(define (help-doc term regexp)
+  (let ((entries (apropos-fold (lambda (module name object data)
+				 (cons (list module
+					     name
+					     (try-value-help name object)
+					     (cond ((procedure? object)
+						    "a procedure")
+						   (else
+						    "an object")))
+				       data))
+			       '()
+			       regexp
+			       apropos-fold-exported))
+	(module car)
+	(name cadr)
+	(doc caddr)
+	(type cadddr))
+    (cond ((not (null? entries))
+           (let ((first? #t)
+                 (undocumented-entries '())
+                 (documented-entries '())
+                 (documentations '()))
+
+             (for-each (lambda (entry)
+                         (let ((entry-summary (simple-format
+                                               #f "~S: ~S\n"
+                                               (module-name (module entry))
+                                               (name entry))))
+                           (if (doc entry)
+                               (begin
+                                 (set! documented-entries
+                                       (cons entry-summary documented-entries))
+                                 ;; *fixme*: Use `describe' when we have GOOPS?
+                                 (set! documentations
+                                       (cons (simple-format
+                                              #f "`~S' is ~A in the ~S module.\n\n~A\n"
+                                              (name entry)
+                                              (type entry)
+                                              (module-name (module entry))
+                                              (doc entry))
+                                             documentations)))
+                               (set! undocumented-entries
+                                     (cons entry-summary
+                                           undocumented-entries)))))
+                       entries)
+
+             (if (and (not (null? documented-entries))
+                      (or (> (length documented-entries) 1)
+                          (not (null? undocumented-entries))))
+                 (begin
+                   (display "Documentation found for:\n")
+                   (for-each (lambda (entry) (display entry))
+                             documented-entries)
+                   (set! first? #f)))
+
+             (for-each (lambda (entry)
+                         (if first?
+                             (set! first? #f)
+                             (newline))
+                         (display entry))
+                       documentations)
+
+             (if (not (null? undocumented-entries))
+                 (begin
+                   (if first?
+                       (set! first? #f)
+                       (newline))
+                   (display "No documentation found for:\n")
+                   (for-each (lambda (entry) (display entry))
+                             undocumented-entries)))))
+          ((search-documentation-files term)
+           => (lambda (doc)
+                (write-line "Documentation from file:")
+                (write-line doc)))
+          (else
+           ;; no matches
+           (display "Did not find any object ")
+           (simple-format #t
+                          (if (symbol? term)
+                              "named `~A'\n"
+                              "matching regexp \"~A\"\n")
+                          term)))))
+
+(define (help-usage)
+  (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
+       (help REGEXP) ditto for objects with names matching REGEXP (a string)
+       (help 'NAME) gives documentation for NAME, even if it is not an object
+       (help ,EXPR) gives documentation for object returned by EXPR
+       (help (my module)) gives module commentary for `(my module)'
+       (help) gives this text
+
+`help' searches among bindings exported from loaded modules, while
+`apropos' searches among bindings visible from the \"current\" module.
+
+Examples: (help help)
+          (help cons)
+          (help \"output-string\")
+
+Other useful sources of helpful information:
+
+(apropos STRING)
+(arity PROCEDURE)
+(name PROCEDURE-OR-MACRO)
+(source PROCEDURE-OR-MACRO)
+
+Tools:
+
+(backtrace)				;show backtrace from last error
+(debug)					;enter the debugger
+(trace [PROCEDURE])			;trace procedure (no arg => show)
+(untrace [PROCEDURE])			;untrace (no arg => untrace all)
+
+(OPTIONSET-options 'full)		;display option information
+(OPTIONSET-enable 'OPTION)
+(OPTIONSET-disable 'OPTION)
+(OPTIONSET-set! OPTION VALUE)
+
+where OPTIONSET is one of debug, read, eval, print
+
+"))
+
+;;; {Apropos}
+;;;
+;;; Author: Roland Orre <orre@nada.kth.se>
+;;;
+
+;; Two arguments: the module, and the pattern, as a string.
+;;
+(define apropos-hook (make-hook 2))
+
+(define (apropos rgx . options)
+  "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
+  (run-hook apropos-hook (current-module) rgx)
+  (if (zero? (string-length rgx))
+      "Empty string not allowed"
+      (let* ((match (make-regexp rgx))
+	     (uses (module-uses (current-module)))
+	     (modules (cons (current-module)
+			    (if (and (not (null? uses))
+				     (eq? (module-name (car uses))
+					  'duplicates))
+				(cdr uses)
+				uses)))
+	     (separator #\tab)
+	     (shadow (member 'shadow options))
+	     (value (member 'value options)))
+	(cond ((member 'full options)
+	       (set! shadow #t)
+	       (set! value #t)))
+	(for-each
+	 (lambda (module)
+	   (let* ((name (module-name module))
+		  (obarray (module-obarray module)))
+	     ;; XXX - should use hash-fold here
+	     (hash-for-each
+	      (lambda (symbol variable)
+		(cond ((regexp-exec match (symbol->string symbol))
+		       (display name)
+		       (display ": ")
+		       (display symbol)
+		       (cond ((variable-bound? variable)
+			      (let ((val (variable-ref variable)))
+				(cond ((or (procedure? val) value)
+				       (display separator)
+				       (display val)))))
+			     (else
+			      (display separator)
+			      (display "(unbound)")))
+		       (if (and shadow
+				(not (eq? (module-ref module symbol)
+					  (module-ref (current-module) symbol))))
+			   (display " shadowed"))
+		       (newline))))
+	      obarray)))
+	 modules))))
+
+(define (apropos-internal rgx)
+  "Return a list of accessible variable names."
+  (apropos-fold (lambda (module name var data)
+		  (cons name data))
+		'()
+		rgx
+		(apropos-fold-accessible (current-module))))
+
+(define (apropos-fold proc init rgx folder)
+  "Folds PROCEDURE over bindings matching third arg REGEXP.
+
+Result is
+
+  (PROCEDURE MODULE1 NAME1 VALUE1
+    (PROCEDURE MODULE2 NAME2 VALUE2
+      ...
+      (PROCEDURE MODULEn NAMEn VALUEn INIT)))
+
+where INIT is the second arg to `apropos-fold'.
+
+Fourth arg FOLDER is one of
+
+  (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
+  apropos-fold-exported		   ;fold over all exported bindings
+  apropos-fold-all		   ;fold over all bindings"
+  (run-hook apropos-hook (current-module) rgx)
+  (let ((match (make-regexp rgx))
+	(recorded (make-hash-table)))
+    (let ((fold-module
+	   (lambda (module data)
+	     (let* ((obarray-filter
+		     (lambda (name val data)
+		       (if (and (regexp-exec match (symbol->string name))
+				(not (hashq-get-handle recorded name)))
+			   (begin
+			     (hashq-set! recorded name #t)
+			     (proc module name val data))
+			   data)))
+		    (module-filter
+		     (lambda (name var data)
+		       (if (variable-bound? var)
+			   (obarray-filter name (variable-ref var) data)
+			   data))))
+	       (cond (module (hash-fold module-filter
+					data
+					(module-obarray module)))
+		     (else data))))))
+      (folder fold-module init))))
+
+(define (make-fold-modules init-thunk traverse extract)
+  "Return procedure capable of traversing a forest of modules.
+The forest traversed is the image of the forest generated by root
+modules returned by INIT-THUNK and the generator TRAVERSE.
+It is an image under the mapping EXTRACT."
+  (lambda (fold-module init)
+    (let* ((table (make-hash-table 31))
+	   (first? (lambda (obj)
+		     (let* ((handle (hash-create-handle! table obj #t))
+			    (first? (cdr handle)))
+		       (set-cdr! handle #f)
+		       first?))))
+      (let rec ((data init)
+		(modules (init-thunk)))
+	(do ((modules modules (cdr modules))
+	     (data data (if (first? (car modules))
+			    (rec (fold-module (extract (car modules)) data)
+				 (traverse (car modules)))
+			    data)))
+	    ((null? modules) data))))))
+
+(define (apropos-fold-accessible module)
+  (make-fold-modules (lambda () (list module))
+		     module-uses
+		     identity))
+
+(define (root-modules)
+  (submodules (resolve-module '() #f)))
+
+(define (submodules mod)
+  (hash-map->list (lambda (k v) v) (module-submodules mod)))
+
+(define apropos-fold-exported
+  (make-fold-modules root-modules submodules module-public-interface))
+
+(define apropos-fold-all
+  (make-fold-modules root-modules submodules identity))
+
+(define (source obj)
+  (cond ((procedure? obj) (procedure-source obj))
+	((macro? obj) (procedure-source (macro-transformer obj)))
+	(else #f)))
+
+(define (arity obj)
+  (define (display-arg-list arg-list)
+    (display #\`)
+    (display (car arg-list))
+    (let loop ((ls (cdr arg-list)))
+      (cond ((null? ls)
+	     (display #\'))
+	    ((not (pair? ls))
+	     (display "', the rest in `")
+	     (display ls)
+	     (display #\'))
+	    (else
+	     (if (pair? (cdr ls))
+		 (display "', `")
+		 (display "' and `"))
+	     (display (car ls))
+	     (loop (cdr ls))))))
+  (define (display-arg-list/summary arg-list type)
+    (let ((len (length arg-list)))
+      (display len)
+      (display " ")
+      (display type)
+      (if (> len 1)
+	  (display " arguments: ")
+	  (display " argument: "))
+      (display-arg-list arg-list)))
+  (cond
+   ((procedure-property obj 'arglist)
+    => (lambda (arglist)
+	 (let ((required-args (car arglist))
+	       (optional-args (cadr arglist))
+	       (keyword-args (caddr arglist))
+	       (allow-other-keys? (cadddr arglist))
+	       (rest-arg (car (cddddr arglist)))
+	       (need-punctuation #f))
+	   (cond ((not (null? required-args))
+		  (display-arg-list/summary required-args "required")
+		  (set! need-punctuation #t)))
+	   (cond ((not (null? optional-args))
+		  (if need-punctuation (display ", "))
+		  (display-arg-list/summary optional-args "optional")
+		  (set! need-punctuation #t)))
+	   (cond ((not (null? keyword-args))
+		  (if need-punctuation (display ", "))
+		  (display-arg-list/summary keyword-args "keyword")
+		  (set! need-punctuation #t)))
+	   (cond (allow-other-keys?
+		  (if need-punctuation (display ", "))
+		  (display "other keywords allowed")
+		  (set! need-punctuation #t)))
+	   (cond (rest-arg
+		  (if need-punctuation (display ", "))
+		  (display "the rest in `")
+		  (display rest-arg)
+		  (display "'"))))))
+   (else
+    (let ((arity (procedure-minimum-arity obj)))
+      (display (car arity))
+      (cond ((caddr arity)
+	     (display " or more"))
+	    ((not (zero? (cadr arity)))
+	     (display " required and ")
+	     (display (cadr arity))
+	     (display " optional")))
+      (if (and (not (caddr arity))
+	       (= (car arity) 1)
+	       (<= (cadr arity) 1))
+	  (display " argument")
+	  (display " arguments")))))
+  (display ".\n"))
+
+
+(define (procedure-arguments proc)
+  "Return an alist describing the arguments that `proc' accepts, or `#f'
+if the information cannot be obtained.
+
+The alist keys that are currently defined are `required', `optional',
+`keyword', `allow-other-keys?', and `rest'."
+  (cond
+   ((procedure-property proc 'arglist)
+    => (match-lambda
+        ((req opt keyword aok? rest)
+         `((required . ,(if (number? req)
+                            (make-list req '_)
+                            req))
+           (optional . ,(if (number? opt)
+                            (make-list opt '_)
+                            opt))
+           (keyword . ,keyword)
+           (allow-other-keys? . ,aok?)
+           (rest . ,rest)))))
+   ((procedure-source proc)
+    => cadr)
+   (((@ (system vm program) program?) proc)
+    ((@ (system vm program) program-arguments-alist) proc))
+   (else #f)))
+
+
+;;; session.scm ends here
+;;;; slib.scm --- definitions needed to get SLIB to work with Guile
+;;;;
+;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 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
+;;;;
+
+;;; Look for slib.init in the $datadir, in /usr/share, and finally in
+;;; the load path.  It's not usually in the load path on common distros,
+;;; but it could be if the user put it there.  The init file takes care
+;;; of defining the module.
+
+(let ((try-load (lambda (dir)
+                  (let ((init (string-append dir "/slib/guile.init")))
+                    (and (file-exists? init)
+                         (begin
+                           (load init)
+                           #t))))))
+  (or (try-load (assq-ref %guile-build-info 'datadir))
+      (try-load "/usr/share")
+      (load-from-path "slib/guile.init")))
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 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 stack-catch)
+  #\use-module (ice-9 save-stack)
+  #\export (stack-catch))
+
+(define (stack-catch key thunk handler)
+  "Like @code{catch}, invoke @var{thunk} in the dynamic context of
+@var{handler} for exceptions matching @var{key}, but also save the
+current stack state in the @var{the-last-stack} fluid, for the purpose
+of debugging or re-throwing of an error.  If thunk throws to the
+symbol @var{key}, then @var{handler} is invoked this way:\n
+@example
+ (handler key args ...)
+@end example\n
+@var{key} is a symbol or #t.\n
+@var{thunk} takes no arguments.  If @var{thunk} returns normally, that
+is the return value of @code{catch}.\n
+Handler is invoked outside the scope of its own @code{catch}.  If
+@var{handler} again throws to the same key, a new handler from further
+up the call chain is invoked.\n
+If the key is @code{#t}, then a throw to @emph{any} symbol will match
+this call to @code{catch}."
+  (catch key
+	 thunk
+	 handler
+	 (lambda (key . args)
+           ;; Narrow by two more frames: this one, and the throw handler.
+           (save-stack 2)
+           (apply throw key args))))
+;;;; streams.scm --- general lazy streams
+;;;; -*- Scheme -*-
+
+;;;; Copyright (C) 1999, 2001, 2004, 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
+
+;; the basic stream operations are inspired by
+;; (i.e. ripped off) Scheme48's `stream' package,
+;; modulo stream-empty? -> stream-null? renaming.
+
+(define-module (ice-9 streams)
+  \:export (make-stream
+	   stream-car stream-cdr stream-null?
+	   list->stream vector->stream port->stream
+	   stream->list stream->reversed-list
+	   stream->list&length stream->reversed-list&length
+	   stream->vector
+	   stream-fold stream-for-each stream-map))
+
+;; Use:
+;;
+;; (make-stream producer initial-state)
+;;  - PRODUCER is a function of one argument, the current state.
+;;    it should return either a pair or an atom (i.e. anything that
+;;    is not a pair).  if PRODUCER returns a pair, then the car of the pair
+;;    is the stream's head value, and the cdr is the state to be fed
+;;    to PRODUCER later.  if PRODUCER returns an atom, then the stream is
+;;    considered depleted.
+;;
+;; (stream-car stream)
+;; (stream-cdr stream)
+;; (stream-null? stream)
+;;  - yes.
+;;
+;; (list->stream list)
+;; (vector->stream vector)
+;;  - make a stream with the same contents as LIST/VECTOR.
+;;
+;; (port->stream port read)
+;;  - makes a stream of values which are obtained by READing from PORT.
+;;
+;; (stream->list stream)
+;;  - returns a list with the same contents as STREAM.
+;;
+;; (stream->reversed-list stream)
+;;  - as above, except the contents are in reversed order.
+;;
+;; (stream->list&length stream)
+;; (stream->reversed-list&length stream)
+;;  - multiple-valued versions of the above two, the second value is the
+;;    length of the resulting list (so you get it for free).
+;;
+;; (stream->vector stream)
+;;  - yes.
+;;
+;; (stream-fold proc init stream0 ...)
+;;  - PROC must take (+ 1 <number-of-stream-arguments>) arguments, like this:
+;;    (PROC car0 ... init).  *NOTE*: the INIT argument is last, not first.
+;;    I don't have any preference either way, but it's consistent with
+;;    `fold[lr]' procedures from SRFI-1.  PROC is applied to successive
+;;    elements of the given STREAM(s) and to the value of the previous
+;;    invocation (INIT on the first invocation).  the last result from PROC
+;;    is returned.
+;;
+;; (stream-for-each proc stream0 ...)
+;;  - like `for-each' we all know and love.
+;;
+;; (stream-map proc stream0 ...)
+;;  - like `map', except returns a stream of results, and not a list.
+
+;; Code:
+
+(define (make-stream m state)
+  (delay
+    (let ((o (m state)))
+      (if (pair? o)
+	  (cons (car o)
+		(make-stream m (cdr o)))
+          '()))))
+
+(define (stream-car stream)
+  "Returns the first element in STREAM.  This is equivalent to `car'."
+  (car (force stream)))
+
+(define (stream-cdr stream)
+  "Returns the first tail of STREAM. Equivalent to `(force (cdr STREAM))'."
+  (cdr (force stream)))
+
+(define (stream-null? stream)
+  "Returns `#t' if STREAM is the end-of-stream marker; otherwise
+returns `#f'.  This is equivalent to `null?', but should be used
+whenever testing for the end of a stream."
+  (null? (force stream)))
+
+(define (list->stream l)
+  "Returns a newly allocated stream whose elements are the elements of
+LIST.  Equivalent to `(apply stream LIST)'."
+  (make-stream
+   (lambda (l) l)
+   l))
+
+(define (vector->stream v)
+  (make-stream
+   (let ((len (vector-length v)))
+     (lambda (i)
+       (or (= i len)
+           (cons (vector-ref v i) (+ 1 i)))))
+   0))
+
+(define (stream->reversed-list&length stream)
+  (let loop ((s stream) (acc '()) (len 0))
+    (if (stream-null? s)
+        (values acc len)
+        (loop (stream-cdr s) (cons (stream-car s) acc) (+ 1 len)))))
+
+(define (stream->reversed-list stream)
+  (call-with-values
+   (lambda () (stream->reversed-list&length stream))
+   (lambda (l len) l)))
+
+(define (stream->list&length stream)
+  (call-with-values
+   (lambda () (stream->reversed-list&length stream))
+   (lambda (l len) (values (reverse! l) len))))
+
+(define (stream->list stream)
+  "Returns a newly allocated list whose elements are the elements of STREAM.
+If STREAM has infinite length this procedure will not terminate."
+  (reverse! (stream->reversed-list stream)))
+
+(define (stream->vector stream)
+  (call-with-values
+   (lambda () (stream->reversed-list&length stream))
+   (lambda (l len)
+     (let ((v (make-vector len)))
+       (let loop ((i 0) (l l))
+         (if (not (null? l))
+             (begin
+               (vector-set! v (- len i 1) (car l))
+               (loop (+ 1 i) (cdr l)))))
+       v))))
+
+(define (stream-fold f init stream . rest)
+  (if (null? rest) ;fast path
+      (stream-fold-one f init stream)
+      (stream-fold-many f init (cons stream rest))))
+
+(define (stream-fold-one f r stream)
+  (if (stream-null? stream)
+      r
+      (stream-fold-one f (f (stream-car stream) r) (stream-cdr stream))))
+
+(define (stream-fold-many f r streams)
+  (if (or-map stream-null? streams)
+      r
+      (stream-fold-many f
+                        (apply f (let recur ((cars
+                                              (map stream-car streams)))
+                                   (if (null? cars)
+                                       (list r)
+                                       (cons (car cars)
+                                             (recur (cdr cars))))))
+                        (map stream-cdr streams))))
+
+(define (stream-for-each f stream . rest)
+  (if (null? rest) ;fast path
+      (stream-for-each-one f stream)
+      (stream-for-each-many f (cons stream rest))))
+
+(define (stream-for-each-one f stream)
+  (if (not (stream-null? stream))
+      (begin
+        (f (stream-car stream))
+        (stream-for-each-one f (stream-cdr stream)))))
+
+(define (stream-for-each-many f streams)
+  (if (not (or-map stream-null? streams))
+      (begin
+        (apply f (map stream-car streams))
+        (stream-for-each-many f (map stream-cdr streams)))))
+
+(define (stream-map f stream . rest)
+  "Returns a newly allocated stream, each element being the result of
+invoking F with the corresponding elements of the STREAMs
+as its arguments."
+  (if (null? rest) ;fast path
+      (make-stream (lambda (s)
+                     (or (stream-null? s)
+                         (cons (f (stream-car s)) (stream-cdr s))))
+                   stream)
+      (make-stream (lambda (streams)
+                     (or (or-map stream-null? streams)
+                         (cons (apply f (map stream-car streams))
+                               (map stream-cdr streams))))
+                   (cons stream rest))))
+
+(define (port->stream port read)
+  (make-stream (lambda (p)
+                 (let ((o (read p)))
+                   (or (eof-object? o)
+                       (cons o p))))
+               port))
+
+;;; streams.scm ends here
+;;;; string-fun.scm --- string manipulation functions
+;;;;
+;;;; 	Copyright (C) 1995, 1996, 1997, 1999, 2001, 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 string-fun)
+  \:export (split-after-char split-before-char split-discarding-char
+	   split-after-char-last split-before-char-last
+	   split-discarding-char-last split-before-predicate
+	   split-after-predicate split-discarding-predicate
+	   separate-fields-discarding-char separate-fields-after-char
+	   separate-fields-before-char string-prefix-predicate string-prefix=?
+	   sans-surrounding-whitespace sans-trailing-whitespace
+	   sans-leading-whitespace sans-final-newline has-trailing-newline?))
+
+;;;;
+;;;
+;;; Various string funcitons, particularly those that take
+;;; advantage of the "shared substring" capability.
+;;;
+
+;;; {String Fun: Dividing Strings Into Fields}
+;;; 
+;;; The names of these functions are very regular.
+;;; Here is a grammar of a call to one of these:
+;;;
+;;;   <string-function-invocation>
+;;;   := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
+;;;
+;;; <str>    = the string
+;;;
+;;; <ret>    = The continuation.  String functions generally return
+;;;	       multiple values by passing them to this procedure.
+;;;
+;;; <action> =    split
+;;;		| separate-fields
+;;;
+;;;		"split" means to divide a string into two parts.
+;;;			<ret> will be called with two arguments.
+;;;
+;;;		"separate-fields" means to divide a string into as many
+;;;			parts as possible.  <ret> will be called with
+;;;			however many fields are found.
+;;;
+;;; <seperator-disposition> = 	  before
+;;;				| after
+;;;				| discarding
+;;;
+;;;		"before" means to leave the seperator attached to
+;;;			the beginning of the field to its right.
+;;;		"after" means to leave the seperator attached to
+;;;			the end of the field to its left.
+;;;		"discarding" means to discard seperators.
+;;;
+;;;		Other dispositions might be handy.  For example, "isolate"
+;;;		could mean to treat the separator as a field unto itself.
+;;;
+;;; <seperator-determination> =	  char
+;;;				| predicate
+;;;
+;;;		"char" means to use a particular character as field seperator.
+;;;		"predicate" means to check each character using a particular predicate.
+;;;		
+;;;		Other determinations might be handy.  For example, "character-set-member".
+;;;
+;;; <seperator-param> = A parameter that completes the meaning of the determinations.
+;;;			For example, if the determination is "char", then this parameter
+;;;			says which character.  If it is "predicate", the parameter is the
+;;;			predicate.
+;;;
+;;;
+;;; For example:
+;;;
+;;;		(separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
+;;;		=> ("foo" " bar" " baz" " " " bat")
+;;;
+;;;		(split-after-char #\- 'an-example-of-split list)
+;;;		=> ("an-" "example-of-split")
+;;;
+;;; As an alternative to using a determination "predicate", or to trying to do anything
+;;; complicated with these functions, consider using regular expressions.
+;;;
+
+(define (split-after-char char str ret)
+  (let ((end (cond
+	      ((string-index str char) => 1+)
+	      (else (string-length str)))))
+    (ret (substring str 0 end)
+	 (substring str end))))
+
+(define (split-before-char char str ret)
+  (let ((end (or (string-index str char)
+		 (string-length str))))
+    (ret (substring str 0 end)
+	 (substring str end))))
+
+(define (split-discarding-char char str ret)
+  (let ((end (string-index str char)))
+    (if (not end)
+	(ret str "")
+	(ret (substring str 0 end)
+	     (substring str (1+ end))))))
+
+(define (split-after-char-last char str ret)
+  (let ((end (cond
+	      ((string-rindex str char) => 1+)
+	      (else 0))))
+    (ret (substring str 0 end)
+	 (substring str end))))
+
+(define (split-before-char-last char str ret)
+  (let ((end (or (string-rindex str char) 0)))
+    (ret (substring str 0 end)
+	 (substring str end))))
+
+(define (split-discarding-char-last char str ret)
+  (let ((end (string-rindex str char)))
+    (if (not end)
+	(ret str "")
+	(ret (substring str 0 end)
+	     (substring str (1+ end))))))
+
+(define (split-before-predicate pred str ret)
+  (let loop ((n 0))
+    (cond
+     ((= n (string-length str))		(ret str ""))
+     ((not (pred (string-ref str n)))	(loop (1+ n)))
+     (else				(ret (substring str 0 n)
+					     (substring str n))))))
+(define (split-after-predicate pred str ret)
+  (let loop ((n 0))
+    (cond
+     ((= n (string-length str))		(ret str ""))
+     ((not (pred (string-ref str n)))	(loop (1+ n)))
+     (else				(ret (substring str 0 (1+ n))
+					     (substring str (1+ n)))))))
+
+(define (split-discarding-predicate pred str ret)
+  (let loop ((n 0))
+    (cond
+     ((= n (string-length str))		(ret str ""))
+     ((not (pred (string-ref str n)))	(loop (1+ n)))
+     (else				(ret (substring str 0 n)
+					     (substring str (1+ n)))))))
+
+(define (separate-fields-discarding-char ch str ret)
+  (let loop ((fields '())
+	     (str str))
+    (cond
+     ((string-rindex str ch)
+      => (lambda (w) (loop (cons (substring str (+ 1 w)) fields)
+			   (substring str 0 w))))
+     (else (apply ret str fields)))))
+
+(define (separate-fields-after-char ch str ret)
+  (reverse
+   (let loop ((fields '())
+             (str str))
+     (cond
+      ((string-index str ch)
+       => (lambda (w) (loop (cons (substring str 0 (+ 1 w)) fields)
+                           (substring str (+ 1 w)))))
+      (else (apply ret str fields))))))
+
+(define (separate-fields-before-char ch str ret)
+  (let loop ((fields '())
+	     (str str))
+    (cond
+     ((string-rindex str ch)
+      => (lambda (w) (loop (cons (substring str w) fields)
+			     (substring str 0 w))))
+     (else (apply ret str fields)))))
+
+
+;;; {String Fun: String Prefix Predicates}
+;;;
+;;; Very simple:
+;;;
+;;; (define-public ((string-prefix-predicate pred?) prefix str)
+;;;  (and (<= (string-length prefix) (string-length str))
+;;;	  (pred? prefix (substring str 0 (string-length prefix)))))
+;;;
+;;; (define-public string-prefix=? (string-prefix-predicate string=?))
+;;;
+
+(define (string-prefix-predicate pred?)
+  (lambda (prefix str)
+    (and (<= (string-length prefix) (string-length str))
+         (pred? prefix (substring str 0 (string-length prefix))))))
+
+(define string-prefix=? (string-prefix-predicate string=?))
+
+
+;;; {String Fun: Strippers}
+;;;
+;;; <stripper> = sans-<removable-part>
+;;;
+;;; <removable-part> = 	  surrounding-whitespace
+;;;			| trailing-whitespace
+;;;			| leading-whitespace
+;;;			| final-newline
+;;;
+
+(define (sans-surrounding-whitespace s)
+  (let ((st 0)
+	(end (string-length s)))
+    (while (and (< st (string-length s))
+		(char-whitespace? (string-ref s st)))
+	   (set! st (1+ st)))
+    (while (and (< 0 end)
+		(char-whitespace? (string-ref s (1- end))))
+	   (set! end (1- end)))
+    (if (< end st)
+	""
+	(substring s st end))))
+
+(define (sans-trailing-whitespace s)
+  (let ((st 0)
+	(end (string-length s)))
+    (while (and (< 0 end)
+		(char-whitespace? (string-ref s (1- end))))
+	   (set! end (1- end)))
+    (if (< end st)
+	""
+	(substring s st end))))
+
+(define (sans-leading-whitespace s)
+  (let ((st 0)
+	(end (string-length s)))
+    (while (and (< st (string-length s))
+		(char-whitespace? (string-ref s st)))
+	   (set! st (1+ st)))
+    (if (< end st)
+	""
+	(substring s st end))))
+
+(define (sans-final-newline str)
+  (cond
+   ((= 0 (string-length str))
+    str)
+
+   ((char=? #\nl (string-ref str (1- (string-length str))))
+    (substring str 0 (1- (string-length str))))
+
+   (else str)))
+
+;;; {String Fun: has-trailing-newline?}
+;;;
+
+(define (has-trailing-newline? str)
+  (and (< 0 (string-length str))
+       (char=? #\nl (string-ref str (1- (string-length str))))))
+
+
+
+;;; {String Fun: with-regexp-parts}
+
+;;; This relies on the older, hairier regexp interface, which we don't
+;;; particularly want to implement, and it's not used anywhere, so
+;;; we're just going to drop it for now.
+;;; (define-public (with-regexp-parts regexp fields str return fail)
+;;;   (let ((parts (regexec regexp str fields)))
+;;;     (if (number? parts)
+;;;         (fail parts)
+;;;         (apply return parts))))
+
+;;;; 	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))))
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 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
+
+;;;; "test.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
+;;; won't pass.  Made the tests (test-cont), (test-sc4), and
+;;; (test-delay) start to run automatically.
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named
+;;; "test.scm", so you'll have to run it from the ice-9 source
+;;; directory, or copy this file elsewhere
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests.  You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;;   There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;; 
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;; 
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;;   either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+		  (display "SECTION") (write args) (newline)
+		  (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+  (lambda (expect fun . args)
+    (write (cons fun args))
+    (display "  ==> ")
+    ((lambda (res)
+      (write res)
+      (newline)
+      (cond ((not (equal? expect res))
+	     (record-error (list res expect (cons fun args)))
+	     (display " BUT EXPECTED ")
+	     (write expect)
+	     (newline)
+	     #f)
+	    (else #t)))
+     (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+  (newline)
+  (if (null? errs) (display "Passed all tests")
+      (begin
+	(display "errors were:")
+	(newline)
+	(display "(SECTION (got expected (call)))")
+	(newline)
+	(for-each (lambda (l) (write l) (newline))
+		  errs)))
+  (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+;'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+  (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+  (list
+   #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\space))
+		  (set! i (+ 3 i))
+		  (write x)
+		  (newline))
+	  disjoint-type-functions)
+(define type-matrix
+  (map (lambda (x)
+	 (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+	   (write t)
+	   (write x)
+	   (newline)
+	   t))
+       type-examples))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+  (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+  (let ((x 4))
+    (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+			   ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+			 ((< 3 3) 'less)
+			 (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+		     (else #f)))
+(test 'composite 'case (case (* 2 3)
+			 ((2 3 5 7) 'prime)
+			 ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+			 ((a e i o u) 'vowel)
+			 ((w y) 'semivowel)
+			 (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+			   (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+			  (odd?
+			   (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+		   (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+			    (i 0 (+ i 1)))
+			   ((= i 5) vec)
+			 (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+	       (do ((x x (cdr x))
+		    (sum 0 (+ sum (car x))))
+		   ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+      (let loop ((numbers '(3 -2 1 6 -5))
+		 (nonneg '())
+		 (neg '()))
+	(cond ((null? numbers) (list nonneg neg))
+	      ((negative? (car numbers))
+	       (loop (cdr numbers)
+		     nonneg
+		     (cons (car numbers) neg)))
+	      (else
+	       (loop (cdr numbers)
+		     (cons (car numbers) nonneg)
+		     neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+	'quasiquote
+	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it. 
+(define (sqt x)
+	(do ((i 0 (+ i 1)))
+	    ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+	(let ((x 5))
+		(define foo (lambda (y) (bar x y)))
+		(define bar (lambda (a b) (+ (* a b) a)))
+		(foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+  (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+   (let ((n 0))
+      (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+	 (g (lambda () (if (eqv? f g) 'g 'both))))
+  (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in?  Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+    (set! char-standard-case char-downcase))
+;;; Not for Guile
+;(test #t 'standard-case
+;      (string=? (symbol->string 'a) (symbol->string 'A)))
+;(test #t 'standard-case
+;      (or (string=? (symbol->string 'a) "A")
+;	  (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+  (let ((v (make-string (string-length s))))
+    (do ((i (- (string-length v) 1) (- i 1)))
+	((< i 0) v)
+      (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+  (set! s (str-copy s))
+  (do ((i 0 (+ 1 i))
+       (sl (string-length s)))
+      ((>= i sl) s)
+      (string-set! s i (char-standard-case (string-ref s i)))))
+;;; Not for Guile
+;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+;(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+;;; Not for Guile
+;(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+;;; Not for Guile
+;(test #t eq? 'mISSISSIppi 'mississippi)
+;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3  5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+	(= n1 (+ (* n2 (quotient n1 n2))
+		 (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+  (define f3.9 (string->number "3.9"))
+  (define f4.0 (string->number "4.0"))
+  (define f-3.25 (string->number "-3.25"))
+  (define f.25 (string->number ".25"))
+  (define f4.5 (string->number "4.5"))
+  (define f3.5 (string->number "3.5"))
+  (define f0.0 (string->number "0.0"))
+  (define f0.8 (string->number "0.8"))
+  (define f1.0 (string->number "1.0"))
+  (define wto write-test-obj)
+  (define dto display-test-obj)
+  (define lto load-test-obj)
+  (newline)
+  (display ";testing inexact numbers; ")
+  (newline)
+  (SECTION 6 5 5)
+  (test #t inexact? f3.9)
+  (test #t 'inexact? (inexact? (max f3.9 4)))
+  (test f4.0 'max (max f3.9 4))
+  (test f4.0 'exact->inexact (exact->inexact 4))
+  (test (- f4.0) round (- f4.5))
+  (test (- f4.0) round (- f3.5))
+  (test (- f4.0) round (- f3.9))
+  (test f0.0 round f0.0)
+  (test f0.0 round f.25)
+  (test f1.0 round f0.8)
+  (test f4.0 round f3.5)
+  (test f4.0 round f4.5)
+  (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+  (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+  (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+  (test #t call-with-output-file
+      "tmp3"
+      (lambda (test-file)
+	(write-char #\; test-file)
+	(display write-test-obj test-file)
+	(newline test-file)
+	(write load-test-obj test-file)
+	(output-port? test-file)))
+  (check-test-file "tmp3")
+  (set! write-test-obj wto)
+  (set! display-test-obj dto)
+  (set! load-test-obj lto)
+  (let ((x (string->number "4195835.0"))
+	(y (string->number "3145727.0")))
+    (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+  (report-errs))
+
+(define (test-bignum)
+  (define tb
+    (lambda (n1 n2)
+      (= n1 (+ (* n2 (quotient n1 n2))
+	       (remainder n1 n2)))))
+  (newline)
+  (display ";testing bignums; ")
+  (newline)
+  (SECTION 6 5 5)
+  (test 0 modulo -2177452800 86400)
+  (test 0 modulo 2177452800 -86400)
+  (test 0 modulo 2177452800 86400)
+  (test 0 modulo -2177452800 -86400)
+  (test #t 'remainder (tb 281474976710655 65535))
+  (test #t 'remainder (tb 281474976710654 65535))
+  (SECTION 6 5 6)
+  (test 281474976710655 string->number "281474976710655")
+  (test "281474976710655" number->string 281474976710655)
+  (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\space #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\space)
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+	(let ((vec (vector 0 '(2 2 2 2) "Anna")))
+	  (vector-set! vec 1 '("Sue" "Sue"))
+	  vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+	(let ((v (make-vector 5)))
+		(for-each (lambda (i) (vector-set! v i (* i i)))
+			'(0 1 2 3 4))
+		v))
+(test -3 call-with-current-continuation
+		(lambda (exit)
+		 (for-each (lambda (x) (if (negative? x) (exit x)))
+		 	'(54 0 37 -3 245 19))
+		#t))
+(define list-length
+ (lambda (obj)
+  (call-with-current-continuation
+   (lambda (return)
+    (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+				((pair? obj) (+ (r (cdr obj)) 1))
+				(else (return #f))))))
+	(r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation.  It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures.  I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.  
+(define (next-leaf-generator obj eot)
+  (letrec ((return #f)
+	   (cont (lambda (x)
+		   (recur obj)
+		   (set! cont (lambda (x) (return eot)))
+		   (cont #f)))
+	   (recur (lambda (obj)
+		      (if (pair? obj)
+			  (for-each recur obj)
+			  (call-with-current-continuation
+			   (lambda (c)
+			     (set! cont c)
+			     (return obj)))))))
+    (lambda () (call-with-current-continuation
+		(lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+  (let* ((eot (list 'eot))
+	 (xf (next-leaf-generator x eot))
+	 (yf (next-leaf-generator y eot)))
+    (letrec ((loop (lambda (x y)
+		     (cond ((not (eq? x y)) #f)
+			   ((eq? eot x) #t)
+			   (else (loop (xf) (yf)))))))
+      (loop (xf) (yf)))))
+(define (test-cont)
+  (newline)
+  (display ";testing continuations; ")
+  (newline)
+  (SECTION 6 9)
+  (test #t leaf-eq? '(a (b (c))) '((a) b c))
+  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+  (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+  (newline)
+  (display ";testing DELAY and FORCE; ")
+  (newline)
+  (SECTION 6 9)
+  (test 3 'delay (force (delay (+ 1 2))))
+  (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+			(list (force p) (force p))))
+  (test 2 'delay (letrec ((a-stream
+			   (letrec ((next (lambda (n)
+					    (cons n (delay (next (+ n 1)))))))
+			     (next 0)))
+			  (head car)
+			  (tail (lambda (stream) (force (cdr stream)))))
+		   (head (tail (tail a-stream)))))
+  (letrec ((count 0)
+	   (p (delay (begin (set! count (+ count 1))
+			    (if (> count x)
+				count
+				(force p)))))
+	   (x 5))
+    (test 6 force p)
+    (set! x 10)
+    (test 6 force p))
+  (test 3 'force
+	(letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+		 (c #f))
+	  (force p)))
+  (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "test.scm" input-port?)
+(define this-file (open-input-file "test.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+  (define test-file (open-input-file name))
+  (test #t 'input-port?
+	(call-with-input-file
+	    name
+	  (lambda (test-file)
+	    (test load-test-obj read test-file)
+	    (test #t eof-object? (peek-char test-file))
+	    (test #t eof-object? (read-char test-file))
+	    (input-port? test-file))))
+  (test #\; read-char test-file)
+  (test display-test-obj read test-file)
+  (test load-test-obj read test-file)
+  (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+  '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+  '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+  (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+      "tmp1"
+      (lambda (test-file)
+	(write-char #\; test-file)
+	(display write-test-obj test-file)
+	(newline test-file)
+	(write load-test-obj test-file)
+	(output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+  (newline)
+  (display ";testing scheme 4 functions; ")
+  (newline)
+  (SECTION 6 7)
+  (test '(#\P #\space #\l) string->list "P l")
+  (test '() string->list "")
+  (test "1\\\"" list->string '(#\1 #\\ #\"))
+  (test "" list->string '())
+  (SECTION 6 8)
+  (test '(dah dah didah) vector->list '#(dah dah didah))
+  (test '() vector->list '#())
+  (test '#(dididit dah) list->vector '(dididit dah))
+  (test '#() list->vector '())
+  (SECTION 6 10 4)
+  (load "tmp1")
+  (test write-test-obj 'load foo)
+  (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+    (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+  (if (and n (exact? n))
+      (test-bignum)))
+(newline)
+(test-cont)
+(newline)
+(test-sc4)
+(newline)
+(test-delay)
+(newline)
+"last item in file"
+;;;; 	Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 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
+;;;;
+;;;; ----------------------------------------------------------------
+;;;; 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.
+;; Briefly, one procedure is exported: `%thread-handler';
+;; as well as four macros: `make-thread', `begin-thread',
+;; `with-mutex' and `monitor'.
+
+;;; Code:
+
+(define-module (ice-9 threads)
+  #\use-module (ice-9 futures)
+  #\use-module (ice-9 match)
+  #\export (begin-thread
+            parallel
+            letpar
+            make-thread
+            with-mutex
+            monitor
+
+            par-map
+            par-for-each
+            n-par-map
+            n-par-for-each
+            n-for-each-par-map
+            %thread-handler))
+
+
+
+;;; 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 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-syntax-rule (make-thread proc arg ...)
+  (call-with-new-thread
+   (lambda () (proc arg ...))
+   %thread-handler))
+
+(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-syntax-rule (monitor first rest ...)
+  (with-mutex (make-mutex)
+    first rest ...))
+
+(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)))))
+
+(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)
+
+;;; threads.scm ends here
+;;;; 	Copyright (C) 2001, 2004, 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 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))
+         (result (proc))
+         (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))
+    result))
+
+(define-macro (time exp)
+  `((@@ (ice-9 time) time-proc) (lambda () ,exp)))
+
+;;; time.scm ends here
+;;; -*- 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)))))
+;; 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"))
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2009, 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 vlist)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (srfi srfi-26)
+  #\use-module (ice-9 format)
+
+  #\export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
+            vlist-null list->vlist vlist-ref vlist-drop vlist-take
+            vlist-length vlist-fold vlist-fold-right vlist-map
+            vlist-unfold vlist-unfold-right vlist-append
+            vlist-reverse vlist-filter vlist-delete vlist->list
+            vlist-for-each
+            block-growth-factor
+
+            vhash? vhash-cons vhash-consq vhash-consv
+            vhash-assoc vhash-assq vhash-assv
+            vhash-delete vhash-delq vhash-delv
+            vhash-fold vhash-fold-right
+            vhash-fold* vhash-foldq* vhash-foldv*
+            alist->vhash))
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; Commentary:
+;;;
+;;; This module provides an implementations of vlists, a functional list-like
+;;; data structure described by Phil Bagwell in "Fast Functional Lists,
+;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report,
+;;; 2002.
+;;;
+;;; The idea is to store vlist elements in increasingly large contiguous blocks
+;;; (implemented as vectors here).  These blocks are linked to one another using
+;;; a pointer to the next block (called `block-base' here) and an offset within
+;;; that block (`block-offset' here).  The size of these blocks form a geometric
+;;; series with ratio `block-growth-factor'.
+;;;
+;;; In the best case (e.g., using a vlist returned by `list->vlist'),
+;;; elements from the first half of an N-element vlist are accessed in O(1)
+;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only
+;;; O(ln(N)).  Furthermore, the data structure improves data locality since
+;;; vlist elements are adjacent, which plays well with caches.
+;;;
+;;; Code:
+
+
+;;;
+;;; VList Blocks and Block Descriptors.
+;;;
+
+(define block-growth-factor
+  (make-fluid 2))
+
+(define-inlinable (make-block base offset size hash-tab?)
+  ;; Return a block (and block descriptor) of SIZE elements pointing to
+  ;; BASE at OFFSET.  If HASH-TAB? is true, we also reserve space for a
+  ;; "hash table".  Note: We use `next-free' instead of `last-used' as
+  ;; suggested by Bagwell.
+  (if hash-tab?
+      (vector (make-vector (* size 3) #f)
+              base offset size 0)
+      (vector (make-vector size)
+              base offset size 0)))
+
+(define-syntax-rule (define-block-accessor name index)
+  (define-inlinable (name block)
+    (vector-ref block index)))
+
+(define-block-accessor block-content 0)
+(define-block-accessor block-base 1)
+(define-block-accessor block-offset 2)
+(define-block-accessor block-size 3)
+(define-block-accessor block-next-free 4)
+
+(define-inlinable (block-hash-table? block)
+  (< (block-size block) (vector-length (block-content block))))
+
+(define-inlinable (set-block-next-free! block next-free)
+  (vector-set! block 4 next-free))
+
+(define-inlinable (block-append! block value offset)
+  ;; This is not thread-safe.  To fix it, see Section 2.8 of the paper.
+  (and (< offset (block-size block))
+       (= offset (block-next-free block))
+       (begin
+         (set-block-next-free! block (1+ offset))
+         (vector-set! (block-content block) offset value)
+         #t)))
+
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+  (vector-ref content offset))
+
+;; Return the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-next-offset content size offset)
+  (vector-ref content (+ size size offset)))
+
+;; Save the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-set-next-offset! content size offset
+                                                     next-offset)
+  (vector-set! content (+ size size offset) next-offset))
+
+;; Returns the index of the last entry stored in CONTENT with
+;; SIZE-modulo hash value KHASH.
+(define-inlinable (block-hash-table-ref content size khash)
+  (vector-ref content (+ size khash)))
+
+(define-inlinable (block-hash-table-set! content size khash offset)
+  (vector-set! content (+ size khash) offset))
+
+;; Add hash table information for the item recently added at OFFSET,
+;; with SIZE-modulo hash KHASH.
+(define-inlinable (block-hash-table-add! content size khash offset)
+  (block-hash-table-set-next-offset! content size offset
+                                     (block-hash-table-ref content size khash))
+  (block-hash-table-set! content size khash offset))
+
+(define block-null
+  ;; The null block.
+  (make-block #f 0 0 #f))
+
+
+;;;
+;;; VLists.
+;;;
+
+(define-record-type <vlist>
+  ;; A vlist is just a base+offset pair pointing to a block.
+
+  ;; XXX: Allocating a <vlist> record in addition to the block at each
+  ;; `vlist-cons' call is inefficient.  However, Bagwell's hack to avoid it
+  ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
+  ;; performance hit for everyone.
+  (make-vlist base offset)
+  vlist?
+  (base    vlist-base)
+  (offset  vlist-offset))
+
+(set-record-type-printer! <vlist>
+                          (lambda (vl port)
+                            (cond ((vlist-null? vl)
+                                   (format port "#<vlist ()>"))
+                                  ((vhash? vl)
+                                   (format port "#<vhash ~x ~a pairs>"
+                                           (object-address vl)
+                                           (vlist-length vl)))
+                                  (else
+                                   (format port "#<vlist ~a>"
+                                           (vlist->list vl))))))
+
+
+(define vlist-null
+  ;; The empty vlist.
+  (make-vlist block-null 0))
+
+;; Asserting that something is a vlist is actually a win if your next
+;; step is to call record accessors, because that causes CSE to
+;; eliminate the type checks in those accessors.
+;;
+(define-inlinable (assert-vlist val)
+  (unless (vlist? val)
+    (throw 'wrong-type-arg
+           #f
+           "Not a vlist: ~S"
+           (list val)
+           (list val))))
+
+(define-inlinable (block-cons item vlist hash-tab?)
+  (let ((base (vlist-base vlist))
+        (offset (1+ (vlist-offset vlist))))
+    (cond
+     ((block-append! base item offset)
+      ;; Fast path: We added the item directly to the block.
+      (make-vlist base offset))
+     (else
+      ;; Slow path: Allocate a new block.
+      (let* ((size (block-size base))
+             (base (make-block
+                    base
+                    (1- offset)
+                    (cond
+                     ((zero? size) 1)
+                     ((< offset size) 1) ;; new vlist head
+                     (else (* (fluid-ref block-growth-factor) size)))
+                    hash-tab?)))
+        (set-block-next-free! base 1)
+        (vector-set! (block-content base) 0 item)
+        (make-vlist base 0))))))
+
+(define (vlist-cons item vlist)
+  "Return a new vlist with ITEM as its head and VLIST as its
+tail."
+  ;; Note: Although the result of `vlist-cons' on a vhash is a valid
+  ;; vlist, it is not a valid vhash.  The new item does not get a hash
+  ;; table entry.  If we allocate a new block, the new block will not
+  ;; have a hash table.  Perhaps we can do something more sensible here,
+  ;; but this is a hot function, so there are performance impacts.
+  (assert-vlist vlist)
+  (block-cons item vlist #f))
+
+(define (vlist-head vlist)
+  "Return the head of VLIST."
+  (assert-vlist vlist)
+  (let ((base   (vlist-base vlist))
+        (offset (vlist-offset vlist)))
+    (block-ref (block-content base) offset)))
+
+(define (vlist-tail vlist)
+  "Return the tail of VLIST."
+  (assert-vlist vlist)
+  (let ((base   (vlist-base vlist))
+        (offset (vlist-offset vlist)))
+    (if (> offset 0)
+        (make-vlist base (- offset 1))
+        (make-vlist (block-base base)
+                    (block-offset base)))))
+
+(define (vlist-null? vlist)
+  "Return true if VLIST is empty."
+  (assert-vlist vlist)
+  (let ((base (vlist-base vlist)))
+    (and (not (block-base base))
+         (= 0 (block-size base)))))
+
+
+;;;
+;;; VList Utilities.
+;;;
+
+(define (list->vlist lst)
+  "Return a new vlist whose contents correspond to LST."
+  (vlist-reverse (fold vlist-cons vlist-null lst)))
+
+(define (vlist-fold proc init vlist)
+  "Fold over VLIST, calling PROC for each element."
+  ;; FIXME: Handle multiple lists.
+  (assert-vlist vlist)
+  (let loop ((base   (vlist-base vlist))
+             (offset (vlist-offset vlist))
+             (result init))
+    (if (eq? base block-null)
+        result
+        (let* ((next  (- offset 1))
+               (done? (< next 0)))
+          (loop (if done? (block-base base) base)
+                (if done? (block-offset base) next)
+                (proc (block-ref (block-content base) offset) result))))))
+
+(define (vlist-fold-right proc init vlist)
+  "Fold over VLIST, calling PROC for each element, starting from
+the last element."
+  (assert-vlist vlist)
+  (let loop ((index  (1- (vlist-length vlist)))
+             (result init))
+    (if (< index 0)
+        result
+        (loop (1- index)
+          (proc (vlist-ref vlist index) result)))))
+
+(define (vlist-reverse vlist)
+  "Return a new VLIST whose content are those of VLIST in reverse
+order."
+  (vlist-fold vlist-cons vlist-null vlist))
+
+(define (vlist-map proc vlist)
+  "Map PROC over the elements of VLIST and return a new vlist."
+  (vlist-fold (lambda (item result)
+                (vlist-cons (proc item) result))
+              vlist-null
+              (vlist-reverse vlist)))
+
+(define (vlist->list vlist)
+  "Return a new list whose contents match those of VLIST."
+  (vlist-fold-right cons '() vlist))
+
+(define (vlist-ref vlist index)
+  "Return the element at index INDEX in VLIST."
+  (assert-vlist vlist)
+  (let loop ((index   index)
+             (base    (vlist-base vlist))
+             (offset  (vlist-offset vlist)))
+    (if (<= index offset)
+        (block-ref (block-content base) (- offset index))
+        (loop (- index offset 1)
+              (block-base base)
+              (block-offset base)))))
+
+(define (vlist-drop vlist count)
+  "Return a new vlist that does not contain the COUNT first elements of
+VLIST."
+  (assert-vlist vlist)
+  (let loop ((count  count)
+             (base   (vlist-base vlist))
+             (offset (vlist-offset vlist)))
+    (if (<= count offset)
+        (make-vlist base (- offset count))
+        (loop (- count offset 1)
+              (block-base base)
+              (block-offset base)))))
+
+(define (vlist-take vlist count)
+  "Return a new vlist that contains only the COUNT first elements of
+VLIST."
+  (let loop ((count  count)
+             (vlist  vlist)
+             (result vlist-null))
+    (if (= 0 count)
+        (vlist-reverse result)
+        (loop (- count 1)
+              (vlist-tail vlist)
+              (vlist-cons (vlist-head vlist) result)))))
+
+(define (vlist-filter pred vlist)
+  "Return a new vlist containing all the elements from VLIST that
+satisfy PRED."
+  (vlist-fold-right (lambda (e v)
+                      (if (pred e)
+                          (vlist-cons e v)
+                          v))
+                    vlist-null
+                    vlist))
+
+(define* (vlist-delete x vlist #\optional (equal? equal?))
+  "Return a new vlist corresponding to VLIST without the elements
+EQUAL? to X."
+  (vlist-filter (lambda (e)
+                  (not (equal? e x)))
+                vlist))
+
+(define (vlist-length vlist)
+  "Return the length of VLIST."
+  (assert-vlist vlist)
+  (let loop ((base (vlist-base vlist))
+             (len  (vlist-offset vlist)))
+    (if (eq? base block-null)
+        len
+        (loop (block-base base)
+              (+ len 1 (block-offset base))))))
+
+(define* (vlist-unfold p f g seed
+                       #\optional (tail-gen (lambda (x) vlist-null)))
+  "Return a new vlist.  See the description of SRFI-1 `unfold' for details."
+  (let uf ((seed seed))
+    (if (p seed)
+        (tail-gen seed)
+        (vlist-cons (f seed)
+                    (uf (g seed))))))
+
+(define* (vlist-unfold-right p f g seed #\optional (tail vlist-null))
+  "Return a new vlist.  See the description of SRFI-1 `unfold-right' for
+details."
+  (let uf ((seed seed) (lis tail))
+    (if (p seed)
+        lis
+        (uf (g seed) (vlist-cons (f seed) lis)))))
+
+(define (vlist-append . vlists)
+  "Append the given lists."
+  (if (null? vlists)
+      vlist-null
+      (fold-right (lambda (vlist result)
+                    (vlist-fold-right (lambda (e v)
+                                        (vlist-cons e v))
+                                      result
+                                      vlist))
+                  vlist-null
+                  vlists)))
+
+(define (vlist-for-each proc vlist)
+  "Call PROC on each element of VLIST.  The result is unspecified."
+  (vlist-fold (lambda (item x)
+                (proc item))
+              (if #f #f)
+              vlist))
+
+
+;;;
+;;; Hash Lists, aka. `VHash'.
+;;;
+
+;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2
+;; associated with K1 and K2, respectively.  The resulting layout is a
+;; follows:
+;;
+;;             ,--------------------.
+;;            0| ,-> (K1 . V1)      | Vlist array
+;;            1| |                  |
+;;            2| |   (K2 . V2)      |
+;;            3| |                  |
+;;        size +-|------------------+
+;;            0| |                  | Hash table
+;;            1| |                  |
+;;            2| +-- O <------------- H
+;;            3| |                  |
+;;    size * 2 +-|------------------+
+;;            0| `-> 2              | Chain links
+;;            1|                    |
+;;            2|    #f              |
+;;            3|                    |
+;;    size * 3 `--------------------'
+;;
+;; The backing store for the vhash is partitioned into three areas: the
+;; vlist part, the hash table part, and the chain links part.  In this
+;; example we have a hash H which, when indexed into the hash table
+;; part, indicates that a value with this hash can be found at offset 0
+;; in the vlist part.  The corresponding index (in this case, 0) of the
+;; chain links array holds the index of the next element in this block
+;; with this hash value, or #f if we reached the end of the chain.
+;;
+;; This API potentially requires users to repeat which hash function and
+;; which equality predicate to use.  This can lead to unpredictable
+;; results if they are used in consistenly, e.g., between `vhash-cons'
+;; and `vhash-assoc', which is undesirable, as argued in
+;; http://savannah.gnu.org/bugs/?22159 .  OTOH, two arguments can be
+;; made in favor of this API:
+;;
+;;  - It's consistent with how alists are handled in SRFI-1.
+;;
+;;  - In practice, users will probably consistenly use either the `q',
+;;    the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
+;;    without any optional argument), i.e., they will rarely explicitly
+;;    pass a hash function or equality predicate.
+
+(define (vhash? obj)
+  "Return true if OBJ is a hash list."
+  (and (vlist? obj)
+       (block-hash-table? (vlist-base obj))))
+
+(define* (vhash-cons key value vhash #\optional (hash hash))
+  "Return a new hash list based on VHASH where KEY is associated
+with VALUE.  Use HASH to compute KEY's hash."
+  (assert-vlist vhash)
+  ;; We should also assert that it is a hash table.  Need to check the
+  ;; performance impacts of that.  Also, vlist-null is a valid hash
+  ;; table, which does not pass vhash?.  A bug, perhaps.
+  (let* ((vhash     (block-cons (cons key value) vhash #t))
+         (base      (vlist-base vhash))
+         (offset    (vlist-offset vhash))
+         (size      (block-size base))
+         (khash     (hash key size))
+         (content   (block-content base)))
+    (block-hash-table-add! content size khash offset)
+    vhash))
+
+(define vhash-consq (cut vhash-cons <> <> <> hashq))
+(define vhash-consv (cut vhash-cons <> <> <> hashv))
+
+(define-inlinable (%vhash-fold* proc init key vhash equal? hash)
+  ;; Fold over all the values associated with KEY in VHASH.
+  (define (visit-block base max-offset result)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash))
+                 (result result))
+        (if offset
+            (loop (block-hash-table-next-offset content size offset)
+                  (if (and (<= offset max-offset)
+                           (equal? key (car (block-ref content offset))))
+                      (proc (cdr (block-ref content offset)) result)
+                      result))
+            (let ((next-block (block-base base)))
+              (if (> (block-size next-block) 0)
+                  (visit-block next-block (block-offset base) result)
+                  result))))))
+
+  (assert-vlist vhash)
+  (if (> (block-size (vlist-base vhash)) 0)
+      (visit-block (vlist-base vhash)
+                   (vlist-offset vhash)
+                   init)
+      init))
+
+(define* (vhash-fold* proc init key vhash
+                      #\optional (equal? equal?) (hash hash))
+  "Fold over all the values associated with KEY in VHASH, with each
+call to PROC having the form ‘(proc value result)’, where
+RESULT is the result of the previous call to PROC and INIT the
+value of RESULT for the first call to PROC."
+  (%vhash-fold* proc init key vhash equal? hash))
+
+(define (vhash-foldq* proc init key vhash)
+  "Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’."
+  (%vhash-fold* proc init key vhash eq? hashq))
+
+(define (vhash-foldv* proc init key vhash)
+  "Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’."
+  (%vhash-fold* proc init key vhash eqv? hashv))
+
+(define-inlinable (%vhash-assoc key vhash equal? hash)
+  ;; A specialization of `vhash-fold*' that stops when the first value
+  ;; associated with KEY is found or when the end-of-list is reached.  Inline to
+  ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
+  ;; the `eq?'  subr.
+  (define (visit-block base max-offset)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash)))
+        (if offset
+            (if (and (<= offset max-offset)
+                     (equal? key (car (block-ref content offset))))
+                (block-ref content offset)
+                (loop (block-hash-table-next-offset content size offset)))
+            (let ((next-block (block-base base)))
+              (and (> (block-size next-block) 0)
+                   (visit-block next-block (block-offset base))))))))
+
+  (assert-vlist vhash)
+  (and (> (block-size (vlist-base vhash)) 0)
+       (visit-block (vlist-base vhash)
+                    (vlist-offset vhash))))
+
+(define* (vhash-assoc key vhash #\optional (equal? equal?) (hash hash))
+  "Return the first key/value pair from VHASH whose key is equal to
+KEY according to the EQUAL? equality predicate."
+  (%vhash-assoc key vhash equal? hash))
+
+(define (vhash-assq key vhash)
+  "Return the first key/value pair from VHASH whose key is ‘eq?’ to
+KEY."
+  (%vhash-assoc key vhash eq? hashq))
+
+(define (vhash-assv key vhash)
+  "Return the first key/value pair from VHASH whose key is ‘eqv?’ to
+KEY."
+  (%vhash-assoc key vhash eqv? hashv))
+
+(define* (vhash-delete key vhash #\optional (equal? equal?) (hash hash))
+  "Remove all associations from VHASH with KEY, comparing keys
+with EQUAL?."
+  (if (vhash-assoc key vhash equal? hash)
+      (vlist-fold (lambda (k+v result)
+                    (let ((k (car k+v))
+                          (v (cdr k+v)))
+                      (if (equal? k key)
+                          result
+                          (vhash-cons k v result hash))))
+                  vlist-null
+                  vhash)
+      vhash))
+
+(define vhash-delq (cut vhash-delete <> <> eq? hashq))
+(define vhash-delv (cut vhash-delete <> <> eqv? hashv))
+
+(define (vhash-fold proc init vhash)
+  "Fold over the key/pair elements of VHASH from left to right, with
+each call to PROC having the form ‘(PROC key value result)’,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
+  (vlist-fold (lambda (key+value result)
+                (proc (car key+value) (cdr key+value)
+                      result))
+              init
+              vhash))
+
+(define (vhash-fold-right proc init vhash)
+  "Fold over the key/pair elements of VHASH from right to left, with
+each call to PROC having the form ‘(PROC key value result)’,
+where RESULT is the result of the previous call to PROC and
+INIT the value of RESULT for the first call to PROC."
+  (vlist-fold-right (lambda (key+value result)
+                      (proc (car key+value) (cdr key+value)
+                            result))
+                    init
+                    vhash))
+
+(define* (alist->vhash alist #\optional (hash hash))
+  "Return the vhash corresponding to ALIST, an association list."
+  (fold-right (lambda (pair result)
+                (vhash-cons (car pair) (cdr pair) result hash))
+              vlist-null
+              alist))
+
+;;; vlist.scm ends here
+;;; installed-scm-file
+
+;;;; Copyright (C) 2003, 2006, 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
+;;;; 
+
+
+(define-module (ice-9 weak-vector)
+  \:export (make-weak-vector list->weak-vector weak-vector weak-vector?
+           weak-vector-length weak-vector-ref weak-vector-set!
+	   make-weak-key-alist-vector
+	   make-weak-value-alist-vector
+	   make-doubly-weak-alist-vector
+	   weak-key-alist-vector?
+	   weak-value-alist-vector?
+	   doubly-weak-alist-vector?)  ; C
+  )
+
+(%init-weaks-builtins) ; defined in libguile/weaks.c
+;;; Guile Virtual Machine Assembly
+
+;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language assembly)
+  #\use-module (rnrs bytevectors)
+  #\use-module (system base pmatch)
+  #\use-module (system vm instruction)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\export (byte-length
+            addr+ align-program align-code align-block
+            assembly-pack assembly-unpack
+            object->assembly assembly->object))
+
+;; len, metalen
+(define *program-header-len* (+ 4 4))
+
+;; lengths are encoded in 3 bytes
+(define *len-len* 3)
+
+
+(define (byte-length assembly)
+  (pmatch assembly
+    ((,inst . _) (guard (>= (instruction-length inst) 0))
+     (+ 1 (instruction-length inst)))
+    ((load-number ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-string ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-wide-string ,str)
+     (+ 1 *len-len* (* 4 (string-length str))))
+    ((load-symbol ,str)
+     (+ 1 *len-len* (string-length str)))
+    ((load-array ,bv)
+     (+ 1 *len-len* (bytevector-length bv)))
+    ((load-program ,labels ,len ,meta . ,code)
+     (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
+    (,label (guard (not (pair? label)))
+     0)
+    (else (error "unknown instruction" assembly))))
+
+
+(define *program-alignment* 8)
+
+(define (addr+ addr code)
+  (fold (lambda (x len) (+ (byte-length x) len))
+        addr
+        code))
+
+(define (code-alignment addr alignment header-len)
+  (make-list (modulo (- alignment
+                        (modulo (+ addr header-len) alignment))
+                     alignment)
+             '(nop)))
+
+(define (align-block addr)
+  '())
+
+(define (align-code code addr alignment header-len)
+  `(,@(code-alignment addr alignment header-len)
+    ,code))
+
+(define (align-program prog addr)
+  (align-code prog addr *program-alignment* 1))
+
+;;;
+;;; Code compress/decompression
+;;;
+
+(define *abbreviations*
+  '(((make-int8 0) . (make-int8:0))
+    ((make-int8 1) . (make-int8:1))))
+  
+(define *expansions*
+  (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
+
+(define (assembly-pack code)
+  (or (assoc-ref *abbreviations* code)
+      code))
+
+(define (assembly-unpack code)
+  (or (assoc-ref *expansions* code)
+      code))
+
+
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->assembly x)
+  (cond ((eq? x #t) `(make-true))
+	((eq? x #f) `(make-false))
+        ((eq? x #nil) `(make-nil))
+	((null? x) `(make-eol))
+	((and (integer? x) (exact? x))
+	 (cond ((and (<= -128 x) (< x 128))
+		(assembly-pack `(make-int8 ,(modulo x 256))))
+	       ((and (<= -32768 x) (< x 32768))
+		(let ((n (if (< x 0) (+ x 65536) x)))
+		  `(make-int16 ,(quotient n 256) ,(modulo n 256))))
+               ((and (<= 0 x #xffffffffffffffff))
+                `(make-uint64 ,@(bytevector->u8-list
+                                 (let ((bv (make-bytevector 8)))
+                                   (bytevector-u64-set! bv 0 x (endianness big))
+                                   bv))))
+	       ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
+                `(make-int64 ,@(bytevector->u8-list
+                                (let ((bv (make-bytevector 8)))
+                                  (bytevector-s64-set! bv 0 x (endianness big))
+                                  bv))))
+	       (else #f)))
+	((char? x)
+         (cond ((<= (char->integer x) #xff)
+                `(make-char8 ,(char->integer x)))
+               (else
+                `(make-char32 ,(char->integer x)))))
+	(else #f)))
+
+(define (assembly->object code)
+  (pmatch code
+    ((make-true) #t)
+    ((make-false) #f) ;; FIXME: Same as the `else' case!
+    ((make-nil) #nil)
+    ((make-eol) '())
+    ((make-int8 ,n)
+     (if (< n 128) n (- n 256)))
+    ((make-int16 ,n1 ,n2)
+     (let ((n (+ (* n1 256) n2)))
+       (if (< n 32768) n (- n 65536))))
+    ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+     (bytevector-u64-ref
+      (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+      0
+      (endianness big)))
+    ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+     (bytevector-s64-ref
+      (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+      0
+      (endianness big)))
+    ((make-char8 ,n)
+     (integer->char n))
+    ((make-char32 ,n1 ,n2 ,n3 ,n4)
+     (integer->char (+ (* n1 #x1000000)
+                       (* n2 #x10000)
+                       (* n3 #x100)
+                       n4)))
+    ((load-string ,s) s)
+    ((load-symbol ,s) (string->symbol s))
+    (else #f)))
+;;; Guile VM assembler
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language assembly compile-bytecode)
+  #\use-module (system base pmatch)
+  #\use-module (system base target)
+  #\use-module (language assembly)
+  #\use-module (system vm instruction)
+  #\use-module (rnrs bytevectors)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\export (compile-bytecode))
+
+(define (compile-bytecode assembly env . opts)
+  (define-syntax-rule (define-inline1 (proc arg) body body* ...)
+    (define-syntax proc
+      (syntax-rules ()
+        ((_ (arg-expr (... ...)))
+         (let ((x (arg-expr (... ...))))
+           (proc x)))
+        ((_ arg)
+         (begin body body* ...)))))
+       
+  (define (fill-bytecode bv target-endianness)
+    (let ((pos 0))
+      (define-inline1 (write-byte b)
+        (bytevector-u8-set! bv pos b)
+        (set! pos (1+ pos)))
+      (define u32-bv (make-bytevector 4))
+      (define-inline1 (write-int24-be x)
+        (bytevector-s32-set! u32-bv 0 x (endianness big))
+        (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
+        (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
+        (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
+        (set! pos (+ pos 3)))
+      (define-inline1 (write-uint32-be x)
+        (bytevector-u32-set! bv pos x (endianness big))
+        (set! pos (+ pos 4)))
+      (define-inline1 (write-uint32 x)
+        (bytevector-u32-set! bv pos x target-endianness)
+        (set! pos (+ pos 4)))
+      (define-inline1 (write-loader-len len)
+        (bytevector-u8-set! bv pos (ash len -16))
+        (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
+        (bytevector-u8-set! bv (+ pos 2) (logand len 255))
+        (set! pos (+ pos 3)))
+      (define-inline1 (write-latin1-string s)
+        (let ((len (string-length s)))
+          (write-loader-len len)
+          (let lp ((i 0))
+            (if (< i len)
+                (begin
+                  (bytevector-u8-set! bv (+ pos i)
+                                      (char->integer (string-ref s i)))
+                  (lp (1+ i)))))
+          (set! pos (+ pos len))))
+      (define-inline1 (write-bytevector bv*)
+        (let ((len (bytevector-length bv*)))
+          (write-loader-len len)
+          (bytevector-copy! bv* 0 bv pos len)
+          (set! pos (+ pos len))))
+      (define-inline1 (write-wide-string s)
+        (write-bytevector (string->utf32 s target-endianness)))
+      (define-inline1 (write-break label)
+        (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+          (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+                ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
+                (else (write-int24-be offset)))))
+
+      (define (write-bytecode asm labels address emit-opcode?)
+        ;; Write ASM's bytecode to BV.  If EMIT-OPCODE? is false, don't
+        ;; emit bytecode for the first opcode encountered.  Assume code
+        ;; starts at ADDRESS (an integer).  LABELS is assumed to be an
+        ;; alist mapping labels to addresses.
+        (define get-addr
+          (let ((start pos))
+            (lambda ()
+              (+ address (- pos start)))))
+        (define (write-break label)
+          (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+            (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+                  ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
+                  (else (write-int24-be offset)))))
+  
+        (let ((inst (car asm))
+              (args (cdr asm)))
+          (let ((opcode (instruction->opcode inst))
+                (len (instruction-length inst)))
+            (if emit-opcode?
+                (write-byte opcode))
+            (pmatch asm
+              ((load-program ,labels ,length ,meta . ,code)
+               (write-uint32 length)
+               (write-uint32 (if meta (1- (byte-length meta)) 0))
+               (fold (lambda (asm address)
+                       (let ((start pos))
+                         (write-bytecode asm labels address #t)
+                         (+ address (- pos start))))
+                     0
+                     code)
+               (if meta
+                   ;; Don't emit the `load-program' byte for metadata.  Note that
+                   ;; META's bytecode meets the alignment requirements of
+                   ;; `scm_objcode', thanks to the alignment computed in `(language
+                   ;; assembly)'.
+                   (write-bytecode meta '() 0 #f)))
+              ((make-char32 ,x) (write-uint32-be x))
+              ((load-number ,str) (write-latin1-string str))
+              ((load-string ,str) (write-latin1-string str))
+              ((load-wide-string ,str) (write-wide-string str))
+              ((load-symbol ,str) (write-latin1-string str))
+              ((load-array ,bv) (write-bytevector bv))
+              ((br ,l) (write-break l))
+              ((br-if ,l) (write-break l))
+              ((br-if-not ,l) (write-break l))
+              ((br-if-eq ,l) (write-break l))
+              ((br-if-not-eq ,l) (write-break l))
+              ((br-if-null ,l) (write-break l))
+              ((br-if-not-null ,l) (write-break l))
+              ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+              ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+              ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+              ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
+                                             ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+                                             ,ntotal-hi ,ntotal-lo
+                                             ,l)
+               (write-byte nreq-hi)
+               (write-byte nreq-lo)
+               (write-byte nreq-and-nopt-hi)
+               (write-byte nreq-and-nopt-lo)
+               (write-byte ntotal-hi)
+               (write-byte ntotal-lo)
+               (write-break l))
+              ((mv-call ,n ,l) (write-byte n) (write-break l))
+              ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
+              (else
+               (cond
+                ((< len 0)
+                 (error "unhanded variable-length instruction" asm))
+                ((not (= (length args) len))
+                 (error "bad number of args to instruction" asm len))
+                (else
+                 (for-each (lambda (x) (write-byte x)) args))))))))
+
+      ;; Don't emit the `load-program' byte.
+      (write-bytecode assembly '() 0 #f)
+      (if (= pos (bytevector-length bv))
+          (values bv env env)
+          (error "failed to fill bytevector" bv pos
+                 (bytevector-length bv)))))
+
+  (pmatch assembly
+    ((load-program ,labels ,length ,meta . ,code)
+     (fill-bytecode (make-bytevector (+ 4 4 length
+                                        (if meta
+                                            (1- (byte-length meta))
+                                            0)))
+                    (target-endianness)))
+    
+    (else (error "bad assembly" assembly))))
+;;; Guile VM code converters
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language assembly decompile-bytecode)
+  #\use-module (system vm instruction)
+  #\use-module (system base pmatch)
+  #\use-module (srfi srfi-4)
+  #\use-module (rnrs bytevectors)
+  #\use-module (language assembly)
+  #\use-module ((system vm objcode) #\select (byte-order))
+  #\export (decompile-bytecode))
+
+(define (decompile-bytecode x env opts)
+  (let ((i 0) (size (u8vector-length x)))
+    (define (pop)
+      (let ((b (cond ((< i size) (u8vector-ref x i))
+                     ((= i size) #f)
+                     (else (error "tried to decode too many bytes")))))
+        (if b (set! i (1+ i)))
+        b))
+    (let ((ret (decode-load-program pop)))
+      (if (= i size)
+          (values ret env)
+          (error "bad bytecode: only decoded ~a out of ~a bytes" i size)))))
+
+(define (br-instruction? x)
+  (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null)))
+(define (br-nargs-instruction? x)
+  (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt br-if-nargs-lt/non-kw)))
+
+(define (bytes->s24 a b c)
+  (let ((x (+ (ash a 16) (ash b 8) c)))
+    (if (zero? (logand (ash 1 23) x))
+        x
+        (- x (ash 1 24)))))
+
+;; FIXME: this is a little-endian disassembly!!!
+(define (decode-load-program pop)
+  (let* ((a (pop)) (b (pop)) (c (pop)) (d (pop))
+         (e (pop)) (f (pop)) (g (pop)) (h (pop))
+         (len (+ a (ash b 8) (ash c 16) (ash d 24)))
+         (metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
+         (labels '())
+         (i 0))
+    (define (ensure-label rel1 rel2 rel3)
+      (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
+        (or (assv-ref labels where)
+            (begin
+              (let ((l (gensym ":L")))
+                (set! labels (acons where l labels))
+                l)))))
+    (define (sub-pop) ;; ...records. ha. ha.
+      (let ((b (cond ((< i len) (pop))
+                     ((= i len) #f)
+                     (else (error "tried to decode too many bytes")))))
+        (if b (set! i (1+ i)))
+        b))
+    (let lp ((out '()))
+      (cond ((> i len)
+             (error "error decoding program -- read too many bytes" out))
+            ((= i len)
+             `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
+                                  (reverse labels))
+                            ,len
+                            ,(if (zero? metalen) #f (decode-load-program pop))
+                            ,@(reverse! out)))
+            (else
+             (let ((exp (decode-bytecode sub-pop)))
+               (pmatch exp
+                 ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
+                  (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
+                 ((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard (br-nargs-instruction? br))
+                  (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
+                 ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
+                                                ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+                                                ,ntotal-hi ,ntotal-lo
+                                                ,rel1 ,rel2 ,rel3)
+                  (lp (cons `(bind-optionals/shuffle-or-br
+                              ,nreq-hi ,nreq-lo
+                              ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+                              ,ntotal-hi ,ntotal-lo
+                              ,(ensure-label rel1 rel2 rel3))
+                            out)))
+                 ((mv-call ,n ,rel1 ,rel2 ,rel3)
+                  (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
+                 ((prompt ,n0 ,rel1 ,rel2 ,rel3)
+                  (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
+                 (else 
+                  (lp (cons exp out))))))))))
+
+(define (decode-bytecode pop)
+  (and=> (pop)
+         (lambda (opcode)
+           (let ((inst (opcode->instruction opcode)))
+             (cond
+              ((eq? inst 'load-program)
+               (decode-load-program pop))
+
+              ((< (instruction-length inst) 0)
+               ;; the negative length indicates a variable length
+               ;; instruction
+               (let* ((make-sequence
+                       (if (or (memq inst '(load-array load-wide-string)))
+                           make-bytevector
+                           make-string))
+                      (sequence-set!
+                       (if (or (memq inst '(load-array load-wide-string)))
+                           bytevector-u8-set!
+                           (lambda (str pos value)
+                             (string-set! str pos (integer->char value)))))
+                      (len (let* ((a (pop)) (b (pop)) (c (pop)))
+                             (+ (ash a 16) (ash b 8) c)))
+                      (seq (make-sequence len)))
+                 (let lp ((i 0))
+                   (if (= i len)
+                       `(,inst ,(if (eq? inst 'load-wide-string)
+                                    (utf32->string seq (native-endianness))
+                                    seq))
+                       (begin
+                         (sequence-set! seq i (pop))
+                         (lp (1+ i)))))))
+              (else
+               ;; fixed length
+               (let lp ((n (instruction-length inst)) (out (list inst)))
+                 (if (zero? n)
+                     (reverse! out)
+                     (lp (1- n) (cons (pop) out))))))))))
+;;; Guile VM code converters
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language assembly disassemble)
+  #\use-module (ice-9 format)
+  #\use-module (srfi srfi-1)
+  #\use-module (system vm instruction)
+  #\use-module (system vm program)
+  #\use-module (system base pmatch)
+  #\use-module (language assembly)
+  #\use-module (system base compile)
+  #\export (disassemble))
+
+(define (disassemble x)
+  (format #t "Disassembly of ~A:\n\n" x)
+  (call-with-values
+      (lambda () (decompile x #\from 'value #\to 'assembly))
+    disassemble-load-program))
+
+(define (disassemble-load-program asm env)
+  (pmatch asm
+    ((load-program ,labels ,len ,meta . ,code)
+     (let ((objs  (and env (assq-ref env 'objects)))
+           (free-vars (and env (assq-ref env 'free-vars)))
+           (meta  (and env (assq-ref env 'meta)))
+           (blocs (and env (assq-ref env 'blocs)))
+           (srcs  (and env (assq-ref env 'sources))))
+       (let lp ((pos 0) (code code) (programs '()))
+         (cond
+          ((null? code)
+           (newline)
+           (for-each
+            (lambda (sym+asm)
+              (format #t "Embedded program ~A:\n\n" (car sym+asm))
+              (disassemble-load-program (cdr sym+asm) '()))
+            (reverse! programs)))
+          (else
+           (let* ((asm (car code))
+                  (len (byte-length asm))
+                  (end (+ pos len)))
+             (pmatch asm
+               ((load-program . _)
+                (let ((sym (gensym "")))
+                  (print-info pos `(load-program ,sym) #f #f)
+                  (lp (+ pos (byte-length asm)) (cdr code)
+                      (acons sym asm programs))))
+               ((nop)
+                (lp (+ pos (byte-length asm)) (cdr code) programs))
+               (else
+                (print-info pos asm
+                            ;; FIXME: code-annotation for whether it's
+                            ;; an arg or not, currently passing nargs=-1
+                            (code-annotation end asm objs -1 blocs
+                                             labels)
+                            (and=> (and srcs (assq end srcs)) source->string))
+                (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
+                 
+       (if (pair? free-vars)
+           (disassemble-free-vars free-vars))
+       (if meta
+           (disassemble-meta meta))
+
+       ;; Disassemble other bytecode in it
+       ;; FIXME: something about the module.
+       (if objs
+           (for-each
+            (lambda (x)
+              (if (program? x)
+                  (begin (display "----------------------------------------\n")
+                         (disassemble x))))
+            (cdr (vector->list objs))))))
+    (else
+     (error "bad load-program form" asm))))
+
+(define (disassemble-free-vars free-vars)
+  (display "Free variables:\n\n")
+  (fold (lambda (free-var i)
+          (print-info i free-var #f #f)
+          (+ 1 i))
+        0
+        free-vars))
+
+(define-macro (unless test . body)
+  `(if (not ,test) (begin ,@body)))
+
+(define *uninteresting-props* '(name))
+
+(define (disassemble-meta meta)
+  (let ((props (filter (lambda (x)
+                         (not (memq (car x) *uninteresting-props*)))
+                       (cdddr meta))))
+    (unless (null? props)
+      (display "Properties:\n\n")
+      (for-each (lambda (x) (print-info #f x #f #f)) props)
+      (newline))))
+
+(define (source->string src)
+  (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
+          (source:line-for-user src) (source:column src)))
+
+(define (make-int16 byte1 byte2)
+  (+ (* byte1 256) byte2))
+
+(define (code-annotation end-addr code objs nargs blocs labels)
+  (let* ((code (assembly-unpack code))
+         (inst (car code))
+         (args (cdr code)))
+    (case inst
+      ((list vector) 
+       (list "~a element~:p" (apply make-int16 args)))
+      ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
+       (list "-> ~A" (assq-ref labels (car args))))
+      ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
+       (list "-> ~A" (assq-ref labels (caddr args))))
+      ((bind-optionals/shuffle-or-br)
+       (list "-> ~A" (assq-ref labels (car (last-pair args)))))
+      ((object-ref)
+       (and objs (list "~s" (vector-ref objs (car args)))))
+      ((local-ref local-boxed-ref local-set local-boxed-set)
+       (and blocs
+            (let lp ((bindings (list-ref blocs (car args))))
+              (and (pair? bindings)
+                   (let ((b (car bindings)))
+                     (if (and (< (binding:start (car bindings)) end-addr)
+                              (>= (binding:end (car bindings)) end-addr))
+                         (list "`~a'~@[ (arg)~]"
+                               (binding:name b) (< (binding:index b) nargs))
+                         (lp (cdr bindings))))))))
+      ((assert-nargs-ee/locals assert-nargs-ge/locals)
+       (list "~a arg~:p, ~a local~:p"
+             (logand (car args) #x7) (ash (car args) -3)))
+      ((free-ref free-boxed-ref free-boxed-set)
+       ;; FIXME: we can do better than this
+       (list "(closure variable)"))
+      ((toplevel-ref toplevel-set)
+       (and objs
+            (let ((v (vector-ref objs (car args))))
+              (if (and (variable? v) (variable-bound? v))
+                  (list "~s" (variable-ref v))
+                  (list "`~s'" v)))))
+      ((mv-call)
+       (list "MV -> ~A" (assq-ref labels (cadr args))))
+      ((prompt)
+       ;; the H is for handler
+       (list "H -> ~A" (assq-ref labels (cadr args))))
+      (else
+       (and=> (assembly->object code)
+              (lambda (obj) (list "~s" obj)))))))
+
+;; i am format's daddy.
+(define (print-info addr info extra src)
+  (format #t "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))
+;;; Guile Virtual Machine Assembly
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language assembly spec)
+  #\use-module (system base language)
+  #\use-module (language assembly compile-bytecode)
+  #\use-module (language assembly decompile-bytecode)
+  #\export (assembly))
+
+(define-language assembly
+  #\title	"Guile Virtual Machine Assembly Language"
+  #\reader	(lambda (port env) (read port))
+  #\printer	write
+  #\parser      read ;; fixme: make a verifier?
+  #\compilers   `((bytecode . ,compile-bytecode))
+  #\decompilers `((bytecode . ,decompile-bytecode))
+  #\for-humans? #f
+  )
+;;; Brainfuck for GNU Guile
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language brainfuck compile-scheme)
+  #\export (compile-scheme))
+
+;; Compilation of Brainfuck to Scheme is pretty straight-forward.  For all of
+;; brainfuck's instructions, there are basic representations in Scheme we
+;; only have to generate.
+;;
+;; Brainfuck's pointer and data-tape are stored in the variables pointer and
+;; tape, where tape is a vector of integer values initially set to zero.  Pointer
+;; starts out at position 0.
+;; Our tape is thus of finite length, with an address range of 0..n for
+;; some defined upper bound n depending on the length of our tape.
+
+
+;; Define the length to use for the tape.
+
+(define tape-size 30000)
+
+
+;; This compiles a whole brainfuck program.  This constructs a Scheme code like:
+;; (let ((pointer 0)
+;;       (tape (make-vector tape-size 0)))
+;;   (begin
+;;     <body>
+;;     (write-char #\newline)))
+;;
+;; So first the pointer and tape variables are set up correctly, then the
+;; program's body is executed in this context, and finally we output an
+;; additional newline character in case the program does not output one.
+;;
+;; TODO: Find out and explain the details about env, the three return values and
+;; how to use the options.  Implement options to set the tape-size, maybe.
+
+(define (compile-scheme exp env opts)
+  (values
+    `(let ((pointer 0)
+           (tape (make-vector ,tape-size 0)))
+       ,@(compile-body (cdr exp))
+       (write-char #\newline))
+    env
+    env))
+
+
+;; Compile a list of instructions to get a list of Scheme codes.  As we always
+;; strip off the car of the instructions-list and cons the result onto the
+;; result-list, it will get out in reversed order first; so we have to (reverse)
+;; it on return.
+
+(define (compile-body instructions)
+  (let iterate ((cur instructions)
+                (result '()))
+    (if (null? cur)
+      (reverse result)
+      (let ((compiled (compile-instruction (car cur))))
+        (iterate (cdr cur) (cons compiled result))))))
+
+
+;; Compile a single instruction to Scheme, using the direct representations
+;; all of Brainfuck's instructions have.
+
+(define (compile-instruction ins)
+  (case (car ins)
+
+    ;; Pointer moval >< is done simply by something like:
+    ;; (set! pointer (+ pointer +-1))
+    ((<bf-move>)
+     (let ((dir (cadr ins)))
+       `(set! pointer (+ pointer ,dir))))
+
+    ;; Cell increment +- is done as:
+    ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
+    ((<bf-increment>)
+     (let ((inc (cadr ins)))
+       `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
+
+    ;; Output . is done by converting the cell's integer value to a character
+    ;; first and then printing out this character:
+    ;; (write-char (integer->char (vector-ref tape pointer)))
+    ((<bf-print>)
+     '(write-char (integer->char (vector-ref tape pointer))))
+
+    ;; Input , is done similarly, read in a character, get its ASCII code and
+    ;; store it into the current cell:
+    ;; (vector-set! tape pointer (char->integer (read-char)))
+    ((<bf-read>)
+     '(vector-set! tape pointer (char->integer (read-char))))
+
+    ;; For loops [...] we use a named let construction to execute the body until
+    ;; the current cell gets zero.  The body is compiled via a recursive call
+    ;; back to (compile-body).
+    ;; (let iterate ()
+    ;;   (if (not (= (vector-ref! tape pointer) 0))
+    ;;     (begin
+    ;;       <body>
+    ;;       (iterate))))
+    ((<bf-loop>)
+     `(let iterate ()
+        (if (not (= (vector-ref tape pointer) 0))
+          (begin
+            ,@(compile-body (cdr ins))
+            (iterate)))))
+
+    (else (error "unknown brainfuck instruction " (car ins)))))
+;;; Brainfuck for GNU Guile
+
+;; 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
+
+;;; Commentary:
+
+;; Brainfuck is a simple language that mostly mimics the operations of a
+;; Turing machine. This file implements a compiler from Brainfuck to
+;; Guile's Tree-IL.
+
+;;; Code:
+
+(define-module (language brainfuck compile-tree-il)
+  #\use-module (system base pmatch)
+  #\use-module (language tree-il)
+  #\export (compile-tree-il))
+
+;; Compilation of Brainfuck is pretty straight-forward. For all of
+;; brainfuck's instructions, there are basic representations in Tree-IL
+;; we only have to generate.
+;;
+;; Brainfuck's pointer and data-tape are stored in the variables pointer and
+;; tape, where tape is a vector of integer values initially set to zero.  Pointer
+;; starts out at position 0.
+;; Our tape is thus of finite length, with an address range of 0..n for
+;; some defined upper bound n depending on the length of our tape.
+
+
+;; Define the length to use for the tape.
+
+(define tape-size 30000)
+
+
+;; This compiles a whole brainfuck program. This constructs a Tree-IL
+;; code equivalent to Scheme code like this:
+;;
+;;    (let ((pointer 0)
+;;          (tape (make-vector tape-size 0)))
+;;      (begin
+;;       <body>
+;;       (write-char #\newline)))
+;;
+;; So first the pointer and tape variables are set up correctly, then the
+;; program's body is executed in this context, and finally we output an
+;; additional newline character in case the program does not output one.
+;;
+;; The fact that we are compiling to Guile primitives gives this
+;; implementation a number of interesting characteristics. First, the
+;; values of the tape cells do not underflow or overflow. We could make
+;; them do otherwise via compiling calls to "modulo" at certain points.
+;;
+;; In addition, tape overruns or underruns will be detected, and will
+;; throw an error, whereas a number of Brainfuck compilers do not detect
+;; this.
+;;
+;; Note that we're generating the S-expression representation of
+;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL
+;; data structures. This makes the compiler more pleasant to look at,
+;; but we do lose is the ability to propagate source information. Since
+;; Brainfuck is so obtuse anyway, this shouldn't matter ;-)
+;;
+;; `compile-tree-il' takes as its input the read expression, the
+;; environment, and some compile options. It returns the compiled
+;; expression, the environment appropriate for the next pass of the
+;; compiler -- in our case, just the environment unchanged -- and the
+;; continuation environment.
+;;
+;; The normal use of a continuation environment is if compiling one
+;; expression changes the environment, and that changed environment
+;; should be passed to the next compiled expression -- for example,
+;; changing the current module. But Brainfuck is incapable of that, so
+;; for us, the continuation environment is just the same environment we
+;; got in.
+;;
+;; FIXME: perhaps use options or the env to set the tape-size?
+
+(define (compile-tree-il exp env opts)
+  (values
+   (parse-tree-il
+    `(let (pointer tape) (pointer tape)
+          ((const 0)
+           (apply (primitive make-vector) (const ,tape-size) (const 0)))
+          ,(compile-body exp)))
+   env
+   env))
+
+
+;; Compile a list of instructions to a Tree-IL expression.
+
+(define (compile-body instructions)
+  (let lp ((in instructions) (out '()))
+    (define (emit x)
+      (lp (cdr in) (cons x out)))
+    (cond
+     ((null? in)
+      ;; No more input, build our output.
+       (cond
+        ((null? out) '(void)) ; no output
+        ((null? (cdr out)) (car out)) ; single expression
+        (else `(begin ,@(reverse out))))  ; sequence
+       )
+     (else
+      (pmatch (car in)
+
+        ;; Pointer moves >< are done simply by something like:
+        ;;   (set! pointer (+ pointer +-1))
+        ((<bf-move> ,dir)
+         (emit `(set! (lexical pointer)
+                      (apply (primitive +) (lexical pointer) (const ,dir)))))
+
+        ;; Cell increment +- is done as:
+        ;;   (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
+        ((<bf-increment> ,inc) 
+         (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
+                       (apply (primitive +)
+                              (apply (primitive vector-ref)
+                                     (lexical tape) (lexical pointer))
+                              (const ,inc)))))
+
+        ;; Output . is done by converting the cell's integer value to a
+        ;; character first and then printing out this character:
+        ;;   (write-char (integer->char (vector-ref tape pointer)))
+        ((<bf-print>) 
+         (emit `(apply (primitive write-char)
+                       (apply (primitive integer->char)
+                              (apply (primitive vector-ref)
+                                     (lexical tape) (lexical pointer))))))
+
+        ;; Input , is done similarly, read in a character, get its ASCII
+        ;; code and store it into the current cell:
+        ;;   (vector-set! tape pointer (char->integer (read-char)))
+        ((<bf-read>) 
+         (emit `(apply (primitive vector-set!)
+                       (lexical tape) (lexical pointer)
+                       (apply (primitive char->integer)
+                              (apply (primitive read-char))))))
+
+        ;; For loops [...] we use a letrec construction to execute the body until
+        ;; the current cell gets zero.  The body is compiled via a recursive call
+        ;; back to (compile-body).
+        ;;   (let iterate ()
+        ;;     (if (not (= (vector-ref! tape pointer) 0))
+        ;;         (begin
+        ;;          <body>
+        ;;          (iterate))))
+        ;;
+        ;; Indeed, letrec is the only way we have to loop in Tree-IL.
+        ;; Note that this does not mean that the closure must actually
+        ;; be created; later passes can compile tail-recursive letrec
+        ;; calls into inline code with gotos. Admittedly, that part of
+        ;; the compiler is not yet in place, but it will be, and in the
+        ;; meantime the code is still reasonably efficient.
+        ((<bf-loop> . ,body)
+         (let ((iterate (gensym)))
+           (emit `(letrec (iterate) (,iterate)
+                          ((lambda ()
+                             (lambda-case
+                              ((() #f #f #f () ())
+                               (if (apply (primitive =)
+                                          (apply (primitive vector-ref)
+                                                 (lexical tape) (lexical pointer))
+                                          (const 0))
+                                   (void)
+                                   (begin ,(compile-body body)
+                                          (apply (lexical ,iterate)))))
+                              #f)))
+                     (apply (lexical ,iterate))))))
+
+        (else (error "unknown brainfuck instruction" (car in))))))))
+;;; Brainfuck for GNU Guile.
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language brainfuck parse)
+  #\export (read-brainfuck))
+
+; Purpose of the parse module is to read in brainfuck in text form and produce
+; the corresponding tree representing the brainfuck code.
+;
+; Each object (representing basically a single instruction) is structured like:
+; (<instruction> [arguments])
+; where <instruction> is a symbolic name representing the type of instruction
+; and the optional arguments represent further data (for instance, the body of
+; a [...] loop as a number of nested instructions).
+
+
+; While reading a number of instructions in sequence, all of them are cons'ed
+; onto a list of instructions; thus this list gets out in reverse order.
+; Additionally, for "comment characters" (everything not an instruction) we
+; generate <bf-nop> NOP instructions.
+;
+; This routine reverses a list of instructions and removes all <bf-nop>'s on the
+; way to fix these two issues for a read-in list.
+
+(define (reverse-without-nops lst)
+  (let iterate ((cur lst)
+                (result '()))
+    (if (null? cur)
+      result
+      (let ((head (car cur))
+            (tail (cdr cur)))
+        (if (eq? (car head) '<bf-nop>)
+          (iterate tail result)
+          (iterate tail (cons head result)))))))
+
+
+; Read in a set of instructions until a terminating ] character is found (or
+; end of file is reached).  This is used both for loop bodies and whole
+; programs, so that a program has to be either terminated by EOF or an
+; additional ], too.
+;
+; For instance, the basic program so just echo one character would be:
+; ,.]
+
+(define (read-brainfuck p)
+  (let iterate ((parsed '()))
+    (let ((chr (read-char p)))
+      (cond
+       ((eof-object? chr)
+        (let ((parsed (reverse-without-nops parsed)))
+          (if (null? parsed)
+              chr ;; pass on the EOF object
+              parsed)))
+       ((eqv? chr #\])
+        (reverse-without-nops parsed))
+       (else
+        (iterate (cons (process-input-char chr p) parsed)))))))
+
+
+; This routine processes a single character of input and builds the
+; corresponding instruction.  Loop bodies are read by recursively calling
+; back (read-brainfuck).
+;
+; For the poiner movement commands >< and the cell increment/decrement +-
+; commands, we only use one instruction form each and specify the direction of
+; the pointer/value increment using an argument to the instruction form.
+
+(define (process-input-char chr p)
+  (case chr
+    ((#\>) '(<bf-move> 1))
+    ((#\<) '(<bf-move> -1))
+    ((#\+) '(<bf-increment> 1))
+    ((#\-) '(<bf-increment> -1))
+    ((#\.) '(<bf-print>))
+    ((#\,) '(<bf-read>))
+    ((#\[) `(<bf-loop> ,@(read-brainfuck p)))
+    (else '(<bf-nop>))))
+;;; Brainfuck for GNU Guile.
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language brainfuck spec)
+  #\use-module (language brainfuck compile-tree-il)
+  #\use-module (language brainfuck compile-scheme)
+  #\use-module (language brainfuck parse)
+  #\use-module (system base language)
+  #\export (brainfuck))
+
+
+; The new language is integrated into Guile via this (define-language)
+; specification in the special module (language [lang] spec).
+; Provided is a parser-routine in #\reader, a output routine in #\printer
+; and one or more compiler routines (as target-language - routine pairs)
+; in #\compilers.  This is the basic set of fields needed to specify a new
+; language.
+
+(define-language brainfuck
+  #\title	"Brainfuck"
+  #\reader	(lambda (port env) (read-brainfuck port))
+  #\compilers	`((tree-il . ,compile-tree-il)
+                  (scheme . ,compile-scheme))
+  #\printer	write
+  )
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language bytecode spec)
+  #\use-module (system base language)
+  #\use-module (system vm objcode)
+  #\export (bytecode))
+
+(define (compile-objcode x e opts)
+  (values (bytecode->objcode x) e e))
+
+(define (decompile-objcode x e opts)
+  (values (objcode->bytecode x) e))
+
+(define-language bytecode
+  #\title	"Guile Bytecode Vectors"
+  #\reader	(lambda (port env) (read port))
+  #\printer	write
+  #\compilers   `((objcode . ,compile-objcode))
+  #\decompilers `((objcode . ,decompile-objcode))
+  #\for-humans? #f
+  )
+;;; ECMAScript for Guile
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language ecmascript array)
+  #\use-module (oop goops)
+  #\use-module (language ecmascript base)
+  #\use-module (language ecmascript function)
+  #\export (*array-prototype* new-array))
+
+
+(define-class <js-array-object> (<js-object>)
+  (vector #\init-value #() #\accessor js-array-vector #\init-keyword #\vector))
+
+(define (new-array . vals)
+  (let ((o (make <js-array-object> #\class "Array"
+                 #\prototype *array-prototype*)))
+    (pput o 'length (length vals))
+    (let ((vect (js-array-vector o)))
+      (let lp ((i 0) (vals vals))
+        (cond ((not (null? vals))
+               (vector-set! vect i (car vals))
+               (lp (1+ i) (cdr vals)))
+              (else o))))))
+
+(define *array-prototype* (make <js-object> #\class "Array"
+                                #\value new-array
+                                #\constructor new-array))
+
+(hashq-set! *program-wrappers* new-array *array-prototype*)
+
+(pput *array-prototype* 'prototype *array-prototype*)
+(pput *array-prototype* 'constructor new-array)
+
+(define-method (pget (o <js-array-object>) p)
+  (cond ((and (integer? p) (exact? p) (>= p 0))
+         (let ((v (js-array-vector o)))
+           (if (< p (vector-length v))
+               (vector-ref v p)
+               (next-method))))
+        ((or (and (symbol? p) (eq? p 'length))
+             (and (string? p) (string=? p "length")))
+         (vector-length (js-array-vector o)))
+        (else (next-method))))
+
+(define-method (pput (o <js-array-object>) p v)
+  (cond ((and (integer? p) (exact? p) (>= 0 p))
+         (let ((vect (js-array-vector o)))
+           (if (< p (vector-length vect))
+               (vector-set! vect p v)
+               ;; Fixme: round up to powers of 2?
+               (let ((new (make-vector (1+ p) 0)))
+                 (vector-move-left! vect 0 (vector-length vect) new 0)
+                 (set! (js-array-vector o) new)
+                 (vector-set! new p v)))))
+        ((or (and (symbol? p) (eq? p 'length))
+             (and (string? p) (string=? p "length")))
+         (let ((vect (js-array-vector o)))
+           (let ((new (make-vector (->uint32 v) 0)))
+             (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v))
+                                new 0)
+             (set! (js-array-vector o) new))))
+        (else (next-method))))
+
+(define-js-method *array-prototype* (toString)
+  (format #f "~A" (js-array-vector this)))
+
+(define-js-method *array-prototype* (concat . rest)
+  (let* ((len (apply + (->uint32 (pget this 'length))
+                     (map (lambda (x) (->uint32 (pget x 'length)))
+                          rest)))
+         (rv (make-vector len 0)))
+    (let lp ((objs (cons this rest)) (i 0))
+      (cond ((null? objs) (make <js-array-object> #\class "Array"
+                                #\prototype *array-prototype*
+                                #\vector rv))
+            ((is-a? (car objs) <js-array-object>)
+             (let ((v (js-array-vector (car objs))))
+               (vector-move-left! v 0 (vector-length v)
+                                  rv i)
+               (lp (cdr objs) (+ i (vector-length v)))))
+            (else
+             (error "generic array concats not yet implemented"))))))
+
+(define-js-method *array-prototype* (join . separator)
+  (let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
+    (if (< i 0)
+        (string-join l (if separator (->string (car separator)) ","))
+        (lp (1+ i)
+            (cons (->string (pget this i)) l)))))
+
+(define-js-method *array-prototype* (pop)
+  (let ((len (->uint32 (pget this 'length))))
+    (if (zero? len)
+        *undefined*
+        (let ((ret (pget this (1- len))))
+          (pput this 'length (1- len))
+          ret))))
+
+(define-js-method *array-prototype* (push . args)
+  (let lp ((args args))
+    (if (null? args)
+        (->uint32 (pget this 'length))
+        (begin (pput this (->uint32 (pget this 'length)) (car args))
+               (lp (cdr args))))))
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language ecmascript base)
+  #\use-module (oop goops)
+  #\export (*undefined* *this*
+            <js-object> *object-prototype*
+            js-prototype js-props js-prop-attrs js-value js-constructor js-class
+            pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel
+
+            object->string object->number object->value/string
+            object->value/number object->value
+
+            ->primitive ->boolean ->number ->integer ->int32 ->uint32
+            ->uint16 ->string ->object
+
+            call/this* call/this lambda/this define-js-method
+
+            new-object new))
+
+(define *undefined* ((@@ (oop goops) make-unbound)))
+(define *this* (make-fluid))
+
+(define-class <js-object> ()
+  (prototype #\getter js-prototype #\init-keyword #\prototype
+             #\init-thunk (lambda () *object-prototype*))
+  (props #\getter js-props #\init-form (make-hash-table 7))
+  (prop-attrs #\getter js-prop-attrs #\init-value #f)
+  (value #\getter js-value #\init-value #f #\init-keyword #\value)
+  (constructor #\getter js-constructor #\init-value #f #\init-keyword #\constructor)
+  (class #\getter js-class #\init-value "Object" #\init-keyword #\class))
+
+(define-method (prop-keys (o <js-object>))
+  (hash-map->list (lambda (k v) k) (js-props o)))
+
+(define-method (pget (o <js-object>) (p <string>))
+  (pget o (string->symbol p)))
+
+(define-method (pget (o <js-object>) p)
+  (let ((h (hashq-get-handle (js-props o) p)))
+    (if h
+        (cdr h)
+        (let ((proto (js-prototype o)))
+          (if proto
+              (pget proto p)
+              *undefined*)))))
+
+(define-method (prop-attrs (o <js-object>) p)
+  (or (let ((attrs (js-prop-attrs o)))
+        (and attrs (hashq-ref (js-prop-attrs o) p)))
+      (let ((proto (js-prototype o)))
+        (if proto
+            (prop-attrs proto p)
+            '()))))
+
+(define-method (prop-has-attr? (o <js-object>) p attr)
+  (memq attr (prop-attrs o p)))
+
+(define-method (pput (o <js-object>) p v)
+  (if (prop-has-attr? o p 'ReadOnly)
+      (throw 'ReferenceError o p)
+      (hashq-set! (js-props o) p v)))
+
+(define-method (pput (o <js-object>) (p <string>) v)
+  (pput o (string->symbol p) v))
+
+(define-method (pdel (o <js-object>) p)
+  (if (prop-has-attr? o p 'DontDelete)
+      #f
+      (begin
+        (pput o p *undefined*)
+        #t)))
+
+(define-method (pdel (o <js-object>) (p <string>) v)
+  (pdel o (string->symbol p)))
+
+(define-method (has-property? (o <js-object>) p)
+  (if (hashq-get-handle (js-props o) p)
+      #t
+      (let ((proto (js-prototype o)))
+        (if proto
+            (has-property? proto p)
+            #f))))
+
+(define (call/this* this f)
+  (with-fluid* *this* this f))
+
+(define-macro (call/this this f . args)
+  `(with-fluid* *this* ,this (lambda () (,f . ,args))))
+(define-macro (lambda/this formals . body)
+  `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body)))
+(define-macro (define-js-method object name-and-args . body)
+  `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body)))
+
+(define *object-prototype* #f)
+(set! *object-prototype* (make <js-object>))
+
+(define-js-method *object-prototype* (toString)
+  (format #f "[object ~A]" (js-class this)))
+(define-js-method *object-prototype* (toLocaleString . args)
+  ((pget *object-prototype* 'toString)))
+(define-js-method *object-prototype* (valueOf)
+  this)
+(define-js-method *object-prototype* (hasOwnProperty p)
+  (and (hashq-get-handle (js-props this) p) #t))
+(define-js-method *object-prototype* (isPrototypeOf v)
+  (eq? this (js-prototype v)))
+(define-js-method *object-prototype* (propertyIsEnumerable p)
+  (and (hashq-get-handle (js-props this) p)
+       (not (prop-has-attr? this p 'DontEnum))))
+
+(define (object->string o error?)
+  (let ((toString (pget o 'toString)))
+    (if (procedure? toString)
+        (let ((x (call/this o toString)))
+          (if (and error? (is-a? x <js-object>))
+              (throw 'TypeError o 'default-value)
+              x))
+        (if error?
+            (throw 'TypeError o 'default-value)
+            o))))
+              
+(define (object->number o error?)
+  (let ((valueOf (pget o 'valueOf)))
+    (if (procedure? valueOf)
+        (let ((x (call/this o valueOf)))
+          (if (and error? (is-a? x <js-object>))
+              (throw 'TypeError o 'default-value)
+              x))
+        (if error?
+            (throw 'TypeError o 'default-value)
+            o))))
+              
+(define (object->value/string o)
+  (if (is-a? o <js-object>)
+      (object->number o #t)
+      o))
+
+(define (object->value/number o)
+  (if (is-a? o <js-object>)
+      (object->string o #t)
+      o))
+
+(define (object->value o)
+  ;; FIXME: if it's a date, we should try numbers first
+  (object->value/string o))
+              
+(define (->primitive x)
+  (if (is-a? x <js-object>)
+      (object->value x)
+      x))
+
+(define (->boolean x)
+  (not (or (not x) (null? x) (eq? x *undefined*)
+           (and (number? x) (or (zero? x) (nan? x)))
+           (and (string? x) (= (string-length x) 0)))))
+
+(define (->number x)
+  (cond ((number? x) x)
+        ((boolean? x) (if x 1 0))
+        ((null? x) 0)
+        ((eq? x *undefined*) +nan.0)
+        ((is-a? x <js-object>) (object->number x #t))
+        ((string? x) (string->number x))
+        (else (throw 'TypeError x '->number))))
+
+(define (->integer x)
+  (let ((n (->number x)))
+    (cond ((nan? n) 0)
+          ((zero? n) n)
+          ((inf? n) n)
+          (else (inexact->exact (round n))))))
+
+(define (->int32 x)
+  (let ((n (->number x)))
+    (if (or (nan? n) (zero? n) (inf? n))
+        0
+        (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
+          (if (negative? n)
+              (- m (ash 1 32))
+              m)))))
+
+(define (->uint32 x)
+  (let ((n (->number x)))
+    (if (or (nan? n) (zero? n) (inf? n))
+        0
+        (logand (1- (ash 1 32)) (inexact->exact (round n))))))
+
+(define (->uint16 x)
+  (let ((n (->number x)))
+    (if (or (nan? n) (zero? n) (inf? n))
+        0
+        (logand (1- (ash 1 16)) (inexact->exact (round n))))))
+
+(define (->string x)
+  (cond ((eq? x *undefined*) "undefined")
+        ((null? x) "null")
+        ((boolean? x) (if x "true" "false"))
+        ((string? x) x)
+        ((number? x)
+         (cond ((nan? x) "NaN")
+               ((zero? x) "0")
+               ((inf? x) "Infinity")
+               (else (number->string x))))
+        (else (->string (object->value/string x)))))
+
+(define (->object x)
+  (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
+        ((null? x) (throw 'TypeError x '->object))
+        ((boolean? x) (make <js-object> #\prototype Boolean #\value x))
+        ((number? x) (make <js-object> #\prototype String #\value x))
+        ((string? x) (make <js-object> #\prototype Number #\value x))
+        (else x)))
+
+(define (new-object . pairs)
+  (let ((o (make <js-object>)))
+    (map (lambda (pair)
+           (pput o (car pair) (cdr pair)))
+         pairs)
+    o))
+(slot-set! *object-prototype* 'constructor new-object)
+
+(define-method (new o . initargs)
+  (let ((ctor (js-constructor o)))
+    (if (not ctor)
+        (throw 'TypeError 'new o)
+        (let ((o (make <js-object>
+                   #\prototype (or (js-prototype o) *object-prototype*))))
+          (let ((new-o (call/this o apply ctor initargs)))
+            (if (is-a? new-o <js-object>)
+                new-o
+                o))))))
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language ecmascript compile-tree-il)
+  #\use-module (language tree-il)
+  #\use-module (ice-9 receive)
+  #\use-module (system base pmatch)
+  #\use-module (srfi srfi-1)
+  #\export (compile-tree-il))
+
+(define-syntax-rule (-> (type arg ...))
+  `(type ,arg ...))
+
+(define-syntax-rule (@implv sym)
+  (-> (@ '(language ecmascript impl) 'sym)))
+
+(define-syntax-rule (@impl sym arg ...)
+  (-> (apply (@implv sym) arg ...)))
+
+(define (empty-lexical-environment)
+  '())
+
+(define (econs name gensym env)
+  (acons name (-> (lexical name gensym)) env))
+
+(define (lookup name env)
+  (or (assq-ref env name)
+      (-> (toplevel name))))
+
+(define (compile-tree-il exp env opts)
+  (values
+   (parse-tree-il
+    (-> (begin (@impl js-init)
+               (comp exp (empty-lexical-environment)))))
+   env
+   env))
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+              props))))
+
+;; for emacs:
+;; (put 'pmatch/source 'scheme-indent-function 1)
+
+(define-syntax-rule (pmatch/source x clause ...)
+  (let ((x x))
+    (let ((res (pmatch x
+                 clause ...)))
+      (let ((loc (location x)))
+        (if loc
+            (set-source-properties! res (location x))))
+      res)))
+
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+  (-> (abort (or (current-return-tag) (error "return outside function"))
+             (list expr)
+             (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+  (let ((tag (gensym "return")))
+    (parameterize ((current-return-tag
+                    (-> (lexical 'return tag))))
+      (-> (let '(return) (list tag)
+               (list (-> (apply (-> (primitive 'make-prompt-tag)))))
+               (-> (prompt (current-return-tag)
+                           (body-thunk)
+                           (let ((val (gensym "val")))
+                             (-> (lambda-case
+                                  `(((k val) #f #f #f () (,(gensym) ,val))
+                                    ,(-> (lexical 'val val)))))))))))))
+
+(define (comp x e)
+  (let ((l (location x)))
+    (define (let1 what proc)
+      (let ((sym (gensym))) 
+        (-> (let (list sym) (list sym) (list what)
+                 (proc sym)))))
+    (define (begin1 what proc)
+      (let1 what (lambda (v)
+                   (-> (begin (proc v)
+                              (-> (lexical v v)))))))
+    (pmatch/source x
+      (null
+       ;; FIXME, null doesn't have much relation to EOL...
+       (-> (const '())))
+      (true
+       (-> (const #t)))
+      (false
+       (-> (const #f)))
+      ((number ,num)
+       (-> (const num)))
+      ((string ,str)
+       (-> (const str)))
+      (this
+       (@impl get-this))
+      ((+ ,a)
+       (-> (apply (-> (primitive '+))
+                  (@impl ->number (comp a e))
+                  (-> (const 0)))))
+      ((- ,a)
+       (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+      ((~ ,a)
+       (@impl bitwise-not (comp a e)))
+      ((! ,a)
+       (@impl logical-not (comp a e)))
+      ((+ ,a ,b)
+       (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+      ((- ,a ,b)
+       (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+      ((/ ,a ,b)
+       (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+      ((* ,a ,b)
+       (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+      ((% ,a ,b)
+       (@impl mod (comp a e) (comp b e)))
+      ((<< ,a ,b)
+       (@impl shift (comp a e) (comp b e)))
+      ((>> ,a ,b)
+       (@impl shift (comp a e) (comp `(- ,b) e)))
+      ((< ,a ,b)
+       (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+      ((<= ,a ,b)
+       (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+      ((> ,a ,b)
+       (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+      ((>= ,a ,b)
+       (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+      ((in ,a ,b)
+       (@impl has-property? (comp a e) (comp b e)))
+      ((== ,a ,b)
+       (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+      ((!= ,a ,b)
+       (-> (apply (-> (primitive 'not))
+                  (-> (apply (-> (primitive 'equal?))
+                             (comp a e) (comp b e))))))
+      ((=== ,a ,b)
+       (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+      ((!== ,a ,b)
+       (-> (apply (-> (primitive 'not))
+                  (-> (apply (-> (primitive 'eqv?))
+                             (comp a e) (comp b e))))))
+      ((& ,a ,b)
+       (@impl band (comp a e) (comp b e)))
+      ((^ ,a ,b)
+       (@impl bxor (comp a e) (comp b e)))
+      ((bor ,a ,b)
+       (@impl bior (comp a e) (comp b e)))
+      ((and ,a ,b)
+       (-> (if (@impl ->boolean (comp a e))
+               (comp b e)
+               (-> (const #f)))))
+      ((or ,a ,b)
+       (let1 (comp a e)
+             (lambda (v)
+               (-> (if (@impl ->boolean (-> (lexical v v)))
+                       (-> (lexical v v))
+                       (comp b e))))))
+      ((if ,test ,then ,else)
+       (-> (if (@impl ->boolean (comp test e))
+               (comp then e)
+               (comp else e))))
+      ((if ,test ,then)
+       (-> (if (@impl ->boolean (comp test e))
+               (comp then e)
+               (@implv *undefined*))))
+      ((postinc (ref ,foo))
+       (begin1 (comp `(ref ,foo) e)
+               (lambda (var)
+                 (-> (set! (lookup foo e)
+                           (-> (apply (-> (primitive '+))
+                                      (-> (lexical var var))
+                                      (-> (const 1)))))))))
+      ((postinc (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (@impl pget
+                              (-> (lexical objvar objvar))
+                              (-> (const prop)))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (apply (-> (primitive '+))
+                                           (-> (lexical tmpvar tmpvar))
+                                           (-> (const 1))))))))))
+      ((postinc (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (@impl pget
+                                      (-> (lexical objvar objvar))
+                                      (-> (lexical propvar propvar)))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (apply (-> (primitive '+))
+                                                   (-> (lexical tmpvar tmpvar))
+                                                   (-> (const 1))))))))))))
+      ((postdec (ref ,foo))
+       (begin1 (comp `(ref ,foo) e)
+               (lambda (var)
+                 (-> (set (lookup foo e)
+                          (-> (apply (-> (primitive '-))
+                                     (-> (lexical var var))
+                                     (-> (const 1)))))))))
+      ((postdec (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (@impl pget
+                              (-> (lexical objvar objvar))
+                              (-> (const prop)))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (apply (-> (primitive '-))
+                                           (-> (lexical tmpvar tmpvar))
+                                           (-> (const 1))))))))))
+      ((postdec (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (@impl pget
+                                      (-> (lexical objvar objvar))
+                                      (-> (lexical propvar propvar)))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (inline
+                                             '- (-> (lexical tmpvar tmpvar))
+                                             (-> (const 1))))))))))))
+      ((preinc (ref ,foo))
+       (let ((v (lookup foo e)))
+         (-> (begin
+               (-> (set! v
+                         (-> (apply (-> (primitive '+))
+                                    v
+                                    (-> (const 1))))))
+               v))))
+      ((preinc (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (apply (-> (primitive '+))
+                                  (@impl pget
+                                         (-> (lexical objvar objvar))
+                                         (-> (const prop)))
+                                  (-> (const 1))))
+                       (lambda (tmpvar)
+                         (@impl pput (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (lexical tmpvar tmpvar))))))))
+      ((preinc (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (-> (apply (-> (primitive '+))
+                                          (@impl pget
+                                                 (-> (lexical objvar objvar))
+                                                 (-> (lexical propvar propvar)))
+                                          (-> (const 1))))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (lexical tmpvar tmpvar))))))))))
+      ((predec (ref ,foo))
+       (let ((v (lookup foo e)))
+         (-> (begin
+               (-> (set! v
+                        (-> (apply (-> (primitive '-))
+                                   v
+                                   (-> (const 1))))))
+               v))))
+      ((predec (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (apply (-> (primitive '-))
+                                  (@impl pget
+                                         (-> (lexical objvar objvar))
+                                         (-> (const prop)))
+                                  (-> (const 1))))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (lexical tmpvar tmpvar))))))))
+      ((predec (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (-> (apply (-> (primitive '-))
+                                          (@impl pget
+                                                 (-> (lexical objvar objvar))
+                                                 (-> (lexical propvar propvar)))
+                                          (-> (const 1))))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (lexical tmpvar tmpvar))))))))))
+      ((ref ,id)
+       (lookup id e))
+      ((var . ,forms)
+       `(begin
+          ,@(map (lambda (form)
+                   (pmatch form
+                     ((,x ,y)
+                      (-> (define x (comp y e))))
+                     ((,x)
+                      (-> (define x (@implv *undefined*))))
+                     (else (error "bad var form" form))))
+                 forms)))
+      ((begin)
+       (-> (void)))
+      ((begin ,form)
+       (comp form e))
+      ((begin . ,forms)
+       `(begin ,@(map (lambda (x) (comp x e)) forms)))
+      ((lambda ,formals ,body)
+       (let ((syms (map (lambda (x)
+                          (gensym (string-append (symbol->string x) " ")))
+                        formals)))
+         `(lambda ()
+            (lambda-case
+             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
+              ,(with-return-prompt
+                (lambda ()
+                  (comp-body e body formals syms))))))))
+      ((call/this ,obj ,prop . ,args)
+       (@impl call/this*
+              obj
+              (-> (lambda '() 
+                    `(lambda-case
+                      ((() #f #f #f () ())
+                       (apply ,(@impl pget obj prop) ,@args)))))))
+      ((call (pref ,obj ,prop) ,args)
+       (comp `(call/this ,(comp obj e)
+                         ,(-> (const prop))
+                         ,@(map (lambda (x) (comp x e)) args))
+             e))
+      ((call (aref ,obj ,prop) ,args)
+       (comp `(call/this ,(comp obj e)
+                         ,(comp prop e)
+                         ,@(map (lambda (x) (comp x e)) args))
+             e))
+      ((call ,proc ,args)
+       `(apply ,(comp proc e)                
+               ,@(map (lambda (x) (comp x e)) args)))
+      ((return ,expr)
+       (return (comp expr e)))
+      ((array . ,args)
+       `(apply ,(@implv new-array)
+               ,@(map (lambda (x) (comp x e)) args)))
+      ((object . ,args)
+       `(apply ,(@implv new-object)
+               ,@(map (lambda (x)
+                         (pmatch x
+                                 ((,prop ,val)
+                                  (-> (apply (-> (primitive 'cons))
+                                             (-> (const prop))
+                                             (comp val e))))
+                                 (else
+                                  (error "bad prop-val pair" x))))
+                       args)))
+      ((pref ,obj ,prop)
+       (@impl pget
+              (comp obj e)
+              (-> (const prop))))
+      ((aref ,obj ,index)
+       (@impl pget
+              (comp obj e)
+              (comp index e)))
+      ((= (ref ,name) ,val)
+       (let ((v (lookup name e)))
+         (-> (begin
+               (-> (set! v (comp val e)))
+               v))))
+      ((= (pref ,obj ,prop) ,val)
+       (@impl pput
+              (comp obj e)
+              (-> (const prop))
+              (comp val e)))
+      ((= (aref ,obj ,prop) ,val)
+       (@impl pput
+              (comp obj e)
+              (comp prop e)
+              (comp val e)))
+      ((+= ,what ,val)
+       (comp `(= ,what (+ ,what ,val)) e))
+      ((-= ,what ,val)
+       (comp `(= ,what (- ,what ,val)) e))
+      ((/= ,what ,val)
+       (comp `(= ,what (/ ,what ,val)) e))
+      ((*= ,what ,val)
+       (comp `(= ,what (* ,what ,val)) e))
+      ((%= ,what ,val)
+       (comp `(= ,what (% ,what ,val)) e))
+      ((>>= ,what ,val)
+       (comp `(= ,what (>> ,what ,val)) e))
+      ((<<= ,what ,val)
+       (comp `(= ,what (<< ,what ,val)) e))
+      ((>>>= ,what ,val)
+       (comp `(= ,what (>>> ,what ,val)) e))
+      ((&= ,what ,val)
+       (comp `(= ,what (& ,what ,val)) e))
+      ((bor= ,what ,val)
+       (comp `(= ,what (bor ,what ,val)) e))
+      ((^= ,what ,val)
+       (comp `(= ,what (^ ,what ,val)) e))
+      ((new ,what ,args)
+       (@impl new
+              (map (lambda (x) (comp x e))
+                   (cons what args))))
+      ((delete (pref ,obj ,prop))
+       (@impl pdel
+              (comp obj e)
+              (-> (const prop))))
+      ((delete (aref ,obj ,prop))
+       (@impl pdel
+              (comp obj e)
+              (comp prop e)))
+      ((void ,expr)
+       (-> (begin
+             (comp expr e)
+             (@implv *undefined*))))
+      ((typeof ,expr)
+       (@impl typeof
+              (comp expr e)))
+      ((do ,statement ,test)
+       (let ((%loop (gensym "%loop "))
+             (%continue (gensym "%continue ")))
+         (let ((e (econs '%loop %loop (econs '%continue %continue e))))
+           (-> (letrec '(%loop %continue) (list %loop %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (begin
+                                                 (comp statement e)
+                                                 (-> (apply (-> (lexical '%continue %continue)))))))))))
+                             (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (@impl ->boolean (comp test e))
+                                                   (-> (apply (-> (lexical '%loop %loop))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (apply (-> (lexical '%loop %loop)))))))))
+      ((while ,test ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (@impl ->boolean (comp test e))
+                                                   (-> (begin (comp statement e)
+                                                              (-> (apply (-> (lexical '%continue %continue))))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (apply (-> (lexical '%continue %continue)))))))))
+      
+      ((for ,init ,test ,inc ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (if test
+                                                       (@impl ->boolean (comp test e))
+                                                       (comp 'true e))
+                                                   (-> (begin (comp statement e)
+                                                              (comp (or inc '(begin)) e)
+                                                              (-> (apply (-> (lexical '%continue %continue))))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (begin (comp (or init '(begin)) e)
+                                  (-> (apply (-> (lexical '%continue %continue)))))))))))
+      
+      ((for-in ,var ,object ,statement)
+       (let ((%enum (gensym "%enum "))
+             (%continue (gensym "%continue ")))
+         (let ((e (econs '%enum %enum (econs '%continue %continue e))))
+           (-> (letrec '(%enum %continue) (list %enum %continue)
+                       (list (@impl make-enumerator (comp object e))
+                             (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          (-> (if (@impl ->boolean
+                                                         (@impl pget
+                                                                (-> (lexical '%enum %enum))
+                                                                (-> (const 'length))))
+                                                  (-> (begin
+                                                        (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+                                                                                  ,(-> (const 'pop))))
+                                                              e)
+                                                        (comp statement e)
+                                                        (-> (apply (-> (lexical '%continue %continue))))))
+                                                  (@implv *undefined*)))))))))
+                       (-> (apply (-> (lexical '%continue %continue)))))))))
+      
+      ((block ,x)
+       (comp x e))
+      (else
+       (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals formal-syms)
+  (define (process)
+    (let lp ((in body) (out '()) (rvars '()))
+      (pmatch in
+        (((var (,x) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             out
+             (if (or (memq x rvars) (memq x formals))
+                 rvars
+                 (cons x rvars))))
+        (((var (,x ,y) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             `((= (ref ,x) ,y) . ,out)
+             (if (or (memq x rvars) (memq x formals))
+                 rvars
+                 (cons x rvars))))
+        (((var) . ,rest)
+         (lp rest out rvars))
+        ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+         (lp rest
+             (cons x out)
+             rvars))
+        ((,x . ,rest) (guard (pair? x))
+         (receive (sub-out rvars)
+             (lp x '() rvars)
+           (lp rest
+               (cons sub-out out)
+               rvars)))
+        ((,x . ,rest)
+         (lp rest
+             (cons x out)
+             rvars))
+        (()
+         (values (reverse! out)
+                 rvars)))))
+  (receive (out rvars)
+      (process)
+    (let* ((names (reverse rvars))
+           (syms (map (lambda (x)
+                        (gensym (string-append (symbol->string x) " ")))
+                      names))
+           (e (fold econs (fold econs e formals formal-syms) names syms)))
+      (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
+               (comp out e))))))
+;;; ECMAScript for Guile
+
+;; 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
+
+;;; Code:
+
+(define-module (language ecmascript function)
+  #\use-module (oop goops)
+  #\use-module (language ecmascript base)
+  #\export (*function-prototype* *program-wrappers*))
+
+
+(define-class <js-program-wrapper> (<js-object>))
+
+(define *program-wrappers* (make-doubly-weak-hash-table 31))
+
+(define *function-prototype* (make <js-object> #\class "Function"
+                                   #\value (lambda args *undefined*)))
+
+(define-js-method *function-prototype* (toString)
+  (format #f "~A" (js-value this)))
+
+(define-js-method *function-prototype* (apply this-arg array)
+  (cond ((or (null? array) (eq? array *undefined*))
+         (call/this this-arg (js-value this)))
+        ((is-a? array <js-array-object>)
+         (call/this this-arg
+                    (lambda ()
+                      (apply (js-value this)
+                             (vector->list (js-array-vector array))))))
+        (else
+         (throw 'TypeError 'apply array))))
+
+(define-js-method *function-prototype* (call this-arg . args)
+  (call/this this-arg
+             (lambda ()
+               (apply (js-value this) args))))
+
+(define-method (pget (o <applicable>) p)
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (pget wrapper p)
+        (pget *function-prototype* p))))
+
+(define-method (pput (o <applicable>) p v)
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (pput wrapper p v)
+        (let ((wrapper (make <js-program-wrapper> #\value o #\class "Function"
+                             #\prototype *function-prototype*)))
+          (hashq-set! *program-wrappers* o wrapper)
+          (pput wrapper p v)))))
+
+(define-method (js-prototype (o <applicable>))
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (js-prototype wrapper)
+        #f)))
+
+(define-method (js-constructor (o <applicable>))
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (js-constructor wrapper)
+        #f)))
+;;; ECMAScript for Guile
+
+;; 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
+
+;;; Code:
+
+(define-module (language ecmascript impl)
+  #\use-module (oop goops)
+  #\use-module (language ecmascript base)
+  #\use-module (language ecmascript function)
+  #\use-module (language ecmascript array)
+  #\re-export (*undefined* *this* call/this*
+               pget pput pdel has-property?
+               ->boolean ->number
+               new-object new new-array)
+  #\export (js-init get-this
+            typeof
+            bitwise-not logical-not
+            shift
+            mod
+            band bxor bior
+            make-enumerator))
+
+
+(define-class <js-module-object> (<js-object>)
+  (module #\init-form (current-module) #\init-keyword #\module
+          #\getter js-module))
+(define-method (pget (o <js-module-object>) (p <string>))
+  (pget o (string->symbol p)))
+(define-method (pget (o <js-module-object>) (p <symbol>))
+  (let ((v (module-variable (js-module o) p)))
+    (if v
+        (variable-ref v)
+        (next-method))))
+(define-method (pput (o <js-module-object>) (p <string>) v)
+  (pput o (string->symbol p) v))
+(define-method (pput (o <js-module-object>) (p <symbol>) v)
+  (module-define! (js-module o) p v))
+(define-method (prop-attrs (o <js-module-object>) (p <symbol>))
+  (cond ((module-local-variable (js-module o) p) '())
+        ((module-variable (js-module o) p) '(DontDelete ReadOnly))
+        (else (next-method))))
+(define-method (prop-attrs (o <js-module-object>) (p <string>))
+  (prop-attrs o (string->symbol p)))
+(define-method (prop-keys (o <js-module-object>))
+  (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o)))
+          (next-method)))
+
+;; we could make a renamer, but having obj['foo-bar'] should be enough
+(define (js-require modstr)
+  (make <js-module-object> #\module
+        (resolve-interface (map string->symbol (string-split modstr #\.)))))
+      
+(define-class <js-global-object> (<js-module-object>))
+(define-method (js-module (o <js-global-object>))
+  (current-module))
+
+(define (init-js-bindings! mod)
+  (module-define! mod 'NaN +nan.0)
+  (module-define! mod 'Infinity +inf.0)
+  (module-define! mod 'undefined *undefined*)
+  (module-define! mod 'require js-require)
+  ;; isNAN, isFinite, parseFloat, parseInt, eval
+  ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent
+  ;; Object Function Array String Boolean Number Date RegExp Error EvalError
+  ;; RangeError ReferenceError SyntaxError TypeError URIError
+  (module-define! mod 'Object *object-prototype*)
+  (module-define! mod 'Array *array-prototype*))
+
+(define (js-init)
+  (cond ((get-this))
+        (else
+         (fluid-set! *this* (make <js-global-object>))
+         (init-js-bindings! (current-module)))))
+
+(define (get-this)
+  (fluid-ref *this*))
+
+(define (typeof x)
+  (cond ((eq? x *undefined*) "undefined")
+        ((null? x) "object")
+        ((boolean? x) "boolean")
+        ((number? x) "number")
+        ((string? x) "string")
+        ((procedure? x) "function")
+        ((is-a? x <js-object>) "object")
+        (else "scm")))
+
+(define bitwise-not lognot)
+(define (logical-not x)
+  (not (->boolean (->primitive x))))
+
+(define shift ash)
+
+(define band logand)
+(define bxor logxor)
+(define bior logior)
+
+(define mod modulo)
+
+(define-method (+ (a <string>) (b <string>))
+  (string-append a b))
+
+(define-method (+ (a <string>) b)
+  (string-append a (->string b)))
+
+(define-method (+ a (b <string>))
+  (string-append (->string a) b))
+
+(define-method (+ a b)
+  (+ (->number a) (->number b)))
+
+(define-method (- a b)
+  (- (->number a) (->number b)))
+
+(define-method (* a b)
+  (* (->number a) (->number b)))
+
+(define-method (/ a b)
+  (/ (->number a) (->number b)))
+
+(define-method (< a b)
+  (< (->number a) (->number b)))
+(define-method (< (a <string>) (b <string>))
+  (string< a b))
+
+(define-method (<= a b)
+  (<= (->number a) (->number b)))
+(define-method (<= (a <string>) (b <string>))
+  (string<= a b))
+
+(define-method (>= a b)
+  (>= (->number a) (->number b)))
+(define-method (>= (a <string>) (b <string>))
+  (string>= a b))
+
+(define-method (> a b)
+  (> (->number a) (->number b)))
+(define-method (> (a <string>) (b <string>))
+  (string> a b))
+
+(define (obj-and-prototypes o)
+  (if o
+      (cons o (obj-and-prototypes (js-prototype o)))
+      '()))
+              
+(define (make-enumerator obj)
+  (let ((props (make-hash-table 23)))
+    (for-each (lambda (o)
+                (for-each (lambda (k) (hashq-set! props k #t))
+                          (prop-keys o)))
+              (obj-and-prototypes obj))
+    (apply new-array (filter (lambda (p)
+                               (not (prop-has-attr? obj p 'DontEnum)))
+                             (hash-map->list (lambda (k v) k) props)))))
+;;; ECMAScript for Guile
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language ecmascript parse)
+  #\use-module (system base lalr)
+  #\use-module (language ecmascript tokenize)
+  #\export (read-ecmascript read-ecmascript/1 make-parser))
+
+(define* (syntax-error message #\optional token)
+  (if (lexical-token? token)
+      (throw 'syntax-error #f message
+             (and=> (lexical-token-source token)
+                    source-location->source-properties)
+             (or (lexical-token-value token)
+                 (lexical-token-category token))
+             #f)
+      (throw 'syntax-error #f message #f token #f)))
+
+(define (read-ecmascript port)
+  (let ((parse (make-parser)))
+    (parse (make-tokenizer port) syntax-error)))
+
+(define (read-ecmascript/1 port)
+  (let ((parse (make-parser)))
+    (parse (make-tokenizer/1 port) syntax-error)))
+
+(define *eof-object*
+  (call-with-input-string "" read-char))
+
+(define (make-parser)
+  ;; Return a fresh ECMAScript parser.  Parsers produced by `lalr-scm' are now
+  ;; stateful (e.g., they won't invoke the tokenizer any more once it has
+  ;; returned `*eoi*'), hence the need to instantiate new parsers.
+
+  (lalr-parser
+   ;; terminal (i.e. input) token types
+   (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma <
+    > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ? 
+    colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /=
+
+    break else new var case finally return void catch for switch while
+    continue function this with default if throw delete in try do
+    instanceof typeof null true false
+
+    Identifier StringLiteral NumericLiteral RegexpLiteral)
+
+
+   (Program (SourceElements) \: $1
+            (*eoi*) \: *eof-object*)
+
+   ;;
+   ;; Verily, here we define statements. Expressions are defined
+   ;; afterwards.
+   ;;
+
+   (SourceElement (Statement) \: $1
+                  (FunctionDeclaration) \: $1)
+
+   (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) \: `(var (,$2 (lambda () ,$6)))
+                        (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) \: `(var (,$2 (lambda ,$4 ,$7))))
+   (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) \: `(lambda () ,$5)
+                       (function Identifier lparen rparen lbrace FunctionBody rbrace) \: `(lambda () ,$6)
+                       (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) \: `(lambda ,$3 ,$6)
+                       (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) \: `(lambda ,$4 ,$7))
+   (FormalParameterList (Identifier) \: `(,$1)
+                        (FormalParameterList comma Identifier) \: `(,@$1 ,$3))
+   (SourceElements (SourceElement) \: $1
+                   (SourceElements SourceElement) \: (if (and (pair? $1) (eq? (car $1) 'begin))
+                                                         `(begin ,@(cdr $1) ,$2)
+                                                         `(begin ,$1 ,$2)))
+   (FunctionBody (SourceElements) \: $1
+                 () \: '(begin))
+
+   (Statement (Block) \: $1
+              (VariableStatement) \: $1
+              (EmptyStatement) \: $1
+              (ExpressionStatement) \: $1
+              (IfStatement) \: $1
+              (IterationStatement) \: $1
+              (ContinueStatement) \: $1
+              (BreakStatement) \: $1
+              (ReturnStatement) \: $1
+              (WithStatement) \: $1
+              (LabelledStatement) \: $1
+              (SwitchStatement) \: $1
+              (ThrowStatement) \: $1
+              (TryStatement) \: $1)
+
+   (Block (lbrace StatementList rbrace) \: `(block ,$2))
+   (StatementList (Statement) \: $1
+                  (StatementList Statement) \: (if (and (pair? $1) (eq? (car $1) 'begin))
+                                                   `(begin ,@(cdr $1) ,$2)
+                                                   `(begin ,$1 ,$2)))
+
+   (VariableStatement (var VariableDeclarationList) \: `(var ,@$2))
+   (VariableDeclarationList (VariableDeclaration) \: `(,$1)
+                            (VariableDeclarationList comma VariableDeclaration) \: `(,@$1 ,$2))
+   (VariableDeclarationListNoIn (VariableDeclarationNoIn) \: `(,$1)
+                                (VariableDeclarationListNoIn comma VariableDeclarationNoIn) \: `(,@$1 ,$2))
+   (VariableDeclaration (Identifier) \: `(,$1)
+                        (Identifier Initialiser) \: `(,$1 ,$2))
+   (VariableDeclarationNoIn (Identifier) \: `(,$1)
+                            (Identifier Initialiser) \: `(,$1 ,$2))
+   (Initialiser (= AssignmentExpression) \: $2)
+   (InitialiserNoIn (= AssignmentExpressionNoIn) \: $2)
+
+   (EmptyStatement (semicolon) \: '(begin))
+
+   (ExpressionStatement (Expression semicolon) \: $1)
+
+   (IfStatement (if lparen Expression rparen Statement else Statement) \: `(if ,$3 ,$5 ,$7)
+                (if lparen Expression rparen Statement) \: `(if ,$3 ,$5))
+   
+   (IterationStatement (do Statement while lparen Expression rparen semicolon) \: `(do ,$2 ,$5)
+
+                       (while lparen Expression rparen Statement) \: `(while ,$3 ,$5)
+
+                       (for lparen semicolon semicolon rparen Statement) \: `(for #f #f #f ,$6)
+                       (for lparen semicolon semicolon Expression rparen Statement) \: `(for #f #f ,$5 ,$7)
+                       (for lparen semicolon Expression semicolon rparen Statement) \: `(for #f ,$4 #f ,$7)
+                       (for lparen semicolon Expression semicolon Expression rparen Statement) \: `(for #f ,$4 ,$6 ,$8)
+
+                       (for lparen ExpressionNoIn semicolon semicolon rparen Statement) \: `(for ,$3 #f #f ,$7)
+                       (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) \: `(for ,$3 #f ,$6 ,$8)
+                       (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) \: `(for ,$3 ,$5 #f ,$8)
+                       (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) \: `(for ,$3 ,$5 ,$7 ,$9)
+
+                       (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) \: `(for (var ,@$4) #f #f ,$8)
+                       (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) \: `(for (var ,@$4) #f ,$7 ,$9)
+                       (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) \: `(for (var ,@$4) ,$6 #f ,$9)
+                       (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) \: `(for (var ,@$4) ,$6 ,$8 ,$10)
+
+                       (for lparen LeftHandSideExpression in Expression rparen Statement) \: `(for-in ,$3 ,$5 ,$7)
+                       (for lparen var VariableDeclarationNoIn in Expression rparen Statement) \: `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))
+
+   (ContinueStatement (continue Identifier semicolon) \: `(continue ,$2)
+                      (continue semicolon) \: `(continue))
+
+   (BreakStatement (break Identifier semicolon) \: `(break ,$2)
+                   (break semicolon) \: `(break))
+
+   (ReturnStatement (return Expression semicolon) \: `(return ,$2)
+                    (return semicolon) \: `(return))
+
+   (WithStatement (with lparen Expression rparen Statement) \: `(with ,$3 ,$5))
+
+   (SwitchStatement (switch lparen Expression rparen CaseBlock) \: `(switch ,$3 ,@$5))
+   (CaseBlock (lbrace rbrace) \: '()
+              (lbrace CaseClauses rbrace) \: $2
+              (lbrace CaseClauses DefaultClause rbrace) \: `(,@$2 ,@$3)
+              (lbrace DefaultClause rbrace) \: `(,$2)
+              (lbrace DefaultClause CaseClauses rbrace) \: `(,@$2 ,@$3))
+   (CaseClauses (CaseClause) \: `(,$1)
+                (CaseClauses CaseClause) \: `(,@$1 ,$2))
+   (CaseClause (case Expression colon) \: `(case ,$2)
+               (case Expression colon StatementList) \: `(case ,$2 ,$4))
+   (DefaultClause (default colon) \: `(default)
+                  (default colon StatementList) \: `(default ,$3))
+
+   (LabelledStatement (Identifier colon Statement) \: `(label ,$1 ,$3))
+
+   (ThrowStatement (throw Expression semicolon) \: `(throw ,$2))
+
+   (TryStatement (try Block Catch) \: `(try ,$2 ,$3 #f)
+                 (try Block Finally) \: `(try ,$2 #f ,$3)
+                 (try Block Catch Finally) \: `(try ,$2 ,$3 ,$4))
+   (Catch (catch lparen Identifier rparen Block) \: `(catch ,$3 ,$5))
+   (Finally (finally Block) \: `(finally ,$2))
+
+   ;;
+   ;; As promised, expressions. We build up to Expression bottom-up, so
+   ;; as to get operator precedence right.
+   ;;
+
+   (PrimaryExpression (this) \: 'this
+                      (null) \: 'null
+                      (true) \: 'true
+                      (false) \: 'false
+                      (Identifier) \: `(ref ,$1)
+                      (StringLiteral) \: `(string ,$1)
+                      (RegexpLiteral) \: `(regexp ,$1)
+                      (NumericLiteral) \: `(number ,$1)
+                      (dot NumericLiteral) \: `(number ,(string->number (string-append "." (number->string $2))))
+                      (ArrayLiteral) \: $1
+                      (ObjectLiteral) \: $1
+                      (lparen Expression rparen) \: $2)
+
+   (ArrayLiteral (lbracket rbracket) \: '(array)
+                 (lbracket Elision rbracket) \: '(array ,@$2)
+                 (lbracket ElementList rbracket) \: `(array ,@$2)
+                 (lbracket ElementList comma rbracket) \: `(array ,@$2)
+                 (lbracket ElementList comma Elision rbracket) \: `(array ,@$2))
+   (ElementList (AssignmentExpression) \: `(,$1)
+                (Elision AssignmentExpression) \: `(,@$1 ,$2)
+                (ElementList comma AssignmentExpression) \: `(,@$1 ,$3)
+                (ElementList comma Elision AssignmentExpression) \: `(,@$1 ,@$3 ,$4))
+   (Elision (comma) \: '((number 0))
+            (Elision comma) \: `(,@$1 (number 0)))
+
+   (ObjectLiteral (lbrace rbrace) \: `(object)
+                  (lbrace PropertyNameAndValueList rbrace) \: `(object ,@$2))
+   (PropertyNameAndValueList (PropertyName colon AssignmentExpression) \: `((,$1 ,$3))
+                             (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) \: `(,@$1 (,$3 ,$5)))
+   (PropertyName (Identifier) \: $1
+                 (StringLiteral) \: (string->symbol $1)
+                 (NumericLiteral) \: $1)
+
+   (MemberExpression (PrimaryExpression) \: $1
+                     (FunctionExpression) \: $1
+                     (MemberExpression lbracket Expression rbracket) \: `(aref ,$1 ,$3)
+                     (MemberExpression dot Identifier) \: `(pref ,$1 ,$3)
+                     (new MemberExpression Arguments) \: `(new ,$2 ,$3))
+
+   (NewExpression (MemberExpression) \: $1
+                  (new NewExpression) \: `(new ,$2 ()))
+
+   (CallExpression (MemberExpression Arguments) \: `(call ,$1 ,$2)
+                   (CallExpression Arguments) \: `(call ,$1 ,$2)
+                   (CallExpression lbracket Expression rbracket) \: `(aref ,$1 ,$3)
+                   (CallExpression dot Identifier) \: `(pref ,$1 ,$3))
+   (Arguments (lparen rparen) \: '()
+              (lparen ArgumentList rparen) \: $2)
+   (ArgumentList (AssignmentExpression) \: `(,$1)
+                 (ArgumentList comma AssignmentExpression) \: `(,@$1 ,$3))
+
+   (LeftHandSideExpression (NewExpression) \: $1
+                           (CallExpression) \: $1)
+
+   (PostfixExpression (LeftHandSideExpression) \: $1
+                      (LeftHandSideExpression ++) \: `(postinc ,$1)
+                      (LeftHandSideExpression --) \: `(postdec ,$1))
+
+   (UnaryExpression (PostfixExpression) \: $1
+                    (delete UnaryExpression) \: `(delete ,$2)
+                    (void UnaryExpression) \: `(void ,$2)
+                    (typeof UnaryExpression) \: `(typeof ,$2)
+                    (++ UnaryExpression) \: `(preinc ,$2)
+                    (-- UnaryExpression) \: `(predec ,$2)
+                    (+ UnaryExpression) \: `(+ ,$2)
+                    (- UnaryExpression) \: `(- ,$2)
+                    (~ UnaryExpression) \: `(~ ,$2)
+                    (! UnaryExpression) \: `(! ,$2))
+
+   (MultiplicativeExpression (UnaryExpression) \: $1
+                             (MultiplicativeExpression * UnaryExpression) \: `(* ,$1 ,$3)
+                             (MultiplicativeExpression / UnaryExpression) \: `(/ ,$1 ,$3)
+                             (MultiplicativeExpression % UnaryExpression) \: `(% ,$1 ,$3))
+
+   (AdditiveExpression (MultiplicativeExpression) \: $1
+                       (AdditiveExpression + MultiplicativeExpression) \: `(+ ,$1 ,$3)
+                       (AdditiveExpression - MultiplicativeExpression) \: `(- ,$1 ,$3))
+
+   (ShiftExpression (AdditiveExpression) \: $1
+                    (ShiftExpression << MultiplicativeExpression) \: `(<< ,$1 ,$3)
+                    (ShiftExpression >> MultiplicativeExpression) \: `(>> ,$1 ,$3)
+                    (ShiftExpression >>> MultiplicativeExpression) \: `(>>> ,$1 ,$3))
+
+   (RelationalExpression (ShiftExpression) \: $1
+                         (RelationalExpression < ShiftExpression) \: `(< ,$1 ,$3)
+                         (RelationalExpression > ShiftExpression) \: `(> ,$1 ,$3)
+                         (RelationalExpression <= ShiftExpression) \: `(<= ,$1 ,$3)
+                         (RelationalExpression >= ShiftExpression) \: `(>= ,$1 ,$3)
+                         (RelationalExpression instanceof ShiftExpression) \: `(instanceof ,$1 ,$3)
+                         (RelationalExpression in ShiftExpression) \: `(in ,$1 ,$3))
+
+   (RelationalExpressionNoIn (ShiftExpression) \: $1
+                             (RelationalExpressionNoIn < ShiftExpression) \: `(< ,$1 ,$3)
+                             (RelationalExpressionNoIn > ShiftExpression) \: `(> ,$1 ,$3)
+                             (RelationalExpressionNoIn <= ShiftExpression) \: `(<= ,$1 ,$3)
+                             (RelationalExpressionNoIn >= ShiftExpression) \: `(>= ,$1 ,$3)
+                             (RelationalExpressionNoIn instanceof ShiftExpression) \: `(instanceof ,$1 ,$3))
+
+   (EqualityExpression (RelationalExpression) \: $1
+                       (EqualityExpression == RelationalExpression) \: `(== ,$1 ,$3)
+                       (EqualityExpression != RelationalExpression) \: `(!= ,$1 ,$3)
+                       (EqualityExpression === RelationalExpression) \: `(=== ,$1 ,$3)
+                       (EqualityExpression !== RelationalExpression) \: `(!== ,$1 ,$3))
+
+   (EqualityExpressionNoIn (RelationalExpressionNoIn) \: $1
+                           (EqualityExpressionNoIn == RelationalExpressionNoIn) \: `(== ,$1 ,$3)
+                           (EqualityExpressionNoIn != RelationalExpressionNoIn) \: `(!= ,$1 ,$3)
+                           (EqualityExpressionNoIn === RelationalExpressionNoIn) \: `(=== ,$1 ,$3)
+                           (EqualityExpressionNoIn !== RelationalExpressionNoIn) \: `(!== ,$1 ,$3))
+
+   (BitwiseANDExpression (EqualityExpression) \: $1
+                         (BitwiseANDExpression & EqualityExpression) \: `(& ,$1 ,$3))
+   (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) \: $1
+                             (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) \: `(& ,$1 ,$3))
+
+   (BitwiseXORExpression (BitwiseANDExpression) \: $1
+                         (BitwiseXORExpression ^ BitwiseANDExpression) \: `(^ ,$1 ,$3))
+   (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) \: $1
+                             (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) \: `(^ ,$1 ,$3))
+
+   (BitwiseORExpression (BitwiseXORExpression) \: $1
+                        (BitwiseORExpression bor BitwiseXORExpression) \: `(bor ,$1 ,$3))
+   (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) \: $1
+                            (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) \: `(bor ,$1 ,$3))
+
+   (LogicalANDExpression (BitwiseORExpression) \: $1
+                         (LogicalANDExpression && BitwiseORExpression) \: `(and ,$1 ,$3))
+   (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) \: $1
+                             (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) \: `(and ,$1 ,$3))
+
+   (LogicalORExpression (LogicalANDExpression) \: $1
+                        (LogicalORExpression or LogicalANDExpression) \: `(or ,$1 ,$3))
+   (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) \: $1
+                            (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) \: `(or ,$1 ,$3))
+
+   (ConditionalExpression (LogicalORExpression) \: $1
+                          (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) \: `(if ,$1 ,$3 ,$5))
+   (ConditionalExpressionNoIn (LogicalORExpressionNoIn) \: $1
+                              (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) \: `(if ,$1 ,$3 ,$5))
+
+   (AssignmentExpression (ConditionalExpression) \: $1
+                         (LeftHandSideExpression AssignmentOperator AssignmentExpression) \: `(,$2 ,$1 ,$3))
+   (AssignmentExpressionNoIn (ConditionalExpressionNoIn) \: $1
+                             (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) \: `(,$2 ,$1 ,$3))
+   (AssignmentOperator (=) \: '=
+                       (*=) \: '*=
+                       (/=) \: '/=
+                       (%=) \: '%=
+                       (+=) \: '+=
+                       (-=) \: '-=
+                       (<<=) \: '<<=
+                       (>>=) \: '>>=
+                       (>>>=) \: '>>>=
+                       (&=) \: '&=
+                       (^=) \: '^=
+                       (bor=) \: 'bor=)
+
+   (Expression (AssignmentExpression) \: $1
+               (Expression comma AssignmentExpression) \: `(begin ,$1 ,$3))
+   (ExpressionNoIn (AssignmentExpressionNoIn) \: $1
+                   (ExpressionNoIn comma AssignmentExpressionNoIn) \: `(begin ,$1 ,$3))))
+;;; ECMAScript specification for Guile
+
+;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language ecmascript spec)
+  #\use-module (system base language)
+  #\use-module (language ecmascript parse)
+  #\use-module (language ecmascript compile-tree-il)
+  #\export (ecmascript))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language ecmascript
+  #\title	"ECMAScript"
+  #\reader	(lambda (port env) (read-ecmascript/1 port))
+  #\compilers   `((tree-il . ,compile-tree-il))
+  ;; a pretty-printer would be interesting.
+  #\printer	write
+  )
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript tokenize)
+  #\use-module (ice-9 rdelim)
+  #\use-module ((srfi srfi-1) #\select (unfold-right))
+  #\use-module (system base lalr)
+  #\export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
+
+(define (syntax-error what loc form . args)
+  (throw 'syntax-error #f what
+         (and=> loc source-location->source-properties)
+         form #f args))
+
+(define (port-source-location port)
+  (make-source-location (port-filename port)
+                        (port-line port)
+                        (port-column port)
+                        (false-if-exception (ftell port))
+                        #f))
+
+;; taken from SSAX, sorta
+(define (read-until delims port loc)
+  (if (eof-object? (peek-char port))
+      (syntax-error "EOF while reading a token" loc #f)
+      (let ((token (read-delimited delims port 'peek)))
+        (if (eof-object? (peek-char port))
+            (syntax-error "EOF while reading a token" loc token)
+            token))))
+
+(define (char-hex? c)
+  (and (not (eof-object? c))
+       (or (char-numeric? c)
+           (memv c '(#\a #\b #\c #\d #\e #\f))
+           (memv c '(#\A #\B #\C #\D #\E #\F)))))
+
+(define (digit->number c)
+  (- (char->integer c) (char->integer #\0)))
+
+(define (hex->number c)
+  (if (char-numeric? c)
+      (digit->number c)
+      (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
+
+(define (read-slash port loc div?)
+  (let ((c1 (begin
+              (read-char port)
+              (peek-char port))))
+    (cond
+     ((eof-object? c1)
+      ;; hmm. error if we're not looking for a div? ?
+      (make-lexical-token '/ loc #f))
+     ((char=? c1 #\/)
+      (read-line port)
+      (next-token port div?))
+     ((char=? c1 #\*)
+      (read-char port)
+      (let lp ((c (read-char port)))
+        (cond
+         ((eof-object? c)
+          (syntax-error "EOF while in multi-line comment" loc #f))
+         ((char=? c #\*)
+          (if (eqv? (peek-char port) #\/)
+              (begin
+                (read-char port)
+                (next-token port div?))
+              (lp (read-char port))))
+         (else
+          (lp (read-char port))))))
+     (div?
+      (case c1
+        ((#\=) (read-char port) (make-lexical-token '/= loc #f))
+        (else (make-lexical-token '/ loc #f))))
+     (else
+      (read-regexp port loc)))))
+
+(define (read-regexp port loc)
+  ;; first slash already read
+  (let ((terms (string #\/ #\\ #\nl #\cr)))
+    (let lp ((str (read-until terms port loc)) (head ""))
+      (let ((terminator (peek-char port)))
+        (cond
+         ((char=? terminator #\/)
+          (read-char port)
+          ;; flags
+          (let lp ((c (peek-char port)) (flags '()))
+            (if (or (eof-object? c)
+                    (not (or (char-alphabetic? c)
+                             (char-numeric? c)
+                             (char=? c #\$)
+                             (char=? c #\_))))
+                (make-lexical-token 'RegexpLiteral loc
+                                    (cons (string-append head str)
+                                          (reverse flags)))
+                (begin (read-char port)
+                       (lp (peek-char port) (cons c flags))))))
+         ((char=? terminator #\\)
+          (read-char port)
+          (let ((echar (read-char port)))
+            (lp (read-until terms port loc)
+                (string-append head str (string #\\ echar)))))
+         (else
+          (syntax-error "regexp literals may not contain newlines"
+                        loc str)))))))
+
+(define (read-string port loc)
+  (let ((c (read-char port)))
+    (let ((terms (string c #\\ #\nl #\cr)))
+      (define (read-escape port)
+        (let ((c (read-char port)))
+          (case c
+            ((#\' #\" #\\) c)
+            ((#\b) #\bs)
+            ((#\f) #\np)
+            ((#\n) #\nl)
+            ((#\r) #\cr)
+            ((#\t) #\tab)
+            ((#\v) #\vt)
+            ((#\0)
+             (let ((next (peek-char port)))
+               (cond
+                ((eof-object? next) #\nul)
+                ((char-numeric? next)
+                 (syntax-error "octal escape sequences are not supported"
+                               loc #f))
+                (else #\nul))))
+            ((#\x)
+             (let* ((a (read-char port))
+                    (b (read-char port)))
+               (cond
+                ((and (char-hex? a) (char-hex? b))
+                 (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
+                (else
+                 (syntax-error "bad hex character escape" loc (string a b))))))
+            ((#\u)
+             (let* ((a (read-char port))
+                    (b (read-char port))
+                    (c (read-char port))
+                    (d (read-char port)))
+               (integer->char (string->number (string a b c d) 16))))
+            (else
+             c))))
+      (let lp ((str (read-until terms port loc)))
+        (let ((terminator (peek-char port)))
+          (cond
+           ((char=? terminator c)
+            (read-char port)
+            (make-lexical-token 'StringLiteral loc str))
+           ((char=? terminator #\\)
+            (read-char port)
+            (let ((echar (read-escape port)))
+              (lp (string-append str (string echar)
+                                 (read-until terms port loc)))))
+           (else
+            (syntax-error "string literals may not contain newlines"
+                          loc str))))))))
+
+(define *keywords*
+  '(("break" . break)
+    ("else" . else)
+    ("new" . new)
+    ("var" . var)
+    ("case" . case)
+    ("finally" . finally)
+    ("return" . return)
+    ("void" . void)
+    ("catch" . catch)
+    ("for" . for)
+    ("switch" . switch)
+    ("while" . while)
+    ("continue" . continue)
+    ("function" . function)
+    ("this" . this)
+    ("with" . with)
+    ("default" . default)
+    ("if" . if)
+    ("throw" . throw)
+    ("delete" . delete)
+    ("in" . in)
+    ("try" . try)
+    ("do" . do)
+    ("instanceof" . instanceof)
+    ("typeof" . typeof)
+
+    ;; these aren't exactly keywords, but hey
+    ("null" . null)
+    ("true" . true)
+    ("false" . false)))
+
+(define *future-reserved-words*
+  '(("abstract" . abstract)
+    ("enum" . enum)
+    ("int" . int)
+    ("short" . short)
+    ("boolean" . boolean)
+    ("export" . export)
+    ("interface" . interface)
+    ("static" . static)
+    ("byte" . byte)
+    ("extends" . extends)
+    ("long" . long)
+    ("super" . super)
+    ("char" . char)
+    ("final" . final)
+    ("native" . native)
+    ("synchronized" . synchronized)
+    ("class" . class)
+    ("float" . float)
+    ("package" . package)
+    ("throws" . throws)
+    ("const" . const)
+    ("goto" . goto)
+    ("private" . private)
+    ("transient" . transient)
+    ("debugger" . debugger)
+    ("implements" . implements)
+    ("protected" . protected)
+    ("volatile" . volatile)
+    ("double" . double)
+    ("import" . import)
+    ("public" . public)))
+
+(define (read-identifier port loc)
+  (let lp ((c (peek-char port)) (chars '()))
+    (if (or (eof-object? c)
+            (not (or (char-alphabetic? c)
+                     (char-numeric? c)
+                     (char=? c #\$)
+                     (char=? c #\_))))
+        (let ((word (list->string (reverse chars))))
+          (cond ((assoc-ref *keywords* word)
+                 => (lambda (x) (make-lexical-token x loc #f)))
+                ((assoc-ref *future-reserved-words* word)
+                 (syntax-error "word is reserved for the future, dude."
+                               loc word))
+                (else (make-lexical-token 'Identifier loc
+                                          (string->symbol word)))))
+        (begin (read-char port)
+               (lp (peek-char port) (cons c chars))))))
+
+(define (read-numeric port loc)
+  (let* ((c0 (if (char=? (peek-char port) #\.)
+                 #\0
+                 (read-char port)))
+         (c1 (peek-char port)))
+    (cond
+     ((eof-object? c1) (digit->number c0))
+     ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X)))
+      (read-char port)
+      (let ((c (peek-char port)))
+        (if (not (char-hex? c))
+            (syntax-error "bad digit reading hexadecimal number"
+                          loc c))
+        (let lp ((c c) (acc 0))
+          (cond ((char-hex? c)
+                 (read-char port)
+                 (lp (peek-char port)
+                     (+ (* 16 acc) (hex->number c))))
+                (else
+                 acc)))))
+     ((and (char=? c0 #\0) (char-numeric? c1))
+      (let lp ((c c1) (acc 0))
+        (cond ((eof-object? c) acc)
+              ((char-numeric? c)
+               (if (or (char=? c #\8) (char=? c #\9))
+                   (syntax-error "invalid digit in octal sequence"
+                                 loc c))
+               (read-char port)
+               (lp (peek-char port)
+                   (+ (* 8 acc) (digit->number c))))
+              (else
+               acc))))
+     (else
+      (let lp ((c1 c1) (acc (digit->number c0)))
+        (cond
+         ((eof-object? c1) acc)
+         ((char-numeric? c1)
+          (read-char port)
+          (lp (peek-char port)
+              (+ (* 10 acc) (digit->number c1))))
+         ((or (char=? c1 #\e) (char=? c1 #\E))
+          (read-char port)
+          (let ((add (let ((c (peek-char port)))
+                       (cond ((eof-object? c)
+                              (syntax-error "error reading exponent: EOF"
+                                            loc #f))
+                             ((char=? c #\+) (read-char port) +)
+                             ((char=? c #\-) (read-char port) -)
+                             ((char-numeric? c) +)
+                             (else
+                              (syntax-error "error reading exponent: non-digit"
+                                            loc c))))))
+            (let lp ((c (peek-char port)) (e 0))
+              (cond ((and (not (eof-object? c)) (char-numeric? c))
+                     (read-char port)
+                     (lp (peek-char port) (add (* 10 e) (digit->number c))))
+                    (else
+                     (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
+         ((char=? c1 #\.)
+          (read-char port)
+          (let lp2 ((c (peek-char port)) (dec 0.0) (n -1))
+            (cond ((and (not (eof-object? c)) (char-numeric? c))
+                   (read-char port)
+                   (lp2 (peek-char port)
+                        (+ dec (* (digit->number c) (expt 10 n)))
+                        (1- n)))
+                  (else
+                   ;; loop back to catch an exponential part
+                   (lp c (+ acc dec))))))
+         (else
+          acc)))))))
+           
+(define *punctuation*
+  '(("{" . lbrace)
+    ("}" . rbrace)
+    ("(" . lparen)
+    (")" . rparen)
+    ("[" . lbracket)
+    ("]" . rbracket)
+    ("." . dot)
+    (";" . semicolon)
+    ("," . comma)
+    ("<" . <)
+    (">" . >)
+    ("<=" . <=)
+    (">=" . >=)
+    ("==" . ==)
+    ("!=" . !=)
+    ("===" . ===)
+    ("!==" . !==)
+    ("+" . +)
+    ("-" . -)
+    ("*" . *)
+    ("%" . %)
+    ("++" . ++)
+    ("--" . --)
+    ("<<" . <<)
+    (">>" . >>)
+    (">>>" . >>>)
+    ("&" . &)
+    ("|" . bor)
+    ("^" . ^)
+    ("!" . !)
+    ("~" . ~)
+    ("&&" . &&)
+    ("||" . or)
+    ("?" . ?)
+    (":" . colon)
+    ("=" . =)
+    ("+=" . +=)
+    ("-=" . -=)
+    ("*=" . *=)
+    ("%=" . %=)
+    ("<<=" . <<=)
+    (">>=" . >>=)
+    (">>>=" . >>>=)
+    ("&=" . &=)
+    ("|=" . bor=)
+    ("^=" . ^=)))
+
+(define *div-punctuation*
+  '(("/" . /)
+    ("/=" . /=)))
+
+;; node ::= (char (symbol | #f) node*)
+(define read-punctuation
+  (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
+                     (cond ((null? puncs)
+                            nodes)
+                           ((assv-ref nodes (string-ref (caar puncs) 0))
+                            => (lambda (node-tail)
+                                 (if (= (string-length (caar puncs)) 1)
+                                     (set-car! node-tail (cdar puncs))
+                                     (set-cdr! node-tail
+                                               (lp (cdr node-tail)
+                                                   `((,(substring (caar puncs) 1)
+                                                      . ,(cdar puncs))))))
+                                 (lp nodes (cdr puncs))))
+                           (else
+                            (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
+                                puncs))))))
+    (lambda (port loc)
+      (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
+        (cond
+         ((assv-ref tree c)
+          => (lambda (node-tail)
+               (read-char port)
+               (lp (peek-char port) (cdr node-tail) (car node-tail))))
+         (candidate
+          (make-lexical-token candidate loc #f))
+         (else
+          (syntax-error "bad syntax: character not allowed" loc c)))))))
+
+(define (next-token port div?)
+  (let ((c   (peek-char port))
+        (loc (port-source-location port)))
+    (case c
+      ((#\ht #\vt #\np #\space #\x00A0) ; whitespace
+       (read-char port)
+       (next-token port div?))
+      ((#\newline #\cr)                 ; line break
+       (read-char port)
+       (next-token port div?))
+      ((#\/)
+       ;; division, single comment, double comment, or regexp
+       (read-slash port loc div?))
+      ((#\" #\')                        ; string literal
+       (read-string port loc))
+      (else
+       (cond
+        ((eof-object? c)
+         '*eoi*)
+        ((or (char-alphabetic? c)
+             (char=? c #\$)
+             (char=? c #\_))
+         ;; reserved word or identifier
+         (read-identifier port loc))
+        ((char-numeric? c)
+         ;; numeric -- also accept . FIXME, requires lookahead
+         (make-lexical-token 'NumericLiteral loc (read-numeric port loc)))
+        (else
+         ;; punctuation
+         (read-punctuation port loc)))))))
+
+(define (make-tokenizer port)
+  (let ((div? #f))
+    (lambda ()
+      (let ((tok (next-token port div?)))
+        (set! div? (and (lexical-token? tok)
+                        (let ((cat (lexical-token-category tok)))
+                          (or (eq? cat 'Identifier)
+                              (eq? cat 'NumericLiteral)
+                              (eq? cat 'StringLiteral)))))
+        tok))))
+
+(define (make-tokenizer/1 port)
+  (let ((div? #f)
+        (eoi? #f)
+        (stack '()))
+    (lambda ()
+      (if eoi?
+          '*eoi*
+          (let ((tok (next-token port div?)))
+            (case (if (lexical-token? tok) (lexical-token-category tok) tok)
+              ((lparen)
+               (set! stack (cons tok stack)))
+              ((rparen)
+               (if (and (pair? stack)
+                        (eq? (lexical-token-category (car stack)) 'lparen))
+                   (set! stack (cdr stack))
+                   (syntax-error "unexpected right parenthesis"
+                                 (lexical-token-source tok)
+                                 #f)))
+              ((lbracket)
+               (set! stack (cons tok stack)))
+              ((rbracket)
+               (if (and (pair? stack)
+                        (eq? (lexical-token-category (car stack)) 'lbracket))
+                   (set! stack (cdr stack))
+                   (syntax-error "unexpected right bracket"
+                                 (lexical-token-source tok)
+                                 #f)))
+              ((lbrace)
+               (set! stack (cons tok stack)))
+              ((rbrace)
+               (if (and (pair? stack)
+                        (eq? (lexical-token-category (car stack)) 'lbrace))
+                   (set! stack (cdr stack))
+                   (syntax-error "unexpected right brace"
+                                 (lexical-token-source tok)
+                                 #f)))
+              ((semicolon)
+               (set! eoi? (null? stack))))
+            (set! div? (and (lexical-token? tok)
+                            (let ((cat (lexical-token-category tok)))
+                              (or (eq? cat 'Identifier)
+                                  (eq? cat 'NumericLiteral)
+                                  (eq? cat 'StringLiteral)))))
+            tok)))))
+
+(define (tokenize port)
+  (let ((next (make-tokenizer port)))
+    (let lp ((out '()))
+      (let ((tok (next)))
+        (if (eq? tok '*eoi*)
+            (reverse! out)
+            (lp (cons tok out)))))))
+
+(define (tokenize/1 port)
+  (let ((next (make-tokenizer/1 port)))
+    (let lp ((out '()))
+      (let ((tok (next)))
+        (if (eq? tok '*eoi*)
+            (reverse! out)
+            (lp (cons tok out)))))))
+
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language elisp bindings)
+  #\export (make-bindings
+            mark-global-needed!
+            map-globals-needed
+            with-lexical-bindings
+            with-dynamic-bindings
+            get-lexical-binding))
+
+;;; This module defines routines to handle analysis of symbol bindings
+;;; used during elisp compilation.  This data allows to collect the
+;;; symbols, for which globals need to be created, or mark certain
+;;; symbols as lexically bound.
+;;;
+;;; Needed globals are stored in an association-list that stores a list
+;;; of symbols for each module they are needed in.
+;;;
+;;; The lexical bindings of symbols are stored in a hash-table that
+;;; associates symbols to fluids; those fluids are used in the
+;;; with-lexical-binding and with-dynamic-binding routines to associate
+;;; symbols to different bindings over a dynamic extent.
+
+;;; Record type used to hold the data necessary.
+
+(define bindings-type
+  (make-record-type 'bindings '(needed-globals lexical-bindings)))
+
+;;; Construct an 'empty' instance of the bindings data structure to be
+;;; used at the start of a fresh compilation.
+
+(define (make-bindings)
+  ((record-constructor bindings-type) '() (make-hash-table)))
+
+;;; Mark that a given symbol is needed as global in the specified
+;;; slot-module.
+
+(define (mark-global-needed! bindings sym module)
+  (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
+                      bindings))
+         (old-in-module (or (assoc-ref old-needed module) '()))
+         (new-in-module (if (memq sym old-in-module)
+                            old-in-module
+                            (cons sym old-in-module)))
+         (new-needed (assoc-set! old-needed module new-in-module)))
+    ((record-modifier bindings-type 'needed-globals)
+     bindings
+     new-needed)))
+
+;;; Cycle through all globals needed in order to generate the code for
+;;; their creation or some other analysis.
+
+(define (map-globals-needed bindings proc)
+  (let ((needed ((record-accessor bindings-type 'needed-globals)
+                 bindings)))
+    (let iterate-modules ((mod-tail needed)
+                          (mod-result '()))
+      (if (null? mod-tail)
+          mod-result
+          (iterate-modules
+           (cdr mod-tail)
+           (let* ((aentry (car mod-tail))
+                  (module (car aentry))
+                  (symbols (cdr aentry)))
+             (let iterate-symbols ((sym-tail symbols)
+                                   (sym-result mod-result))
+               (if (null? sym-tail)
+                   sym-result
+                   (iterate-symbols (cdr sym-tail)
+                                    (cons (proc module (car sym-tail))
+                                          sym-result))))))))))
+
+;;; Get the current lexical binding (gensym it should refer to in the
+;;; current scope) for a symbol or #f if it is dynamically bound.
+
+(define (get-lexical-binding bindings sym)
+  (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
+               bindings))
+         (slot (hash-ref lex sym #f)))
+    (if slot
+        (fluid-ref slot)
+        #f)))
+
+;;; Establish a binding or mark a symbol as dynamically bound for the
+;;; extent of calling proc.
+
+(define (with-symbol-bindings bindings syms targets proc)
+  (if (or (not (list? syms))
+          (not (and-map symbol? syms)))
+      (error "can't bind non-symbols" syms))
+  (let ((lex ((record-accessor bindings-type 'lexical-bindings)
+              bindings)))
+    (for-each (lambda (sym)
+                (if (not (hash-ref lex sym))
+                    (hash-set! lex sym (make-fluid))))
+              syms)
+    (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
+                  targets
+                  proc)))
+
+(define (with-lexical-bindings bindings syms targets proc)
+  (if (or (not (list? targets))
+          (not (and-map symbol? targets)))
+      (error "invalid targets for lexical binding" targets)
+      (with-symbol-bindings bindings syms targets proc)))
+
+(define (with-dynamic-bindings bindings syms proc)
+  (with-symbol-bindings bindings
+                        syms
+                        (map (lambda (el) #f) syms)
+                        proc))
+;;; Guile Emacs Lisp
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language elisp compile-tree-il)
+  #\use-module (language elisp bindings)
+  #\use-module (language elisp runtime)
+  #\use-module (language tree-il)
+  #\use-module (system base pmatch)
+  #\use-module (system base compile)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-8)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\export (compile-tree-il
+            compile-progn
+            compile-if
+            compile-defconst
+            compile-defvar
+            compile-setq
+            compile-let
+            compile-lexical-let
+            compile-flet
+            compile-let*
+            compile-lexical-let*
+            compile-flet*
+            compile-without-void-checks
+            compile-with-always-lexical
+            compile-guile-ref
+            compile-guile-primitive
+            compile-while
+            compile-function
+            compile-defmacro
+            compile-defun
+            #{compile-\`}
+            compile-quote))
+
+;;; Certain common parameters (like the bindings data structure or
+;;; compiler options) are not always passed around but accessed using
+;;; fluids to simulate dynamic binding (hey, this is about elisp).
+
+;;; The bindings data structure to keep track of symbol binding related
+;;; data.
+
+(define bindings-data (make-fluid))
+
+;;; Store for which symbols (or all/none) void checks are disabled.
+
+(define disable-void-check (make-fluid))
+
+;;; Store which symbols (or all/none) should always be bound lexically,
+;;; even with ordinary let and as lambda arguments.
+
+(define always-lexical (make-fluid))
+
+;;; Find the source properties of some parsed expression if there are
+;;; any associated with it.
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+         (and (not (null? props))
+              props))))
+
+;;; Values to use for Elisp's nil and t.
+
+(define (nil-value loc)
+  (make-const loc (@ (language elisp runtime) nil-value)))
+
+(define (t-value loc)
+  (make-const loc (@ (language elisp runtime) t-value)))
+
+;;; Modules that contain the value and function slot bindings.
+
+(define runtime '(language elisp runtime))
+
+(define value-slot (@ (language elisp runtime) value-slot-module))
+
+(define function-slot (@ (language elisp runtime) function-slot-module))
+
+;;; The backquoting works the same as quasiquotes in Scheme, but the
+;;; forms are named differently; to make easy adaptions, we define these
+;;; predicates checking for a symbol being the car of an
+;;; unquote/unquote-splicing/backquote form.
+
+(define (unquote? sym)
+  (and (symbol? sym) (eq? sym '#{\,})))
+
+(define (unquote-splicing? sym)
+  (and (symbol? sym) (eq? sym '#{\,\@})))
+
+;;; Build a call to a primitive procedure nicely.
+
+(define (call-primitive loc sym . args)
+  (make-application loc (make-primitive-ref loc sym) args))
+
+;;; Error reporting routine for syntax/compilation problems or build
+;;; code for a runtime-error output.
+
+(define (report-error loc . args)
+  (apply error args))
+
+(define (runtime-error loc msg . args)
+  (make-application loc
+                    (make-primitive-ref loc 'error)
+                    (cons (make-const loc msg) args)))
+
+;;; Generate code to ensure a global symbol is there for further use of
+;;; a given symbol.  In general during the compilation, those needed are
+;;; only tracked with the bindings data structure.  Afterwards, however,
+;;; for all those needed symbols the globals are really generated with
+;;; this routine.
+
+(define (generate-ensure-global loc sym module)
+  (make-application loc
+                    (make-module-ref loc runtime 'ensure-fluid! #t)
+                    (list (make-const loc module)
+                          (make-const loc sym))))
+
+(define (ensuring-globals loc bindings body)
+  (make-sequence
+   loc
+   `(,@(map-globals-needed (fluid-ref bindings)
+                           (lambda (mod sym)
+                             (generate-ensure-global loc sym mod)))
+     ,body)))
+
+;;; Build a construct that establishes dynamic bindings for certain
+;;; variables.  We may want to choose between binding with fluids and
+;;; with-fluids* and using just ordinary module symbols and
+;;; setting/reverting their values with a dynamic-wind.
+
+(define (let-dynamic loc syms module vals body)
+  (call-primitive
+   loc
+   'with-fluids*
+   (make-application loc
+                     (make-primitive-ref loc 'list)
+                     (map (lambda (sym)
+                            (make-module-ref loc module sym #t))
+                          syms))
+   (make-application loc (make-primitive-ref loc 'list) vals)
+   (make-lambda loc
+                '()
+                (make-lambda-case #f '() #f #f #f '() '() body #f))))
+
+;;; Handle access to a variable (reference/setting) correctly depending
+;;; on whether it is currently lexically or dynamically bound.  lexical
+;;; access is done only for references to the value-slot module!
+
+(define (access-variable loc
+                         sym
+                         module
+                         handle-global
+                         handle-lexical
+                         handle-dynamic)
+  (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
+    (cond
+     (lexical (handle-lexical lexical))
+     ((equal? module function-slot) (handle-global))
+     (else (handle-dynamic)))))
+
+;;; Generate code to reference a variable.  For references in the
+;;; value-slot module, we may want to generate a lexical reference
+;;; instead if the variable has a lexical binding.
+
+(define (reference-variable loc sym module)
+  (access-variable
+   loc
+   sym
+   module
+   (lambda () (make-module-ref loc module sym #t))
+   (lambda (lexical) (make-lexical-ref loc lexical lexical))
+   (lambda ()
+     (mark-global-needed! (fluid-ref bindings-data) sym module)
+     (call-primitive loc
+                     'fluid-ref
+                     (make-module-ref loc module sym #t)))))
+
+;;; Generate code to set a variable.  Just as with reference-variable, in
+;;; case of a reference to value-slot, we want to generate a lexical set
+;;; when the variable has a lexical binding.
+
+(define (set-variable! loc sym module value)
+  (access-variable
+   loc
+   sym
+   module
+   (lambda ()
+     (make-application
+      loc
+      (make-module-ref loc runtime 'set-variable! #t)
+      (list (make-const loc module) (make-const loc sym) value)))
+   (lambda (lexical) (make-lexical-set loc lexical lexical value))
+   (lambda ()
+     (mark-global-needed! (fluid-ref bindings-data) sym module)
+     (call-primitive loc
+                     'fluid-set!
+                     (make-module-ref loc module sym #t)
+                     value))))
+
+;;; Process the bindings part of a let or let* expression; that is,
+;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
+;;; . val2) ...).
+
+(define (process-let-bindings loc bindings)
+  (map
+   (lambda (b)
+     (if (symbol? b)
+         (cons b 'nil)
+         (if (or (not (list? b))
+                 (not (= (length b) 2)))
+             (report-error
+              loc
+              "expected symbol or list of 2 elements in let")
+             (if (not (symbol? (car b)))
+                 (report-error loc "expected symbol in let")
+                 (cons (car b) (cadr b))))))
+   bindings))
+
+;;; Split the let bindings into a list to be done lexically and one
+;;; dynamically.  A symbol will be bound lexically if and only if: We're
+;;; processing a lexical-let (i.e. module is 'lexical), OR we're
+;;; processing a value-slot binding AND the symbol is already lexically
+;;; bound or is always lexical, OR we're processing a function-slot
+;;; binding.
+
+(define (bind-lexically? sym module)
+  (or (eq? module 'lexical)
+      (eq? module function-slot)
+      (and (equal? module value-slot)
+           (let ((always (fluid-ref always-lexical)))
+             (or (eq? always 'all)
+                 (memq sym always)
+                 (get-lexical-binding (fluid-ref bindings-data) sym))))))
+
+(define (split-let-bindings bindings module)
+  (let iterate ((tail bindings)
+                (lexical '())
+                (dynamic '()))
+    (if (null? tail)
+        (values (reverse lexical) (reverse dynamic))
+        (if (bind-lexically? (caar tail) module)
+            (iterate (cdr tail) (cons (car tail) lexical) dynamic)
+            (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
+
+;;; Compile let and let* expressions.  The code here is used both for
+;;; let/let* and flet/flet*, just with a different bindings module.
+;;;
+;;; A special module value 'lexical means that we're doing a lexical-let
+;;; instead and the bindings should not be saved to globals at all but
+;;; be done with the lexical framework instead.
+
+;;; Let is done with a single call to let-dynamic binding them locally
+;;; to new values all "at once".  If there is at least one variable to
+;;; bind lexically among the bindings, we first do a let for all of them
+;;; to evaluate all values before any bindings take place, and then call
+;;; let-dynamic for the variables to bind dynamically.
+
+(define (generate-let loc module bindings body)
+  (let ((bind (process-let-bindings loc bindings)))
+    (call-with-values
+        (lambda () (split-let-bindings bind module))
+      (lambda (lexical dynamic)
+        (for-each (lambda (sym)
+                    (mark-global-needed! (fluid-ref bindings-data)
+                                         sym
+                                         module))
+                  (map car dynamic))
+        (let ((make-values (lambda (for)
+                             (map (lambda (el) (compile-expr (cdr el)))
+                                  for)))
+              (make-body (lambda ()
+                           (make-sequence loc (map compile-expr body)))))
+          (if (null? lexical)
+              (let-dynamic loc (map car dynamic) module
+                           (make-values dynamic) (make-body))
+              (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+                     (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+                     (all-syms (append lexical-syms dynamic-syms))
+                     (vals (append (make-values lexical)
+                                   (make-values dynamic))))
+                (make-let loc
+                          all-syms
+                          all-syms
+                          vals
+                          (with-lexical-bindings
+                           (fluid-ref bindings-data)
+                           (map car lexical) lexical-syms
+                           (lambda ()
+                             (if (null? dynamic)
+                                 (make-body)
+                                 (let-dynamic loc
+                                              (map car dynamic)
+                                              module
+                                              (map
+                                               (lambda (sym)
+                                                 (make-lexical-ref loc
+                                                                   sym
+                                                                   sym))
+                                               dynamic-syms)
+                                              (make-body)))))))))))))
+
+;;; Let* is compiled to a cascaded set of "small lets" for each binding
+;;; in turn so that each one already sees the preceding bindings.
+
+(define (generate-let* loc module bindings body)
+  (let ((bind (process-let-bindings loc bindings)))
+    (begin
+      (for-each (lambda (sym)
+                  (if (not (bind-lexically? sym module))
+                      (mark-global-needed! (fluid-ref bindings-data)
+                                           sym
+                                           module)))
+                (map car bind))
+      (let iterate ((tail bind))
+        (if (null? tail)
+            (make-sequence loc (map compile-expr body))
+            (let ((sym (caar tail))
+                  (value (compile-expr (cdar tail))))
+              (if (bind-lexically? sym module)
+                  (let ((target (gensym)))
+                    (make-let loc
+                              `(,target)
+                              `(,target)
+                              `(,value)
+                              (with-lexical-bindings
+                               (fluid-ref bindings-data)
+                               `(,sym)
+                               `(,target)
+                               (lambda () (iterate (cdr tail))))))
+                  (let-dynamic loc
+                               `(,(caar tail))
+                               module
+                               `(,value)
+                               (iterate (cdr tail))))))))))
+
+;;; Split the argument list of a lambda expression into required,
+;;; optional and rest arguments and also check it is actually valid.
+;;; Additionally, we create a list of all "local variables" (that is,
+;;; required, optional and rest arguments together) and also this one
+;;; split into those to be bound lexically and dynamically.  Returned is
+;;; as multiple values: required optional rest lexical dynamic
+
+(define (bind-arg-lexical? arg)
+  (let ((always (fluid-ref always-lexical)))
+    (or (eq? always 'all)
+        (memq arg always))))
+
+(define (split-lambda-arguments loc args)
+  (let iterate ((tail args)
+                (mode 'required)
+                (required '())
+                (optional '())
+                (lexical '())
+                (dynamic '()))
+    (cond
+     ((null? tail)
+      (let ((final-required (reverse required))
+            (final-optional (reverse optional))
+            (final-lexical (reverse lexical))
+            (final-dynamic (reverse dynamic)))
+        (values final-required
+                final-optional
+                #f
+                final-lexical
+                final-dynamic)))
+     ((and (eq? mode 'required)
+           (eq? (car tail) '&optional))
+      (iterate (cdr tail) 'optional required optional lexical dynamic))
+     ((eq? (car tail) '&rest)
+      (if (or (null? (cdr tail))
+              (not (null? (cddr tail))))
+          (report-error loc "expected exactly one symbol after &rest")
+          (let* ((rest (cadr tail))
+                 (rest-lexical (bind-arg-lexical? rest))
+                 (final-required (reverse required))
+                 (final-optional (reverse optional))
+                 (final-lexical (reverse (if rest-lexical
+                                             (cons rest lexical)
+                                             lexical)))
+                 (final-dynamic (reverse (if rest-lexical
+                                             dynamic
+                                             (cons rest dynamic)))))
+            (values final-required
+                    final-optional
+                    rest
+                    final-lexical
+                    final-dynamic))))
+     (else
+      (if (not (symbol? (car tail)))
+          (report-error loc
+                        "expected symbol in argument list, got"
+                        (car tail))
+          (let* ((arg (car tail))
+                 (bind-lexical (bind-arg-lexical? arg))
+                 (new-lexical (if bind-lexical
+                                  (cons arg lexical)
+                                  lexical))
+                 (new-dynamic (if bind-lexical
+                                  dynamic
+                                  (cons arg dynamic))))
+            (case mode
+              ((required) (iterate (cdr tail) mode
+                                   (cons arg required) optional
+                                   new-lexical new-dynamic))
+              ((optional) (iterate (cdr tail) mode
+                                   required (cons arg optional)
+                                   new-lexical new-dynamic))
+              (else
+               (error "invalid mode in split-lambda-arguments"
+                      mode)))))))))
+
+;;; Compile a lambda expression.  One thing we have to be aware of is
+;;; that lambda arguments are usually dynamically bound, even when a
+;;; lexical binding is intact for a symbol.  For symbols that are marked
+;;; as 'always lexical,' however, we lexically bind here as well, and
+;;; thus we get them out of the let-dynamic call and register a lexical
+;;; binding for them (the lexical target variable is already there,
+;;; namely the real lambda argument from TreeIL).
+
+(define (compile-lambda loc args body)
+  (if (not (list? args))
+      (report-error loc "expected list for argument-list" args))
+  (if (null? body)
+      (report-error loc "function body must not be empty"))
+  (receive (required optional rest lexical dynamic)
+           (split-lambda-arguments loc args)
+    (define (process-args args)
+      (define (find-pairs pairs filter)
+        (lset-intersection (lambda (name+sym x)
+                             (eq? (car name+sym) x))
+                           pairs
+                           filter))
+      (let* ((syms (map (lambda (x) (gensym)) args))
+             (pairs (map cons args syms))
+             (lexical-pairs (find-pairs pairs lexical))
+             (dynamic-pairs (find-pairs pairs dynamic)))
+        (values syms pairs lexical-pairs dynamic-pairs)))
+    (let*-values (((required-syms
+                    required-pairs
+                    required-lex-pairs
+                    required-dyn-pairs)
+                   (process-args required))
+                  ((optional-syms
+                    optional-pairs
+                    optional-lex-pairs
+                    optional-dyn-pairs)
+                   (process-args optional))
+                  ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
+                   (process-args (if rest (list rest) '())))
+                  ((the-rest-sym) (if rest (car rest-syms) #f))
+                  ((all-syms) (append required-syms
+                                      optional-syms
+                                      rest-syms))
+                  ((all-lex-pairs) (append required-lex-pairs
+                                           optional-lex-pairs
+                                           rest-lex-pairs))
+                  ((all-dyn-pairs) (append required-dyn-pairs
+                                           optional-dyn-pairs
+                                           rest-dyn-pairs)))
+      (for-each (lambda (sym)
+                  (mark-global-needed! (fluid-ref bindings-data)
+                                       sym
+                                       value-slot))
+                dynamic)
+      (with-dynamic-bindings
+       (fluid-ref bindings-data)
+       dynamic
+       (lambda ()
+         (with-lexical-bindings
+          (fluid-ref bindings-data)
+          (map car all-lex-pairs)
+          (map cdr all-lex-pairs)
+          (lambda ()
+            (make-lambda
+             loc
+             '()
+             (make-lambda-case
+              #f
+              required
+              optional
+              rest
+              #f
+              (map (lambda (x) (nil-value loc)) optional)
+              all-syms
+              (let ((compiled-body
+                     (make-sequence loc (map compile-expr body))))
+                (make-sequence
+                 loc
+                 (list
+                  (if rest
+                      (make-conditional
+                       loc
+                       (call-primitive loc
+                                       'null?
+                                       (make-lexical-ref loc
+                                                         rest
+                                                         the-rest-sym))
+                       (make-lexical-set loc
+                                         rest
+                                         the-rest-sym
+                                         (nil-value loc))
+                       (make-void loc))
+                      (make-void loc))
+                  (if (null? dynamic)
+                      compiled-body
+                      (let-dynamic loc
+                                   dynamic
+                                   value-slot
+                                   (map (lambda (name-sym)
+                                          (make-lexical-ref
+                                           loc
+                                           (car name-sym)
+                                           (cdr name-sym)))
+                                        all-dyn-pairs)
+                                   compiled-body)))))
+              #f)))))))))
+
+;;; Handle the common part of defconst and defvar, that is, checking for
+;;; a correct doc string and arguments as well as maybe in the future
+;;; handling the docstring somehow.
+
+(define (handle-var-def loc sym doc)
+  (cond
+   ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
+   ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
+   ((and (not (null? doc)) (not (string? (car doc))))
+    (report-error loc "expected string as third argument of defvar, got"
+                  (car doc)))
+   ;; TODO: Handle doc string if present.
+   (else #t)))
+
+;;; Handle macro and special operator bindings.
+
+(define (find-operator sym type)
+  (and
+   (symbol? sym)
+   (module-defined? (resolve-interface function-slot) sym)
+   (let* ((op (module-ref (resolve-module function-slot) sym))
+          (op (if (fluid? op) (fluid-ref op) op)))
+     (if (and (pair? op) (eq? (car op) type))
+         (cdr op)
+         #f))))
+
+;;; See if a (backquoted) expression contains any unquotes.
+
+(define (contains-unquotes? expr)
+  (if (pair? expr)
+      (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
+          #t
+          (or (contains-unquotes? (car expr))
+              (contains-unquotes? (cdr expr))))
+      #f))
+
+;;; Process a backquoted expression by building up the needed
+;;; cons/append calls.  For splicing, it is assumed that the expression
+;;; spliced in evaluates to a list.  The emacs manual does not really
+;;; state either it has to or what to do if it does not, but Scheme
+;;; explicitly forbids it and this seems reasonable also for elisp.
+
+(define (unquote-cell? expr)
+  (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
+
+(define (unquote-splicing-cell? expr)
+  (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
+
+(define (process-backquote loc expr)
+  (if (contains-unquotes? expr)
+      (if (pair? expr)
+          (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
+              (compile-expr (cadr expr))
+              (let* ((head (car expr))
+                     (processed-tail (process-backquote loc (cdr expr)))
+                     (head-is-list-2 (and (list? head)
+                                          (= (length head) 2)))
+                     (head-unquote (and head-is-list-2
+                                        (unquote? (car head))))
+                     (head-unquote-splicing (and head-is-list-2
+                                                 (unquote-splicing?
+                                                  (car head)))))
+                (if head-unquote-splicing
+                    (call-primitive loc
+                                    'append
+                                    (compile-expr (cadr head))
+                                    processed-tail)
+                    (call-primitive loc 'cons
+                                    (if head-unquote
+                                        (compile-expr (cadr head))
+                                        (process-backquote loc head))
+                                    processed-tail))))
+          (report-error loc
+                        "non-pair expression contains unquotes"
+                        expr))
+      (make-const loc expr)))
+
+;;; Temporarily update a list of symbols that are handled specially
+;;; (disabled void check or always lexical) for compiling body.  We need
+;;; to handle special cases for already all / set to all and the like.
+
+(define (with-added-symbols loc fluid syms body)
+  (if (null? body)
+      (report-error loc "symbol-list construct has empty body"))
+  (if (not (or (eq? syms 'all)
+               (and (list? syms) (and-map symbol? syms))))
+      (report-error loc "invalid symbol list" syms))
+  (let ((old (fluid-ref fluid))
+        (make-body (lambda ()
+                     (make-sequence loc (map compile-expr body)))))
+    (if (eq? old 'all)
+        (make-body)
+        (let ((new (if (eq? syms 'all)
+                       'all
+                       (append syms old))))
+          (with-fluids ((fluid new))
+            (make-body))))))
+
+;;; Special operators
+
+(defspecial progn (loc args)
+  (make-sequence loc (map compile-expr args)))
+
+(defspecial if (loc args)
+  (pmatch args
+    ((,cond ,then . ,else)
+     (make-conditional loc
+                       (compile-expr cond)
+                       (compile-expr then)
+                       (if (null? else)
+                           (nil-value loc)
+                           (make-sequence loc
+                                          (map compile-expr else)))))))
+
+(defspecial defconst (loc args)
+  (pmatch args
+    ((,sym ,value . ,doc)
+     (if (handle-var-def loc sym doc)
+         (make-sequence loc
+                        (list (set-variable! loc
+                                             sym
+                                             value-slot
+                                             (compile-expr value))
+                              (make-const loc sym)))))))
+
+(defspecial defvar (loc args)
+  (pmatch args
+    ((,sym) (make-const loc sym))
+    ((,sym ,value . ,doc)
+     (if (handle-var-def loc sym doc)
+         (make-sequence
+          loc
+          (list
+           (make-conditional
+            loc
+            (make-conditional
+             loc
+             (call-primitive
+              loc
+              'module-bound?
+              (call-primitive loc
+                              'resolve-interface
+                              (make-const loc value-slot))
+              (make-const loc sym))
+             (call-primitive loc
+                             'fluid-bound?
+                             (make-module-ref loc value-slot sym #t))
+             (make-const loc #f))
+            (make-void loc)
+            (set-variable! loc sym value-slot (compile-expr value)))
+           (make-const loc sym)))))))
+
+(defspecial setq (loc args)
+  (define (car* x) (if (null? x) '() (car x)))
+  (define (cdr* x) (if (null? x) '() (cdr x)))
+  (define (cadr* x) (car* (cdr* x)))
+  (define (cddr* x) (cdr* (cdr* x)))
+  (make-sequence
+   loc
+   (let loop ((args args) (last (nil-value loc)))
+     (if (null? args)
+         (list last)
+         (let ((sym (car args))
+               (val (compile-expr (cadr* args))))
+           (if (not (symbol? sym))
+               (report-error loc "expected symbol in setq")
+               (cons
+                (set-variable! loc sym value-slot val)
+                (loop (cddr* args)
+                      (reference-variable loc sym value-slot)))))))))
+  
+(defspecial let (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc value-slot bindings body))))
+
+(defspecial lexical-let (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc 'lexical bindings body))))
+
+(defspecial flet (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc function-slot bindings body))))
+
+(defspecial let* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc value-slot bindings body))))
+
+(defspecial lexical-let* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc 'lexical bindings body))))
+
+(defspecial flet* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc function-slot bindings body))))
+
+;;; Temporarily set symbols as always lexical only for the lexical scope
+;;; of a construct.
+
+(defspecial with-always-lexical (loc args)
+  (pmatch args
+    ((,syms . ,body)
+     (with-added-symbols loc always-lexical syms body))))
+
+;;; guile-ref allows building TreeIL's module references from within
+;;; elisp as a way to access data within the Guile universe.  The module
+;;; and symbol referenced are static values, just like (@ module symbol)
+;;; does!
+
+(defspecial guile-ref (loc args)
+  (pmatch args
+    ((,module ,sym) (guard (and (list? module) (symbol? sym)))
+     (make-module-ref loc module sym #t))))
+
+;;; guile-primitive allows to create primitive references, which are
+;;; still a little faster.
+
+(defspecial guile-primitive (loc args)
+  (pmatch args
+    ((,sym)
+     (make-primitive-ref loc sym))))
+
+;;; A while construct is transformed into a tail-recursive loop like
+;;; this:
+;;;
+;;; (letrec ((iterate (lambda ()
+;;;                     (if condition
+;;;                       (begin body
+;;;                              (iterate))
+;;;                       #nil))))
+;;;   (iterate))
+;;;
+;;; As letrec is not directly accessible from elisp, while is
+;;; implemented here instead of with a macro.
+
+(defspecial while (loc args)
+  (pmatch args
+    ((,condition . ,body)
+     (let* ((itersym (gensym))
+            (compiled-body (map compile-expr body))
+            (iter-call (make-application loc
+                                         (make-lexical-ref loc
+                                                           'iterate
+                                                           itersym)
+                                         (list)))
+            (full-body (make-sequence loc
+                                      `(,@compiled-body ,iter-call)))
+            (lambda-body (make-conditional loc
+                                           (compile-expr condition)
+                                           full-body
+                                           (nil-value loc)))
+            (iter-thunk (make-lambda loc
+                                     '()
+                                     (make-lambda-case #f
+                                                       '()
+                                                       #f
+                                                       #f
+                                                       #f
+                                                       '()
+                                                       '()
+                                                       lambda-body
+                                                       #f))))
+       (make-letrec loc
+                    #f
+                    '(iterate)
+                    (list itersym)
+                    (list iter-thunk)
+                    iter-call)))))
+
+(defspecial function (loc args)
+  (pmatch args
+    (((lambda ,args . ,body))
+     (compile-lambda loc args body))
+    ((,sym) (guard (symbol? sym))
+     (reference-variable loc sym function-slot))))
+
+(defspecial defmacro (loc args)
+  (pmatch args
+    ((,name ,args . ,body)
+     (if (not (symbol? name))
+         (report-error loc "expected symbol as macro name" name)
+         (let* ((tree-il
+                 (make-sequence
+                  loc
+                  (list
+                   (set-variable!
+                    loc
+                    name
+                    function-slot
+                    (make-application
+                     loc
+                     (make-module-ref loc '(guile) 'cons #t)
+                     (list (make-const loc 'macro)
+                           (compile-lambda loc args body))))
+                   (make-const loc name)))))
+           (compile (ensuring-globals loc bindings-data tree-il)
+                    #\from 'tree-il
+                    #\to 'value)
+           tree-il)))))
+
+(defspecial defun (loc args)
+  (pmatch args
+    ((,name ,args . ,body)
+     (if (not (symbol? name))
+         (report-error loc "expected symbol as function name" name)
+         (make-sequence loc
+                        (list (set-variable! loc
+                                             name
+                                             function-slot
+                                             (compile-lambda loc
+                                                             args
+                                                             body))
+                              (make-const loc name)))))))
+
+(defspecial #{\`} (loc args)
+  (pmatch args
+    ((,val)
+     (process-backquote loc val))))
+
+(defspecial quote (loc args)
+  (pmatch args
+    ((,val)
+     (make-const loc val))))
+
+;;; Compile a compound expression to Tree-IL.
+
+(define (compile-pair loc expr)
+  (let ((operator (car expr))
+        (arguments (cdr expr)))
+    (cond
+     ((find-operator operator 'special-operator)
+      => (lambda (special-operator-function)
+           (special-operator-function loc arguments)))
+     ((find-operator operator 'macro)
+      => (lambda (macro-function)
+           (compile-expr (apply macro-function arguments))))
+     (else
+      (make-application loc
+                        (if (symbol? operator)
+                            (reference-variable loc
+                                                operator
+                                                function-slot)
+                            (compile-expr operator))
+                        (map compile-expr arguments))))))
+
+;;; Compile a symbol expression.  This is a variable reference or maybe
+;;; some special value like nil.
+
+(define (compile-symbol loc sym)
+  (case sym
+    ((nil) (nil-value loc))
+    ((t) (t-value loc))
+    (else (reference-variable loc sym value-slot))))
+
+;;; Compile a single expression to TreeIL.
+
+(define (compile-expr expr)
+  (let ((loc (location expr)))
+    (cond
+     ((symbol? expr)
+      (compile-symbol loc expr))
+     ((pair? expr)
+      (compile-pair loc expr))
+     (else (make-const loc expr)))))
+
+;;; Process the compiler options.
+;;; FIXME: Why is '(()) passed as options by the REPL?
+
+(define (valid-symbol-list-arg? value)
+  (or (eq? value 'all)
+      (and (list? value) (and-map symbol? value))))
+
+(define (process-options! opt)
+  (if (and (not (null? opt))
+           (not (equal? opt '(()))))
+      (if (null? (cdr opt))
+          (report-error #f "Invalid compiler options" opt)
+          (let ((key (car opt))
+                (value (cadr opt)))
+            (case key
+              ((#\warnings)             ; ignore
+               #f)
+              ((#\always-lexical)
+               (if (valid-symbol-list-arg? value)
+                   (fluid-set! always-lexical value)
+                   (report-error #f
+                                 "Invalid value for #\always-lexical"
+                                 value)))
+              (else (report-error #f
+                                  "Invalid compiler option"
+                                  key)))))))
+
+;;; Entry point for compilation to TreeIL.  This creates the bindings
+;;; data structure, and after compiling the main expression we need to
+;;; make sure all globals for symbols used during the compilation are
+;;; created using the generate-ensure-global function.
+
+(define (compile-tree-il expr env opts)
+  (values
+   (with-fluids ((bindings-data (make-bindings))
+                 (disable-void-check '())
+                 (always-lexical '()))
+     (process-options! opts)
+     (let ((compiled (compile-expr expr)))
+      (ensuring-globals (location expr) bindings-data compiled)))
+   env
+   env))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language elisp lexer)
+  #\use-module (ice-9 regex)
+  #\export (get-lexer get-lexer/1))
+
+;;; This is the lexical analyzer for the elisp reader.  It is
+;;; hand-written instead of using some generator.  I think this is the
+;;; best solution because of all that fancy escape sequence handling and
+;;; the like.
+;;;
+;;; Characters are handled internally as integers representing their
+;;; code value.  This is necessary because elisp allows a lot of fancy
+;;; modifiers that set certain high-range bits and the resulting values
+;;; would not fit into a real Scheme character range.  Additionally,
+;;; elisp wants characters as integers, so we just do the right thing...
+;;;
+;;; TODO: #@count comments
+
+;;; Report an error from the lexer (that is, invalid input given).
+
+(define (lexer-error port msg . args)
+  (apply error msg args))
+
+;;; In a character, set a given bit.  This is just some bit-wise or'ing
+;;; on the characters integer code and converting back to character.
+
+(define (set-char-bit chr bit)
+  (logior chr (ash 1 bit)))
+
+;;; Check if a character equals some other.  This is just like char=?
+;;; except that the tested one could be EOF in which case it simply
+;;; isn't equal.
+
+(define (is-char? tested should-be)
+  (and (not (eof-object? tested))
+       (char=? tested should-be)))
+
+;;; For a character (as integer code), find the real character it
+;;; represents or #\nul if out of range.  This is used to work with
+;;; Scheme character functions like char-numeric?.
+
+(define (real-character chr)
+  (if (< chr 256)
+      (integer->char chr)
+      #\nul))
+
+;;; Return the control modified version of a character.  This is not
+;;; just setting a modifier bit, because ASCII conrol characters must be
+;;; handled as such, and in elisp C-? is the delete character for
+;;; historical reasons.  Otherwise, we set bit 26.
+
+(define (add-control chr)
+  (let ((real (real-character chr)))
+    (if (char-alphabetic? real)
+        (- (char->integer (char-upcase real)) (char->integer #\@))
+        (case real
+          ((#\?) 127)
+          ((#\@) 0)
+          (else (set-char-bit chr 26))))))
+
+;;; Parse a charcode given in some base, basically octal or hexadecimal
+;;; are needed.  A requested number of digits can be given (#f means it
+;;; does not matter and arbitrary many are allowed), and additionally
+;;; early return allowed (if fewer valid digits are found).  These
+;;; options are all we need to handle the \u, \U, \x and \ddd (octal
+;;; digits) escape sequences.
+
+(define (charcode-escape port base digits early-return)
+  (let iterate ((result 0)
+                (procdigs 0))
+    (if (and digits (>= procdigs digits))
+        result
+        (let* ((cur (read-char port))
+               (value (cond
+                       ((char-numeric? cur)
+                        (- (char->integer cur) (char->integer #\0)))
+                       ((char-alphabetic? cur)
+                        (let ((code (- (char->integer (char-upcase cur))
+                                       (char->integer #\A))))
+                          (if (< code 0)
+                              #f
+                              (+ code 10))))
+                       (else #f)))
+               (valid (and value (< value base))))
+          (if (not valid)
+              (if (or (not digits) early-return)
+                  (begin
+                    (unread-char cur port)
+                    result)
+                  (lexer-error port
+                               "invalid digit in escape-code"
+                               base
+                               cur))
+              (iterate (+ (* result base) value) (1+ procdigs)))))))
+
+;;; Read a character and process escape-sequences when necessary.  The
+;;; special in-string argument defines if this character is part of a
+;;; string literal or a single character literal, the difference being
+;;; that in strings the meta modifier sets bit 7, while it is bit 27 for
+;;; characters.
+
+(define basic-escape-codes
+  '((#\a . 7)
+    (#\b . 8)
+    (#\t . 9)
+    (#\n . 10)
+    (#\v . 11)
+    (#\f . 12)
+    (#\r . 13)
+    (#\e . 27)
+    (#\s . 32)
+    (#\d . 127)))
+
+(define (get-character port in-string)
+  (let ((meta-bits `((#\A . 22)
+                     (#\s . 23)
+                     (#\H . 24)
+                     (#\S . 25)
+                     (#\M . ,(if in-string 7 27))))
+        (cur (read-char port)))
+    (if (char=? cur #\\)
+        ;; Handle an escape-sequence.
+        (let* ((escaped (read-char port))
+               (esc-code (assq-ref basic-escape-codes escaped))
+               (meta (assq-ref meta-bits escaped)))
+          (cond
+           ;; Meta-check must be before esc-code check because \s- must
+           ;; be recognized as the super-meta modifier if a - follows.
+           ;; If not, it will be caught as \s -> space escape code.
+           ((and meta (is-char? (peek-char port) #\-))
+            (if (not (char=? (read-char port) #\-))
+                (error "expected - after control sequence"))
+            (set-char-bit (get-character port in-string) meta))
+           ;; One of the basic control character escape names?
+           (esc-code esc-code)
+           ;; Handle \ddd octal code if it is one.
+           ((and (char>=? escaped #\0) (char<? escaped #\8))
+            (begin
+              (unread-char escaped port)
+              (charcode-escape port 8 3 #t)))
+           ;; Check for some escape-codes directly or otherwise use the
+           ;; escaped character literally.
+           (else
+            (case escaped
+              ((#\^) (add-control (get-character port in-string)))
+              ((#\C)
+               (if (is-char? (peek-char port) #\-)
+                   (begin
+                     (if (not (char=? (read-char port) #\-))
+                         (error "expected - after control sequence"))
+                     (add-control (get-character port in-string)))
+                   escaped))
+              ((#\x) (charcode-escape port 16 #f #t))
+              ((#\u) (charcode-escape port 16 4 #f))
+              ((#\U) (charcode-escape port 16 8 #f))
+              (else (char->integer escaped))))))
+        ;; No escape-sequence, just the literal character.  But remember
+        ;; to get the code instead!
+        (char->integer cur))))
+
+;;; Read a symbol or number from a port until something follows that
+;;; marks the start of a new token (like whitespace or parentheses).
+;;; The data read is returned as a string for further conversion to the
+;;; correct type, but we also return what this is
+;;; (integer/float/symbol).  If any escaped character is found, it must
+;;; be a symbol.  Otherwise we at the end check the result-string
+;;; against regular expressions to determine if it is possibly an
+;;; integer or a float.
+
+(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
+
+(define float-regex
+  (make-regexp
+   "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))
+
+;;; A dot is also allowed literally, only a single dort alone is parsed
+;;; as the 'dot' terminal for dotted lists.
+
+(define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?."))
+
+(define (get-symbol-or-number port)
+  (let iterate ((result-chars '())
+                (had-escape #f))
+    (let* ((c (read-char port))
+           (finish (lambda ()
+                     (let ((result (list->string
+                                    (reverse result-chars))))
+                       (values
+                        (cond
+                         ((and (not had-escape)
+                               (regexp-exec integer-regex result))
+                          'integer)
+                         ((and (not had-escape)
+                               (regexp-exec float-regex result))
+                          'float)
+                         (else 'symbol))
+                        result))))
+           (need-no-escape? (lambda (c)
+                              (or (char-numeric? c)
+                                  (char-alphabetic? c)
+                                  (char-set-contains?
+                                   no-escape-punctuation
+                                   c)))))
+      (cond
+       ((eof-object? c) (finish))
+       ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
+       ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
+       (else
+        (unread-char c port)
+        (finish))))))
+
+;;; Parse a circular structure marker without the leading # (which was
+;;; already read and recognized), that is, a number as identifier and
+;;; then either = or #.
+
+(define (get-circular-marker port)
+  (call-with-values
+      (lambda ()
+        (let iterate ((result 0))
+          (let ((cur (read-char port)))
+            (if (char-numeric? cur)
+                (let ((val (- (char->integer cur) (char->integer #\0))))
+                  (iterate (+ (* result 10) val)))
+                (values result cur)))))
+    (lambda (id type)
+      (case type
+        ((#\#) `(circular-ref . ,id))
+        ((#\=) `(circular-def . ,id))
+        (else (lexer-error port
+                           "invalid circular marker character"
+                           type))))))
+
+;;; Main lexer routine, which is given a port and does look for the next
+;;; token.
+
+(define (lex port)
+  (let ((return (let ((file (if (file-port? port)
+                                (port-filename port)
+                                #f))
+                      (line (1+ (port-line port)))
+                      (column (1+ (port-column port))))
+                  (lambda (token value)
+                    (let ((obj (cons token value)))
+                      (set-source-property! obj 'filename file)
+                      (set-source-property! obj 'line line)
+                      (set-source-property! obj 'column column)
+                      obj))))
+        ;; Read afterwards so the source-properties are correct above
+        ;; and actually point to the very character to be read.
+        (c (read-char port)))
+    (cond
+     ;; End of input must be specially marked to the parser.
+     ((eof-object? c) (return 'eof c))
+     ;; Whitespace, just skip it.
+     ((char-whitespace? c) (lex port))
+     ;; The dot is only the one for dotted lists if followed by
+     ;; whitespace.  Otherwise it is considered part of a number of
+     ;; symbol.
+     ((and (char=? c #\.)
+           (char-whitespace? (peek-char port)))
+      (return 'dot #f))
+     ;; Continue checking for literal character values.
+     (else
+      (case c
+        ;; A line comment, skip until end-of-line is found.
+        ((#\;)
+         (let iterate ()
+           (let ((cur (read-char port)))
+             (if (or (eof-object? cur) (char=? cur #\newline))
+                 (lex port)
+                 (iterate)))))
+        ;; A character literal.
+        ((#\?)
+         (return 'character (get-character port #f)))
+        ;; A literal string.  This is mainly a sequence of characters
+        ;; just as in the character literals, the only difference is
+        ;; that escaped newline and space are to be completely ignored
+        ;; and that meta-escapes set bit 7 rather than bit 27.
+        ((#\")
+         (let iterate ((result-chars '()))
+           (let ((cur (read-char port)))
+             (case cur
+               ((#\")
+                (return 'string (list->string (reverse result-chars))))
+               ((#\\)
+                (let ((escaped (read-char port)))
+                  (case escaped
+                    ((#\newline #\space)
+                     (iterate result-chars))
+                    (else
+                     (unread-char escaped port)
+                     (unread-char cur port)
+                     (iterate
+                      (cons (integer->char (get-character port #t))
+                            result-chars))))))
+               (else (iterate (cons cur result-chars)))))))
+        ((#\#)
+         (let ((c (read-char port)))
+          (case c
+            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+             (unread-char c port)
+             (let ((mark (get-circular-marker port)))
+               (return (car mark) (cdr mark))))
+            ((#\')
+             (return 'function #f)))))
+        ;; Parentheses and other special-meaning single characters.
+        ((#\() (return 'paren-open #f))
+        ((#\)) (return 'paren-close #f))
+        ((#\[) (return 'square-open #f))
+        ((#\]) (return 'square-close #f))
+        ((#\') (return 'quote #f))
+        ((#\`) (return 'backquote #f))
+        ;; Unquote and unquote-splicing.
+        ((#\,)
+         (if (is-char? (peek-char port) #\@)
+             (if (not (char=? (read-char port) #\@))
+                 (error "expected @ in unquote-splicing")
+                 (return 'unquote-splicing #f))
+             (return 'unquote #f)))
+        ;; Remaining are numbers and symbols.  Process input until next
+        ;; whitespace is found, and see if it looks like a number
+        ;; (float/integer) or symbol and return accordingly.
+        (else
+         (unread-char c port)
+         (call-with-values
+             (lambda () (get-symbol-or-number port))
+           (lambda (type str)
+             (case type
+               ((symbol)
+                ;; str could be empty if the first character is already
+                ;; something not allowed in a symbol (and not escaped)!
+                ;; Take care about that, it is an error because that
+                ;; character should have been handled elsewhere or is
+                ;; invalid in the input.
+                (if (zero? (string-length str))
+                    (begin
+                      ;; Take it out so the REPL might not get into an
+                      ;; infinite loop with further reading attempts.
+                      (read-char port)
+                      (error "invalid character in input" c))
+                    (return 'symbol (string->symbol str))))
+               ((integer)
+                ;; In elisp, something like "1." is an integer, while
+                ;; string->number returns an inexact real.  Thus we need
+                ;; a conversion here, but it should always result in an
+                ;; integer!
+                (return
+                 'integer
+                 (let ((num (inexact->exact (string->number str))))
+                   (if (not (integer? num))
+                       (error "expected integer" str num))
+                   num)))
+               ((float)
+                (return 'float (let ((num (string->number str)))
+                                 (if (exact? num)
+                                     (error "expected inexact float"
+                                            str
+                                            num))
+                                 num)))
+               (else (error "wrong number/symbol type" type)))))))))))
+
+;;; Build a lexer thunk for a port.  This is the exported routine which
+;;; can be used to create a lexer for the parser to use.
+
+(define (get-lexer port)
+  (lambda () (lex port)))
+
+;;; Build a special lexer that will only read enough for one expression
+;;; and then always return end-of-input.  If we find one of the quotation
+;;; stuff, one more expression is needed in any case.
+
+(define (get-lexer/1 port)
+  (let ((lex (get-lexer port))
+        (finished #f)
+        (paren-level 0))
+    (lambda ()
+      (if finished
+          (cons 'eof ((@ (ice-9 binary-ports) eof-object)))
+          (let ((next (lex))
+                (quotation #f))
+            (case (car next)
+              ((paren-open square-open)
+               (set! paren-level (1+ paren-level)))
+              ((paren-close square-close)
+               (set! paren-level (1- paren-level)))
+              ((quote backquote unquote unquote-splicing circular-def)
+               (set! quotation #t)))
+            (if (and (not quotation) (<= paren-level 0))
+                (set! finished #t))
+            next)))))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language elisp parser)
+  #\use-module (language elisp lexer)
+  #\export (read-elisp))
+
+;;; The parser (reader) for elisp expressions.
+;;;
+;;; It is hand-written (just as the lexer is) instead of using some
+;;; parser generator because this allows easier transfer of source
+;;; properties from the lexer ((text parse-lalr) seems not to allow
+;;; access to the original lexer token-pair) and is easy enough anyways.
+
+;;; Report a parse error.  The first argument is some current lexer
+;;; token where source information is available should it be useful.
+
+(define (parse-error token msg . args)
+  (apply error msg args))
+
+;;; For parsing circular structures, we keep track of definitions in a
+;;; hash-map that maps the id's to their values.  When defining a new
+;;; id, though, we immediatly fill the slot with a promise before
+;;; parsing and setting the real value, because it must already be
+;;; available at that time in case of a circular reference.  The promise
+;;; refers to a local variable that will be set when the real value is
+;;; available through a closure.  After parsing the expression is
+;;; completed, we work through it again and force all promises we find.
+;;; The definitions themselves are stored in a fluid and their scope is
+;;; one call to read-elisp (but not only the currently parsed
+;;; expression!).
+
+(define circular-definitions (make-fluid))
+
+(define (make-circular-definitions)
+  (make-hash-table))
+
+(define (circular-ref token)
+  (if (not (eq? (car token) 'circular-ref))
+      (error "invalid token for circular-ref" token))
+  (let* ((id (cdr token))
+         (value (hashq-ref (fluid-ref circular-definitions) id)))
+    (if value
+        value
+        (parse-error token "undefined circular reference" id))))
+
+;;; Returned is a closure that, when invoked, will set the final value.
+;;; This means both the variable the promise will return and the
+;;; hash-table slot so we don't generate promises any longer.
+
+(define (circular-define! token)
+  (if (not (eq? (car token) 'circular-def))
+      (error "invalid token for circular-define!" token))
+  (let ((value #f)
+        (table (fluid-ref circular-definitions))
+        (id (cdr token)))
+    (hashq-set! table id (delay value))
+    (lambda (real-value)
+      (set! value real-value)
+      (hashq-set! table id real-value))))
+
+;;; Work through a parsed data structure and force the promises there.
+;;; After a promise is forced, the resulting value must not be recursed
+;;; on; this may lead to infinite recursion with a circular structure,
+;;; and additionally this value was already processed when it was
+;;; defined.  All deep data structures that can be parsed must be
+;;; handled here!
+
+(define (force-promises! data)
+  (cond
+   ((pair? data)
+    (begin
+      (if (promise? (car data))
+          (set-car! data (force (car data)))
+          (force-promises! (car data)))
+      (if (promise? (cdr data))
+          (set-cdr! data (force (cdr data)))
+          (force-promises! (cdr data)))))
+   ((vector? data)
+    (let ((len (vector-length data)))
+      (let iterate ((i 0))
+        (if (< i len)
+            (let ((el (vector-ref data i)))
+              (if (promise? el)
+                  (vector-set! data i (force el))
+                  (force-promises! el))
+              (iterate (1+ i)))))))
+   ;; Else nothing needs to be done.
+   ))
+
+;;; We need peek-functionality for the next lexer token, this is done
+;;; with some single token look-ahead storage.  This is handled by a
+;;; closure which allows getting or peeking the next token.  When one
+;;; expression is fully parsed, we don't want a look-ahead stored here
+;;; because it would miss from future parsing.  This is verified by the
+;;; finish action.
+
+(define (make-lexer-buffer lex)
+  (let ((look-ahead #f))
+    (lambda (action)
+      (if (eq? action 'finish)
+          (if look-ahead
+              (error "lexer-buffer is not empty when finished")
+              #f)
+          (begin
+            (if (not look-ahead)
+                (set! look-ahead (lex)))
+            (case action
+              ((peek) look-ahead)
+              ((get)
+               (let ((result look-ahead))
+                 (set! look-ahead #f)
+                 result))
+              (else (error "invalid lexer-buffer action" action))))))))
+
+;;; Get the contents of a list, where the opening parentheses has
+;;; already been found.  The same code is used for vectors and lists,
+;;; where lists allow the dotted tail syntax and vectors not;
+;;; additionally, the closing parenthesis must of course match.  The
+;;; implementation here is not tail-recursive, but I think it is clearer
+;;; and simpler this way.
+
+(define (get-list lex allow-dot close-square)
+  (let* ((next (lex 'peek))
+         (type (car next)))
+    (cond
+     ((eq? type (if close-square 'square-close 'paren-close))
+      (begin
+        (if (not (eq? (car (lex 'get)) type))
+            (error "got different token than peeked"))
+        '()))
+     ((and allow-dot (eq? type 'dot))
+      (begin
+        (if (not (eq? (car (lex 'get)) type))
+            (error "got different token than peeked"))
+        (let ((tail (get-list lex #f close-square)))
+          (if (not (= (length tail) 1))
+              (parse-error next
+                           "expected exactly one element after dot"))
+          (car tail))))
+     (else
+      ;; Do both parses in exactly this sequence!
+      (let* ((head (get-expression lex))
+             (tail (get-list lex allow-dot close-square)))
+        (cons head tail))))))
+
+;;; Parse a single expression from a lexer-buffer.  This is the main
+;;; routine in our recursive-descent parser.
+
+(define quotation-symbols '((quote . quote)
+                            (backquote . #\`)
+                            (unquote . #\,)
+                            (unquote-splicing . #\,\@)))
+
+(define (get-expression lex)
+  (let* ((token (lex 'get))
+         (type (car token))
+         (return (lambda (result)
+                   (if (pair? result)
+                       (set-source-properties!
+                        result
+                        (source-properties token)))
+                   result)))
+    (case type
+      ((eof)
+       (parse-error token "end of file during parsing"))
+      ((integer float symbol character string)
+       (return (cdr token)))
+      ((function)
+       (return `(function ,(get-expression lex))))
+      ((quote backquote unquote unquote-splicing)
+       (return (list (assq-ref quotation-symbols type)
+                     (get-expression lex))))
+      ((paren-open)
+       (return (get-list lex #t #f)))
+      ((square-open)
+       (return (list->vector (get-list lex #f #t))))
+      ((circular-ref)
+       (circular-ref token))
+      ((circular-def)
+       ;; The order of definitions is important!
+       (let* ((setter (circular-define! token))
+              (expr (get-expression lex)))
+         (setter expr)
+         (force-promises! expr)
+         expr))
+      (else
+       (parse-error token "expected expression, got" token)))))
+
+;;; Define the reader function based on this; build a lexer, a
+;;; lexer-buffer, and then parse a single expression to return.  We also
+;;; define a circular-definitions data structure to use.
+
+(define (read-elisp port)
+  (with-fluids ((circular-definitions (make-circular-definitions)))
+    (let* ((lexer (get-lexer port))
+           (lexbuf (make-lexer-buffer lexer))
+           (next (lexbuf 'peek)))
+      (if (eq? (car next) 'eof)
+          (cdr next)
+          (let ((result (get-expression lexbuf)))
+            (lexbuf 'finish)
+            result)))))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language elisp runtime)
+  #\export (nil-value
+            t-value
+            value-slot-module
+            function-slot-module
+            elisp-bool
+            ensure-fluid!
+            reference-variable
+            set-variable!
+            runtime-error
+            macro-error)
+  #\export-syntax (built-in-func built-in-macro defspecial prim))
+
+;;; This module provides runtime support for the Elisp front-end.
+
+;;; Values for t and nil. (FIXME remove this abstraction)
+
+(define nil-value #nil)
+
+(define t-value #t)
+
+;;; Modules for the binding slots.
+;;; Note: Naming those value-slot and/or function-slot clashes with the
+;;; submodules of these names!
+
+(define value-slot-module '(language elisp runtime value-slot))
+
+(define function-slot-module '(language elisp runtime function-slot))
+
+;;; Report an error during macro compilation, that means some special
+;;; compilation (syntax) error; or report a simple runtime-error from a
+;;; built-in function.
+
+(define (macro-error msg . args)
+  (apply error msg args))
+
+(define runtime-error macro-error)
+
+;;; Convert a scheme boolean to Elisp.
+
+(define (elisp-bool b)
+  (if b
+      t-value
+      nil-value))
+
+;;; Routines for access to elisp dynamically bound symbols.  This is
+;;; used for runtime access using functions like symbol-value or set,
+;;; where the symbol accessed might not be known at compile-time.  These
+;;; always access the dynamic binding and can not be used for the
+;;; lexical!
+
+(define (ensure-fluid! module sym)
+  (let ((intf (resolve-interface module))
+        (resolved (resolve-module module)))
+    (if (not (module-defined? intf sym))
+        (let ((fluid (make-unbound-fluid)))
+          (module-define! resolved sym fluid)
+          (module-export! resolved `(,sym))))))
+
+(define (reference-variable module sym)
+  (let ((resolved (resolve-module module)))
+   (cond
+    ((equal? module function-slot-module)
+     (module-ref resolved sym))
+    (else
+     (ensure-fluid! module sym)
+     (fluid-ref (module-ref resolved sym))))))
+
+(define (set-variable! module sym value)
+  (let ((intf (resolve-interface module))
+        (resolved (resolve-module module)))
+    (cond
+     ((equal? module function-slot-module)
+      (cond
+       ((module-defined? intf sym)
+        (module-set! resolved sym value))
+      (else
+       (module-define! resolved sym value)
+       (module-export! resolved `(,sym)))))
+    (else
+     (ensure-fluid! module sym)
+     (fluid-set! (module-ref resolved sym) value))))
+  value)
+
+;;; Define a predefined function or predefined macro for use in the
+;;; function-slot and macro-slot modules, respectively.
+
+(define-syntax built-in-func
+  (syntax-rules ()
+    ((_ name value)
+     (begin
+       (define-public name value)))))
+
+(define (make-id template-id . data)
+  (let ((append-symbols
+         (lambda (symbols)
+           (string->symbol
+            (apply string-append (map symbol->string symbols))))))
+    (datum->syntax template-id
+                   (append-symbols
+                    (map (lambda (datum)
+                           ((if (identifier? datum)
+                                syntax->datum
+                                identity)
+                            datum))
+                         data)))))
+
+(define-syntax built-in-macro
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name value)
+       (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
+        #'(begin
+            (define-public scheme-name
+              (make-fluid (cons 'macro value)))))))))
+
+(define-syntax defspecial
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name args body ...)
+       (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
+         #'(begin
+             (define scheme-name
+               (make-fluid
+                (cons 'special-operator
+                      (lambda args body ...))))))))))
+
+;;; Call a guile-primitive that may be rebound for elisp and thus needs
+;;; absolute addressing.
+
+(define-syntax prim
+  (syntax-rules ()
+    ((_ sym args ...)
+     ((@ (guile) sym) args ...))))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+(define-module (language elisp runtime function-slot)
+  #\use-module (language elisp runtime subrs)
+  #\use-module ((language elisp runtime macros)
+                #\select
+                ((macro-lambda . lambda)
+                 (macro-prog1 . prog1)
+                 (macro-prog2 . prog2)
+                 (macro-when . when)
+                 (macro-unless . unless)
+                 (macro-cond . cond)
+                 (macro-and . and)
+                 (macro-or . or)
+                 (macro-dotimes . dotimes)
+                 (macro-dolist . dolist)
+                 (macro-catch . catch)
+                 (macro-unwind-protect . unwind-protect)
+                 (macro-pop . pop)
+                 (macro-push . push)))
+  #\use-module ((language elisp compile-tree-il)
+                #\select
+                ((compile-progn . progn)
+                 (compile-if . if)
+                 (compile-defconst . defconst)
+                 (compile-defvar . defvar)
+                 (compile-setq . setq)
+                 (compile-let . let)
+                 (compile-lexical-let . lexical-let)
+                 (compile-flet . flet)
+                 (compile-let* . let*)
+                 (compile-lexical-let* . lexical-let*)
+                 (compile-flet* . flet*)
+                 (compile-with-always-lexical . with-always-lexical)
+                 (compile-guile-ref . guile-ref)
+                 (compile-guile-primitive . guile-primitive)
+                 (compile-while . while)
+                 (compile-function . function)
+                 (compile-defun . defun)
+                 (compile-defmacro . defmacro)
+                 (#{compile-\`} . #\`)
+                 (compile-quote . quote)))
+  #\duplicates (last)
+  ;; special operators
+  #\re-export (progn
+               if
+               defconst
+               defvar
+               setq
+               let
+               lexical-let
+               flet
+               let*
+               lexical-let*
+               flet*
+               with-always-lexical
+               guile-ref
+               guile-primitive
+               while
+               function
+               defun
+               defmacro
+               #\`
+               quote)
+  ;; macros
+  #\re-export (lambda
+               prog1
+               prog2
+               when
+               unless
+               cond
+               and
+               or
+               dotimes
+               dolist
+               catch
+               unwind-protect
+               pop
+               push)
+  ;; functions
+  #\re-export (eq
+               equal
+               floatp
+               integerp
+               numberp
+               wholenump
+               zerop
+               =
+               /=
+               <
+               <=
+               >
+               >=
+               max
+               min
+               abs
+               float
+               1+
+               1-
+               +
+               -
+               *
+               %
+               ffloor
+               fceiling
+               ftruncate
+               fround
+               consp
+               atomp
+               listp
+               nlistp
+               null
+               car
+               cdr
+               car-safe
+               cdr-safe
+               nth
+               nthcdr
+               length
+               cons
+               list
+               make-list
+               append
+               reverse
+               copy-tree
+               number-sequence
+               setcar
+               setcdr
+               symbol-value
+               symbol-function
+               set
+               fset
+               makunbound
+               fmakunbound
+               boundp
+               fboundp
+               apply
+               funcall
+               throw
+               not
+               eval
+               load))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language elisp runtime macros)
+  #\use-module (language elisp runtime))
+
+;;; This module contains the macro definitions of elisp symbols.  In
+;;; contrast to the other runtime modules, those are used directly
+;;; during compilation, of course, so not really in runtime.  But I
+;;; think it fits well to the others here.
+ 
+(built-in-macro lambda
+  (lambda cdr
+    `(function (lambda ,@cdr))))
+
+;;; The prog1 and prog2 constructs can easily be defined as macros using
+;;; progn and some lexical-let's to save the intermediate value to
+;;; return at the end.
+
+(built-in-macro prog1
+  (lambda (form1 . rest)
+    (let ((temp (gensym)))
+      `(lexical-let ((,temp ,form1))
+         ,@rest
+         ,temp))))
+
+(built-in-macro prog2
+  (lambda (form1 form2 . rest)
+    `(progn ,form1 (prog1 ,form2 ,@rest))))
+
+;;; Define the conditionals when and unless as macros.
+
+(built-in-macro when
+  (lambda (condition . thens)
+    `(if ,condition (progn ,@thens) nil)))
+
+(built-in-macro unless
+  (lambda (condition . elses)
+    `(if ,condition nil (progn ,@elses))))
+
+;;; Impement the cond form as nested if's.  A special case is a
+;;; (condition) subform, in which case we need to return the condition
+;;; itself if it is true and thus save it in a local variable before
+;;; testing it.
+
+(built-in-macro cond
+  (lambda (. clauses)
+    (let iterate ((tail clauses))
+      (if (null? tail)
+          'nil
+          (let ((cur (car tail))
+                (rest (iterate (cdr tail))))
+            (prim cond
+                  ((prim or (not (list? cur)) (null? cur))
+                   (macro-error "invalid clause in cond" cur))
+                  ((null? (cdr cur))
+                   (let ((var (gensym)))
+                     `(lexical-let ((,var ,(car cur)))
+                        (if ,var
+                            ,var
+                            ,rest))))
+                  (else
+                   `(if ,(car cur)
+                        (progn ,@(cdr cur))
+                        ,rest))))))))
+
+;;; The `and' and `or' forms can also be easily defined with macros.
+
+(built-in-macro and
+  (case-lambda
+    (() 't)
+    ((x) x)
+    ((x . args)
+     (let iterate ((x x) (tail args))
+       (if (null? tail)
+           x
+           `(if ,x
+                ,(iterate (car tail) (cdr tail))
+                nil))))))
+
+(built-in-macro or
+  (case-lambda
+    (() 'nil)
+    ((x) x)
+    ((x . args)
+     (let iterate ((x x) (tail args))
+       (if (null? tail)
+           x
+           (let ((var (gensym)))
+             `(lexical-let ((,var ,x))
+                (if ,var
+                    ,var
+                    ,(iterate (car tail) (cdr tail))))))))))
+
+;;; Define the dotimes and dolist iteration macros.
+
+(built-in-macro dotimes
+  (lambda (args . body)
+    (if (prim or
+              (not (list? args))
+              (< (length args) 2)
+              (> (length args) 3))
+        (macro-error "invalid dotimes arguments" args)
+        (let ((var (car args))
+              (count (cadr args)))
+          (if (not (symbol? var))
+              (macro-error "expected symbol as dotimes variable"))
+          `(let ((,var 0))
+             (while ((guile-primitive <) ,var ,count)
+               ,@body
+               (setq ,var ((guile-primitive 1+) ,var)))
+             ,@(if (= (length args) 3)
+                   (list (caddr args))
+                   '()))))))
+
+(built-in-macro dolist
+  (lambda (args . body)
+    (if (prim or
+              (not (list? args))
+              (< (length args) 2)
+              (> (length args) 3))
+        (macro-error "invalid dolist arguments" args)
+        (let ((var (car args))
+              (iter-list (cadr args))
+              (tailvar (gensym)))
+          (if (not (symbol? var))
+              (macro-error "expected symbol as dolist variable")
+              `(let (,var)
+                 (lexical-let ((,tailvar ,iter-list))
+                   (while ((guile-primitive not)
+                           ((guile-primitive null?) ,tailvar))
+                          (setq ,var ((guile-primitive car) ,tailvar))
+                          ,@body
+                          (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
+                   ,@(if (= (length args) 3)
+                         (list (caddr args))
+                         '()))))))))
+
+;;; Exception handling.  unwind-protect and catch are implemented as
+;;; macros (throw is a built-in function).
+
+;;; catch and throw can mainly be implemented directly using Guile's
+;;; primitives for exceptions, the only difficulty is that the keys used
+;;; within Guile must be symbols, while elisp allows any value and
+;;; checks for matches using eq (eq?).  We handle this by using always #t
+;;; as key for the Guile primitives and check for matches inside the
+;;; handler; if the elisp keys are not eq?, we rethrow the exception.
+
+(built-in-macro catch
+  (lambda (tag . body)
+    (if (null? body)
+        (macro-error "catch with empty body"))
+    (let ((tagsym (gensym)))
+      `(lexical-let ((,tagsym ,tag))
+         ((guile-primitive catch)
+          #t
+          (lambda () ,@body)
+          ,(let* ((dummy-key (gensym))
+                  (elisp-key (gensym))
+                  (value (gensym))
+                  (arglist `(,dummy-key ,elisp-key ,value)))
+             `(with-always-lexical
+               ,arglist
+               (lambda ,arglist
+                 (if (eq ,elisp-key ,tagsym)
+                     ,value
+                     ((guile-primitive throw) ,dummy-key ,elisp-key
+                      ,value))))))))))
+
+;;; unwind-protect is just some weaker construct as dynamic-wind, so
+;;; straight-forward to implement.
+
+(built-in-macro unwind-protect
+  (lambda (body . clean-ups)
+    (if (null? clean-ups)
+        (macro-error "unwind-protect without cleanup code"))
+    `((guile-primitive dynamic-wind)
+      (lambda () nil)
+      (lambda () ,body)
+      (lambda () ,@clean-ups))))
+
+;;; Pop off the first element from a list or push one to it.
+
+(built-in-macro pop
+  (lambda (list-name)
+    `(prog1 (car ,list-name)
+            (setq ,list-name (cdr ,list-name)))))
+
+(built-in-macro push
+  (lambda (new-el list-name)
+    `(setq ,list-name (cons ,new-el ,list-name))))
+;;; Guile Emacs Lisp
+
+;;; 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
+
+;;; Code:
+
+(define-module (language elisp runtime subrs)
+  #\use-module (language elisp runtime)
+  #\use-module (system base compile))
+
+;;; This module contains the function-slots of elisp symbols. Elisp
+;;; built-in functions are implemented as predefined function bindings
+;;; here.
+
+;;; Equivalence and equalness predicates.
+
+(built-in-func eq
+  (lambda (a b)
+    (elisp-bool (eq? a b))))
+
+(built-in-func equal
+  (lambda (a b)
+    (elisp-bool (equal? a b))))
+
+;;; Number predicates.
+
+(built-in-func floatp
+  (lambda (num)
+    (elisp-bool (and (real? num)
+                     (or (inexact? num)
+                         (prim not (integer? num)))))))
+
+(built-in-func integerp
+  (lambda (num)
+    (elisp-bool (and (exact? num)
+                     (integer? num)))))
+
+(built-in-func numberp
+  (lambda (num)
+    (elisp-bool (real? num))))
+
+(built-in-func wholenump
+  (lambda (num)
+    (elisp-bool (and (exact? num)
+                     (integer? num)
+                     (prim >= num 0)))))
+
+(built-in-func zerop
+  (lambda (num)
+    (elisp-bool (prim = num 0))))
+
+;;; Number comparisons.
+
+(built-in-func =
+  (lambda (num1 num2)
+    (elisp-bool (prim = num1 num2))))
+
+(built-in-func /=
+  (lambda (num1 num2)
+    (elisp-bool (prim not (prim = num1 num2)))))
+
+(built-in-func <
+  (lambda (num1 num2)
+    (elisp-bool (prim < num1 num2))))
+
+(built-in-func <=
+  (lambda (num1 num2)
+    (elisp-bool (prim <= num1 num2))))
+
+(built-in-func >
+  (lambda (num1 num2)
+    (elisp-bool (prim > num1 num2))))
+
+(built-in-func >=
+  (lambda (num1 num2)
+    (elisp-bool (prim >= num1 num2))))
+
+(built-in-func max
+  (lambda (. nums)
+    (prim apply (@ (guile) max) nums)))
+
+(built-in-func min
+  (lambda (. nums)
+    (prim apply (@ (guile) min) nums)))
+
+(built-in-func abs
+  (@ (guile) abs))
+
+;;; Number conversion.
+
+(built-in-func float
+  (lambda (num)
+    (if (exact? num)
+        (exact->inexact num)
+        num)))
+
+;;; TODO: truncate, floor, ceiling, round.
+
+;;; Arithmetic functions.
+
+(built-in-func 1+ (@ (guile) 1+))
+
+(built-in-func 1- (@ (guile) 1-))
+
+(built-in-func + (@ (guile) +))
+
+(built-in-func - (@ (guile) -))
+
+(built-in-func * (@ (guile) *))
+
+(built-in-func % (@ (guile) modulo))
+
+;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
+;;; values).
+
+;;; Floating-point rounding operations.
+
+(built-in-func ffloor (@ (guile) floor))
+
+(built-in-func fceiling (@ (guile) ceiling))
+
+(built-in-func ftruncate (@ (guile) truncate))
+
+(built-in-func fround (@ (guile) round))
+
+;;; List predicates.
+
+(built-in-func consp
+  (lambda (el)
+    (elisp-bool (pair? el))))
+
+(built-in-func atomp
+  (lambda (el)
+    (elisp-bool (prim not (pair? el)))))
+
+(built-in-func listp
+  (lambda (el)
+    (elisp-bool (or (pair? el) (null? el)))))
+
+(built-in-func nlistp
+  (lambda (el)
+    (elisp-bool (and (prim not (pair? el))
+                     (prim not (null? el))))))
+
+(built-in-func null
+  (lambda (el)
+    (elisp-bool (null? el))))
+
+;;; Accessing list elements.
+
+(built-in-func car
+  (lambda (el)
+    (if (null? el)
+        nil-value
+        (prim car el))))
+
+(built-in-func cdr
+  (lambda (el)
+    (if (null? el)
+        nil-value
+        (prim cdr el))))
+
+(built-in-func car-safe
+  (lambda (el)
+    (if (pair? el)
+        (prim car el)
+        nil-value)))
+
+(built-in-func cdr-safe
+  (lambda (el)
+    (if (pair? el)
+        (prim cdr el)
+        nil-value)))
+
+(built-in-func nth
+  (lambda (n lst)
+    (if (negative? n)
+        (prim car lst)
+        (let iterate ((i n)
+                      (tail lst))
+          (cond
+           ((null? tail) nil-value)
+           ((zero? i) (prim car tail))
+           (else (iterate (prim 1- i) (prim cdr tail))))))))
+
+(built-in-func nthcdr
+  (lambda (n lst)
+    (if (negative? n)
+        lst
+        (let iterate ((i n)
+                      (tail lst))
+          (cond
+           ((null? tail) nil-value)
+           ((zero? i) tail)
+           (else (iterate (prim 1- i) (prim cdr tail))))))))
+
+(built-in-func length (@ (guile) length))
+
+;;; Building lists.
+
+(built-in-func cons (@ (guile) cons))
+
+(built-in-func list (@ (guile) list))
+
+(built-in-func make-list
+  (lambda (len obj)
+    (prim make-list len obj)))
+
+(built-in-func append (@ (guile) append))
+
+(built-in-func reverse (@ (guile) reverse))
+
+(built-in-func copy-tree (@ (guile) copy-tree))
+
+(built-in-func number-sequence
+  (lambda (from . rest)
+    (if (prim > (prim length rest) 2)
+        (runtime-error "too many arguments for number-sequence"
+                       (prim cdddr rest))
+        (if (null? rest)
+            `(,from)
+            (let ((to (prim car rest))
+                  (sep (if (or (null? (prim cdr rest))
+                               (eq? nil-value (prim cadr rest)))
+                           1
+                           (prim cadr rest))))
+              (cond
+               ((or (eq? nil-value to) (prim = to from)) `(,from))
+               ((and (zero? sep) (prim not (prim = from to)))
+                (runtime-error "infinite list in number-sequence"))
+               ((prim < (prim * to sep) (prim * from sep)) '())
+               (else
+                (let iterate ((i (prim +
+                                       from
+                                       (prim *
+                                             sep
+                                             (prim quotient
+                                                   (prim abs
+                                                         (prim -
+                                                               to
+                                                               from))
+                                                   (prim abs sep)))))
+                              (result '()))
+                  (if (prim = i from)
+                      (prim cons i result)
+                      (iterate (prim - i sep)
+                               (prim cons i result)))))))))))
+
+;;; Changing lists.
+
+(built-in-func setcar
+  (lambda (cell val)
+    (if (and (null? cell) (null? val))
+        #nil
+        (prim set-car! cell val))
+    val))
+
+(built-in-func setcdr
+  (lambda (cell val)
+    (if (and (null? cell) (null? val))
+        #nil
+        (prim set-cdr! cell val))
+    val))
+
+;;; Accessing symbol bindings for symbols known only at runtime.
+
+(built-in-func symbol-value
+  (lambda (sym)
+    (reference-variable value-slot-module sym)))
+
+(built-in-func symbol-function
+  (lambda (sym)
+    (reference-variable function-slot-module sym)))
+
+(built-in-func set
+  (lambda (sym value)
+    (set-variable! value-slot-module sym value)))
+
+(built-in-func fset
+  (lambda (sym value)
+    (set-variable! function-slot-module sym value)))
+
+(built-in-func makunbound
+  (lambda (sym)
+    (if (module-bound? (resolve-interface value-slot-module) sym)
+      (let ((var (module-variable (resolve-module value-slot-module)
+                                  sym)))
+        (if (and (variable-bound? var) (fluid? (variable-ref var)))
+            (fluid-unset! (variable-ref var))
+            (variable-unset! var))))
+    sym))
+
+(built-in-func fmakunbound
+  (lambda (sym)
+    (if (module-bound? (resolve-interface function-slot-module) sym)
+        (let ((var (module-variable
+                    (resolve-module function-slot-module)
+                    sym)))
+          (if (and (variable-bound? var) (fluid? (variable-ref var)))
+              (fluid-unset! (variable-ref var))
+              (variable-unset! var))))
+    sym))
+
+(built-in-func boundp
+  (lambda (sym)
+    (elisp-bool
+     (and
+      (module-bound? (resolve-interface value-slot-module) sym)
+      (let ((var (module-variable (resolve-module value-slot-module)
+                                  sym)))
+        (and (variable-bound? var)
+             (if (fluid? (variable-ref var))
+                 (fluid-bound? (variable-ref var))
+                 #t)))))))
+
+(built-in-func fboundp
+  (lambda (sym)
+    (elisp-bool
+     (and
+      (module-bound? (resolve-interface function-slot-module) sym)
+      (let* ((var (module-variable (resolve-module function-slot-module)
+                                   sym)))
+       (and (variable-bound? var)
+            (if (fluid? (variable-ref var))
+                (fluid-bound? (variable-ref var))
+                #t)))))))
+
+;;; Function calls. These must take care of special cases, like using
+;;; symbols or raw lambda-lists as functions!
+
+(built-in-func apply
+  (lambda (func . args)
+    (let ((real-func (cond
+                      ((symbol? func)
+                       (reference-variable function-slot-module func))
+                      ((list? func)
+                       (if (and (prim not (null? func))
+                                (eq? (prim car func) 'lambda))
+                           (compile func #\from 'elisp #\to 'value)
+                           (runtime-error "list is not a function"
+                                          func)))
+                      (else func))))
+      (prim apply (@ (guile) apply) real-func args))))
+
+(built-in-func funcall
+  (lambda (func . args)
+    (apply func args)))
+
+;;; Throw can be implemented as built-in function.
+
+(built-in-func throw
+  (lambda (tag value)
+    (prim throw 'elisp-exception tag value)))
+
+;;; Miscellaneous.
+
+(built-in-func not
+  (lambda (x)
+    (if x nil-value t-value)))
+
+(built-in-func eval
+  (lambda (form)
+    (compile form #\from 'elisp #\to 'value)))
+
+(built-in-func load
+  (lambda* (file)
+    (compile-file file #\from 'elisp #\to 'value)
+    #t))
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 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
+
+;;; Code:
+
+(define-module (language elisp runtime value-slot))
+
+;;; This module contains the value-slots of elisp symbols.
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language elisp spec)
+  #\use-module (language elisp compile-tree-il)
+  #\use-module (language elisp parser)
+  #\use-module (system base language)
+  #\export (elisp))
+
+(define-language elisp
+  #\title     "Emacs Lisp"
+  #\reader    (lambda (port env) (read-elisp port))
+  #\printer   write
+  #\compilers `((tree-il . ,compile-tree-il)))
+;;; Guile Low Intermediate Language
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language glil)
+  #\use-module (system base syntax)
+  #\use-module (system base pmatch)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\export
+  (<glil-program> make-glil-program glil-program?
+   glil-program-meta glil-program-body
+   
+   <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
+   glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
+
+   <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
+   glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
+   glil-opt-prelude-nlocs glil-opt-prelude-else-label
+
+   <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
+   glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
+   glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
+   glil-kw-prelude-nlocs glil-kw-prelude-else-label
+
+   <glil-bind> make-glil-bind glil-bind?
+   glil-bind-vars
+
+   <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
+   glil-mv-bind-vars glil-mv-bind-rest
+
+   <glil-unbind> make-glil-unbind glil-unbind?
+
+   <glil-source> make-glil-source glil-source?
+   glil-source-props
+
+   <glil-void> make-glil-void glil-void?
+
+   <glil-const> make-glil-const glil-const?
+   glil-const-obj
+
+   <glil-lexical> make-glil-lexical glil-lexical?
+   glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
+
+   <glil-toplevel> make-glil-toplevel glil-toplevel?
+   glil-toplevel-op glil-toplevel-name
+
+   <glil-module> make-glil-module glil-module?
+   glil-module-op glil-module-mod glil-module-name glil-module-public?
+
+   <glil-label> make-glil-label glil-label?
+   glil-label-label
+
+   <glil-branch> make-glil-branch glil-branch?
+   glil-branch-inst glil-branch-label
+
+   <glil-call> make-glil-call glil-call?
+   glil-call-inst glil-call-nargs
+
+   <glil-mv-call> make-glil-mv-call glil-mv-call?
+   glil-mv-call-nargs glil-mv-call-ra
+
+   <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?
+
+   parse-glil unparse-glil))
+
+(define (print-glil x port)
+  (format port "#<glil ~s>" (unparse-glil x)))
+
+(define-type (<glil> #\printer print-glil)
+  ;; Meta operations
+  (<glil-program> meta body)
+  (<glil-std-prelude> nreq nlocs else-label)
+  (<glil-opt-prelude> nreq nopt rest nlocs else-label)
+  (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+  (<glil-bind> vars)
+  (<glil-mv-bind> vars rest)
+  (<glil-unbind>)
+  (<glil-source> props)
+  ;; Objects
+  (<glil-void>)
+  (<glil-const> obj)
+  ;; Variables
+  (<glil-lexical> local? boxed? op index)
+  (<glil-toplevel> op name)
+  (<glil-module> op mod name public?)
+  ;; Controls
+  (<glil-label> label)
+  (<glil-branch> inst label)
+  (<glil-call> inst nargs)
+  (<glil-mv-call> nargs ra)
+  (<glil-prompt> label escape-only?))
+
+
+
+(define (parse-glil x)
+  (pmatch x
+    ((program ,meta . ,body)
+     (make-glil-program meta (map parse-glil body)))
+    ((std-prelude ,nreq ,nlocs ,else-label)
+     (make-glil-std-prelude nreq nlocs else-label))
+    ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
+     (make-glil-opt-prelude nreq nopt rest nlocs else-label))
+    ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
+     (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
+    ((bind . ,vars) (make-glil-bind vars))
+    ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
+    ((unbind) (make-glil-unbind))
+    ((source ,props) (make-glil-source props))
+    ((void) (make-glil-void))
+    ((const ,obj) (make-glil-const obj))
+    ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
+    ((toplevel ,op ,name) (make-glil-toplevel op name))
+    ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
+    ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
+    ((label ,label) (make-glil-label label))
+    ((branch ,inst ,label) (make-glil-branch inst label))
+    ((call ,inst ,nargs) (make-glil-call inst nargs))
+    ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
+    ((prompt ,label ,escape-only?)
+     (make-glil-prompt label escape-only?))
+    (else (error "invalid glil" x))))
+
+(define (unparse-glil glil)
+  (record-case glil
+    ;; meta
+    ((<glil-program> meta body)
+     `(program ,meta ,@(map unparse-glil body)))
+    ((<glil-std-prelude> nreq nlocs else-label)
+     `(std-prelude ,nreq ,nlocs ,else-label))
+    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+     `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
+    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+     `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
+    ((<glil-bind> vars) `(bind ,@vars))
+    ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
+    ((<glil-unbind>) `(unbind))
+    ((<glil-source> props) `(source ,props))
+    ;; constants
+    ((<glil-void>) `(void))
+    ((<glil-const> obj) `(const ,obj))
+    ;; variables
+    ((<glil-lexical> local? boxed? op index)
+     `(lexical ,local? ,boxed? ,op ,index))
+    ((<glil-toplevel> op name)
+     `(toplevel ,op ,name))
+    ((<glil-module> op mod name public?)
+     `(module ,(if public? 'public 'private) ,op ,mod ,name))
+    ;; controls
+    ((<glil-label> label) `(label ,label))
+    ((<glil-branch> inst label) `(branch ,inst ,label))
+    ((<glil-call> inst nargs) `(call ,inst ,nargs))
+    ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
+    ((<glil-prompt> label escape-only?)
+     `(prompt ,label escape-only?))))
+;;; Guile VM assembler
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language glil compile-assembly)
+  #\use-module (system base syntax)
+  #\use-module (system base pmatch)
+  #\use-module (language glil)
+  #\use-module (language assembly)
+  #\use-module (system vm instruction)
+  #\use-module ((system vm program) #\select (make-binding))
+  #\use-module (ice-9 receive)
+  #\use-module (ice-9 vlist)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\use-module (rnrs bytevectors)
+  #\export (compile-assembly))
+
+;; Traversal helpers
+;;
+(define (vhash-fold-right2 proc vhash s0 s1)
+  (let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1))
+    (if (zero? i)
+        (values s0 s1)
+        (receive (s0 s1) (let ((pair (vlist-ref vhash (1- i))))
+                           (proc (car pair) (cdr pair) s0 s1))
+          (lp (1- i) s0 s1)))))
+
+(define (fold2 proc ls s0 s1)
+  (let lp ((ls ls) (s0 s0) (s1 s1))
+    (if (null? ls)
+        (values s0 s1)
+        (receive (s0 s1) (proc (car ls) s0 s1)
+          (lp (cdr ls) s0 s1)))))
+
+(define (vector-fold2 proc vect s0 s1)
+  (let ((len (vector-length vect)))
+    (let lp ((i 0) (s0 s0) (s1 s1))
+      (if (< i len)
+          (receive (s0 s1) (proc (vector-ref vect i) s0 s1)
+            (lp (1+ i) s0 s1))
+          (values s0 s1)))))
+
+;; Variable cache cells go in the object table, and serialize as their
+;; keys. The reason we wrap the keys in these records is so they don't
+;; compare as `equal?' to other objects in the object table.
+;;
+;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
+
+(define-record <variable-cache-cell> key)
+
+(define (limn-sources sources)
+  (let lp ((in sources) (out '()) (filename #f))
+    (if (null? in)
+        (reverse! out)
+        (let ((addr (caar in))
+              (new-filename (assq-ref (cdar in ) 'filename))
+              (line (assq-ref (cdar in) 'line))
+              (column (assq-ref (cdar in) 'column)))
+          (cond
+           ((not (equal? new-filename filename))
+            (lp (cdr in)
+                `((,addr . (,line . ,column))
+                  (filename . ,new-filename)
+                  . ,out)
+                new-filename))
+           ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
+            (lp (cdr in)
+                `((,addr . (,line . ,column))
+                  . ,out)
+                filename))
+           (else
+            (lp (cdr in) out filename)))))))
+
+
+;; Avoid going through the compiler so as to avoid adding to the
+;; constant store.
+(define (make-meta bindings sources arities tail)
+  (let ((body `(,@(dump-object `(,bindings ,sources ,arities ,@tail) 0)
+                (return))))
+    `(load-program ()
+                   ,(addr+ 0 body)
+                   #f
+                   ,@body)))
+
+;; If this is true, the object doesn't need to go in a constant table.
+;;
+(define (immediate? x)
+  (object->assembly x))
+
+;; This tests for a proper scheme list whose last cdr is '(), not #nil.
+;;
+(define (scheme-list? x)
+  (and (list? x)
+       (or (eq? x '())
+           (let ((p (last-pair x)))
+             (and (pair? p)
+                  (eq? (cdr p) '()))))))
+
+;; Note: in all of these procedures that build up constant tables, the
+;; first (zeroth) index is reserved.  At runtime it is replaced with the
+;; procedure's module.  Hence all of this 1+ length business.
+
+;; Build up a vhash of constant -> index, allowing us to build up a
+;; constant table for a whole compilation unit.
+;;
+(define (build-constant-store x)
+  (define (add-to-store store x)
+    (define (add-to-end store x)
+      (vhash-cons x (1+ (vlist-length store)) store))
+    (cond
+     ((vhash-assoc x store)
+      ;; Already in the store.
+      store)
+     ((immediate? x)
+      ;; Immediates don't need to go in the constant table.
+      store)
+     ((or (number? x)
+          (string? x)
+          (symbol? x)
+          (keyword? x))
+      ;; Atoms.
+      (add-to-end store x))
+     ((variable-cache-cell? x)
+      ;; Variable cache cells (see below).
+      (add-to-end (add-to-store store (variable-cache-cell-key x))
+                  x))
+     ((list? x)
+      ;; Add the elements to the store, then the list itself.  We could
+      ;; try hashing the cdrs as well, but that seems a bit overkill, and
+      ;; this way we do compress the bytecode a bit by allowing the use of
+      ;; the `list' opcode.
+      (let ((store (fold (lambda (x store)
+                           (add-to-store store x))
+                         store
+                         x)))
+        (add-to-end store x)))
+     ((pair? x)
+      ;; Non-lists get caching on both fields.
+      (let ((store (add-to-store (add-to-store store (car x))
+                                 (cdr x))))
+        (add-to-end store x)))
+     ((and (vector? x)
+           (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
+      ;; Likewise, add the elements to the store, then the vector itself.
+      ;; Important for the vectors produced by the psyntax expansion
+      ;; process.
+      (let ((store (fold (lambda (x store)
+                           (add-to-store store x))
+                         store
+                         (vector->list x))))
+        (add-to-end store x)))
+     ((array? x)
+      ;; Naive assumption that if folks are using arrays, that perhaps
+      ;; there's not much more duplication.
+      (add-to-end store x))
+     (else
+      (error "build-constant-store: unrecognized object" x))))
+
+  (let walk ((x x) (store vlist-null))
+    (record-case x
+      ((<glil-program> meta body)
+       (fold walk store body))
+      ((<glil-const> obj)
+       (add-to-store store obj))
+      ((<glil-kw-prelude> kw)
+       (add-to-store store kw))
+      ((<glil-toplevel> op name)
+       ;; We don't add toplevel variable cache cells to the global
+       ;; constant table, because they are sensitive to changes in
+       ;; modules as the toplevel expressions are evaluated.  So we just
+       ;; add the name.
+       (add-to-store store name))
+      ((<glil-module> op mod name public?)
+       ;; However, it is fine add module variable cache cells to the
+       ;; global table, as their bindings are not dependent on the
+       ;; current module.
+       (add-to-store store
+                     (make-variable-cache-cell (list mod name public?))))
+      (else store))))
+
+;; Analyze one <glil-program> to determine its object table.  Produces a
+;; vhash of constant to index.
+;;
+(define (build-object-table x)
+  (define (add store x)
+    (if (vhash-assoc x store)
+        store
+        (vhash-cons x (1+ (vlist-length store)) store)))
+  (record-case x
+    ((<glil-program> meta body)
+     (fold (lambda (x table)
+             (record-case x
+               ((<glil-program> meta body)
+                ;; Add the GLIL itself to the table.
+                (add table x))
+               ((<glil-const> obj)
+                (if (immediate? obj)
+                    table
+                    (add table obj)))
+               ((<glil-kw-prelude> kw)
+                (add table kw))
+               ((<glil-toplevel> op name)
+                (add table (make-variable-cache-cell name)))
+               ((<glil-module> op mod name public?)
+                (add table (make-variable-cache-cell (list mod name public?))))
+               (else table)))
+           vlist-null
+           body))))
+
+;; A functional stack of names of live variables.
+(define (make-open-binding name boxed? index)
+  (list name boxed? index))
+(define (make-closed-binding open-binding start end)
+  (make-binding (car open-binding) (cadr open-binding)
+                (caddr open-binding) start end))
+(define (open-binding bindings vars start)
+  (cons
+   (acons start
+          (map
+           (lambda (v)
+             (pmatch v
+               ((,name ,boxed? ,i)
+                (make-open-binding name boxed? i))
+               (else (error "unknown binding type" v))))
+           vars)
+          (car bindings))
+   (cdr bindings)))
+(define (close-binding bindings end)
+  (pmatch bindings
+    ((((,start . ,closing) . ,open) . ,closed)
+     (cons open
+           (fold (lambda (o tail)
+                   ;; the cons is for dsu sort
+                   (acons start (make-closed-binding o start end)
+                          tail))
+                 closed
+                 closing)))
+    (else (error "broken bindings" bindings))))
+(define (close-all-bindings bindings end)
+  (if (null? (car bindings))
+      (map cdr
+           (stable-sort (reverse (cdr bindings))
+                        (lambda (x y) (< (car x) (car y)))))
+      (close-all-bindings (close-binding bindings end) end)))
+
+
+;; A functional arities thingamajiggy.
+;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
+(define (open-arity addr nreq nopt rest kw arities)
+  (cons
+   (cond
+    (kw (list addr nreq nopt rest kw))
+    (rest (list addr nreq nopt rest))
+    (nopt (list addr nreq nopt))
+    (nreq (list addr nreq))
+    (else (list addr)))
+   arities))
+(define (close-arity addr arities)
+  (pmatch arities
+    (() '())
+    (((,start . ,tail) . ,rest)
+     `((,start ,addr . ,tail) . ,rest))
+    (else (error "bad arities" arities))))
+(define (begin-arity end start nreq nopt rest kw arities)
+  (open-arity start nreq nopt rest kw (close-arity end arities)))
+
+(define (compile-assembly glil)
+  (let* ((all-constants (build-constant-store glil))
+         (prog (compile-program glil all-constants))
+         (len (byte-length prog)))
+    ;; The top objcode thunk.  We're going to wrap this thunk in
+    ;; a thunk -- yo dawgs -- with the goal being to lift all
+    ;; constants up to the top level.  The store forms a DAG, so
+    ;; we can actually build up later elements in terms of
+    ;; earlier ones.
+    ;;
+    (cond
+     ((vlist-null? all-constants)
+      ;; No constants: just emit the inner thunk.
+      prog)
+     (else
+      ;; We have an object store, so write it out, attach it
+      ;; to the inner thunk, and tail call.
+      (receive (tablecode addr) (dump-constants all-constants)
+        (let ((prog (align-program prog addr)))
+          ;; Outer thunk.
+          `(load-program ()
+                         ,(+ (addr+ addr prog)
+                             2          ; for (tail-call 0)
+                             )
+                         #f
+                         ;; Load the table, build the inner
+                         ;; thunk, then tail call.
+                         ,@tablecode
+                         ,@prog
+                         (tail-call 0))))))))
+
+(define (compile-program glil constants)
+  (record-case glil
+    ((<glil-program> meta body)
+     (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+              (label-alist '()) (arities '()) (addr 0))
+       (cond
+        ((null? body)
+         (let ((code (fold append '() code))
+               (bindings (close-all-bindings bindings addr))
+               (sources (limn-sources (reverse! source-alist)))
+               (labels (reverse label-alist))
+               (arities (reverse (close-arity addr arities)))
+               (len addr))
+           (let* ((meta (make-meta bindings sources arities meta))
+                  (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)))
+             `(load-program ,labels
+                            ,(+ len meta-pad)
+                            ,meta
+                            ,@code
+                            ,@(if meta
+                                  (make-list meta-pad '(nop))
+                                  '())))))
+        (else
+         (receive (subcode bindings source-alist label-alist arities)
+             (glil->assembly (car body) bindings
+                             source-alist label-alist
+                             constants arities addr)
+           (lp (cdr body) (cons subcode code)
+               bindings source-alist label-alist arities
+               (addr+ addr subcode)))))))))
+
+(define (compile-objtable constants table addr)
+  (define (load-constant idx)
+    (if (< idx 256)
+        (values `((object-ref ,idx))
+                2)
+        (values `((long-object-ref
+                   ,(quotient idx 256) ,(modulo idx 256)))
+                3)))
+  (cond
+   ((vlist-null? table)
+    ;; Empty table; just return #f.
+    (values '((make-false))
+            (1+ addr)))
+   (else
+    (call-with-values
+        (lambda ()
+          (vhash-fold-right2
+           (lambda (obj idx codes addr)
+             (cond
+              ((vhash-assoc obj constants)
+               => (lambda (pair)
+                    (receive (load len) (load-constant (cdr pair))
+                      (values (cons load codes)
+                              (+ addr len)))))
+              ((variable-cache-cell? obj)
+               (cond
+                ((vhash-assoc (variable-cache-cell-key obj) constants)
+                 => (lambda (pair)
+                      (receive (load len) (load-constant (cdr pair))
+                        (values (cons load codes)
+                                (+ addr len)))))
+                (else (error "vcache cell key not in table" obj))))
+              ((glil-program? obj)
+               ;; Programs are not cached in the global constants
+               ;; table because when a program is loaded, its module
+               ;; is bound, and we want to do that only after any
+               ;; preceding effectful statements.
+               (let* ((table (build-object-table obj))
+                      (prog (compile-program obj table)))
+                 (receive (tablecode addr)
+                     (compile-objtable constants table addr)
+                   (let ((prog (align-program prog addr)))
+                     (values (cons `(,@tablecode ,@prog)
+                                   codes)
+                             (addr+ addr prog))))))
+              (else
+               (error "unrecognized constant" obj))))
+           table
+           '(((make-false))) (1+ addr)))
+      (lambda (elts addr)
+        (let ((len (1+ (vlist-length table))))
+          (values
+           (fold append
+                 `((vector ,(quotient len 256) ,(modulo len 256)))
+                 elts)
+           (+ addr 3))))))))
+
+(define (glil->assembly glil bindings source-alist label-alist
+                        constants arities addr)
+  (define (emit-code x)
+    (values x bindings source-alist label-alist arities))
+  (define (emit-object-ref i)
+    (values (if (< i 256)
+                `((object-ref ,i))
+                `((long-object-ref ,(quotient i 256) ,(modulo i 256))))
+            bindings source-alist label-alist arities))
+  (define (emit-code/arity x nreq nopt rest kw)
+    (values x bindings source-alist label-alist
+            (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
+  
+  (record-case glil
+    ((<glil-program> meta body)
+     (cond
+      ((vhash-assoc glil constants)
+       ;; We are cached in someone's objtable; just emit a load.
+       => (lambda (pair)
+            (emit-object-ref (cdr pair))))
+      (else
+       ;; Otherwise, build an objtable for the program, compile it, and
+       ;; emit a load-program.
+       (let* ((table (build-object-table glil))
+              (prog (compile-program glil table)))
+         (receive (tablecode addr) (compile-objtable constants table addr)
+           (emit-code `(,@tablecode ,@(align-program prog addr))))))))
+    
+    ((<glil-std-prelude> nreq nlocs else-label)
+     (emit-code/arity
+      (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label))
+          `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3))))
+          `(,(if else-label
+                 `(br-if-nargs-ne ,(quotient nreq 256)
+                                  ,(modulo nreq 256)
+                                  ,else-label)
+                 `(assert-nargs-ee ,(quotient nreq 256)
+                                   ,(modulo nreq 256)))
+            (reserve-locals ,(quotient nlocs 256)
+                            ,(modulo nlocs 256))))
+      nreq #f #f #f))
+
+    ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+     (let ((bind-required
+            (if else-label
+                `((br-if-nargs-lt ,(quotient nreq 256)
+                                  ,(modulo nreq 256)
+                                  ,else-label))
+                `((assert-nargs-ge ,(quotient nreq 256)
+                                   ,(modulo nreq 256)))))
+           (bind-optionals
+            (if (zero? nopt)
+                '()
+                `((bind-optionals ,(quotient (+ nopt nreq) 256)
+                                  ,(modulo (+ nreq nopt) 256)))))
+           (bind-rest
+            (cond
+             (rest
+              `((push-rest ,(quotient (+ nreq nopt) 256)
+                           ,(modulo (+ nreq nopt) 256))))
+             (else
+              (if else-label
+                  `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
+                                    ,(modulo (+ nreq nopt) 256)
+                                    ,else-label))
+                  `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
+                                     ,(modulo (+ nreq nopt) 256))))))))
+       (emit-code/arity
+        `(,@bind-required
+          ,@bind-optionals
+          ,@bind-rest
+          (reserve-locals ,(quotient nlocs 256)
+                          ,(modulo nlocs 256)))
+        nreq nopt rest #f)))
+    
+    ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+     (let* ((kw-idx (or (and=> (vhash-assoc kw constants) cdr)
+                        (error "kw not in objtable")))
+            (bind-required
+             (if else-label
+                 `((br-if-nargs-lt ,(quotient nreq 256)
+                                   ,(modulo nreq 256)
+                                   ,else-label))
+                 `((assert-nargs-ge ,(quotient nreq 256)
+                                    ,(modulo nreq 256)))))
+            (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
+            (bind-optionals-and-shuffle
+             `((,(if (and else-label (not rest))
+                     'bind-optionals/shuffle-or-br
+                     'bind-optionals/shuffle)
+                ,(quotient nreq 256)
+                ,(modulo nreq 256)
+                ,(quotient (+ nreq nopt) 256)
+                ,(modulo (+ nreq nopt) 256)
+                ,(quotient ntotal 256)
+                ,(modulo ntotal 256)
+                ,@(if (and else-label (not rest))
+                      `(,else-label)
+                      '()))))
+            (bind-kw
+             ;; when this code gets called, all optionals are filled
+             ;; in, space has been made for kwargs, and the kwargs
+             ;; themselves have been shuffled above the slots for all
+             ;; req/opt/kwargs locals.
+             `((bind-kwargs
+                ,(quotient kw-idx 256)
+                ,(modulo kw-idx 256)
+                ,(quotient ntotal 256)
+                ,(modulo ntotal 256)
+                ,(logior (if rest 2 0)
+                         (if allow-other-keys? 1 0)))))
+            (bind-rest
+             (if rest
+                 `((bind-rest ,(quotient ntotal 256)
+                              ,(modulo ntotal 256)
+                              ,(quotient rest 256)
+                              ,(modulo rest 256)))
+                 '())))
+         
+       (let ((code `(,@bind-required
+                     ,@bind-optionals-and-shuffle
+                     ,@bind-kw
+                     ,@bind-rest
+                     (reserve-locals ,(quotient nlocs 256)
+                                     ,(modulo nlocs 256)))))
+         (values code bindings source-alist label-alist
+                 (begin-arity addr (addr+ addr code) nreq nopt rest
+                              (and kw (cons allow-other-keys? kw))
+                              arities)))))
+    
+    ((<glil-bind> vars)
+     (values '()
+             (open-binding bindings vars addr)
+             source-alist
+             label-alist
+             arities))
+
+    ((<glil-mv-bind> vars rest)
+     (if (integer? vars)
+         (values `((truncate-values ,vars ,(if rest 1 0)))
+                 bindings
+                 source-alist
+                 label-alist
+                 arities)
+         (values `((truncate-values ,(length vars) ,(if rest 1 0)))
+                 (open-binding bindings vars addr)
+                 source-alist
+                 label-alist
+                 arities)))
+    
+    ((<glil-unbind>)
+     (values '()
+             (close-binding bindings addr)
+             source-alist
+             label-alist
+             arities))
+             
+    ((<glil-source> props)
+     (values '()
+             bindings
+             (acons addr props source-alist)
+             label-alist
+             arities))
+
+    ((<glil-void>)
+     (emit-code '((void))))
+
+    ((<glil-const> obj)
+     (cond
+      ((object->assembly obj)
+       => (lambda (code)
+            (emit-code (list code))))
+      ((vhash-assoc obj constants)
+       => (lambda (pair)
+            (emit-object-ref (cdr pair))))
+      (else (error "const not in table" obj))))
+
+    ((<glil-lexical> local? boxed? op index)
+     (emit-code
+      (if local?
+          (if (< index 256)
+              (case op
+                ((ref) (if boxed?
+                           `((local-boxed-ref ,index))
+                           `((local-ref ,index))))
+                ((set) (if boxed?
+                           `((local-boxed-set ,index))
+                           `((local-set ,index))))
+                ((box) `((box ,index)))
+                ((empty-box) `((empty-box ,index)))
+                ((fix) `((fix-closure 0 ,index)))
+                ((bound?) (if boxed?
+                              `((local-ref ,index)
+                                (variable-bound?))
+                              `((local-bound? ,index))))
+                (else (error "what" op)))
+              (let ((a (quotient index 256))
+                    (b (modulo index 256)))
+                (case op
+                  ((ref)
+                   (if boxed?
+                       `((long-local-ref ,a ,b)
+                         (variable-ref))
+                       `((long-local-ref ,a ,b))))
+                  ((set)
+                   (if boxed?
+                       `((long-local-ref ,a ,b)
+                         (variable-set))
+                       `((long-local-set ,a ,b))))
+                  ((box)
+                   `((make-variable)
+                     (variable-set)
+                     (long-local-set ,a ,b)))
+                  ((empty-box)
+                   `((make-variable)
+                     (long-local-set ,a ,b)))
+                  ((fix)
+                   `((fix-closure ,a ,b)))
+                  ((bound?)
+                   (if boxed?
+                       `((long-local-ref ,a ,b)
+                         (variable-bound?))
+                       `((long-local-bound? ,a ,b))))
+                  (else (error "what" op)))))
+          `((,(case op
+                ((ref) (if boxed? 'free-boxed-ref 'free-ref))
+                ((set) (if boxed? 'free-boxed-set (error "what." glil)))
+                (else (error "what" op)))
+             ,index)))))
+    
+    ((<glil-toplevel> op name)
+     (case op
+       ((ref set)
+        (cond
+         ((and=> (vhash-assoc (make-variable-cache-cell name) constants)
+                 cdr)
+          => (lambda (i)
+               (emit-code (if (< i 256)
+                              `((,(case op
+                                    ((ref) 'toplevel-ref)
+                                    ((set) 'toplevel-set))
+                                 ,i))
+                              `((,(case op
+                                    ((ref) 'long-toplevel-ref)
+                                    ((set) 'long-toplevel-set))
+                                 ,(quotient i 256)
+                                 ,(modulo i 256)))))))
+         (else
+          (let ((i (or (and=> (vhash-assoc name constants) cdr)
+                       (error "toplevel name not in objtable" name))))
+            (emit-code `(,(if (< i 256)
+                              `(object-ref ,i)
+                              `(long-object-ref ,(quotient i 256)
+                                                ,(modulo i 256)))
+                         (link-now)
+                         ,(case op
+                            ((ref) '(variable-ref))
+                            ((set) '(variable-set)))))))))
+       ((define)
+        (let ((i (or (and=> (vhash-assoc name constants) cdr)
+                     (error "toplevel name not in objtable" name))))
+          (emit-code `(,(if (< i 256)
+                            `(object-ref ,i)
+                            `(long-object-ref ,(quotient i 256)
+                                              ,(modulo i 256)))
+                       (define)))))
+       (else
+        (error "unknown toplevel var kind" op name))))
+
+    ((<glil-module> op mod name public?)
+     (let ((key (list mod name public?)))
+       (case op
+         ((ref set)
+          (let ((i (or (and=> (vhash-assoc (make-variable-cache-cell key)
+                                           constants) cdr)
+                       (error "module vcache not in objtable" key))))
+            (emit-code (if (< i 256)
+                           `((,(case op
+                                 ((ref) 'toplevel-ref)
+                                 ((set) 'toplevel-set))
+                              ,i))
+                           `((,(case op
+                                 ((ref) 'long-toplevel-ref)
+                                 ((set) 'long-toplevel-set))
+                              ,(quotient i 256)
+                              ,(modulo i 256)))))))
+         (else
+          (error "unknown module var kind" op key)))))
+
+    ((<glil-label> label)
+     (let ((code (align-block addr)))
+       (values code
+               bindings
+               source-alist
+               (acons label (addr+ addr code) label-alist)
+               arities)))
+
+    ((<glil-branch> inst label)
+     (emit-code `((,inst ,label))))
+
+    ;; nargs is number of stack args to insn. probably should rename.
+    ((<glil-call> inst nargs)
+     (if (not (instruction? inst))
+         (error "Unknown instruction:" inst))
+     (let ((pops (instruction-pops inst)))
+       (cond ((< pops 0)
+              (case (instruction-length inst)
+                ((1) (emit-code `((,inst ,nargs))))
+                ((2) (emit-code `((,inst ,(quotient nargs 256)
+                                         ,(modulo nargs 256)))))
+                (else (error "Unknown length for variable-arg instruction:"
+                             inst (instruction-length inst)))))
+             ((= pops nargs)
+              (emit-code `((,inst))))
+             (else
+              (error "Wrong number of stack arguments to instruction:" inst nargs)))))
+
+    ((<glil-mv-call> nargs ra)
+     (emit-code `((mv-call ,nargs ,ra))))
+
+    ((<glil-prompt> label escape-only?)
+     (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
+
+(define (dump-object x addr)
+  (define (too-long x)
+    (error (string-append x " too long")))
+
+  (cond
+   ((object->assembly x) => list)
+   ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
+   ((number? x)
+    `((load-number ,(number->string x))))
+   ((string? x)
+    (case (string-bytes-per-char x)
+      ((1) `((load-string ,x)))
+      ((4) (align-code `(load-wide-string ,x) addr 4 4))
+      (else (error "bad string bytes per char" x))))
+   ((symbol? x)
+    (let ((str (symbol->string x)))
+      (case (string-bytes-per-char str)
+        ((1) `((load-symbol ,str)))
+        ((4) `(,@(dump-object str addr)
+               (make-symbol)))
+        (else (error "bad string bytes per char" str)))))
+   ((keyword? x)
+    `(,@(dump-object (keyword->symbol x) addr)
+      (make-keyword)))
+   ((scheme-list? x)
+    (let ((tail (let ((len (length x)))
+                  (if (>= len 65536) (too-long "list"))
+                  `((list ,(quotient len 256) ,(modulo len 256))))))
+      (let dump-objects ((objects x) (codes '()) (addr addr))
+        (if (null? objects)
+            (fold append tail codes)
+            (let ((code (dump-object (car objects) addr)))
+              (dump-objects (cdr objects) (cons code codes)
+                            (addr+ addr code)))))))
+   ((pair? x)
+    (let ((kar (dump-object (car x) addr)))
+      `(,@kar
+        ,@(dump-object (cdr x) (addr+ addr kar))
+        (cons))))
+   ((and (vector? x)
+         (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
+    (let* ((len (vector-length x))
+           (tail (if (>= len 65536)
+                     (too-long "vector")
+                     `((vector ,(quotient len 256) ,(modulo len 256))))))
+      (let dump-objects ((i 0) (codes '()) (addr addr))
+        (if (>= i len)
+            (fold append tail codes)
+            (let ((code (dump-object (vector-ref x i) addr)))
+              (dump-objects (1+ i) (cons code codes)
+                            (addr+ addr code)))))))
+   ((and (array? x) (symbol? (array-type x)))
+    (let* ((type (dump-object (array-type x) addr))
+           (shape (dump-object (array-shape x) (addr+ addr type))))
+      `(,@type
+        ,@shape
+        ,@(align-code
+           `(load-array ,(uniform-array->bytevector x))
+           (addr+ (addr+ addr type) shape)
+           8
+           4))))
+   ((array? x)
+    ;; an array of generic scheme values
+    (let* ((contents (array-contents x))
+           (len (vector-length contents)))
+      (let dump-objects ((i 0) (codes '()) (addr addr))
+        (if (< i len)
+            (let ((code (dump-object (vector-ref contents i) addr)))
+              (dump-objects (1+ i) (cons code codes)
+                            (addr+ addr code)))
+            (fold append
+                  `(,@(dump-object (array-shape x) addr)
+                    (make-array ,(quotient (ash len -16) 256)
+                                ,(logand #xff (ash len -8))
+                                ,(logand #xff len)))
+                  codes)))))
+   (else
+    (error "dump-object: unrecognized object" x))))
+
+(define (dump-constants constants)
+  (define (ref-or-dump x i addr)
+    (let ((pair (vhash-assoc x constants)))
+      (if (and pair (< (cdr pair) i))
+          (let ((idx (cdr pair)))
+            (if (< idx 256)
+                (values `((object-ref ,idx))
+                        (+ addr 2))
+                (values `((long-object-ref ,(quotient idx 256)
+                                           ,(modulo idx 256)))
+                        (+ addr 3))))
+          (dump1 x i addr))))
+  (define (dump1 x i addr)
+    (cond
+     ((object->assembly x)
+      => (lambda (code)
+           (values (list code)
+                   (+ (byte-length code) addr))))
+     ((or (number? x)
+          (string? x)
+          (symbol? x)
+          (keyword? x))
+      ;; Atoms.
+      (let ((code (dump-object x addr)))
+        (values code (addr+ addr code))))
+     ((variable-cache-cell? x)
+      (dump1 (variable-cache-cell-key x) i addr))
+     ((scheme-list? x)
+      (receive (codes addr)
+          (fold2 (lambda (x codes addr)
+                   (receive (subcode addr) (ref-or-dump x i addr)
+                     (values (cons subcode codes) addr)))
+                 x '() addr)
+        (values (fold append
+                      (let ((len (length x)))
+                        `((list ,(quotient len 256) ,(modulo len 256))))
+                      codes)
+                (+ addr 3))))
+     ((pair? x)
+      (receive (car-code addr) (ref-or-dump (car x) i addr)
+        (receive (cdr-code addr) (ref-or-dump (cdr x) i addr)
+          (values `(,@car-code ,@cdr-code (cons))
+                  (1+ addr)))))
+     ((and (vector? x)
+           (<= (vector-length x) #xffff)
+           (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
+      (receive (codes addr)
+          (vector-fold2 (lambda (x codes addr)
+                          (receive (subcode addr) (ref-or-dump x i addr)
+                            (values (cons subcode codes) addr)))
+                        x '() addr)
+        (values (fold append
+                      (let ((len (vector-length x)))
+                        `((vector ,(quotient len 256) ,(modulo len 256))))
+                      codes)
+                (+ addr 3))))
+     ((and (array? x) (symbol? (array-type x)))
+      (receive (type addr) (ref-or-dump (array-type x) i addr)
+        (receive (shape addr) (ref-or-dump (array-shape x) i addr)
+          (let ((bv (align-code `(load-array ,(uniform-array->bytevector x))
+                                addr 8 4)))
+            (values `(,@type ,@shape ,@bv)
+                    (addr+ addr bv))))))
+     ((array? x)
+      (let ((contents (array-contents x)))
+        (receive (codes addr)
+            (vector-fold2 (lambda (x codes addr)
+                            (receive (subcode addr) (ref-or-dump x i addr)
+                              (values (cons subcode codes) addr)))
+                          contents '() addr)
+          (receive (shape addr) (ref-or-dump (array-shape x) i addr)
+            (values (fold append
+                          (let ((len (vector-length contents)))
+                            `(,@shape
+                              (make-array ,(quotient (ash len -16) 256)
+                                          ,(logand #xff (ash len -8))
+                                          ,(logand #xff len))))
+                          codes)
+                    (+ addr 4))))))
+     (else
+      (error "write-table: unrecognized object" x))))
+
+  (receive (codes addr)
+      (vhash-fold-right2 (lambda (obj idx code addr)
+                           ;; The vector is on the stack.  Dup it, push
+                           ;; the index, push the val, then vector-set.
+                           (let ((pre `((dup)
+                                        ,(object->assembly idx))))
+                             (receive (valcode addr) (dump1 obj idx
+                                                            (addr+ addr pre))
+                               (values (cons* '((vector-set))
+                                              valcode
+                                              pre
+                                              code)
+                                       (1+ addr)))))
+                         constants
+                         '(((assert-nargs-ee/locals 1)
+                            ;; Push the vector.
+                            (local-ref 0)))
+                         4)
+    (let* ((len (1+ (vlist-length constants)))
+           (pre-prog-addr (+ 2          ; reserve-locals
+                             len 3      ; empty vector
+                             2          ; local-set
+                             1          ; new-frame
+                             2          ; local-ref
+                             ))
+           (prog (align-program
+                  `(load-program ()
+                                 ,(+ addr 1)
+                                 #f
+                                 ;; The `return' will be at the tail of the
+                                 ;; program.  The vector is already pushed
+                                 ;; on the stack.
+                                 . ,(fold append '((return)) codes))
+                  pre-prog-addr)))
+      (values `(;; Reserve storage for the vector.
+                (assert-nargs-ee/locals ,(logior 0 (ash 1 3)))
+                ;; Push the vector, and store it in slot 0.
+                ,@(make-list len '(make-false))
+                (vector ,(quotient len 256) ,(modulo len 256))
+                (local-set 0)
+                ;; Now we open the call frame.
+                ;;
+                (new-frame)
+                ;; Now build a thunk to init the constants.  It will
+                ;; have the unfinished constant table both as its
+                ;; argument and as its objtable.  The former allows it
+                ;; to update the objtable, with vector-set!, and the
+                ;; latter allows init code to refer to previously set
+                ;; values.
+                ;;
+                ;; Grab the vector, to be the objtable.
+                (local-ref 0)
+                ;; Now the load-program, properly aligned.  Pops the vector.
+                ,@prog
+                ;; Grab the vector, as an argument this time.
+                (local-ref 0)
+                ;; Call the init thunk with the vector as an arg.
+                (call 1)
+                ;; The thunk also returns the vector.  Leave it on the
+                ;; stack for compile-assembly to use.
+                )
+              ;; The byte length of the init code, which we can
+              ;; determine without folding over the code again.
+              (+ (addr+ pre-prog-addr prog) ; aligned program
+                 2 ; local-ref
+                 2 ; call
+                 )))))
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language glil spec)
+  #\use-module (system base language)
+  #\use-module (language glil)
+  #\use-module (language glil compile-assembly)
+  #\export (glil))
+
+(define (write-glil exp . port)
+  (apply write (unparse-glil exp) port))
+
+(define (compile-asm x e opts)
+  (values (compile-assembly x) e e))
+
+(define-language glil
+  #\title	"Guile Lowlevel Intermediate Language (GLIL)"
+  #\reader	(lambda (port env) (read port))
+  #\printer	write-glil
+  #\parser      parse-glil
+  #\compilers   `((assembly . ,compile-asm))
+  #\for-humans? #f
+  )
+;;; Guile Virtual Machine Object Code
+
+;; Copyright (C) 2001 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
+
+;;; Code:
+
+(define-module (language objcode)
+  #\export (encode-length decode-length))
+
+
+;;;
+;;; Variable-length interface
+;;;
+
+;; NOTE: decoded in vm_fetch_length in vm.c as well.
+
+(define (encode-length len)
+  (cond ((< len 254) (u8vector len))
+	((< len (* 256 256))
+	 (u8vector 254 (quotient len 256) (modulo len 256)))
+	((< len most-positive-fixnum)
+	 (u8vector 255
+		   (quotient len (* 256 256 256))
+		   (modulo (quotient len (* 256 256)) 256)
+		   (modulo (quotient len 256) 256)
+		   (modulo len 256)))
+	(else (error "Too long code length:" len))))
+
+(define (decode-length pop)
+  (let ((x (pop)))
+    (cond ((< x 254) x)
+	  ((= x 254) (+ (ash x 8) (pop)))
+	  (else
+           (let* ((b2 (pop))
+                  (b3 (pop))
+                  (b4 (pop)))
+             (+ (ash x 24) (ash b2 16) (ash b3 8) b4))))))
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language objcode spec)
+  #\use-module (system base language)
+  #\use-module (system vm objcode)
+  #\use-module (system vm program)
+  #\export (objcode))
+
+(define (objcode->value x e opts)
+  (let ((thunk (make-program x #f #f)))
+    (if (eq? e (current-module))
+        ;; save a cons in this case
+        (values (thunk) e e)
+        (save-module-excursion
+         (lambda ()
+           (set-current-module e)
+           (values (thunk) e e))))))
+
+;; since locals are allocated on the stack and can have limited scope,
+;; in many cases we use one local for more than one lexical variable. so
+;; the returned locals set is a list, where element N of the list is
+;; itself a list of bindings for local variable N.
+(define (collapse-locals locs)
+  (let lp ((ret '()) (locs locs))
+    (if (null? locs)
+        (map cdr (sort! ret 
+                        (lambda (x y) (< (car x) (car y)))))
+        (let ((b (car locs)))
+          (cond
+           ((assv-ref ret (binding:index b))
+            => (lambda (bindings)
+                 (append! bindings (list b))
+                 (lp ret (cdr locs))))
+           (else
+            (lp (acons (binding:index b) (list b) ret)
+                (cdr locs))))))))
+
+(define (decompile-value x env opts)
+  (cond
+   ((program? x)
+    (let ((objs  (program-objects x))
+          (meta  (program-meta x))
+          (free-vars  (program-free-variables x))
+          (binds (program-bindings x))
+          (srcs  (program-sources x)))
+      (let ((blocs (and binds (collapse-locals binds))))
+        (values (program-objcode x)
+                `((objects . ,objs)
+                  (meta    . ,(and meta (meta)))
+                  (free-vars . ,free-vars)
+                  (blocs   . ,blocs)
+                  (sources . ,srcs))))))
+   ((objcode? x)
+    (values x #f))
+   (else
+    (error "Object for disassembly not a program or objcode" x))))
+
+(define-language objcode
+  #\title	"Guile Object Code"
+  #\reader	#f
+  #\printer	write-objcode
+  #\compilers   `((value . ,objcode->value))
+  #\decompilers `((value . ,decompile-value))
+  #\for-humans? #f
+  )
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001, 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
+
+;;; Code:
+
+(define-module (language scheme compile-tree-il)
+  #\use-module (language tree-il)
+  #\export (compile-tree-il))
+
+;;; environment := MODULE
+
+(define (compile-tree-il x e opts)
+  (save-module-excursion
+   (lambda ()
+     (set-current-module e)
+     (let* ((x (macroexpand x 'c '(compile load eval)))
+            (cenv (current-module)))
+       (values x cenv cenv)))))
+;;; Guile VM code converters
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code:
+
+(define-module (language scheme decompile-tree-il)
+  #\use-module (language tree-il)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-26)
+  #\use-module (ice-9 receive)
+  #\use-module (ice-9 vlist)
+  #\use-module (ice-9 match)
+  #\use-module (system base syntax)
+  #\export (decompile-tree-il))
+
+(define (decompile-tree-il e env opts)
+  (apply do-decompile e env opts))
+
+(define* (do-decompile e env
+                       #\key
+                       (use-derived-syntax? #t)
+                       (avoid-lambda? #t)
+                       (use-case? #t)
+                       (strip-numeric-suffixes? #f)
+                       #\allow-other-keys)
+
+  (receive (output-name-table occurrence-count-table)
+      (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
+
+    (define (output-name s)      (hashq-ref output-name-table s))
+    (define (occurrence-count s) (hashq-ref occurrence-count-table s))
+
+    (define (const x) (lambda (_) x))
+    (define (atom? x) (not (or (pair? x) (vector? x))))
+
+    (define (build-void) '(if #f #f))
+
+    (define (build-begin es)
+      (match es
+        (() (build-void))
+        ((e) e)
+        (_ `(begin ,@es))))
+
+    (define (build-lambda-body e)
+      (match e
+        (('let () body ...) body)
+        (('begin es ...) es)
+        (_ (list e))))
+
+    (define (build-begin-body e)
+      (match e
+        (('begin es ...) es)
+        (_ (list e))))
+
+    (define (build-define name e)
+      (match e
+        ((? (const avoid-lambda?)
+            ('lambda formals body ...))
+         `(define (,name ,@formals) ,@body))
+        ((? (const avoid-lambda?)
+            ('lambda* formals body ...))
+         `(define* (,name ,@formals) ,@body))
+        (_ `(define ,name ,e))))
+
+    (define (build-let names vals body)
+      (match `(let ,(map list names vals)
+                ,@(build-lambda-body body))
+        ((_ () e) e)
+        ((_ (b) ('let* (bs ...) body ...))
+         `(let* (,b ,@bs) ,@body))
+        ((? (const use-derived-syntax?)
+            (_ (b1) ('let (b2) body ...)))
+         `(let* (,b1 ,b2) ,@body))
+        (e e)))
+
+    (define (build-letrec in-order? names vals body)
+      (match `(,(if in-order? 'letrec* 'letrec)
+               ,(map list names vals)
+               ,@(build-lambda-body body))
+        ((_ () e) e)
+        ((_ () body ...) `(let () ,@body))
+        ((_ ((name ('lambda (formals ...) body ...)))
+            (name args ...))
+         (=> failure)
+         (if (= (length formals) (length args))
+             `(let ,name ,(map list formals args) ,@body)
+             (failure)))
+        ((? (const avoid-lambda?)
+            ('letrec* _ body ...))
+         `(let ()
+            ,@(map build-define names vals)
+            ,@body))
+        (e e)))
+
+    (define (build-if test consequent alternate)
+      (match alternate
+        (('if #f _) `(if ,test ,consequent))
+        (_ `(if ,test ,consequent ,alternate))))
+
+    (define (build-and xs)
+      (match xs
+        (() #t)
+        ((x) x)
+        (_ `(and ,@xs))))
+
+    (define (build-or xs)
+      (match xs
+        (() #f)
+        ((x) x)
+        (_ `(or ,@xs))))
+
+    (define (case-test-var test)
+      (match test
+        (('memv (? atom? v) ('quote (datums ...)))
+         v)
+        (('eqv? (? atom? v) ('quote datum))
+         v)
+        (_ #f)))
+
+    (define (test->datums v test)
+      (match (cons v test)
+        ((v 'memv v ('quote (xs ...)))
+         xs)
+        ((v 'eqv? v ('quote x))
+         (list x))
+        (_ #f)))
+
+    (define (build-else-tail e)
+      (match e
+        (('if #f _) '())
+        (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
+                           (else #f)))
+        (_ `((else ,@(build-begin-body e))))))
+
+    (define (build-cond-else-tail e)
+      (match e
+        (('cond clauses ...) clauses)
+        (_ (build-else-tail e))))
+
+    (define (build-case-else-tail v e)
+      (match (cons v e)
+        ((v 'case v clauses ...)
+         clauses)
+        ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
+         `((,xs ,@(build-begin-body consequent))
+           ,@(build-case-else-tail v (build-begin alternate*))))
+        ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
+         `(((,x) ,@(build-begin-body consequent))
+           ,@(build-case-else-tail v (build-begin alternate*))))
+        (_ (build-else-tail e))))
+
+    (define (clauses+tail clauses)
+      (match clauses
+        ((cs ... (and c ('else . _))) (values cs (list c)))
+        (_ (values clauses '()))))
+
+    (define (build-cond tests consequents alternate)
+      (case (length tests)
+        ((0) alternate)
+        ((1) (build-if (car tests) (car consequents) alternate))
+        (else `(cond ,@(map (lambda (test consequent)
+                              `(,test ,@(build-begin-body consequent)))
+                            tests consequents)
+                     ,@(build-cond-else-tail alternate)))))
+
+    (define (build-cond-or-case tests consequents alternate)
+      (if (not use-case?)
+          (build-cond tests consequents alternate)
+          (let* ((v (and (not (null? tests))
+                         (case-test-var (car tests))))
+                 (datum-lists (take-while identity
+                                          (map (cut test->datums v <>)
+                                               tests)))
+                 (n (length datum-lists))
+                 (tail (build-case-else-tail v (build-cond
+                                                (drop tests n)
+                                                (drop consequents n)
+                                                alternate))))
+            (receive (clauses tail) (clauses+tail tail)
+              (let ((n (+ n (length clauses)))
+                    (datum-lists (append datum-lists
+                                         (map car clauses)))
+                    (consequents (append consequents
+                                         (map build-begin
+                                              (map cdr clauses)))))
+                (if (< n 2)
+                    (build-cond tests consequents alternate)
+                    `(case ,v
+                       ,@(map cons datum-lists (map build-begin-body
+                                                    (take consequents n)))
+                       ,@tail)))))))
+
+    (define (recurse e)
+
+      (define (recurse-body e)
+        (build-lambda-body (recurse e)))
+
+      (record-case e
+        ((<void>)
+         (build-void))
+
+        ((<const> exp)
+         (if (and (self-evaluating? exp) (not (vector? exp)))
+             exp
+             `(quote ,exp)))
+
+        ((<sequence> exps)
+         (build-begin (map recurse exps)))
+
+        ((<application> proc args)
+         (match `(,(recurse proc) ,@(map recurse args))
+           ((('lambda (formals ...) body ...) args ...)
+            (=> failure)
+            (if (= (length formals) (length args))
+                (build-let formals args (build-begin body))
+                (failure)))
+           (e e)))
+
+        ((<primitive-ref> name)
+         name)
+
+        ((<lexical-ref> gensym)
+         (output-name gensym))
+
+        ((<lexical-set> gensym exp)
+         `(set! ,(output-name gensym) ,(recurse exp)))
+
+        ((<module-ref> mod name public?)
+         `(,(if public? '@ '@@) ,mod ,name))
+
+        ((<module-set> mod name public? exp)
+         `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
+
+        ((<toplevel-ref> name)
+         name)
+
+        ((<toplevel-set> name exp)
+         `(set! ,name ,(recurse exp)))
+
+        ((<toplevel-define> name exp)
+         (build-define name (recurse exp)))
+
+        ((<lambda> meta body)
+         (if body
+             (let ((body (recurse body))
+                   (doc (assq-ref meta 'documentation)))
+               (if (not doc)
+                   body
+                   (match body
+                     (('lambda formals body ...)
+                      `(lambda ,formals ,doc ,@body))
+                     (('lambda* formals body ...)
+                      `(lambda* ,formals ,doc ,@body))
+                     (('case-lambda (formals body ...) clauses ...)
+                      `(case-lambda (,formals ,doc ,@body) ,@clauses))
+                     (('case-lambda* (formals body ...) clauses ...)
+                      `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+                     (e e))))
+             '(case-lambda)))
+
+        ((<lambda-case> req opt rest kw inits gensyms body alternate)
+         (let ((names (map output-name gensyms)))
+           (cond
+            ((and (not opt) (not kw) (not alternate))
+             `(lambda ,(if rest (apply cons* names) names)
+                ,@(recurse-body body)))
+            ((and (not opt) (not kw))
+             (let ((alt-expansion (recurse alternate))
+                   (formals (if rest (apply cons* names) names)))
+               (case (car alt-expansion)
+                 ((lambda)
+                  `(case-lambda (,formals ,@(recurse-body body))
+                                ,(cdr alt-expansion)))
+                 ((lambda*)
+                  `(case-lambda* (,formals ,@(recurse-body body))
+                                 ,(cdr alt-expansion)))
+                 ((case-lambda)
+                  `(case-lambda (,formals ,@(recurse-body body))
+                                ,@(cdr alt-expansion)))
+                 ((case-lambda*)
+                  `(case-lambda* (,formals ,@(recurse-body body))
+                                 ,@(cdr alt-expansion))))))
+            (else
+             (let* ((alt-expansion (and alternate (recurse alternate)))
+                    (nreq (length req))
+                    (nopt (if opt (length opt) 0))
+                    (restargs (if rest (list-ref names (+ nreq nopt)) '()))
+                    (reqargs (list-head names nreq))
+                    (optargs (if opt
+                                 `(#\optional
+                                   ,@(map list
+                                          (list-head (list-tail names nreq) nopt)
+                                          (map recurse
+                                               (list-head inits nopt))))
+                                 '()))
+                    (kwargs (if kw
+                                `(#\key
+                                  ,@(map list
+                                         (map output-name (map caddr (cdr kw)))
+                                         (map recurse
+                                              (list-tail inits nopt))
+                                         (map car (cdr kw)))
+                                  ,@(if (car kw)
+                                        '(#\allow-other-keys)
+                                        '()))
+                                '()))
+                    (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
+               (if (not alt-expansion)
+                   `(lambda* ,formals ,@(recurse-body body))
+                   (case (car alt-expansion)
+                     ((lambda lambda*)
+                      `(case-lambda* (,formals ,@(recurse-body body))
+                                     ,(cdr alt-expansion)))
+                     ((case-lambda case-lambda*)
+                      `(case-lambda* (,formals ,@(recurse-body body))
+                                     ,@(cdr alt-expansion))))))))))
+
+        ((<conditional> test consequent alternate)
+         (define (simplify-test e)
+           (match e
+             (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
+              `(memv ,v '(,a ,b)))
+             (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
+              `(memv ,v '(,a ,@bs)))
+             (('case (? atom? v)
+                ((datum) #t) ...
+                ('else ('eqv? v ('quote last-datum))))
+              `(memv ,v '(,@datum ,last-datum)))
+             (_ e)))
+         (match `(if ,(simplify-test (recurse test))
+                     ,(recurse consequent)
+                     ,@(if (void? alternate) '()
+                           (list (recurse alternate))))
+           (('if test ('if ('and xs ...) consequent))
+            (build-if (build-and (cons test xs))
+                      consequent
+                      (build-void)))
+           ((? (const use-derived-syntax?)
+               ('if test1 ('if test2 consequent)))
+            (build-if (build-and (list test1 test2))
+                      consequent
+                      (build-void)))
+           (('if (? atom? x) x ('or ys ...))
+            (build-or (cons x ys)))
+           ((? (const use-derived-syntax?)
+               ('if (? atom? x) x y))
+            (build-or (list x y)))
+           (('if test consequent)
+            `(if ,test ,consequent))
+           (('if test ('and xs ...) #f)
+            (build-and (cons test xs)))
+           ((? (const use-derived-syntax?)
+               ('if test consequent #f))
+            (build-and (list test consequent)))
+           ((? (const use-derived-syntax?)
+               ('if test1 consequent1
+                    ('if test2 consequent2 . alternate*)))
+            (build-cond-or-case (list test1 test2)
+                                (list consequent1 consequent2)
+                                (build-begin alternate*)))
+           (('if test consequent ('cond clauses ...))
+            `(cond (,test ,@(build-begin-body consequent))
+                   ,@clauses))
+           (('if ('memv (? atom? v) ('quote (xs ...))) consequent
+                 ('case v clauses ...))
+            `(case ,v (,xs ,@(build-begin-body consequent))
+                   ,@clauses))
+           (('if ('eqv? (? atom? v) ('quote x)) consequent
+                 ('case v clauses ...))
+            `(case ,v ((,x) ,@(build-begin-body consequent))
+                   ,@clauses))
+           (e e)))
+
+        ((<let> gensyms vals body)
+         (match (build-let (map output-name gensyms)
+                           (map recurse vals)
+                           (recurse body))
+           (('let ((v e)) ('or v xs ...))
+            (=> failure)
+            (if (and (not (null? gensyms))
+                     (= 3 (occurrence-count (car gensyms))))
+                `(or ,e ,@xs)
+                (failure)))
+           (('let ((v e)) ('case v clauses ...))
+            (=> failure)
+            (if (and (not (null? gensyms))
+                     ;; FIXME: This fails if any of the 'memv's were
+                     ;; optimized into multiple 'eqv?'s, because the
+                     ;; occurrence count will be higher than we expect.
+                     (= (occurrence-count (car gensyms))
+                        (1+ (length (clauses+tail clauses)))))
+                `(case ,e ,@clauses)
+                (failure)))
+           (e e)))
+
+        ((<letrec> in-order? gensyms vals body)
+         (build-letrec in-order?
+                       (map output-name gensyms)
+                       (map recurse vals)
+                       (recurse body)))
+
+        ((<fix> gensyms vals body)
+         ;; not a typo, we really do translate back to letrec. use letrec* since it
+         ;; doesn't matter, and the naive letrec* transformation does not require an
+         ;; inner let.
+         (build-letrec #t
+                       (map output-name gensyms)
+                       (map recurse vals)
+                       (recurse body)))
+
+        ((<let-values> exp body)
+         `(call-with-values (lambda () ,@(recurse-body exp))
+            ,(recurse (make-lambda #f '() body))))
+
+        ((<dynwind> body winder unwinder)
+         `(dynamic-wind ,(recurse winder)
+                        (lambda () ,@(recurse-body body))
+                        ,(recurse unwinder)))
+
+        ((<dynlet> fluids vals body)
+         `(with-fluids ,(map list
+                             (map recurse fluids)
+                             (map recurse vals))
+            ,@(recurse-body body)))
+
+        ((<dynref> fluid)
+         `(fluid-ref ,(recurse fluid)))
+
+        ((<dynset> fluid exp)
+         `(fluid-set! ,(recurse fluid) ,(recurse exp)))
+
+        ((<prompt> tag body handler)
+         `(call-with-prompt
+           ,(recurse tag)
+           (lambda () ,@(recurse-body body))
+           ,(recurse handler)))
+
+
+        ((<abort> tag args tail)
+         `(apply abort ,(recurse tag) ,@(map recurse args)
+                 ,(recurse tail)))))
+    (values (recurse e) env)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Algorithm for choosing better variable names
+;; ============================================
+;;
+;; First we perform an analysis pass, collecting the following
+;; information:
+;;
+;; * For each gensym: how many occurrences will occur in the output?
+;;
+;; * For each gensym A: which gensyms does A conflict with?  Gensym A
+;;   and gensym B conflict if they have the same base name (usually the
+;;   same as the source name, but see below), and if giving them the
+;;   same name would cause a bad variable reference due to unintentional
+;;   variable capture.
+;;
+;; The occurrence counter is indexed by gensym and is global (within each
+;; invocation of the algorithm), implemented using a hash table.  We also
+;; keep a global mapping from gensym to source name as provided by the
+;; binding construct (we prefer not to trust the source names in the
+;; lexical ref or set).
+;;
+;; As we recurse down into lexical binding forms, we keep track of a
+;; mapping from base name to an ordered list of bindings, innermost
+;; first.  When we encounter a variable occurrence, we increment the
+;; counter, look up the base name (preferring not to trust the 'name' in
+;; the lexical ref or set), and then look up the bindings currently in
+;; effect for that base name.  Hopefully our gensym will be the first
+;; (innermost) binding.  If not, we register a conflict between the
+;; referenced gensym and the other bound gensyms with the same base name
+;; that shadow the binding we want.  These are simply the gensyms on the
+;; binding list that come before our gensym.
+;;
+;; Top-level bindings are treated specially.  Whenever top-level
+;; references are found, they conflict with every lexical binding
+;; currently in effect with the same base name.  They are guaranteed to
+;; be assigned to their source names.  For purposes of recording
+;; conflicts (which are normally keyed on gensyms) top-level identifiers
+;; are assigned a pseudo-gensym that is an interned pair of the form
+;; (top-level . <name>).  This allows them to be compared using 'eq?'
+;; like other gensyms.
+;;
+;; The base name is normally just the source name.  However, if the
+;; source name has a suffix of the form "-N" (where N is a positive
+;; integer without leading zeroes), then we strip that suffix (multiple
+;; times if necessary) to form the base name.  We must do this because
+;; we add suffixes of that form in order to resolve conflicts, and we
+;; must ensure that only identifiers with the same base name can
+;; possibly conflict with each other.
+;;
+;; XXX FIXME: Currently, primitives are treated exactly like top-level
+;; bindings.  This handles conflicting lexical bindings properly, but
+;; does _not_ handle the case where top-level bindings conflict with the
+;; needed primitives.
+;;
+;; Also note that this requires that 'choose-output-names' be kept in
+;; sync with 'tree-il->scheme'.  Primitives that are introduced by
+;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
+;;
+;; We also ensure that lexically-bound identifiers found in operator
+;; position will never be assigned one of the standard primitive names.
+;; This is needed because 'tree-il->scheme' recognizes primitive names
+;; in operator position and assumes that they have the standard
+;; bindings.
+;;
+;;
+;; How we assign an output name to each gensym
+;; ===========================================
+;;
+;; We process the gensyms in order of decreasing occurrence count, with
+;; each gensym choosing the best output name possible, as long as it
+;; isn't the same name as any of the previously-chosen output names of
+;; conflicting gensyms.
+;;
+
+
+;;
+;; 'choose-output-names' analyzes the top-level form e, chooses good
+;; variable names that are as close as possible to the source names,
+;; and returns two values:
+;;
+;;  * a hash table mapping gensym to output name
+;;  * a hash table mapping gensym to number of occurrences
+;;
+(define choose-output-names
+  (let ()
+    (define primitive?
+      ;; This is a list of primitives that 'tree-il->scheme' assumes
+      ;; will have the standard bindings when found in operator
+      ;; position.
+      (let* ((primitives '(if quote @ @@ set! define define*
+                              begin let let* letrec letrec*
+                              and or cond case
+                              lambda lambda* case-lambda case-lambda*
+                              apply call-with-values dynamic-wind
+                              with-fluids fluid-ref fluid-set!
+                              call-with-prompt abort memv eqv?))
+             (table (make-hash-table (length primitives))))
+        (for-each (cut hashq-set! table <> #t) primitives)
+        (lambda (name) (hashq-ref table name))))
+
+    ;; Repeatedly strip suffix of the form "-N", where N is a string
+    ;; that could be produced by number->string given a positive
+    ;; integer.  In other words, the first digit of N may not be 0.
+    (define compute-base-name
+      (let ((digits (string->char-set "0123456789")))
+        (define (base-name-string str)
+          (let ((i (string-skip-right str digits)))
+            (if (and i (< (1+ i) (string-length str))
+                     (eq? #\- (string-ref str i))
+                     (not (eq? #\0 (string-ref str (1+ i)))))
+                (base-name-string (substring str 0 i))
+                str)))
+        (lambda (sym)
+          (string->symbol (base-name-string (symbol->string sym))))))
+
+    ;; choose-output-names
+    (lambda (e use-derived-syntax? strip-numeric-suffixes?)
+
+      (define lexical-gensyms '())
+
+      (define top-level-intern!
+        (let ((table (make-hash-table)))
+          (lambda (name)
+            (let ((h (hashq-create-handle! table name #f)))
+              (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
+                                 (cdr h)))))))
+      (define (top-level? s) (pair? s))
+      (define (top-level-name s) (cdr s))
+
+      (define occurrence-count-table (make-hash-table))
+      (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
+      (define (increment-occurrence-count! s)
+        (let ((h (hashq-create-handle! occurrence-count-table s 0)))
+          (if (zero? (cdr h))
+              (set! lexical-gensyms (cons s lexical-gensyms)))
+          (set-cdr! h (1+ (cdr h)))))
+
+      (define base-name
+        (let ((table (make-hash-table)))
+          (lambda (name)
+            (let ((h (hashq-create-handle! table name #f)))
+              (or (cdr h) (begin (set-cdr! h (compute-base-name name))
+                                 (cdr h)))))))
+
+      (define source-name-table (make-hash-table))
+      (define (set-source-name! s name)
+        (if (not (top-level? s))
+            (let ((name (if strip-numeric-suffixes?
+                            (base-name name)
+                            name)))
+              (hashq-set! source-name-table s name))))
+      (define (source-name s)
+        (if (top-level? s)
+            (top-level-name s)
+            (hashq-ref source-name-table s)))
+
+      (define conflict-table (make-hash-table))
+      (define (conflicts s) (or (hashq-ref conflict-table s) '()))
+      (define (add-conflict! a b)
+        (define (add! a b)
+          (if (not (top-level? a))
+              (let ((h (hashq-create-handle! conflict-table a '())))
+                (if (not (memq b (cdr h)))
+                    (set-cdr! h (cons b (cdr h)))))))
+        (add! a b)
+        (add! b a))
+
+      (let recurse-with-bindings ((e e) (bindings vlist-null))
+        (let recurse ((e e))
+
+          ;; We call this whenever we encounter a top-level ref or set
+          (define (top-level name)
+            (let ((bname (base-name name)))
+              (let ((s (top-level-intern! name))
+                    (conflicts (vhash-foldq* cons '() bname bindings)))
+                (for-each (cut add-conflict! s <>) conflicts))))
+
+          ;; We call this whenever we encounter a primitive reference.
+          ;; We must also call it for every primitive that might be
+          ;; inserted by 'tree-il->scheme'.  It is okay to call this
+          ;; even when 'tree-il->scheme' will not insert the named
+          ;; primitive; the worst that will happen is for a lexical
+          ;; variable of the same name to be renamed unnecessarily.
+          (define (primitive name) (top-level name))
+
+          ;; We call this whenever we encounter a lexical ref or set.
+          (define (lexical s)
+            (increment-occurrence-count! s)
+            (let ((conflicts
+                   (take-while
+                    (lambda (s*) (not (eq? s s*)))
+                    (reverse! (vhash-foldq* cons
+                                            '()
+                                            (base-name (source-name s))
+                                            bindings)))))
+              (for-each (cut add-conflict! s <>) conflicts)))
+
+          (record-case e
+            ((<void>)  (primitive 'if)) ; (if #f #f)
+            ((<const>) (primitive 'quote))
+
+            ((<application> proc args)
+             (if (lexical-ref? proc)
+                 (let* ((gensym (lexical-ref-gensym proc))
+                        (name (source-name gensym)))
+                   ;; If the operator position contains a bare variable
+                   ;; reference with the same source name as a standard
+                   ;; primitive, we must ensure that it will be given a
+                   ;; different name, so that 'tree-il->scheme' will not
+                   ;; misinterpret the resulting expression.
+                   (if (primitive? name)
+                       (add-conflict! gensym (top-level-intern! name)))))
+             (recurse proc)
+             (for-each recurse args))
+
+            ((<primitive-ref> name) (primitive name))
+
+            ((<lexical-ref> gensym) (lexical gensym))
+            ((<lexical-set> gensym exp)
+             (primitive 'set!) (lexical gensym) (recurse exp))
+
+            ((<module-ref> public?) (primitive (if public? '@ '@@)))
+            ((<module-set> public? exp)
+             (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
+
+            ((<toplevel-ref> name) (top-level name))
+            ((<toplevel-set> name exp)
+             (primitive 'set!) (top-level name) (recurse exp))
+            ((<toplevel-define> name exp) (top-level name) (recurse exp))
+
+            ((<conditional> test consequent alternate)
+             (cond (use-derived-syntax?
+                    (primitive 'and) (primitive 'or)
+                    (primitive 'cond) (primitive 'case)
+                    (primitive 'else) (primitive '=>)))
+             (primitive 'if)
+             (recurse test) (recurse consequent) (recurse alternate))
+
+            ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+            ((<lambda> body)
+             (if body (recurse body) (primitive 'case-lambda)))
+
+            ((<lambda-case> req opt rest kw inits gensyms body alternate)
+             (primitive 'lambda)
+             (cond ((or opt kw alternate)
+                    (primitive 'lambda*)
+                    (primitive 'case-lambda)
+                    (primitive 'case-lambda*)))
+             (primitive 'let)
+             (if use-derived-syntax? (primitive 'let*))
+             (let* ((names (append req (or opt '()) (if rest (list rest) '())
+                                   (map cadr (if kw (cdr kw) '()))))
+                    (base-names (map base-name names))
+                    (body-bindings
+                     (fold vhash-consq bindings base-names gensyms)))
+               (for-each increment-occurrence-count! gensyms)
+               (for-each set-source-name! gensyms names)
+               (for-each recurse inits)
+               (recurse-with-bindings body body-bindings)
+               (if alternate (recurse alternate))))
+
+            ((<let> names gensyms vals body)
+             (primitive 'let)
+             (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+             (for-each increment-occurrence-count! gensyms)
+             (for-each set-source-name! gensyms names)
+             (for-each recurse vals)
+             (recurse-with-bindings
+              body (fold vhash-consq bindings (map base-name names) gensyms)))
+
+            ((<letrec> in-order? names gensyms vals body)
+             (primitive 'let)
+             (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+             (primitive (if in-order? 'letrec* 'letrec))
+             (for-each increment-occurrence-count! gensyms)
+             (for-each set-source-name! gensyms names)
+             (let* ((base-names (map base-name names))
+                    (bindings (fold vhash-consq bindings base-names gensyms)))
+               (for-each (cut recurse-with-bindings <> bindings) vals)
+               (recurse-with-bindings body bindings)))
+
+            ((<fix> names gensyms vals body)
+             (primitive 'let)
+             (primitive 'letrec*)
+             (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+             (for-each increment-occurrence-count! gensyms)
+             (for-each set-source-name! gensyms names)
+             (let* ((base-names (map base-name names))
+                    (bindings (fold vhash-consq bindings base-names gensyms)))
+               (for-each (cut recurse-with-bindings <> bindings) vals)
+               (recurse-with-bindings body bindings)))
+
+            ((<let-values> exp body)
+             (primitive 'call-with-values)
+             (recurse exp) (recurse body))
+
+            ((<dynwind> winder body unwinder)
+             (primitive 'dynamic-wind)
+             (recurse winder) (recurse body) (recurse unwinder))
+
+            ((<dynlet> fluids vals body)
+             (primitive 'with-fluids)
+             (for-each recurse fluids)
+             (for-each recurse vals)
+             (recurse body))
+
+            ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
+            ((<dynset> fluid exp)
+             (primitive 'fluid-set!) (recurse fluid) (recurse exp))
+
+            ((<prompt> tag body handler)
+             (primitive 'call-with-prompt)
+             (primitive 'lambda)
+             (recurse tag) (recurse body) (recurse handler))
+
+            ((<abort> tag args tail)
+             (primitive 'apply)
+             (primitive 'abort)
+             (recurse tag) (for-each recurse args) (recurse tail)))))
+
+      (let ()
+        (define output-name-table (make-hash-table))
+        (define (set-output-name! s name)
+          (hashq-set! output-name-table s name))
+        (define (output-name s)
+          (if (top-level? s)
+              (top-level-name s)
+              (hashq-ref output-name-table s)))
+
+        (define sorted-lexical-gensyms
+          (sort-list lexical-gensyms
+                     (lambda (a b) (> (occurrence-count a)
+                                      (occurrence-count b)))))
+
+        (for-each (lambda (s)
+                    (set-output-name!
+                     s
+                     (let ((the-conflicts (conflicts s))
+                           (the-source-name (source-name s)))
+                       (define (not-yet-taken? name)
+                         (not (any (lambda (s*)
+                                     (and=> (output-name s*)
+                                            (cut eq? name <>)))
+                                   the-conflicts)))
+                       (if (not-yet-taken? the-source-name)
+                           the-source-name
+                           (let ((prefix (string-append
+                                          (symbol->string the-source-name)
+                                          "-")))
+                             (let loop ((i 1) (name the-source-name))
+                               (if (not-yet-taken? name)
+                                   name
+                                   (loop (+ i 1)
+                                         (string->symbol
+                                          (string-append
+                                           prefix
+                                           (number->string i)))))))))))
+                  sorted-lexical-gensyms)
+        (values output-name-table occurrence-count-table)))))
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code:
+
+(define-module (language scheme spec)
+  #\use-module (system base compile)
+  #\use-module (system base language)
+  #\use-module (language scheme compile-tree-il)
+  #\use-module (language scheme decompile-tree-il)
+  #\export (scheme))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language scheme
+  #\title	"Scheme"
+  #\reader      (lambda (port env)
+                  ;; Use the binding of current-reader from the environment.
+                  ;; FIXME: Handle `read-options' as well?
+                  ((or (and=> (and=> (module-variable env 'current-reader)
+                                     variable-ref)
+                              fluid-ref)
+                       read)
+                   port))
+
+  #\compilers   `((tree-il . ,compile-tree-il))
+  #\decompilers `((tree-il . ,decompile-tree-il))
+  #\evaluator	(lambda (x module) (primitive-eval x))
+  #\printer	write
+  #\make-default-environment
+                (lambda ()
+                  ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+                  ;; `fluid-set!', etc. don't have any effect in the current environment.
+                  (let ((m (make-fresh-user-module)))
+                    ;; Provide a separate `current-reader' fluid so that
+                    ;; compile-time changes to `current-reader' are
+                    ;; limited to the current compilation unit.
+                    (module-define! m 'current-reader (make-fluid))
+
+                    ;; Default to `simple-format', as is the case until
+                    ;; (ice-9 format) is loaded.  This allows
+                    ;; compile-time warnings to be emitted when using
+                    ;; unsupported options.
+                    (module-set! m 'format simple-format)
+
+                    m)))
+;;;; 	Copyright (C) 2009, 2010, 2011, 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 (language tree-il)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-11)
+  #\use-module (system base pmatch)
+  #\use-module (system base syntax)
+  #\export (tree-il-src
+
+            <void> void? make-void void-src
+            <const> const? make-const const-src const-exp
+            <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
+            <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
+            <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
+            <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
+            <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
+            <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
+            <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
+            <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
+            <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
+            <application> application? make-application application-src application-proc application-args
+            <sequence> sequence? make-sequence sequence-src sequence-exps
+            <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
+            <lambda-case> lambda-case? make-lambda-case lambda-case-src
+                          lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
+                          lambda-case-inits lambda-case-gensyms
+                          lambda-case-body lambda-case-alternate
+            <let> let? make-let let-src let-names let-gensyms let-vals let-body
+            <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
+            <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
+            <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
+            <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
+            <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
+            <dynref> dynref? make-dynref dynref-src dynref-fluid
+            <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
+            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
+            <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+
+            parse-tree-il
+            unparse-tree-il
+            tree-il->scheme
+
+            tree-il-fold
+            make-tree-il-folder
+            post-order!
+            pre-order!
+
+            tree-il=?
+            tree-il-hash))
+
+(define (print-tree-il exp port)
+  (format port "#<tree-il ~S>" (unparse-tree-il exp)))
+
+(define-syntax borrow-core-vtables
+  (lambda (x)
+    (syntax-case x ()
+      ((_)
+       (let lp ((n 0) (out '()))
+         (if (< n (vector-length %expanded-vtables))
+             (lp (1+ n)
+                 (let* ((vtable (vector-ref %expanded-vtables n))
+                        (stem (struct-ref vtable (+ vtable-offset-user 0)))
+                        (fields (struct-ref vtable (+ vtable-offset-user 2)))
+                        (sfields (map
+                                  (lambda (f) (datum->syntax x f))
+                                  fields))
+                        (type (datum->syntax x (symbol-append '< stem '>)))
+                        (ctor (datum->syntax x (symbol-append 'make- stem)))
+                        (pred (datum->syntax x (symbol-append stem '?))))
+                   (let lp ((n 0) (fields fields)
+                            (out (cons*
+                                  #`(define (#,ctor #,@sfields)
+                                      (make-struct #,type 0 #,@sfields))
+                                  #`(define (#,pred x)
+                                      (and (struct? x)
+                                           (eq? (struct-vtable x) #,type)))
+                                  #`(struct-set! #,type vtable-index-printer
+                                                 print-tree-il)
+                                  #`(define #,type
+                                           (vector-ref %expanded-vtables #,n))
+                                       out)))
+                     (if (null? fields)
+                         out
+                         (lp (1+ n)
+                             (cdr fields)
+                             (let ((acc (datum->syntax
+                                         x (symbol-append stem '- (car fields)))))
+                               (cons #`(define #,acc
+                                         (make-procedure-with-setter
+                                          (lambda (x) (struct-ref x #,n))
+                                          (lambda (x v) (struct-set! x #,n v))))
+                                     out)))))))
+             #`(begin #,@(reverse out))))))))
+
+(borrow-core-vtables)
+
+  ;; (<void>)
+  ;; (<const> exp)
+  ;; (<primitive-ref> name)
+  ;; (<lexical-ref> name gensym)
+  ;; (<lexical-set> name gensym exp)
+  ;; (<module-ref> mod name public?)
+  ;; (<module-set> mod name public? exp)
+  ;; (<toplevel-ref> name)
+  ;; (<toplevel-set> name exp)
+  ;; (<toplevel-define> name exp)
+  ;; (<conditional> test consequent alternate)
+  ;; (<application> proc args)
+  ;; (<sequence> exps)
+  ;; (<lambda> meta body)
+  ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
+  ;; (<let> names gensyms vals body)
+  ;; (<letrec> in-order? names gensyms vals body)
+  ;; (<dynlet> fluids vals body)
+
+(define-type (<tree-il> #\common-slots (src) #\printer print-tree-il)
+  (<fix> names gensyms vals body)
+  (<let-values> exp body)
+  (<dynwind> winder body unwinder)
+  (<dynref> fluid)
+  (<dynset> fluid exp)
+  (<prompt> tag body handler)
+  (<abort> tag args tail))
+
+
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (pair? props) props))))
+
+(define (parse-tree-il exp)
+  (let ((loc (location exp))
+        (retrans (lambda (x) (parse-tree-il x))))
+    (pmatch exp
+     ((void)
+      (make-void loc))
+
+     ((apply ,proc . ,args)
+      (make-application loc (retrans proc) (map retrans args)))
+
+     ((if ,test ,consequent ,alternate)
+      (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
+
+     ((primitive ,name) (guard (symbol? name))
+      (make-primitive-ref loc name))
+
+     ((lexical ,name) (guard (symbol? name))
+      (make-lexical-ref loc name name))
+
+     ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+      (make-lexical-ref loc name sym))
+
+     ((set! (lexical ,name) ,exp) (guard (symbol? name))
+      (make-lexical-set loc name name (retrans exp)))
+
+     ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+      (make-lexical-set loc name sym (retrans exp)))
+
+     ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-ref loc mod name #t))
+
+     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-set loc mod name #t (retrans exp)))
+
+     ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-ref loc mod name #f))
+
+     ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-set loc mod name #f (retrans exp)))
+
+     ((toplevel ,name) (guard (symbol? name))
+      (make-toplevel-ref loc name))
+
+     ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+      (make-toplevel-set loc name (retrans exp)))
+
+     ((define ,name ,exp) (guard (symbol? name))
+      (make-toplevel-define loc name (retrans exp)))
+
+     ((lambda ,meta ,body)
+      (make-lambda loc meta (retrans body)))
+
+     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
+      (make-lambda-case loc req opt rest kw
+                        (map retrans inits) gensyms
+                        (retrans body)
+                        (and=> alternate retrans)))
+
+     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
+      (make-lambda-case loc req opt rest kw
+                        (map retrans inits) gensyms
+                        (retrans body)
+                        #f))
+
+     ((const ,exp)
+      (make-const loc exp))
+
+     ((begin . ,exps)
+      (make-sequence loc (map retrans exps)))
+
+     ((let ,names ,gensyms ,vals ,body)
+      (make-let loc names gensyms (map retrans vals) (retrans body)))
+
+     ((letrec ,names ,gensyms ,vals ,body)
+      (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
+
+     ((letrec* ,names ,gensyms ,vals ,body)
+      (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
+
+     ((fix ,names ,gensyms ,vals ,body)
+      (make-fix loc names gensyms (map retrans vals) (retrans body)))
+
+     ((let-values ,exp ,body)
+      (make-let-values loc (retrans exp) (retrans body)))
+
+     ((dynwind ,winder ,body ,unwinder)
+      (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+
+     ((dynlet ,fluids ,vals ,body)
+      (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
+
+     ((dynref ,fluid)
+      (make-dynref loc (retrans fluid)))
+
+     ((dynset ,fluid ,exp)
+      (make-dynset loc (retrans fluid) (retrans exp)))
+
+     ((prompt ,tag ,body ,handler)
+      (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
+
+     ((abort ,tag ,args ,tail)
+      (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
+
+     (else
+      (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+  (record-case tree-il
+    ((<void>)
+     '(void))
+
+    ((<application> proc args)
+     `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+    ((<conditional> test consequent alternate)
+     `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
+
+    ((<primitive-ref> name)
+     `(primitive ,name))
+
+    ((<lexical-ref> name gensym)
+     `(lexical ,name ,gensym))
+
+    ((<lexical-set> name gensym exp)
+     `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+    ((<module-ref> mod name public?)
+     `(,(if public? '@ '@@) ,mod ,name))
+
+    ((<module-set> mod name public? exp)
+     `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+    ((<toplevel-ref> name)
+     `(toplevel ,name))
+
+    ((<toplevel-set> name exp)
+     `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+    ((<toplevel-define> name exp)
+     `(define ,name ,(unparse-tree-il exp)))
+
+    ((<lambda> meta body)
+     (if body
+         `(lambda ,meta ,(unparse-tree-il body))
+         `(lambda ,meta (lambda-case))))
+
+    ((<lambda-case> req opt rest kw inits gensyms body alternate)
+     `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
+                    ,(unparse-tree-il body))
+                   . ,(if alternate (list (unparse-tree-il alternate)) '())))
+
+    ((<const> exp)
+     `(const ,exp))
+
+    ((<sequence> exps)
+     `(begin ,@(map unparse-tree-il exps)))
+
+    ((<let> names gensyms vals body)
+     `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+    ((<letrec> in-order? names gensyms vals body)
+     `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
+       ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+    ((<fix> names gensyms vals body)
+     `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+    ((<let-values> exp body)
+     `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
+
+    ((<dynwind> winder body unwinder)
+     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
+               ,(unparse-tree-il unwinder)))
+
+    ((<dynlet> fluids vals body)
+     `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
+              ,(unparse-tree-il body)))
+
+    ((<dynref> fluid)
+     `(dynref ,(unparse-tree-il fluid)))
+
+    ((<dynset> fluid exp)
+     `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
+
+    ((<prompt> tag body handler)
+     `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
+
+    ((<abort> tag args tail)
+     `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
+             ,(unparse-tree-il tail)))))
+
+(define* (tree-il->scheme e #\optional (env #f) (opts '()))
+  (values ((@ (language scheme decompile-tree-il)
+              decompile-tree-il)
+           e env opts)))
+
+
+(define (tree-il-fold leaf down up seed tree)
+  "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
+into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
+invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
+and SEED is the current result, intially seeded with SEED.
+
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+  (let loop ((tree   tree)
+             (result seed))
+    (if (or (null? tree) (pair? tree))
+        (fold loop result tree)
+        (record-case tree
+          ((<lexical-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<module-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<toplevel-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<toplevel-define> exp)
+           (up tree (loop exp (down tree result))))
+          ((<conditional> test consequent alternate)
+           (up tree (loop alternate
+                          (loop consequent
+                                (loop test (down tree result))))))
+          ((<application> proc args)
+           (up tree (loop (cons proc args) (down tree result))))
+          ((<sequence> exps)
+           (up tree (loop exps (down tree result))))
+          ((<lambda> body)
+           (let ((result (down tree result)))
+             (up tree
+                 (if body
+                     (loop body result)
+                     result))))
+          ((<lambda-case> inits body alternate)
+           (up tree (if alternate
+                        (loop alternate
+                              (loop body (loop inits (down tree result))))
+                        (loop body (loop inits (down tree result))))))
+          ((<let> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<letrec> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<fix> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<let-values> exp body)
+           (up tree (loop body (loop exp (down tree result)))))
+          ((<dynwind> body winder unwinder)
+           (up tree (loop unwinder
+                          (loop winder
+                                (loop body (down tree result))))))
+          ((<dynlet> fluids vals body)
+           (up tree (loop body
+                          (loop vals
+                                (loop fluids (down tree result))))))
+          ((<dynref> fluid)
+           (up tree (loop fluid (down tree result))))
+          ((<dynset> fluid exp)
+           (up tree (loop exp (loop fluid (down tree result)))))
+          ((<prompt> tag body handler)
+           (up tree
+               (loop tag (loop body (loop handler
+                                          (down tree result))))))
+          ((<abort> tag args tail)
+           (up tree (loop tail (loop args (loop tag (down tree result))))))
+          (else
+           (leaf tree result))))))
+
+
+(define-syntax-rule (make-tree-il-folder seed ...)
+  (lambda (tree down up seed ...)
+    (define (fold-values proc exps seed ...)
+      (if (null? exps)
+          (values seed ...)
+          (let-values (((seed ...) (proc (car exps) seed ...)))
+            (fold-values proc (cdr exps) seed ...))))
+    (let foldts ((tree tree) (seed seed) ...)
+      (let*-values
+          (((seed ...) (down tree seed ...))
+           ((seed ...)
+            (record-case tree
+              ((<lexical-set> exp)
+               (foldts exp seed ...))
+              ((<module-set> exp)
+               (foldts exp seed ...))
+              ((<toplevel-set> exp)
+               (foldts exp seed ...))
+              ((<toplevel-define> exp)
+               (foldts exp seed ...))
+              ((<conditional> test consequent alternate)
+               (let*-values (((seed ...) (foldts test seed ...))
+                             ((seed ...) (foldts consequent seed ...)))
+                 (foldts alternate seed ...)))
+              ((<application> proc args)
+               (let-values (((seed ...) (foldts proc seed ...)))
+                 (fold-values foldts args seed ...)))
+              ((<sequence> exps)
+               (fold-values foldts exps seed ...))
+              ((<lambda> body)
+               (if body
+                   (foldts body seed ...)
+                   (values seed ...)))
+              ((<lambda-case> inits body alternate)
+               (let-values (((seed ...) (fold-values foldts inits seed ...)))
+                 (if alternate
+                     (let-values (((seed ...) (foldts body seed ...)))
+                       (foldts alternate seed ...))
+                     (foldts body seed ...))))
+              ((<let> vals body)
+               (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<letrec> vals body)
+               (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<fix> vals body)
+               (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<let-values> exp body)
+               (let*-values (((seed ...) (foldts exp seed ...)))
+                 (foldts body seed ...)))
+              ((<dynwind> body winder unwinder)
+               (let*-values (((seed ...) (foldts body seed ...))
+                             ((seed ...) (foldts winder seed ...)))
+                 (foldts unwinder seed ...)))
+              ((<dynlet> fluids vals body)
+               (let*-values (((seed ...) (fold-values foldts fluids seed ...))
+                             ((seed ...) (fold-values foldts vals seed ...)))
+                 (foldts body seed ...)))
+              ((<dynref> fluid)
+               (foldts fluid seed ...))
+              ((<dynset> fluid exp)
+               (let*-values (((seed ...) (foldts fluid seed ...)))
+                 (foldts exp seed ...)))
+              ((<prompt> tag body handler)
+               (let*-values (((seed ...) (foldts tag seed ...))
+                             ((seed ...) (foldts body seed ...)))
+                 (foldts handler seed ...)))
+              ((<abort> tag args tail)
+               (let*-values (((seed ...) (foldts tag seed ...))
+                             ((seed ...) (fold-values foldts args seed ...)))
+                 (foldts tail seed ...)))
+              (else
+               (values seed ...)))))
+        (up tree seed ...)))))
+
+(define (post-order! f x)
+  (let lp ((x x))
+    (record-case x
+      ((<application> proc args)
+       (set! (application-proc x) (lp proc))
+       (set! (application-args x) (map lp args)))
+
+      ((<conditional> test consequent alternate)
+       (set! (conditional-test x) (lp test))
+       (set! (conditional-consequent x) (lp consequent))
+       (set! (conditional-alternate x) (lp alternate)))
+
+      ((<lexical-set> name gensym exp)
+       (set! (lexical-set-exp x) (lp exp)))
+
+      ((<module-set> mod name public? exp)
+       (set! (module-set-exp x) (lp exp)))
+
+      ((<toplevel-set> name exp)
+       (set! (toplevel-set-exp x) (lp exp)))
+
+      ((<toplevel-define> name exp)
+       (set! (toplevel-define-exp x) (lp exp)))
+
+      ((<lambda> body)
+       (if body
+           (set! (lambda-body x) (lp body))))
+
+      ((<lambda-case> inits body alternate)
+       (set! inits (map lp inits))
+       (set! (lambda-case-body x) (lp body))
+       (if alternate
+           (set! (lambda-case-alternate x) (lp alternate))))
+
+      ((<sequence> exps)
+       (set! (sequence-exps x) (map lp exps)))
+
+      ((<let> gensyms vals body)
+       (set! (let-vals x) (map lp vals))
+       (set! (let-body x) (lp body)))
+
+      ((<letrec> gensyms vals body)
+       (set! (letrec-vals x) (map lp vals))
+       (set! (letrec-body x) (lp body)))
+
+      ((<fix> gensyms vals body)
+       (set! (fix-vals x) (map lp vals))
+       (set! (fix-body x) (lp body)))
+
+      ((<let-values> exp body)
+       (set! (let-values-exp x) (lp exp))
+       (set! (let-values-body x) (lp body)))
+
+      ((<dynwind> body winder unwinder)
+       (set! (dynwind-body x) (lp body))
+       (set! (dynwind-winder x) (lp winder))
+       (set! (dynwind-unwinder x) (lp unwinder)))
+
+      ((<dynlet> fluids vals body)
+       (set! (dynlet-fluids x) (map lp fluids))
+       (set! (dynlet-vals x) (map lp vals))
+       (set! (dynlet-body x) (lp body)))
+
+      ((<dynref> fluid)
+       (set! (dynref-fluid x) (lp fluid)))
+
+      ((<dynset> fluid exp)
+       (set! (dynset-fluid x) (lp fluid))
+       (set! (dynset-exp x) (lp exp)))
+
+      ((<prompt> tag body handler)
+       (set! (prompt-tag x) (lp tag))
+       (set! (prompt-body x) (lp body))
+       (set! (prompt-handler x) (lp handler)))
+
+      ((<abort> tag args tail)
+       (set! (abort-tag x) (lp tag))
+       (set! (abort-args x) (map lp args))
+       (set! (abort-tail x) (lp tail)))
+
+      (else #f))
+
+    (or (f x) x)))
+
+(define (pre-order! f x)
+  (let lp ((x x))
+    (let ((x (or (f x) x)))
+      (record-case x
+        ((<application> proc args)
+         (set! (application-proc x) (lp proc))
+         (set! (application-args x) (map lp args)))
+
+        ((<conditional> test consequent alternate)
+         (set! (conditional-test x) (lp test))
+         (set! (conditional-consequent x) (lp consequent))
+         (set! (conditional-alternate x) (lp alternate)))
+
+        ((<lexical-set> exp)
+         (set! (lexical-set-exp x) (lp exp)))
+
+        ((<module-set> exp)
+         (set! (module-set-exp x) (lp exp)))
+
+        ((<toplevel-set> exp)
+         (set! (toplevel-set-exp x) (lp exp)))
+
+        ((<toplevel-define> exp)
+         (set! (toplevel-define-exp x) (lp exp)))
+
+        ((<lambda> body)
+         (if body
+             (set! (lambda-body x) (lp body))))
+
+        ((<lambda-case> inits body alternate)
+         (set! inits (map lp inits))
+         (set! (lambda-case-body x) (lp body))
+         (if alternate (set! (lambda-case-alternate x) (lp alternate))))
+
+        ((<sequence> exps)
+         (set! (sequence-exps x) (map lp exps)))
+
+        ((<let> vals body)
+         (set! (let-vals x) (map lp vals))
+         (set! (let-body x) (lp body)))
+
+        ((<letrec> vals body)
+         (set! (letrec-vals x) (map lp vals))
+         (set! (letrec-body x) (lp body)))
+
+        ((<fix> vals body)
+         (set! (fix-vals x) (map lp vals))
+         (set! (fix-body x) (lp body)))
+
+        ((<let-values> exp body)
+         (set! (let-values-exp x) (lp exp))
+         (set! (let-values-body x) (lp body)))
+
+        ((<dynwind> body winder unwinder)
+         (set! (dynwind-body x) (lp body))
+         (set! (dynwind-winder x) (lp winder))
+         (set! (dynwind-unwinder x) (lp unwinder)))
+
+        ((<dynlet> fluids vals body)
+         (set! (dynlet-fluids x) (map lp fluids))
+         (set! (dynlet-vals x) (map lp vals))
+         (set! (dynlet-body x) (lp body)))
+
+        ((<dynref> fluid)
+         (set! (dynref-fluid x) (lp fluid)))
+
+        ((<dynset> fluid exp)
+         (set! (dynset-fluid x) (lp fluid))
+         (set! (dynset-exp x) (lp exp)))
+
+        ((<prompt> tag body handler)
+         (set! (prompt-tag x) (lp tag))
+         (set! (prompt-body x) (lp body))
+         (set! (prompt-handler x) (lp handler)))
+
+        ((<abort> tag args tail)
+         (set! (abort-tag x) (lp tag))
+         (set! (abort-args x) (map lp args))
+         (set! (abort-tail x) (lp tail)))
+
+        (else #f))
+      x)))
+
+;; FIXME: We should have a better primitive than this.
+(define (struct-nfields x)
+  (/ (string-length (symbol->string (struct-layout x))) 2))
+
+(define (tree-il=? a b)
+  (cond
+   ((struct? a)
+    (and (struct? b)
+         (eq? (struct-vtable a) (struct-vtable b))
+         ;; Assume that all structs are tree-il, so we skip over the
+         ;; src slot.
+         (let lp ((n (1- (struct-nfields a))))
+           (or (zero? n)
+               (and (tree-il=? (struct-ref a n) (struct-ref b n))
+                    (lp (1- n)))))))
+   ((pair? a)
+    (and (pair? b)
+         (tree-il=? (car a) (car b))
+         (tree-il=? (cdr a) (cdr b))))
+   (else
+    (equal? a b))))
+
+(define-syntax hash-bits
+  (make-variable-transformer
+   (lambda (x)
+     (syntax-case x ()
+       (var
+        (identifier? #'var)
+        (logcount most-positive-fixnum))))))
+
+(define (tree-il-hash exp)
+  (let ((hash-depth 4)
+        (hash-width 3))
+    (define (hash-exp exp depth)
+      (define (rotate x bits)
+        (logior (ash x (- bits))
+                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+      (define (mix h1 h2)
+        (logxor h1 (rotate h2 8)))
+      (define (hash-struct s)
+        (let ((len (struct-nfields s))
+              (h (hashq (struct-vtable s) most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((i (max (- len hash-width) 1)) (h h))
+                (if (< i len)
+                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+                    h)))))
+      (define (hash-list l)
+        (let ((h (hashq 'list most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((l l) (width 0) (h h))
+                (if (< width hash-width)
+                    (lp (cdr l) (1+ width)
+                        (mix (hash-exp (car l) (1+ depth)) h))
+                    h)))))
+      (cond
+       ((struct? exp) (hash-struct exp))
+       ((list? exp) (hash-list exp))
+       (else (hash exp most-positive-fixnum))))
+
+    (hash-exp exp 0)))
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 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
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\use-module (ice-9 vlist)
+  #\use-module (ice-9 match)
+  #\use-module (system base syntax)
+  #\use-module (system base message)
+  #\use-module (system vm program)
+  #\use-module (language tree-il)
+  #\use-module (system base pmatch)
+  #\export (analyze-lexicals
+            analyze-tree
+            unused-variable-analysis
+            unused-toplevel-analysis
+            unbound-variable-analysis
+            arity-analysis
+            format-analysis))
+
+;; Allocation is the process of assigning storage locations for lexical
+;; variables. A lexical variable has a distinct "address", or storage
+;; location, for each procedure in which it is referenced.
+;;
+;; A variable is "local", i.e., allocated on the stack, if it is
+;; referenced from within the procedure that defined it. Otherwise it is
+;; a "closure" variable. For example:
+;;
+;;    (lambda (a) a) ; a will be local
+;; `a' is local to the procedure.
+;;
+;;    (lambda (a) (lambda () a))
+;; `a' is local to the outer procedure, but a closure variable with
+;; respect to the inner procedure.
+;;
+;; If a variable is ever assigned, it needs to be heap-allocated
+;; ("boxed"). This is so that closures and continuations capture the
+;; variable's identity, not just one of the values it may have over the
+;; course of program execution. If the variable is never assigned, there
+;; is no distinction between value and identity, so closing over its
+;; identity (whether through closures or continuations) can make a copy
+;; of its value instead.
+;;
+;; Local variables are stored on the stack within a procedure's call
+;; frame. Their index into the stack is determined from their linear
+;; postion within a procedure's binding path:
+;; (let (0 1)
+;;   (let (2 3) ...)
+;;   (let (2) ...))
+;;   (let (2 3 4) ...))
+;; etc.
+;;
+;; This algorithm has the problem that variables are only allocated
+;; indices at the end of the binding path. If variables bound early in
+;; the path are not used in later portions of the path, their indices
+;; will not be recycled. This problem is particularly egregious in the
+;; expansion of `or':
+;;
+;;  (or x y z)
+;;    -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
+;;
+;; As you can see, the `a' binding is only used in the ephemeral
+;; `consequent' clause of the first `if', but its index would be
+;; reserved for the whole of the `or' expansion. So we have a hack for
+;; this specific case. A proper solution would be some sort of liveness
+;; analysis, and not our linear allocation algorithm.
+;;
+;; Closure variables are captured when a closure is created, and stored in a
+;; vector inline to the closure object itself. Each closure variable has a
+;; unique index into that vector.
+;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;;  (letrec ((lp (lambda () (lp)))) (lp))
+;;    => (fix ((lp (lambda () (lp)))) (lp))
+;;      => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;;         ^ jump over the loop  ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
+;;
+;; The return value of `analyze-lexicals' is a hash table, the
+;; "allocation".
+;;
+;; The allocation maps gensyms -- recall that each lexically bound
+;; variable has a unique gensym -- to storage locations ("addresses").
+;; Since one gensym may have many storage locations, if it is referenced
+;; in many procedures, it is a two-level map.
+;;
+;; The allocation also stored information on how many local variables
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
+;;
+;; In addition, we have a conflation: while we're traversing the code,
+;; recording information to pass to the compiler, we take the
+;; opportunity to generate labels for each lambda-case clause, so that
+;; generated code can skip argument checks at runtime if they match at
+;; compile-time.
+;;
+;; Also, while we're a-traversing and an-allocating, we check prompt
+;; handlers to see if the "continuation" argument is used. If not, we
+;; mark the prompt as being "escape-only". This allows us to implement
+;; `catch' and `throw' using `prompt' and `control', but without causing
+;; a continuation to be reified. Heh heh.
+;;
+;; That is:
+;;
+;;  sym -> {lambda -> address}
+;;  lambda -> (labels . free-locs)
+;;  lambda-case -> (gensym . nlocs)
+;;  prompt -> escape-only?
+;;
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define (make-hashq k v)
+  (let ((res (make-hash-table)))
+    (hashq-set! res k v)
+    res))
+
+(define (analyze-lexicals x)
+  ;; bound-vars: lambda -> (sym ...)
+  ;;  all identifiers bound within a lambda
+  (define bound-vars (make-hash-table))
+  ;; free-vars: lambda -> (sym ...)
+  ;;  all identifiers referenced in a lambda, but not bound
+  ;;  NB, this includes identifiers referenced by contained lambdas
+  (define free-vars (make-hash-table))
+  ;; assigned: sym -> #t
+  ;;  variables that are assigned
+  (define assigned (make-hash-table))
+  ;; refcounts: sym -> count
+  ;;  allows us to detect the or-expansion in O(1) time
+  (define refcounts (make-hash-table))
+  ;; labels: sym -> lambda
+  ;;  for determining if fixed-point procedures can be rendered as
+  ;;  labels.
+  (define labels (make-hash-table))
+
+  ;; returns variables referenced in expr
+  (define (analyze! x proc labels-in-proc tail? tail-call-args)
+    (define (step y) (analyze! y proc '() #f #f))
+    (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+    (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+                                              (and tail? args)))
+    (define (recur/labels x new-proc labels)
+      (analyze! x new-proc (append labels labels-in-proc) #t #f))
+    (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
+    (record-case x
+      ((<application> proc args)
+       (apply lset-union eq? (step-tail-call proc args)
+              (map step args)))
+
+      ((<conditional> test consequent alternate)
+       (lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
+
+      ((<lexical-ref> gensym)
+       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+       (if (not (and tail-call-args
+                     (memq gensym labels-in-proc)
+                     (let ((p (hashq-ref labels gensym)))
+                       (and p
+                            (let lp ((c (lambda-body p)))
+                              (and c (lambda-case? c)
+                                   (or 
+                                    ;; for now prohibit optional &
+                                    ;; keyword arguments; can relax this
+                                    ;; restriction later
+                                    (and (= (length (lambda-case-req c))
+                                            (length tail-call-args))
+                                         (not (lambda-case-opt c))
+                                         (not (lambda-case-kw c))
+                                         (not (lambda-case-rest c)))
+                                    (lp (lambda-case-alternate c)))))))))
+           (hashq-set! labels gensym #f))
+       (list gensym))
+      
+      ((<lexical-set> gensym exp)
+       (hashq-set! assigned gensym #t)
+       (hashq-set! labels gensym #f)
+       (lset-adjoin eq? (step exp) gensym))
+      
+      ((<module-set> exp)
+       (step exp))
+      
+      ((<toplevel-set> exp)
+       (step exp))
+      
+      ((<toplevel-define> exp)
+       (step exp))
+      
+      ((<sequence> exps)
+       (let lp ((exps exps) (ret '()))
+         (cond ((null? exps) '())
+               ((null? (cdr exps))
+                (lset-union eq? ret (step-tail (car exps))))
+               (else
+                (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+      
+      ((<lambda> body)
+       ;; order is important here
+       (hashq-set! bound-vars x '())
+       (let ((free (recur body x)))
+         (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+         (hashq-set! free-vars x free)
+         free))
+      
+      ((<lambda-case> opt kw inits gensyms body alternate)
+       (hashq-set! bound-vars proc
+                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
+       (lset-union
+        eq?
+        (lset-difference eq?
+                         (lset-union eq?
+                                     (apply lset-union eq? (map step inits))
+                                     (step-tail body))
+                         gensyms)
+        (if alternate (step-tail alternate) '())))
+      
+      ((<let> gensyms vals body)
+       (hashq-set! bound-vars proc
+                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
+       (lset-difference eq?
+                        (apply lset-union eq? (step-tail body) (map step vals))
+                        gensyms))
+      
+      ((<letrec> gensyms vals body)
+       (hashq-set! bound-vars proc
+                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
+       (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
+       (lset-difference eq?
+                        (apply lset-union eq? (step-tail body) (map step vals))
+                        gensyms))
+      
+      ((<fix> gensyms vals body)
+       ;; Try to allocate these procedures as labels.
+       (for-each (lambda (sym val) (hashq-set! labels sym val))
+                 gensyms vals)
+       (hashq-set! bound-vars proc
+                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
+       ;; Step into subexpressions.
+       (let* ((var-refs
+               (map
+                ;; Since we're trying to label-allocate the lambda,
+                ;; pretend it's not a closure, and just recurse into its
+                ;; body directly. (Otherwise, recursing on a closure
+                ;; that references one of the fix's bound vars would
+                ;; prevent label allocation.)
+                (lambda (x)
+                  (record-case x
+                    ((<lambda> body)
+                     ;; just like the closure case, except here we use
+                     ;; recur/labels instead of recur
+                     (hashq-set! bound-vars x '())
+                     (let ((free (recur/labels body x gensyms)))
+                       (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+                       (hashq-set! free-vars x free)
+                       free))))
+                vals))
+              (vars-with-refs (map cons gensyms var-refs))
+              (body-refs (recur/labels body proc gensyms)))
+         (define (delabel-dependents! sym)
+           (let ((refs (assq-ref vars-with-refs sym)))
+             (if refs
+                 (for-each (lambda (sym)
+                             (if (hashq-ref labels sym)
+                                 (begin
+                                   (hashq-set! labels sym #f)
+                                   (delabel-dependents! sym))))
+                           refs))))
+         ;; Stepping into the lambdas and the body might have made some
+         ;; procedures not label-allocatable -- which might have
+         ;; knock-on effects. For example:
+         ;;   (fix ((a (lambda () (b)))
+         ;;         (b (lambda () a)))
+         ;;     (a))
+         ;; As far as `a' is concerned, both `a' and `b' are
+         ;; label-allocatable. But `b' references `a' not in a proc-tail
+         ;; position, which makes `a' not label-allocatable. The
+         ;; knock-on effect is that, when back-propagating this
+         ;; information to `a', `b' will also become not
+         ;; label-allocatable, as it is referenced within `a', which is
+         ;; allocated as a closure. This is a transitive relationship.
+         (for-each (lambda (sym)
+                     (if (not (hashq-ref labels sym))
+                         (delabel-dependents! sym)))
+                   gensyms)
+         ;; Now lift bound variables with label-allocated lambdas to the
+         ;; parent procedure.
+         (for-each
+          (lambda (sym val)
+            (if (hashq-ref labels sym)
+                ;; Remove traces of the label-bound lambda. The free
+                ;; vars will propagate up via the return val.
+                (begin
+                  (hashq-set! bound-vars proc
+                              (append (hashq-ref bound-vars val)
+                                      (hashq-ref bound-vars proc)))
+                  (hashq-remove! bound-vars val)
+                  (hashq-remove! free-vars val))))
+          gensyms vals)
+         (lset-difference eq?
+                          (apply lset-union eq? body-refs var-refs)
+                          gensyms)))
+      
+      ((<let-values> exp body)
+       (lset-union eq? (step exp) (step body)))
+      
+      ((<dynwind> body winder unwinder)
+       (lset-union eq? (step body) (step winder) (step unwinder)))
+      
+      ((<dynlet> fluids vals body)
+       (apply lset-union eq? (step body) (map step (append fluids vals))))
+      
+      ((<dynref> fluid)
+       (step fluid))
+      
+      ((<dynset> fluid exp)
+       (lset-union eq? (step fluid) (step exp)))
+      
+      ((<prompt> tag body handler)
+       (lset-union eq? (step tag) (step body) (step-tail handler)))
+      
+      ((<abort> tag args tail)
+       (apply lset-union eq? (step tag) (step tail) (map step args)))
+      
+      (else '())))
+  
+  ;; allocation: sym -> {lambda -> address}
+  ;;             lambda -> (labels . free-locs)
+  ;;             lambda-case -> (gensym . nlocs)
+  (define allocation (make-hash-table))
+  
+  (define (allocate! x proc n)
+    (define (recur y) (allocate! y proc n))
+    (record-case x
+      ((<application> proc args)
+       (apply max (recur proc) (map recur args)))
+
+      ((<conditional> test consequent alternate)
+       (max (recur test) (recur consequent) (recur alternate)))
+
+      ((<lexical-set> exp)
+       (recur exp))
+      
+      ((<module-set> exp)
+       (recur exp))
+      
+      ((<toplevel-set> exp)
+       (recur exp))
+      
+      ((<toplevel-define> exp)
+       (recur exp))
+      
+      ((<sequence> exps)
+       (apply max (map recur exps)))
+      
+      ((<lambda> body)
+       ;; allocate closure vars in order
+       (let lp ((c (hashq-ref free-vars x)) (n 0))
+         (if (pair? c)
+             (begin
+               (hashq-set! (hashq-ref allocation (car c))
+                           x
+                           `(#f ,(hashq-ref assigned (car c)) . ,n))
+               (lp (cdr c) (1+ n)))))
+      
+       (let ((nlocs (allocate! body x 0))
+             (free-addresses
+              (map (lambda (v)
+                     (hashq-ref (hashq-ref allocation v) proc))
+                   (hashq-ref free-vars x)))
+             (labels (filter cdr
+                             (map (lambda (sym)
+                                    (cons sym (hashq-ref labels sym)))
+                                  (hashq-ref bound-vars x)))))
+         ;; set procedure allocations
+         (hashq-set! allocation x (cons labels free-addresses)))
+       n)
+
+      ((<lambda-case> opt kw inits gensyms body alternate)
+       (max
+        (let lp ((gensyms gensyms) (n n))
+          (if (null? gensyms)
+              (let ((nlocs (apply
+                            max
+                            (allocate! body proc n)
+                            ;; inits not logically at the end, but they
+                            ;; are the list...
+                            (map (lambda (x) (allocate! x proc n)) inits))))
+                ;; label and nlocs for the case
+                (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
+                nlocs)
+              (begin
+                (hashq-set! allocation (car gensyms)
+                            (make-hashq
+                             proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n)))
+                (lp (cdr gensyms) (1+ n)))))
+        (if alternate (allocate! alternate proc n) n)))
+      
+      ((<let> gensyms vals body)
+       (let ((nmax (apply max (map recur vals))))
+         (cond
+          ;; the `or' hack
+          ((and (conditional? body)
+                (= (length gensyms) 1)
+                (let ((v (car gensyms)))
+                  (and (not (hashq-ref assigned v))
+                       (= (hashq-ref refcounts v 0) 2)
+                       (lexical-ref? (conditional-test body))
+                       (eq? (lexical-ref-gensym (conditional-test body)) v)
+                       (lexical-ref? (conditional-consequent body))
+                       (eq? (lexical-ref-gensym (conditional-consequent body)) v))))
+           (hashq-set! allocation (car gensyms)
+                       (make-hashq proc `(#t #f . ,n)))
+           ;; the 1+ for this var
+           (max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
+          (else
+           (let lp ((gensyms gensyms) (n n))
+             (if (null? gensyms)
+                 (max nmax (allocate! body proc n))
+                 (let ((v (car gensyms)))
+                   (hashq-set!
+                    allocation v
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr gensyms) (1+ n)))))))))
+      
+      ((<letrec> gensyms vals body)
+       (let lp ((gensyms gensyms) (n n))
+         (if (null? gensyms)
+             (let ((nmax (apply max
+                                (map (lambda (x)
+                                       (allocate! x proc n))
+                                     vals))))
+               (max nmax (allocate! body proc n)))
+             (let ((v (car gensyms)))
+               (hashq-set!
+                allocation v
+                (make-hashq proc
+                            `(#t ,(hashq-ref assigned v) . ,n)))
+               (lp (cdr gensyms) (1+ n))))))
+
+      ((<fix> gensyms vals body)
+       (let lp ((in gensyms) (n n))
+         (if (null? in)
+             (let lp ((gensyms gensyms) (vals vals) (nmax n))
+               (cond
+                ((null? gensyms)
+                 (max nmax (allocate! body proc n)))
+                ((hashq-ref labels (car gensyms))                 
+                 ;; allocate lambda body inline to proc
+                 (lp (cdr gensyms)
+                     (cdr vals)
+                     (record-case (car vals)
+                       ((<lambda> body)
+                        (max nmax (allocate! body proc n))))))
+                (else
+                 ;; allocate closure
+                 (lp (cdr gensyms)
+                     (cdr vals)
+                     (max nmax (allocate! (car vals) proc n))))))
+             
+             (let ((v (car in)))
+               (cond
+                ((hashq-ref assigned v)
+                 (error "fixpoint procedures may not be assigned" x))
+                ((hashq-ref labels v)
+                 ;; no binding, it's a label
+                 (lp (cdr in) n))
+                (else
+                 ;; allocate closure binding
+                 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+                 (lp (cdr in) (1+ n))))))))
+
+      ((<let-values> exp body)
+       (max (recur exp) (recur body)))
+      
+      ((<dynwind> body winder unwinder)
+       (max (recur body) (recur winder) (recur unwinder)))
+      
+      ((<dynlet> fluids vals body)
+       (apply max (recur body) (map recur (append fluids vals))))
+      
+      ((<dynref> fluid)
+       (recur fluid))
+      
+      ((<dynset> fluid exp)
+       (max (recur fluid) (recur exp)))
+      
+      ((<prompt> tag body handler)
+       (let ((cont-var (and (lambda-case? handler)
+                            (pair? (lambda-case-gensyms handler))
+                            (car (lambda-case-gensyms handler)))))
+         (hashq-set! allocation x
+                     (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
+         (max (recur tag) (recur body) (recur handler))))
+      
+      ((<abort> tag args tail)
+       (apply max (recur tag) (recur tail) (map recur args)))
+      
+      (else n)))
+
+  (analyze! x #f '() #t #f)
+  (allocate! x #f 0)
+
+  allocation)
+
+
+;;;
+;;; Tree analyses for warnings.
+;;;
+
+(define-record-type <tree-analysis>
+  (make-tree-analysis leaf down up post init)
+  tree-analysis?
+  (leaf tree-analysis-leaf)  ;; (lambda (x result env locs) ...)
+  (down tree-analysis-down)  ;; (lambda (x result env locs) ...)
+  (up   tree-analysis-up)    ;; (lambda (x result env locs) ...)
+  (post tree-analysis-post)  ;; (lambda (result env) ...)
+  (init tree-analysis-init)) ;; arbitrary value
+
+(define (analyze-tree analyses tree env)
+  "Run all tree analyses listed in ANALYSES on TREE for ENV, using
+`tree-il-fold'.  Return TREE.  The leaf/down/up procedures of each analysis are
+passed a ``location stack', which is the stack of `tree-il-src' values for each
+parent tree (a list); it can be used to approximate source location when
+accurate information is missing from a given `tree-il' element."
+
+  (define (traverse proc update-locs)
+    ;; Return a tree traversing procedure that returns a list of analysis
+    ;; results prepended by the location stack.
+    (lambda (x results)
+      (let ((locs (update-locs x (car results))))
+        (cons locs ;; the location stack
+              (map (lambda (analysis result)
+                     ((proc analysis) x result env locs))
+                   analyses
+                   (cdr results))))))
+
+  ;; Keeping/extending/shrinking the location stack.
+  (define (keep-locs x locs)   locs)
+  (define (extend-locs x locs) (cons (tree-il-src x) locs))
+  (define (shrink-locs x locs) (cdr locs))
+
+  (let ((results
+         (tree-il-fold (traverse tree-analysis-leaf keep-locs)
+                       (traverse tree-analysis-down extend-locs)
+                       (traverse tree-analysis-up   shrink-locs)
+                       (cons '() ;; empty location stack
+                             (map tree-analysis-init analyses))
+                       tree)))
+
+    (for-each (lambda (analysis result)
+                ((tree-analysis-post analysis) result env))
+              analyses
+              (cdr results)))
+
+  tree)
+
+
+;;;
+;;; Unused variable analysis.
+;;;
+
+;; <binding-info> records are used during tree traversals in
+;; `unused-variable-analysis'.  They contain a list of the local vars
+;; currently in scope, and a list of locals vars that have been referenced.
+(define-record-type <binding-info>
+  (make-binding-info vars refs)
+  binding-info?
+  (vars binding-info-vars)  ;; ((GENSYM NAME LOCATION) ...)
+  (refs binding-info-refs)) ;; (GENSYM ...)
+
+(define (gensym? sym)
+  ;; Return #t if SYM is (likely) a generated symbol.
+  (string-any #\space (symbol->string sym)))
+
+(define unused-variable-analysis
+  ;; Report unused variables in the given tree.
+  (make-tree-analysis
+   (lambda (x info env locs)
+     ;; X is a leaf: extend INFO's refs accordingly.
+     (let ((refs (binding-info-refs info))
+           (vars (binding-info-vars info)))
+       (record-case x
+         ((<lexical-ref> gensym)
+          (make-binding-info vars (vhash-consq gensym #t refs)))
+         (else info))))
+
+   (lambda (x info env locs)
+     ;; Going down into X: extend INFO's variable list
+     ;; accordingly.
+     (let ((refs (binding-info-refs info))
+           (vars (binding-info-vars info))
+           (src  (tree-il-src x)))
+       (define (extend inner-vars inner-names)
+         (fold (lambda (var name vars)
+                 (vhash-consq var (list name src) vars))
+               vars
+               inner-vars
+               inner-names))
+
+       (record-case x
+         ((<lexical-set> gensym)
+          (make-binding-info vars (vhash-consq gensym #t refs)))
+         ((<lambda-case> req opt inits rest kw gensyms)
+          (let ((names `(,@req
+                         ,@(or opt '())
+                         ,@(if rest (list rest) '())
+                         ,@(if kw (map cadr (cdr kw)) '()))))
+            (make-binding-info (extend gensyms names) refs)))
+         ((<let> gensyms names)
+          (make-binding-info (extend gensyms names) refs))
+         ((<letrec> gensyms names)
+          (make-binding-info (extend gensyms names) refs))
+         ((<fix> gensyms names)
+          (make-binding-info (extend gensyms names) refs))
+         (else info))))
+
+   (lambda (x info env locs)
+     ;; Leaving X's scope: shrink INFO's variable list
+     ;; accordingly and reported unused nested variables.
+     (let ((refs (binding-info-refs info))
+           (vars (binding-info-vars info)))
+       (define (shrink inner-vars refs)
+         (vlist-for-each
+          (lambda (var)
+            (let ((gensym (car var)))
+              ;; Don't report lambda parameters as unused.
+              (if (and (memq gensym inner-vars)
+                       (not (vhash-assq gensym refs))
+                       (not (lambda-case? x)))
+                  (let ((name (cadr var))
+                        ;; We can get approximate source location by going up
+                        ;; the LOCS location stack.
+                        (loc  (or (caddr var)
+                                  (find pair? locs))))
+                    (if (and (not (gensym? name))
+                             (not (eq? name '_)))
+                        (warning 'unused-variable loc name))))))
+          vars)
+         (vlist-drop vars (length inner-vars)))
+
+       ;; For simplicity, we leave REFS untouched, i.e., with
+       ;; names of variables that are now going out of scope.
+       ;; It doesn't hurt as these are unique names, it just
+       ;; makes REFS unnecessarily fat.
+       (record-case x
+         ((<lambda-case> gensyms)
+          (make-binding-info (shrink gensyms refs) refs))
+         ((<let> gensyms)
+          (make-binding-info (shrink gensyms refs) refs))
+         ((<letrec> gensyms)
+          (make-binding-info (shrink gensyms refs) refs))
+         ((<fix> gensyms)
+          (make-binding-info (shrink gensyms refs) refs))
+         (else info))))
+
+   (lambda (result env) #t)
+   (make-binding-info vlist-null vlist-null)))
+
+
+;;;
+;;; Unused top-level variable analysis.
+;;;
+
+;; <reference-graph> record top-level definitions that are made, references to
+;; top-level definitions and their context (the top-level definition in which
+;; the reference appears), as well as the current context (the top-level
+;; definition we're currently in).  The second part (`refs' below) is
+;; effectively a graph from which we can determine unused top-level definitions.
+(define-record-type <reference-graph>
+  (make-reference-graph refs defs toplevel-context)
+  reference-graph?
+  (defs             reference-graph-defs) ;; ((NAME . LOC) ...)
+  (refs             reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...)
+  (toplevel-context reference-graph-toplevel-context)) ;; NAME | #f
+
+(define (graph-reachable-nodes root refs reachable)
+  ;; Add to REACHABLE the nodes reachable from ROOT in graph REFS.  REFS is a
+  ;; vhash mapping nodes to the list of their children: for instance,
+  ;; ((A -> (B C)) (B -> (A)) (C -> ())) corresponds to
+  ;;
+  ;;  ,-------.
+  ;;  v       |
+  ;;  A ----> B
+  ;;  |
+  ;;  v
+  ;;  C
+  ;;
+  ;; REACHABLE is a vhash of nodes known to be otherwise reachable.
+
+  (let loop ((root   root)
+             (path   vlist-null)
+             (result reachable))
+    (if (or (vhash-assq root path)
+            (vhash-assq root result))
+        result
+        (let* ((children (or (and=> (vhash-assq root refs) cdr) '()))
+               (path     (vhash-consq root #t path))
+               (result   (fold (lambda (kid result)
+                                 (loop kid path result))
+                               result
+                               children)))
+          (fold (lambda (kid result)
+                  (vhash-consq kid #t result))
+                result
+                children)))))
+
+(define (graph-reachable-nodes* roots refs)
+  ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
+  (vlist-fold (lambda (root+true result)
+                (let* ((root      (car root+true))
+                       (reachable (graph-reachable-nodes root refs result)))
+                  (vhash-consq root #t reachable)))
+              vlist-null
+              roots))
+
+(define (partition* pred vhash)
+  ;; Partition VHASH according to PRED.  Return the two resulting vhashes.
+  (let ((result
+         (vlist-fold (lambda (k+v result)
+                       (let ((k  (car k+v))
+                             (v  (cdr k+v))
+                             (r1 (car result))
+                             (r2 (cdr result)))
+                         (if (pred k)
+                             (cons (vhash-consq k v r1) r2)
+                             (cons r1 (vhash-consq k v r2)))))
+                     (cons vlist-null vlist-null)
+                     vhash)))
+    (values (car result) (cdr result))))
+
+(define unused-toplevel-analysis
+  ;; Report unused top-level definitions that are not exported.
+  (let ((add-ref-from-context
+         (lambda (graph name)
+           ;; Add an edge CTX -> NAME in GRAPH.
+           (let* ((refs     (reference-graph-refs graph))
+                  (defs     (reference-graph-defs graph))
+                  (ctx      (reference-graph-toplevel-context graph))
+                  (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
+             (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
+                                   defs ctx)))))
+    (define (macro-variable? name env)
+      (and (module? env)
+           (let ((var (module-variable env name)))
+             (and var (variable-bound? var)
+                  (macro? (variable-ref var))))))
+
+    (make-tree-analysis
+     (lambda (x graph env locs)
+       ;; X is a leaf.
+       (let ((ctx (reference-graph-toplevel-context graph)))
+         (record-case x
+           ((<toplevel-ref> name src)
+            (add-ref-from-context graph name))
+           (else graph))))
+
+     (lambda (x graph env locs)
+       ;; Going down into X.
+       (let ((ctx  (reference-graph-toplevel-context graph))
+             (refs (reference-graph-refs graph))
+             (defs (reference-graph-defs graph)))
+         (record-case x
+           ((<toplevel-define> name src)
+            (let ((refs refs)
+                  (defs (vhash-consq name (or src (find pair? locs))
+                                     defs)))
+              (make-reference-graph refs defs name)))
+           ((<toplevel-set> name src)
+            (add-ref-from-context graph name))
+           (else graph))))
+
+     (lambda (x graph env locs)
+       ;; Leaving X's scope.
+       (record-case x
+         ((<toplevel-define>)
+          (let ((refs (reference-graph-refs graph))
+                (defs (reference-graph-defs graph)))
+            (make-reference-graph refs defs #f)))
+         (else graph)))
+
+     (lambda (graph env)
+       ;; Process the resulting reference graph: determine all private definitions
+       ;; not reachable from any public definition.  Macros
+       ;; (syntax-transformers), which are globally bound, never considered
+       ;; unused since we can't tell whether a macro is actually used; in
+       ;; addition, macros are considered roots of the graph since they may use
+       ;; private bindings.  FIXME: The `make-syntax-transformer' calls don't
+       ;; contain any literal `toplevel-ref' of the global bindings they use so
+       ;; this strategy fails.
+       (define (exported? name)
+         (if (module? env)
+             (module-variable (module-public-interface env) name)
+             #t))
+
+       (let-values (((public-defs private-defs)
+                     (partition* (lambda (name)
+                                   (or (exported? name)
+                                       (macro-variable? name env)))
+                                 (reference-graph-defs graph))))
+         (let* ((roots     (vhash-consq #f #t public-defs))
+                (refs      (reference-graph-refs graph))
+                (reachable (graph-reachable-nodes* roots refs))
+                (unused    (vlist-filter (lambda (name+src)
+                                           (not (vhash-assq (car name+src)
+                                                            reachable)))
+                                         private-defs)))
+           (vlist-for-each (lambda (name+loc)
+                             (let ((name (car name+loc))
+                                   (loc  (cdr name+loc)))
+                               (if (not (gensym? name))
+                                   (warning 'unused-toplevel loc name))))
+                           unused))))
+
+     (make-reference-graph vlist-null vlist-null #f))))
+
+
+;;;
+;;; Unbound variable analysis.
+;;;
+
+;; <toplevel-info> records are used during tree traversal in search of
+;; possibly unbound variable.  They contain a list of references to
+;; potentially unbound top-level variables, and a list of the top-level
+;; defines that have been encountered.
+(define-record-type <toplevel-info>
+  (make-toplevel-info refs defs)
+  toplevel-info?
+  (refs  toplevel-info-refs)  ;; ((VARIABLE-NAME . LOCATION) ...)
+  (defs  toplevel-info-defs)) ;; (VARIABLE-NAME ...)
+
+(define (goops-toplevel-definition proc args env)
+  ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+  ;; the name of the variable being defined; otherwise return #f.  This
+  ;; assumes knowledge of the current implementation of `define-class' et al.
+  (define (toplevel-define-arg args)
+    (match args
+      ((($ <const> _ (and (? symbol?) exp)) _)
+       exp)
+      (_ #f)))
+
+  (match proc
+    (($ <module-ref> _ '(oop goops) 'toplevel-define! #f)
+     (toplevel-define-arg args))
+    (($ <toplevel-ref> _ 'toplevel-define!)
+     ;; This may be the result of expanding one of the GOOPS macros within
+     ;; `oop/goops.scm'.
+     (and (eq? env (resolve-module '(oop goops)))
+          (toplevel-define-arg args)))
+    (_ #f)))
+
+(define unbound-variable-analysis
+  ;; Report possibly unbound variables in the given tree.
+  (make-tree-analysis
+   (lambda (x info env locs)
+     ;; X is a leaf: extend INFO's refs accordingly.
+     (let ((refs (toplevel-info-refs info))
+           (defs (toplevel-info-defs info)))
+       (define (bound? name)
+         (or (and (module? env)
+                  (module-variable env name))
+             (vhash-assq name defs)))
+
+       (record-case x
+         ((<toplevel-ref> name src)
+          (if (bound? name)
+              info
+              (let ((src (or src (find pair? locs))))
+                (make-toplevel-info (vhash-consq name src refs)
+                                    defs))))
+         (else info))))
+
+   (lambda (x info env locs)
+     ;; Going down into X.
+     (let* ((refs (toplevel-info-refs info))
+            (defs (toplevel-info-defs info))
+            (src  (tree-il-src x)))
+       (define (bound? name)
+         (or (and (module? env)
+                  (module-variable env name))
+             (vhash-assq name defs)))
+
+       (record-case x
+         ((<toplevel-set> name src)
+          (if (bound? name)
+              (make-toplevel-info refs defs)
+              (let ((src (find pair? locs)))
+                (make-toplevel-info (vhash-consq name src refs)
+                                    defs))))
+         ((<toplevel-define> name)
+          (make-toplevel-info (vhash-delq name refs)
+                              (vhash-consq name #t defs)))
+
+         ((<application> proc args)
+          ;; Check for a dynamic top-level definition, as is
+          ;; done by code expanded from GOOPS macros.
+          (let ((name (goops-toplevel-definition proc args
+                                                 env)))
+            (if (symbol? name)
+                (make-toplevel-info (vhash-delq name refs)
+                                    (vhash-consq name #t defs))
+                (make-toplevel-info refs defs))))
+         (else
+          (make-toplevel-info refs defs)))))
+
+   (lambda (x info env locs)
+     ;; Leaving X's scope.
+     info)
+
+   (lambda (toplevel env)
+     ;; Post-process the result.
+     (vlist-for-each (lambda (name+loc)
+                       (let ((name (car name+loc))
+                             (loc  (cdr name+loc)))
+                         (warning 'unbound-variable loc name)))
+                     (vlist-reverse (toplevel-info-refs toplevel))))
+
+   (make-toplevel-info vlist-null vlist-null)))
+
+
+;;;
+;;; Arity analysis.
+;;;
+
+;; <arity-info> records contain information about lexical definitions of
+;; procedures currently in scope, top-level procedure definitions that have
+;; been encountered, and calls to top-level procedures that have been
+;; encountered.
+(define-record-type <arity-info>
+  (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
+  arity-info?
+  (toplevel-calls   toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+  (lexical-lambdas  lexical-lambdas)          ;; ((GENSYM . DEFINITION) ...)
+  (toplevel-lambdas toplevel-lambdas))        ;; ((NAME . DEFINITION) ...)
+
+(define (validate-arity proc application lexical?)
+  ;; Validate the argument count of APPLICATION, a tree-il application of
+  ;; PROC, emitting a warning in case of argument count mismatch.
+
+  (define (filter-keyword-args keywords allow-other-keys? args)
+    ;; Filter keyword arguments from ARGS and return the resulting list.
+    ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
+    ;; specified whethere keywords not listed in KEYWORDS are allowed.
+    (let loop ((args   args)
+               (result '()))
+      (if (null? args)
+          (reverse result)
+          (let ((arg (car args)))
+            (if (and (const? arg)
+                     (or (memq (const-exp arg) keywords)
+                         (and allow-other-keys?
+                              (keyword? (const-exp arg)))))
+                (loop (if (pair? (cdr args))
+                          (cddr args)
+                          '())
+                      result)
+                (loop (cdr args)
+                      (cons arg result)))))))
+
+  (define (arities proc)
+    ;; Return the arities of PROC, which can be either a tree-il or a
+    ;; procedure.
+    (define (len x)
+      (or (and (or (null? x) (pair? x))
+               (length x))
+          0))
+    (cond ((program? proc)
+           (values (procedure-name proc)
+                   (map (lambda (a)
+                          (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
+                                (map car (arity:kw a))
+                                (arity:allow-other-keys? a)))
+                        (program-arities proc))))
+          ((procedure? proc)
+           (if (struct? proc)
+               ;; An applicable struct.
+               (arities (struct-ref proc 0))
+               ;; An applicable smob.
+               (let ((arity (procedure-minimum-arity proc)))
+                 (values (procedure-name proc)
+                         (list (list (car arity) (cadr arity) (caddr arity)
+                                     #f #f))))))
+          (else
+           (let loop ((name    #f)
+                      (proc    proc)
+                      (arities '()))
+             (if (not proc)
+                 (values name (reverse arities))
+                 (record-case proc
+                   ((<lambda-case> req opt rest kw alternate)
+                    (loop name alternate
+                          (cons (list (len req) (len opt) rest
+                                      (and (pair? kw) (map car (cdr kw)))
+                                      (and (pair? kw) (car kw)))
+                                arities)))
+                   ((<lambda> meta body)
+                    (loop (assoc-ref meta 'name) body arities))
+                   (else
+                    (values #f #f))))))))
+
+  (let ((args (application-args application))
+        (src  (tree-il-src application)))
+    (call-with-values (lambda () (arities proc))
+      (lambda (name arities)
+        (define matches?
+          (find (lambda (arity)
+                  (pmatch arity
+                    ((,req ,opt ,rest? ,kw ,aok?)
+                     (let ((args (if (pair? kw)
+                                     (filter-keyword-args kw aok? args)
+                                     args)))
+                       (if (and req opt)
+                           (let ((count (length args)))
+                             (and (>= count req)
+                                  (or rest?
+                                      (<= count (+ req opt)))))
+                           #t)))
+                    (else #t)))
+                arities))
+
+        (if (not matches?)
+            (warning 'arity-mismatch src
+                     (or name (with-output-to-string (lambda () (write proc))))
+                     lexical?)))))
+  #t)
+
+(define arity-analysis
+  ;; Report arity mismatches in the given tree.
+  (make-tree-analysis
+   (lambda (x info env locs)
+     ;; X is a leaf.
+     info)
+   (lambda (x info env locs)
+     ;; Down into X.
+     (define (extend lexical-name val info)
+       ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
+       (let ((toplevel-calls   (toplevel-procedure-calls info))
+             (lexical-lambdas  (lexical-lambdas info))
+             (toplevel-lambdas (toplevel-lambdas info)))
+         (record-case val
+           ((<lambda> body)
+            (make-arity-info toplevel-calls
+                             (vhash-consq lexical-name val
+                                          lexical-lambdas)
+                             toplevel-lambdas))
+           ((<lexical-ref> gensym)
+            ;; lexical alias
+            (let ((val* (vhash-assq gensym lexical-lambdas)))
+              (if (pair? val*)
+                  (extend lexical-name (cdr val*) info)
+                  info)))
+           ((<toplevel-ref> name)
+            ;; top-level alias
+            (make-arity-info toplevel-calls
+                             (vhash-consq lexical-name val
+                                          lexical-lambdas)
+                             toplevel-lambdas))
+           (else info))))
+
+     (let ((toplevel-calls   (toplevel-procedure-calls info))
+           (lexical-lambdas  (lexical-lambdas info))
+           (toplevel-lambdas (toplevel-lambdas info)))
+
+       (record-case x
+         ((<toplevel-define> name exp)
+          (record-case exp
+            ((<lambda> body)
+             (make-arity-info toplevel-calls
+                              lexical-lambdas
+                              (vhash-consq name exp toplevel-lambdas)))
+            ((<toplevel-ref> name)
+             ;; alias for another toplevel
+             (let ((proc (vhash-assq name toplevel-lambdas)))
+               (make-arity-info toplevel-calls
+                                lexical-lambdas
+                                (vhash-consq (toplevel-define-name x)
+                                             (if (pair? proc)
+                                                 (cdr proc)
+                                                 exp)
+                                             toplevel-lambdas))))
+            (else info)))
+         ((<let> gensyms vals)
+          (fold extend info gensyms vals))
+         ((<letrec> gensyms vals)
+          (fold extend info gensyms vals))
+         ((<fix> gensyms vals)
+          (fold extend info gensyms vals))
+
+         ((<application> proc args src)
+          (record-case proc
+            ((<lambda> body)
+             (validate-arity proc x #t)
+             info)
+            ((<toplevel-ref> name)
+             (make-arity-info (vhash-consq name x toplevel-calls)
+                              lexical-lambdas
+                              toplevel-lambdas))
+            ((<lexical-ref> gensym)
+             (let ((proc (vhash-assq gensym lexical-lambdas)))
+               (if (pair? proc)
+                   (record-case (cdr proc)
+                     ((<toplevel-ref> name)
+                      ;; alias to toplevel
+                      (make-arity-info (vhash-consq name x toplevel-calls)
+                                       lexical-lambdas
+                                       toplevel-lambdas))
+                     (else
+                      (validate-arity (cdr proc) x #t)
+                      info))
+
+                   ;; If GENSYM wasn't found, it may be because it's an
+                   ;; argument of the procedure being compiled.
+                   info)))
+            (else info)))
+         (else info))))
+
+   (lambda (x info env locs)
+     ;; Up from X.
+     (define (shrink name val info)
+       ;; Remove NAME from the lexical-lambdas of INFO.
+       (let ((toplevel-calls   (toplevel-procedure-calls info))
+             (lexical-lambdas  (lexical-lambdas info))
+             (toplevel-lambdas (toplevel-lambdas info)))
+         (make-arity-info toplevel-calls
+                          (if (vhash-assq name lexical-lambdas)
+                              (vlist-tail lexical-lambdas)
+                              lexical-lambdas)
+                          toplevel-lambdas)))
+
+     (let ((toplevel-calls   (toplevel-procedure-calls info))
+           (lexical-lambdas  (lexical-lambdas info))
+           (toplevel-lambdas (toplevel-lambdas info)))
+       (record-case x
+         ((<let> gensyms vals)
+          (fold shrink info gensyms vals))
+         ((<letrec> gensyms vals)
+          (fold shrink info gensyms vals))
+         ((<fix> gensyms vals)
+          (fold shrink info gensyms vals))
+
+         (else info))))
+
+   (lambda (result env)
+     ;; Post-processing: check all top-level procedure calls that have been
+     ;; encountered.
+     (let ((toplevel-calls   (toplevel-procedure-calls result))
+           (toplevel-lambdas (toplevel-lambdas result)))
+       (vlist-for-each
+        (lambda (name+application)
+          (let* ((name        (car name+application))
+                 (application (cdr name+application))
+                 (proc
+                  (or (and=> (vhash-assq name toplevel-lambdas) cdr)
+                      (and (module? env)
+                           (false-if-exception
+                            (module-ref env name)))))
+                 (proc*
+                  ;; handle toplevel aliases
+                  (if (toplevel-ref? proc)
+                      (let ((name (toplevel-ref-name proc)))
+                        (and (module? env)
+                             (false-if-exception
+                              (module-ref env name))))
+                      proc)))
+            (cond ((lambda? proc*)
+                   (validate-arity proc* application #t))
+                  ((procedure? proc*)
+                   (validate-arity proc* application #f)))))
+        toplevel-calls)))
+
+   (make-arity-info vlist-null vlist-null vlist-null)))
+
+
+;;;
+;;; `format' argument analysis.
+;;;
+
+(define &syntax-error
+  ;; The `throw' key for syntax errors.
+  (gensym "format-string-syntax-error"))
+
+(define (format-string-argument-count fmt)
+  ;; Return the minimum and maxium number of arguments that should
+  ;; follow format string FMT (or, ahem, a good estimate thereof) or
+  ;; `any' if the format string can be followed by any number of
+  ;; arguments.
+
+  (define (drop-group chars end)
+    ;; Drop characters from CHARS until "~END" is encountered.
+    (let loop ((chars  chars)
+               (tilde? #f))
+      (if (null? chars)
+          (throw &syntax-error 'unterminated-iteration)
+          (if tilde?
+              (if (eq? (car chars) end)
+                  (cdr chars)
+                  (loop (cdr chars) #f))
+              (if (eq? (car chars) #\~)
+                  (loop (cdr chars) #t)
+                  (loop (cdr chars) #f))))))
+
+  (define (digit? char)
+    ;; Return true if CHAR is a digit, #f otherwise.
+    (memq char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
+
+  (define (previous-number chars)
+    ;; Return the previous series of digits found in CHARS.
+    (let ((numbers (take-while digit? chars)))
+      (and (not (null? numbers))
+           (string->number (list->string (reverse numbers))))))
+
+  (let loop ((chars       (string->list fmt))
+             (state       'literal)
+             (params      '())
+             (conditions  '())
+             (end-group   #f)
+             (min-count 0)
+             (max-count 0))
+    (if (null? chars)
+        (if end-group
+            (throw &syntax-error 'unterminated-conditional)
+            (values min-count max-count))
+        (case state
+          ((tilde)
+           (case (car chars)
+             ((#\~ #\% #\& #\t #\T #\_ #\newline #\( #\) #\! #\| #\/ #\q #\Q)
+                        (loop (cdr chars) 'literal '()
+                              conditions end-group
+                              min-count max-count))
+             ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@ #\+ #\- #\#)
+                        (loop (cdr chars)
+                              'tilde (cons (car chars) params)
+                              conditions end-group
+                              min-count max-count))
+             ((#\v #\V) (loop (cdr chars)
+                              'tilde (cons (car chars) params)
+                              conditions end-group
+                              (+ 1 min-count)
+                              (+ 1 max-count)))
+             ((#\p #\P) (let* ((colon?    (memq #\: params))
+                               (min-count (if colon?
+                                              (max 1 min-count)
+                                              (+ 1 min-count))))
+                          (loop (cdr chars) 'literal '()
+                                conditions end-group
+                                min-count
+                                (if colon?
+                                    (max max-count min-count)
+                                    (+ 1 max-count)))))
+             ((#\[)
+              (loop chars 'literal '() '()
+                    (let ((selector (previous-number params))
+                          (at?      (memq #\@ params)))
+                      (lambda (chars conds)
+                        ;; end of group
+                        (let ((mins (map car conds))
+                              (maxs (map cdr conds))
+                              (sel? (and selector
+                                         (< selector (length conds)))))
+                          (if (and (every number? mins)
+                                   (every number? maxs))
+                              (loop chars 'literal '() conditions end-group
+                                    (+ min-count
+                                       (if sel?
+                                           (car (list-ref conds selector))
+                                           (+ (if at? 0 1)
+                                              (if (null? mins)
+                                                  0
+                                                  (apply min mins)))))
+                                    (+ max-count
+                                       (if sel?
+                                           (cdr (list-ref conds selector))
+                                           (+ (if at? 0 1)
+                                              (if (null? maxs)
+                                                  0
+                                                  (apply max maxs))))))
+                              (values 'any 'any))))) ;; XXX: approximation
+                    0 0))
+             ((#\;)
+              (if end-group
+                  (loop (cdr chars) 'literal '()
+                        (cons (cons min-count max-count) conditions)
+                        end-group
+                        0 0)
+                  (throw &syntax-error 'unexpected-semicolon)))
+             ((#\])
+              (if end-group
+                  (end-group (cdr chars)
+                             (reverse (cons (cons min-count max-count)
+                                            conditions)))
+                  (throw &syntax-error 'unexpected-conditional-termination)))
+             ((#\{)     (if (memq #\@ params)
+                            (values min-count 'any)
+                            (loop (drop-group (cdr chars) #\})
+                                  'literal '()
+                                  conditions end-group
+                                  (+ 1 min-count) (+ 1 max-count))))
+             ((#\*)     (if (memq #\@ params)
+                            (values 'any 'any) ;; it's unclear what to do here
+                            (loop (cdr chars)
+                                  'literal '()
+                                  conditions end-group
+                                  (+ (or (previous-number params) 1)
+                                     min-count)
+                                  (+ (or (previous-number params) 1)
+                                     max-count))))
+             ((#\? #\k #\K)
+              ;; We don't have enough info to determine the exact number
+              ;; of args, but we could determine a lower bound (TODO).
+              (values 'any 'any))
+             ((#\^)
+              (values min-count 'any))
+             ((#\h #\H)
+                        (let ((argc (if (memq #\: params) 2 1)))
+                          (loop (cdr chars) 'literal '()
+                                conditions end-group
+                                (+ argc min-count)
+                                (+ argc max-count))))
+             ((#\')
+              (if (null? (cdr chars))
+                  (throw &syntax-error 'unexpected-termination)
+                  (loop (cddr chars) 'tilde (cons (cadr chars) params)
+                        conditions end-group min-count max-count)))
+             (else      (loop (cdr chars) 'literal '()
+                              conditions end-group
+                              (+ 1 min-count) (+ 1 max-count)))))
+          ((literal)
+           (case (car chars)
+             ((#\~)     (loop (cdr chars) 'tilde '()
+                              conditions end-group
+                              min-count max-count))
+             (else      (loop (cdr chars) 'literal '()
+                              conditions end-group
+                              min-count max-count))))
+          (else (error "computer bought the farm" state))))))
+
+(define (proc-ref? exp proc special-name env)
+  "Return #t when EXP designates procedure PROC in ENV.  As a last
+resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+
+  (define special?
+    (cut eq? <> special-name))
+
+  (match exp
+    (($ <toplevel-ref> _ (? special?))
+     ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
+     #t)
+    (($ <toplevel-ref> _ name)
+     (let ((var (module-variable env name)))
+       (and var (variable-bound? var)
+            (eq? (variable-ref var) proc))))
+    (($ <module-ref> _ _ (? special?))
+     #t)
+    (($ <module-ref> _ module name public?)
+     (let* ((mod (if public?
+                     (false-if-exception (resolve-interface module))
+                     (resolve-module module #\ensure #f)))
+            (var (and mod (module-variable mod name))))
+       (and var (variable-bound? var) (eq? (variable-ref var) proc))))
+    (($ <lexical-ref> _ (? special?))
+     #t)
+    (_ #f)))
+
+(define gettext? (cut proc-ref? <> gettext '_ <>))
+(define ngettext? (cut proc-ref? <> ngettext 'N_ <>))
+
+(define (const-fmt x env)
+  ;; Return the literal format string for X, or #f.
+  (match x
+    (($ <const> _ (? string? exp))
+     exp)
+    (($ <application> _ (? (cut gettext? <> env))
+        (($ <const> _ (? string? fmt))))
+     ;; Gettexted literals, like `(_ "foo")'.
+     fmt)
+    (($ <application> _ (? (cut ngettext? <> env))
+        (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ \.\.1))
+     ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
+
+     ;; TODO: Check whether the singular and plural strings have the
+     ;; same format escapes.
+     fmt)
+    (_ #f)))
+
+(define format-analysis
+  ;; Report arity mismatches in the given tree.
+  (make-tree-analysis
+   (lambda (x _ env locs)
+     ;; X is a leaf.
+     #t)
+
+   (lambda (x _ env locs)
+     ;; Down into X.
+     (define (check-format-args args loc)
+       (pmatch args
+         ((,port ,fmt . ,rest)
+          (guard (const-fmt fmt env))
+          (if (and (const? port)
+                   (not (boolean? (const-exp port))))
+              (warning 'format loc 'wrong-port (const-exp port)))
+          (let ((fmt   (const-fmt fmt env))
+                (count (length rest)))
+            (catch &syntax-error
+              (lambda ()
+                (let-values (((min max)
+                              (format-string-argument-count fmt)))
+                  (and min max
+                       (or (and (or (eq? min 'any) (>= count min))
+                                (or (eq? max 'any) (<= count max)))
+                           (warning 'format loc 'wrong-format-arg-count
+                                    fmt min max count)))))
+              (lambda (_ key)
+                (warning 'format loc 'syntax-error key fmt)))))
+         ((,port ,fmt . ,rest)
+          (if (and (const? port)
+                   (not (boolean? (const-exp port))))
+              (warning 'format loc 'wrong-port (const-exp port)))
+
+          (match fmt
+            (($ <const> loc* (? (negate string?) fmt))
+             (warning 'format (or loc* loc) 'wrong-format-string fmt))
+
+            ;; Warn on non-literal format strings, unless they refer to
+            ;; a lexical variable named "fmt".
+            (($ <lexical-ref> _ fmt)
+             #t)
+            ((? (negate const?))
+             (warning 'format loc 'non-literal-format-string))))
+         (else
+          (warning 'format loc 'wrong-num-args (length args)))))
+
+     (define (check-simple-format-args args loc)
+       ;; Check the arguments to the `simple-format' procedure, which is
+       ;; less capable than that of (ice-9 format).
+
+       (define allowed-chars
+         '(#\A #\S #\a #\s #\~ #\%))
+
+       (define (format-chars fmt)
+         (let loop ((chars  (string->list fmt))
+                    (result '()))
+           (match chars
+             (()
+              (reverse result))
+             ((#\~ opt rest ...)
+              (loop rest (cons opt result)))
+             ((_ rest ...)
+              (loop rest result)))))
+
+       (match args
+         ((port ($ <const> _ (? string? fmt)) _ ...)
+          (let ((opts (format-chars fmt)))
+            (or (every (cut memq <> allowed-chars) opts)
+                (begin
+                  (warning 'format loc 'simple-format fmt
+                           (find (negate (cut memq <> allowed-chars)) opts))
+                  #f))))
+         ((port (= (cut const-fmt <> env) (? string? fmt)) args ...)
+          (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc))
+         (_ #t)))
+
+     (define (resolve-toplevel name)
+       (and (module? env)
+            (false-if-exception (module-ref env name))))
+
+     (match x
+       (($ <application> src ($ <toplevel-ref> _ name) args)
+        (let ((proc (resolve-toplevel name)))
+          (if (or (and (eq? proc (@ (guile) simple-format))
+                       (check-simple-format-args args
+                                                 (or src (find pair? locs))))
+                  (eq? proc (@ (ice-9 format) format)))
+              (check-format-args args (or src (find pair? locs))))))
+       (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+        (check-format-args args (or src (find pair? locs))))
+       (($ <application> src ($ <module-ref> _ '(guile)
+                                (or 'format 'simple-format))
+           args)
+        (and (check-simple-format-args args
+                                       (or src (find pair? locs)))
+             (check-format-args args (or src (find pair? locs)))))
+       (_ #t))
+     #t)
+
+   (lambda (x _ env locs)
+     ;; Up from X.
+     #t)
+
+   (lambda (_ env)
+     ;; Post-processing.
+     #t)
+
+   #t))
+;;; Tree-il canonicalizer
+
+;; Copyright (C) 2011, 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
+
+;;; Code:
+
+(define-module (language tree-il canonicalize)
+  #\use-module (language tree-il)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-1)
+  #\export (canonicalize!))
+
+(define (tree-il-any proc exp)
+  (tree-il-fold (lambda (exp res)
+                  (or res (proc exp)))
+                (lambda (exp res)
+                  (or res (proc exp)))
+                (lambda (exp res) res)
+                #f exp))
+
+(define (canonicalize! x)
+  (post-order!
+   (lambda (x)
+     (match x
+       (($ <sequence> src (tail))
+        tail)
+       (($ <sequence> src exps)
+        (and (any sequence? exps)
+             (make-sequence src
+                            (append-map (lambda (x)
+                                          (if (sequence? x)
+                                              (sequence-exps x)
+                                              (list x)))
+                                        exps))))
+       (($ <let> src () () () body)
+        body)
+       (($ <letrec> src _ () () () body)
+        body)
+       (($ <fix> src () () () body)
+        body)
+       (($ <dynlet> src () () body)
+        body)
+       (($ <lambda> src meta #f)
+        ;; Give a body to case-lambda with no clauses.
+        (make-lambda
+         src meta
+         (make-lambda-case
+          #f '() #f #f #f '() '()
+          (make-application
+           #f
+           (make-primitive-ref #f 'throw)
+           (list (make-const #f 'wrong-number-of-args)
+                 (make-const #f #f)
+                 (make-const #f "Wrong number of arguments")
+                 (make-const #f '())
+                 (make-const #f #f)))
+          #f)))
+       (($ <prompt> src tag body handler)
+        (define (escape-only? handler)
+          (match handler
+            (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
+             (not (tree-il-any (lambda (x)
+                                 (and (lexical-ref? x)
+                                      (eq? (lexical-ref-gensym x) cont)))
+                               body)))
+            (else #f)))
+        (define (thunk-application? x)
+          (match x
+            (($ <application> _
+                ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
+                ()) #t)
+            (_ #f)))
+        (define (make-thunk-application body)
+          (define thunk
+            (make-lambda #f '()
+                         (make-lambda-case #f '() #f #f #f '() '() body #f)))
+          (make-application #f thunk '()))
+
+        ;; This code has a nasty job to do: to ensure that either the
+        ;; handler is escape-only, or the body is the application of a
+        ;; thunk.  Sad but true.
+        (if (or (escape-only? handler)
+                (thunk-application? body))
+            #f
+            (make-prompt src tag (make-thunk-application body) handler)))
+       (_ #f)))
+   x))
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,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
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+  #\use-module (system base syntax)
+  #\use-module (system base pmatch)
+  #\use-module (system base message)
+  #\use-module (ice-9 receive)
+  #\use-module (language glil)
+  #\use-module (system vm instruction)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il optimize)
+  #\use-module (language tree-il canonicalize)
+  #\use-module (language tree-il analyze)
+  #\use-module ((srfi srfi-1) #\select (filter-map))
+  #\export (compile-glil))
+
+;; allocation:
+;;  sym -> {lambda -> address}
+;;  lambda -> (labels . free-locs)
+;;  lambda-case -> (gensym . nlocs)
+;;
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+  `((unused-variable     . ,unused-variable-analysis)
+    (unused-toplevel     . ,unused-toplevel-analysis)
+    (unbound-variable    . ,unbound-variable-analysis)
+    (arity-mismatch      . ,arity-analysis)
+    (format              . ,format-analysis)))
+
+(define (compile-glil x e opts)
+  (define warnings
+    (or (and=> (memq #\warnings opts) cadr)
+        '()))
+
+  ;; Go through the warning passes.
+  (let ((analyses (filter-map (lambda (kind)
+                                (assoc-ref %warning-passes kind))
+                              warnings)))
+    (analyze-tree analyses x e))
+
+  (let* ((x (make-lambda (tree-il-src x) '()
+                         (make-lambda-case #f '() #f #f #f '() '() x #f)))
+         (x (optimize! x e opts))
+         (x (canonicalize! x))
+         (allocation (analyze-lexicals x)))
+
+    (with-fluids ((*comp-module* e))
+      (values (flatten-lambda x #f allocation)
+              e
+              e))))
+
+
+
+(define *primcall-ops* (make-hash-table))
+(for-each
+ (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
+ '(((eq? . 2) . eq?)
+   ((eqv? . 2) . eqv?)
+   ((equal? . 2) . equal?)
+   ((= . 2) . ee?)
+   ((< . 2) . lt?)
+   ((> . 2) . gt?)
+   ((<= . 2) . le?)
+   ((>= . 2) . ge?)
+   ((+ . 2) . add)
+   ((- . 2) . sub)
+   ((1+ . 1) . add1)
+   ((1- . 1) . sub1)
+   ((* . 2) . mul)
+   ((/ . 2) . div)
+   ((quotient . 2) . quo)
+   ((remainder . 2) . rem)
+   ((modulo . 2) . mod)
+   ((ash . 2) . ash)
+   ((logand . 2) . logand)
+   ((logior . 2) . logior)
+   ((logxor . 2) . logxor)
+   ((not . 1) . not)
+   ((pair? . 1) . pair?)
+   ((cons . 2) . cons)
+   ((car . 1) . car)
+   ((cdr . 1) . cdr)
+   ((set-car! . 2) . set-car!)
+   ((set-cdr! . 2) . set-cdr!)
+   ((null? . 1) . null?)
+   ((list? . 1) . list?)
+   ((symbol? . 1) . symbol?)
+   ((vector? . 1) . vector?)
+   (list . list)
+   (vector . vector)
+   ((class-of . 1) . class-of)
+   ((vector-ref . 2) . vector-ref)
+   ((vector-set! . 3) . vector-set)
+   ((variable-ref . 1) . variable-ref)
+   ;; nb, *not* variable-set! -- the args are switched
+   ((variable-bound? . 1) . variable-bound?)
+   ((struct? . 1) . struct?)
+   ((struct-vtable . 1) . struct-vtable)
+   ((struct-ref . 2) . struct-ref)
+   ((struct-set! . 3) . struct-set)
+   (make-struct/no-tail . make-struct)
+
+   ;; hack for javascript
+   ((return . 1) . return)
+   ;; hack for lua
+   (return/values . return/values)
+
+   ((bytevector-u8-ref . 2) . bv-u8-ref)
+   ((bytevector-u8-set! . 3) . bv-u8-set)
+   ((bytevector-s8-ref . 2) . bv-s8-ref)
+   ((bytevector-s8-set! . 3) . bv-s8-set)
+
+   ((bytevector-u16-ref . 3) . bv-u16-ref)
+   ((bytevector-u16-set! . 4) . bv-u16-set)
+   ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
+   ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
+   ((bytevector-s16-ref . 3) . bv-s16-ref)
+   ((bytevector-s16-set! . 4) . bv-s16-set)
+   ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
+   ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
+    
+   ((bytevector-u32-ref . 3) . bv-u32-ref)
+   ((bytevector-u32-set! . 4) . bv-u32-set)
+   ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
+   ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
+   ((bytevector-s32-ref . 3) . bv-s32-ref)
+   ((bytevector-s32-set! . 4) . bv-s32-set)
+   ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
+   ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
+    
+   ((bytevector-u64-ref . 3) . bv-u64-ref)
+   ((bytevector-u64-set! . 4) . bv-u64-set)
+   ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
+   ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
+   ((bytevector-s64-ref . 3) . bv-s64-ref)
+   ((bytevector-s64-set! . 4) . bv-s64-set)
+   ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
+   ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
+    
+   ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
+   ((bytevector-ieee-single-set! . 4) . bv-f32-set)
+   ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
+   ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
+   ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
+   ((bytevector-ieee-double-set! . 4) . bv-f64-set)
+   ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
+   ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
+
+
+
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation proc)
+  (map (lambda (id v)
+         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+           ((#t ,boxed? . ,n)
+            (list id boxed? n))
+           (,x (error "bad var list element" id v x))))
+       ids
+       vars))
+
+(define (emit-bindings src ids vars allocation proc emit-code)
+  (emit-code src (make-glil-bind
+                  (vars->bind-list ids vars allocation proc))))
+
+(define (with-output-to-code proc)
+  (let ((out '()))
+    (define (emit-code src x)
+      (set! out (cons x out))
+      (if src
+          (set! out (cons (make-glil-source src) out))))
+    (proc emit-code)
+    (reverse out)))
+
+(define (flatten-lambda x self-label allocation)
+  (record-case x
+    ((<lambda> src meta body)
+     (make-glil-program
+      meta
+      (with-output-to-code
+       (lambda (emit-code)
+         ;; write source info for proc
+         (if src (emit-code #f (make-glil-source src)))
+         ;; compile the body, yo
+         (flatten-lambda-case body allocation x self-label
+                              (car (hashq-ref allocation x))
+                              emit-code)))))))
+
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+                             emit-code)
+  (define (emit-label label)
+    (emit-code #f (make-glil-label label)))
+  (define (emit-branch src inst label)
+    (emit-code src (make-glil-branch inst label)))
+
+  ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+  ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+  (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
+    (define (comp-tail tree) (comp tree context RA MVRA))
+    (define (comp-push tree) (comp tree 'push #f #f))
+    (define (comp-drop tree) (comp tree 'drop #f #f))
+    (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+    (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+    ;; A couple of helpers. Note that if we are in tail context, we
+    ;; won't have an RA.
+    (define (maybe-emit-return)
+      (if RA
+          (emit-branch #f 'br RA)
+          (if (eq? context 'tail)
+              (emit-code #f (make-glil-call 'return 1)))))
+    
+    ;; After lexical binding forms in non-tail context, call this
+    ;; function to clear stack slots, allowing their previous values to
+    ;; be collected.
+    (define (clear-stack-slots context syms)
+      (case context
+        ((push drop)
+         (for-each (lambda (v)
+                     (and=>
+                      ;; Can be #f if the var is labels-allocated.
+                      (hashq-ref allocation v)
+                      (lambda (h)
+                        (pmatch (hashq-ref h self)
+                          ((#t _ . ,n)
+                           (emit-code #f (make-glil-void))
+                           (emit-code #f (make-glil-lexical #t #f 'set n)))
+                          (,loc (error "bad let var allocation" x loc))))))
+                   syms))))
+
+    (record-case x
+      ((<void>)
+       (case context
+         ((push vals tail)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+
+      ((<const> src exp)
+       (case context
+         ((push vals tail)
+          (emit-code src (make-glil-const exp))))
+       (maybe-emit-return))
+
+      ;; FIXME: should represent sequence as exps tail
+      ((<sequence> exps)
+       (let lp ((exps exps))
+         (if (null? (cdr exps))
+             (comp-tail (car exps))
+             (begin
+               (comp-drop (car exps))
+               (lp (cdr exps))))))
+
+      ((<application> src proc args)
+       ;; FIXME: need a better pattern-matcher here
+       (cond
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@apply)
+              (>= (length args) 1))
+         (let ((proc (car args))
+               (args (cdr args)))
+           (cond
+            ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+                  (not (eq? context 'push)) (not (eq? context 'vals)))
+             ;; tail: (lambda () (apply values '(1 2)))
+             ;; drop: (lambda () (apply values '(1 2)) 3)
+             ;; push: (lambda () (list (apply values '(10 12)) 1))
+             (case context
+               ((drop) (for-each comp-drop args) (maybe-emit-return))
+               ((tail)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'return/values* (length args))))))
+
+            (else
+             (case context
+               ((tail)
+                (comp-push proc)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+               ((push)
+                (emit-code src (make-glil-call 'new-frame 0))
+                (comp-push proc)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'apply (1+ (length args))))
+                (maybe-emit-return))
+               ((vals)
+                (comp-vals
+                 (make-application src (make-primitive-ref #f 'apply)
+                                   (cons proc args))
+                 MVRA)
+                (maybe-emit-return))
+               ((drop)
+                ;; Well, shit. The proc might return any number of
+                ;; values (including 0), since it's in a drop context,
+                ;; yet apply does not create a MV continuation. So we
+                ;; mv-call out to our trampoline instead.
+                (comp-drop
+                 (make-application src (make-primitive-ref #f 'apply)
+                                   (cons proc args)))
+                (maybe-emit-return)))))))
+        
+        ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
+         ;; tail: (lambda () (values '(1 2)))
+         ;; drop: (lambda () (values '(1 2)) 3)
+         ;; push: (lambda () (list (values '(10 12)) 1))
+         ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+         (case context
+           ((drop) (for-each comp-drop args) (maybe-emit-return))
+           ((push)
+            (case (length args)
+              ((0)
+               ;; FIXME: This is surely an error.  We need to add a
+               ;; values-mismatch warning pass.
+               (emit-code src (make-glil-call 'new-frame 0))
+               (comp-push proc)
+               (emit-code src (make-glil-call 'call 0))
+               (maybe-emit-return))
+              (else
+               ;; Taking advantage of unspecified order of evaluation of
+               ;; arguments.
+               (for-each comp-drop (cdr args))
+               (comp-push (car args))
+               (maybe-emit-return))))
+           ((vals)
+            (for-each comp-push args)
+            (emit-code #f (make-glil-const (length args)))
+            (emit-branch src 'br MVRA))
+           ((tail)
+            (for-each comp-push args)
+            (emit-code src (let ((len (length args)))
+                             (if (= len 1)
+                                 (make-glil-call 'return 1)
+                                 (make-glil-call 'return/values len)))))))
+        
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@call-with-values)
+              (= (length args) 2))
+	 ;; CONSUMER
+         ;; PRODUCER
+         ;; (mv-call MV)
+         ;; ([tail]-call 1)
+         ;; goto POST
+         ;; MV: [tail-]call/nargs
+         ;; POST: (maybe-drop)
+         (case context
+           ((vals)
+            ;; Fall back.
+            (comp-vals
+             (make-application src (make-primitive-ref #f 'call-with-values)
+                               args)
+             MVRA)
+            (maybe-emit-return))
+           (else
+            (let ((MV (make-label)) (POST (make-label))
+                  (producer (car args)) (consumer (cadr args)))
+              (if (not (eq? context 'tail))
+                  (emit-code src (make-glil-call 'new-frame 0)))
+              (comp-push consumer)
+              (emit-code src (make-glil-call 'new-frame 0))
+              (comp-push producer)
+              (emit-code src (make-glil-mv-call 0 MV))
+              (case context
+                ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+                (else   (emit-code src (make-glil-call 'call 1))
+                        (emit-branch #f 'br POST)))
+              (emit-label MV)
+              (case context
+                ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+                (else   (emit-code src (make-glil-call 'call/nargs 0))
+                        (emit-label POST)
+                        (if (eq? context 'drop)
+                            (emit-code #f (make-glil-call 'drop 1)))
+                        (maybe-emit-return)))))))
+
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@call-with-current-continuation)
+              (= (length args) 1))
+         (case context
+           ((tail)
+            (comp-push (car args))
+            (emit-code src (make-glil-call 'tail-call/cc 1)))
+           ((vals)
+            (comp-vals
+             (make-application
+              src (make-primitive-ref #f 'call-with-current-continuation)
+              args)
+             MVRA)
+            (maybe-emit-return))
+           ((push)
+            (comp-push (car args))
+            (emit-code src (make-glil-call 'call/cc 1))
+            (maybe-emit-return))
+           ((drop)
+            ;; Crap. Just like `apply' in drop context.
+            (comp-drop
+             (make-application
+              src (make-primitive-ref #f 'call-with-current-continuation)
+              args))
+            (maybe-emit-return))))
+
+        ;; A hack for variable-set, the opcode for which takes its args
+        ;; reversed, relative to the variable-set! function
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) 'variable-set!)
+              (= (length args) 2))
+         (comp-push (cadr args))
+         (comp-push (car args))
+         (emit-code src (make-glil-call 'variable-set 2))
+         (case context
+           ((tail push vals) (emit-code #f (make-glil-void))))
+         (maybe-emit-return))
+        
+        ((and (primitive-ref? proc)
+              (or (hash-ref *primcall-ops*
+                            (cons (primitive-ref-name proc) (length args)))
+                  (hash-ref *primcall-ops* (primitive-ref-name proc))))
+         => (lambda (op)
+              (for-each comp-push args)
+              (emit-code src (make-glil-call op (length args)))
+              (case (instruction-pushes op)
+                ((0)
+                 (case context
+                   ((tail push vals) (emit-code #f (make-glil-void))))
+                 (maybe-emit-return))
+                ((1)
+                 (case context
+                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                 (maybe-emit-return))
+                ((-1)
+                 ;; A control instruction, like return/values.  Here we
+                 ;; just have to hope that the author of the tree-il
+                 ;; knew what they were doing.
+                 *unspecified*)
+                (else
+                 (error "bad primitive op: too many pushes"
+                        op (instruction-pushes op))))))
+        
+        ;; call to the same lambda-case in tail position
+        ((and (lexical-ref? proc)
+              self-label (eq? (lexical-ref-gensym proc) self-label)
+              (eq? context 'tail)
+              (not (lambda-case-kw lcase))
+              (not (lambda-case-rest lcase))
+              (= (length args)
+                 (+ (length (lambda-case-req lcase))
+                    (or (and=> (lambda-case-opt lcase) length) 0))))
+         (for-each comp-push args)
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t #f . ,index) ; unboxed
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       ((#t #t . ,index) ; boxed
+                        ;; new box
+                        (emit-code #f (make-glil-lexical #t #t 'box index)))
+                       (,x (error "bad lambda-case arg allocation" x))))
+                   (reverse (lambda-case-gensyms lcase)))
+         (emit-branch src 'br (car (hashq-ref allocation lcase))))
+        
+        ;; lambda, the ultimate goto
+        ((and (lexical-ref? proc)
+              (assq (lexical-ref-gensym proc) fix-labels))
+         ;; like the self-tail-call case, though we can handle "drop"
+         ;; contexts too. first, evaluate new values, pushing them on
+         ;; the stack
+         (for-each comp-push args)
+         ;; find the specific case, rename args, and goto the case label
+         (let lp ((lcase (lambda-body
+                          (assq-ref fix-labels (lexical-ref-gensym proc)))))
+           (cond
+            ((and (lambda-case? lcase)
+                  (not (lambda-case-kw lcase))
+                  (not (lambda-case-opt lcase))
+                  (not (lambda-case-rest lcase))
+                  (= (length args) (length (lambda-case-req lcase))))
+             ;; we have a case that matches the args; rename variables
+             ;; and goto the case label
+             (for-each (lambda (sym)
+                         (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                           ((#t #f . ,index) ; unboxed
+                            (emit-code #f (make-glil-lexical #t #f 'set index)))
+                           ((#t #t . ,index) ; boxed
+                            (emit-code #f (make-glil-lexical #t #t 'box index)))
+                           (,x (error "bad lambda-case arg allocation" x))))
+                       (reverse (lambda-case-gensyms lcase)))
+             (emit-branch src 'br (car (hashq-ref allocation lcase))))
+            ((lambda-case? lcase)
+             ;; no match, try next case
+             (lp (lambda-case-alternate lcase)))
+            (else
+             ;; no cases left. we can't really handle this currently.
+             ;; ideally we would push on a new frame, then do a "local
+             ;; call" -- which doesn't require consing up a program
+             ;; object. but for now error, as this sort of case should
+             ;; preclude label allocation.
+             (error "couldn't find matching case for label call" x)))))
+        
+        (else
+         (if (not (eq? context 'tail))
+             (emit-code src (make-glil-call 'new-frame 0)))
+         (comp-push proc)
+         (for-each comp-push args)
+         (let ((len (length args)))
+           (case context
+             ((tail) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'tail-call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'tail-call/nargs 0)))))
+             ((push) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'call/nargs 0))))
+                     (maybe-emit-return))
+             ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+             ;; limited to 255 args.  Can work around it with a
+             ;; trampoline and tail-call/nargs, but it's not so nice.
+             ((vals) (emit-code src (make-glil-mv-call len MVRA))
+                     (maybe-emit-return))
+             ((drop) (let ((MV (make-label)) (POST (make-label)))
+                       (emit-code src (make-glil-mv-call len MV))
+                       (emit-code #f (make-glil-call 'drop 1))
+                       (emit-branch #f 'br (or RA POST))
+                       (emit-label MV)
+                       (emit-code #f (make-glil-mv-bind 0 #f))
+                       (if RA
+                           (emit-branch #f 'br RA)
+                           (emit-label POST)))))))))
+
+      ((<conditional> src test consequent alternate)
+       ;;     TEST
+       ;;     (br-if-not L1)
+       ;;     consequent
+       ;;     (br L2)
+       ;; L1: alternate
+       ;; L2:
+       (let ((L1 (make-label)) (L2 (make-label)))
+         ;; need a pattern matcher
+         (record-case test
+           ((<application> proc args)
+            (record-case proc
+              ((<primitive-ref> name)
+               (let ((len (length args)))
+                 (cond
+
+                  ((and (eq? name 'eq?) (= len 2))
+                   (comp-push (car args))
+                   (comp-push (cadr args))
+                   (emit-branch src 'br-if-not-eq L1))
+
+                  ((and (eq? name 'null?) (= len 1))
+                   (comp-push (car args))
+                   (emit-branch src 'br-if-not-null L1))
+
+                  ((and (eq? name 'not) (= len 1))
+                   (let ((app (car args)))
+                     (record-case app
+                       ((<application> proc args)
+                        (let ((len (length args)))
+                          (record-case proc
+                            ((<primitive-ref> name)
+                             (cond
+
+                              ((and (eq? name 'eq?) (= len 2))
+                               (comp-push (car args))
+                               (comp-push (cadr args))
+                               (emit-branch src 'br-if-eq L1))
+                            
+                              ((and (eq? name 'null?) (= len 1))
+                               (comp-push (car args))
+                               (emit-branch src 'br-if-null L1))
+
+                              (else
+                               (comp-push app)
+                               (emit-branch src 'br-if L1))))
+                            (else
+                             (comp-push app)
+                             (emit-branch src 'br-if L1)))))
+                       (else
+                        (comp-push app)
+                        (emit-branch src 'br-if L1)))))
+                  
+                  (else
+                   (comp-push test)
+                   (emit-branch src 'br-if-not L1)))))
+              (else
+               (comp-push test)
+               (emit-branch src 'br-if-not L1))))
+           (else
+            (comp-push test)
+            (emit-branch src 'br-if-not L1)))
+
+         (comp-tail consequent)
+         ;; if there is an RA, comp-tail will cause a jump to it -- just
+         ;; have to clean up here if there is no RA.
+         (if (and (not RA) (not (eq? context 'tail)))
+             (emit-branch #f 'br L2))
+         (emit-label L1)
+         (comp-tail alternate)
+         (if (and (not RA) (not (eq? context 'tail)))
+             (emit-label L2))))
+      
+      ((<primitive-ref> src name)
+       (cond
+        ((eq? (module-variable (fluid-ref *comp-module*) name)
+              (module-variable the-root-module name))
+         (case context
+           ((tail push vals)
+            (emit-code src (make-glil-toplevel 'ref name))))
+         (maybe-emit-return))
+        ((module-variable the-root-module name)
+         (case context
+           ((tail push vals)
+            (emit-code src (make-glil-module 'ref '(guile) name #f))))
+         (maybe-emit-return))
+        (else
+         (case context
+           ((tail push vals)
+            (emit-code src (make-glil-module
+                            'ref (module-name (fluid-ref *comp-module*)) name #f))))
+         (maybe-emit-return))))
+
+      ((<lexical-ref> src gensym)
+       (case context
+         ((push vals tail)
+          (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+            ((,local? ,boxed? . ,index)
+             (emit-code src (make-glil-lexical local? boxed? 'ref index)))
+            (,loc
+             (error "bad lexical allocation" x loc)))))
+       (maybe-emit-return))
+      
+      ((<lexical-set> src gensym exp)
+       (comp-push exp)
+       (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+         ((,local? ,boxed? . ,index)
+          (emit-code src (make-glil-lexical local? boxed? 'set index)))
+         (,loc
+          (error "bad lexical allocation" x loc)))
+       (case context
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+      
+      ((<module-ref> src mod name public?)
+       (emit-code src (make-glil-module 'ref mod name public?))
+       (case context
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
+      
+      ((<module-set> src mod name public? exp)
+       (comp-push exp)
+       (emit-code src (make-glil-module 'set mod name public?))
+       (case context
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+
+      ((<toplevel-ref> src name)
+       (emit-code src (make-glil-toplevel 'ref name))
+       (case context
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
+      
+      ((<toplevel-set> src name exp)
+       (comp-push exp)
+       (emit-code src (make-glil-toplevel 'set name))
+       (case context
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+      
+      ((<toplevel-define> src name exp)
+       (comp-push exp)
+       (emit-code src (make-glil-toplevel 'define name))
+       (case context
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+
+      ((<lambda>)
+       (let ((free-locs (cdr (hashq-ref allocation x))))
+         (case context
+           ((push vals tail)
+            (emit-code #f (flatten-lambda x #f allocation))
+            (if (not (null? free-locs))
+                (begin
+                  (for-each
+                   (lambda (loc)
+                     (pmatch loc
+                       ((,local? ,boxed? . ,n)
+                        (emit-code #f (make-glil-lexical local? #f 'ref n)))
+                       (else (error "bad lambda free var allocation" x loc))))
+                   free-locs)
+                  (emit-code #f (make-glil-call 'make-closure
+                                                (length free-locs))))))))
+       (maybe-emit-return))
+      
+      ((<lambda-case> src req opt rest kw inits gensyms alternate body)
+       ;; o/~ feature on top of feature o/~
+       ;; req := (name ...)
+       ;; opt := (name ...) | #f
+       ;; rest := name | #f
+       ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+       ;; gensyms: (sym ...)
+       ;; init: tree-il in context of gensyms
+       ;; gensyms map to named arguments in the following order:
+       ;;  required, optional (positional), rest, keyword.
+       (let* ((nreq (length req))
+              (nopt (if opt (length opt) 0))
+              (rest-idx (and rest (+ nreq nopt)))
+              (opt-names (or opt '()))
+              (allow-other-keys? (if kw (car kw) #f))
+              (kw-indices (map (lambda (x)
+                                 (pmatch x
+                                   ((,key ,name ,var)
+                                    (cons key (list-index gensyms var)))
+                                   (else (error "bad kwarg" x))))
+                               (if kw (cdr kw) '())))
+              (nargs (apply max (+ nreq nopt (if rest 1 0))
+                            (map 1+ (map cdr kw-indices))))
+              (nlocs (cdr (hashq-ref allocation x)))
+              (alternate-label (and alternate (make-label))))
+         (or (= nargs
+                (length gensyms)
+                (+ nreq (length inits) (if rest 1 0)))
+             (error "lambda-case gensyms don't correspond to args"
+                    req opt rest kw inits gensyms nreq nopt kw-indices nargs))
+         ;; the prelude, to check args & reset the stack pointer,
+         ;; allowing room for locals
+         (emit-code
+          src
+          (cond
+           (kw
+            (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+                                  allow-other-keys? nlocs alternate-label))
+           ((or rest opt)
+            (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
+           (#t
+            (make-glil-std-prelude nreq nlocs alternate-label))))
+         ;; box args if necessary
+         (for-each
+          (lambda (v)
+            (pmatch (hashq-ref (hashq-ref allocation v) self)
+              ((#t #t . ,n)
+               (emit-code #f (make-glil-lexical #t #f 'ref n))
+               (emit-code #f (make-glil-lexical #t #t 'box n)))))
+          gensyms)
+         ;; write bindings info
+         (if (not (null? gensyms))
+             (emit-bindings
+              #f
+              (let lp ((kw (if kw (cdr kw) '()))
+                       (names (append (reverse opt-names) (reverse req)))
+                       (gensyms (list-tail gensyms (+ nreq nopt
+                                                (if rest 1 0)))))
+                (pmatch kw
+                  (()
+                   ;; fixme: check that gensyms is empty
+                   (reverse (if rest (cons rest names) names)))
+                  (((,key ,name ,var) . ,kw)
+                   (if (memq var gensyms)
+                       (lp kw (cons name names) (delq var gensyms))
+                       (lp kw names gensyms)))
+                  (,kw (error "bad keywords, yo" kw))))
+              gensyms allocation self emit-code))
+         ;; init optional/kw args
+         (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
+           (cond
+            ((null? inits))             ; done
+            ((and rest-idx (= n rest-idx))
+             (lp inits (1+ n) (cdr gensyms)))
+            (#t
+             (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
+               ((#t ,boxed? . ,n*) (guard (= n* n))
+                (let ((L (make-label)))
+                  (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+                  (emit-code #f (make-glil-branch 'br-if L))
+                  (comp-push (car inits))
+                  (emit-code #f (make-glil-lexical #t boxed? 'set n))
+                  (emit-label L)
+                  (lp (cdr inits) (1+ n) (cdr gensyms))))
+               (#t (error "bad arg allocation" (car gensyms) inits))))))
+         ;; post-prelude case label for label calls
+         (emit-label (car (hashq-ref allocation x)))
+         (comp-tail body)
+         (if (not (null? gensyms))
+             (emit-code #f (make-glil-unbind)))
+         (if alternate-label
+             (begin
+               (emit-label alternate-label)
+               (flatten-lambda-case alternate allocation self self-label
+                                    fix-labels emit-code)))))
+      
+      ((<let> src names gensyms vals body)
+       (for-each comp-push vals)
+       (emit-bindings src names gensyms allocation self emit-code)
+       (for-each (lambda (v)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
+                     ((#t #f . ,n)
+                      (emit-code src (make-glil-lexical #t #f 'set n)))
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'box n)))
+                     (,loc (error "bad let var allocation" x loc))))
+                 (reverse gensyms))
+       (comp-tail body)
+       (clear-stack-slots context gensyms)
+       (emit-code #f (make-glil-unbind)))
+
+      ((<letrec> src in-order? names gensyms vals body)
+       ;; First prepare heap storage slots.
+       (for-each (lambda (v)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+                     (,loc (error "bad letrec var allocation" x loc))))
+                 gensyms)
+       ;; Even though the slots are empty, the bindings are valid.
+       (emit-bindings src names gensyms allocation self emit-code)
+       (cond
+        (in-order?
+         ;; For letrec*, bind values in order.
+         (for-each (lambda (name v val)
+                     (pmatch (hashq-ref (hashq-ref allocation v) self)
+                       ((#t #t . ,n)
+                        (comp-push val)
+                        (emit-code src (make-glil-lexical #t #t 'set n)))
+                       (,loc (error "bad letrec var allocation" x loc))))
+                   names gensyms vals))
+        (else
+         ;; But for letrec, eval all values, then bind.
+         (for-each comp-push vals)
+         (for-each (lambda (v)
+                     (pmatch (hashq-ref (hashq-ref allocation v) self)
+                       ((#t #t . ,n)
+                        (emit-code src (make-glil-lexical #t #t 'set n)))
+                       (,loc (error "bad letrec var allocation" x loc))))
+                   (reverse gensyms))))
+       (comp-tail body)
+       (clear-stack-slots context gensyms)
+       (emit-code #f (make-glil-unbind)))
+
+      ((<fix> src names gensyms vals body)
+       ;; The ideal here is to just render the lambda bodies inline, and
+       ;; wire the code together with gotos. We can do that if
+       ;; analyze-lexicals has determined that a given var has "label"
+       ;; allocation -- which is the case if it is in `fix-labels'.
+       ;;
+       ;; But even for closures that we can't inline, we can do some
+       ;; tricks to avoid heap-allocation for the binding itself. Since
+       ;; we know the vals are lambdas, we can set them to their local
+       ;; var slots first, then capture their bindings, mutating them in
+       ;; place.
+       (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
+         (for-each
+          (lambda (x v)
+            (cond
+             ((hashq-ref allocation x)
+              ;; allocating a closure
+              (emit-code #f (flatten-lambda x v allocation))
+              (let ((free-locs (cdr (hashq-ref allocation x))))
+                (if (not (null? free-locs))
+                    ;; Need to make-closure first, so we have a fresh closure on
+                    ;; the heap, but with a temporary free values.
+                    (begin
+                      (for-each (lambda (loc)
+                                  (emit-code #f (make-glil-const #f)))
+                                free-locs)
+                      (emit-code #f (make-glil-call 'make-closure
+                                                    (length free-locs))))))
+              (pmatch (hashq-ref (hashq-ref allocation v) self)
+                ((#t #f . ,n)
+                 (emit-code src (make-glil-lexical #t #f 'set n)))
+                (,loc (error "bad fix var allocation" x loc))))
+             (else
+              ;; labels allocation: emit label & body, but jump over it
+              (let ((POST (make-label)))
+                (emit-branch #f 'br POST)
+                (let lp ((lcase (lambda-body x)))
+                  (if lcase
+                      (record-case lcase
+                        ((<lambda-case> src req gensyms body alternate)
+                         (emit-label (car (hashq-ref allocation lcase)))
+                         ;; FIXME: opt & kw args in the bindings
+                         (emit-bindings #f req gensyms allocation self emit-code)
+                         (if src
+                             (emit-code #f (make-glil-source src)))
+                         (comp-fix body (or RA new-RA))
+                         (emit-code #f (make-glil-unbind))
+                         (lp alternate)))
+                      (emit-label POST)))))))
+          vals
+          gensyms)
+         ;; Emit bindings metadata for closures
+         (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
+                        (cond ((null? gensyms) (reverse! out))
+                              ((assq (car gensyms) fix-labels)
+                               (lp out (cdr gensyms) (cdr names)))
+                              (else
+                               (lp (acons (car gensyms) (car names) out)
+                                   (cdr gensyms) (cdr names)))))))
+           (emit-bindings src (map cdr binds) (map car binds)
+                          allocation self emit-code))
+         ;; Now go back and fix up the bindings for closures.
+         (for-each
+          (lambda (x v)
+            (let ((free-locs (if (hashq-ref allocation x)
+                                 (cdr (hashq-ref allocation x))
+                                 ;; can hit this latter case for labels allocation
+                                 '())))
+              (if (not (null? free-locs))
+                  (begin
+                    (for-each
+                     (lambda (loc)
+                       (pmatch loc
+                         ((,local? ,boxed? . ,n)
+                          (emit-code #f (make-glil-lexical local? #f 'ref n)))
+                         (else (error "bad free var allocation" x loc))))
+                     free-locs)
+                    (pmatch (hashq-ref (hashq-ref allocation v) self)
+                      ((#t #f . ,n)
+                       (emit-code #f (make-glil-lexical #t #f 'fix n)))
+                      (,loc (error "bad fix var allocation" x loc)))))))
+          vals
+          gensyms)
+         (comp-tail body)
+         (if new-RA
+             (emit-label new-RA))
+         (clear-stack-slots context gensyms)
+         (emit-code #f (make-glil-unbind))))
+
+      ((<let-values> src exp body)
+       (record-case body
+         ((<lambda-case> req opt kw rest gensyms body alternate)
+          (if (or opt kw alternate)
+              (error "unexpected lambda-case in let-values" x))
+          (let ((MV (make-label)))
+            (comp-vals exp MV)
+            (emit-code #f (make-glil-const 1))
+            (emit-label MV)
+            (emit-code src (make-glil-mv-bind
+                            (vars->bind-list
+                             (append req (if rest (list rest) '()))
+                             gensyms allocation self)
+                            (and rest #t)))
+            (for-each (lambda (v)
+                        (pmatch (hashq-ref (hashq-ref allocation v) self)
+                          ((#t #f . ,n)
+                           (emit-code src (make-glil-lexical #t #f 'set n)))
+                          ((#t #t . ,n)
+                           (emit-code src (make-glil-lexical #t #t 'box n)))
+                          (,loc (error "bad let-values var allocation" x loc))))
+                      (reverse gensyms))
+            (comp-tail body)
+            (clear-stack-slots context gensyms)
+            (emit-code #f (make-glil-unbind))))))
+
+      ;; much trickier than i thought this would be, at first, due to the need
+      ;; to have body's return value(s) on the stack while the unwinder runs,
+      ;; then proceed with returning or dropping or what-have-you, interacting
+      ;; with RA and MVRA. What have you, I say.
+      ((<dynwind> src body winder unwinder)
+       (comp-push winder)
+       (comp-push unwinder)
+       (comp-drop (make-application src winder '()))
+       (emit-code #f (make-glil-call 'wind 2))
+
+       (case context
+         ((tail)
+          (let ((MV (make-label)))
+            (comp-vals body MV)
+            ;; one value: unwind...
+            (emit-code #f (make-glil-call 'unwind 0))
+            (comp-drop (make-application src unwinder '()))
+            ;; ...and return the val
+            (emit-code #f (make-glil-call 'return 1))
+            
+            (emit-label MV)
+            ;; multiple values: unwind...
+            (emit-code #f (make-glil-call 'unwind 0))
+            (comp-drop (make-application src unwinder '()))
+            ;; and return the values.
+            (emit-code #f (make-glil-call 'return/nvalues 1))))
+         
+         ((push)
+          ;; we only want one value. so ask for one value
+          (comp-push body)
+          ;; and unwind, leaving the val on the stack
+          (emit-code #f (make-glil-call 'unwind 0))
+          (comp-drop (make-application src unwinder '())))
+         
+         ((vals)
+          (let ((MV (make-label)))
+            (comp-vals body MV)
+            ;; one value: push 1 and fall through to MV case
+            (emit-code #f (make-glil-const 1))
+            
+            (emit-label MV)
+            ;; multiple values: unwind...
+            (emit-code #f (make-glil-call 'unwind 0))
+            (comp-drop (make-application src unwinder '()))
+            ;; and goto the MVRA.
+            (emit-branch #f 'br MVRA)))
+         
+         ((drop)
+          ;; compile body, discarding values. then unwind...
+          (comp-drop body)
+          (emit-code #f (make-glil-call 'unwind 0))
+          (comp-drop (make-application src unwinder '()))
+          ;; and fall through, or goto RA if there is one.
+          (if RA
+              (emit-branch #f 'br RA)))))
+
+      ((<dynlet> src fluids vals body)
+       (for-each comp-push fluids)
+       (for-each comp-push vals)
+       (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
+
+       (case context
+         ((tail)
+          (let ((MV (make-label)))
+            ;; NB: in tail case, it is possible to preserve asymptotic tail
+            ;; recursion, via merging unwind-fluids structures -- but we'd need
+            ;; to compile in the body twice (once in tail context, assuming the
+            ;; caller unwinds, and once with this trampoline thing, unwinding
+            ;; ourselves).
+            (comp-vals body MV)
+            ;; one value: unwind and return
+            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (emit-code #f (make-glil-call 'return 1))
+            
+            (emit-label MV)
+            ;; multiple values: unwind and return values
+            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (emit-code #f (make-glil-call 'return/nvalues 1))))
+         
+         ((push)
+          (comp-push body)
+          (emit-code #f (make-glil-call 'unwind-fluids 0)))
+         
+         ((vals)
+          (let ((MV (make-label)))
+            (comp-vals body MV)
+            ;; one value: push 1 and fall through to MV case
+            (emit-code #f (make-glil-const 1))
+            
+            (emit-label MV)
+            ;; multiple values: unwind and goto MVRA
+            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (emit-branch #f 'br MVRA)))
+         
+         ((drop)
+          ;; compile body, discarding values. then unwind...
+          (comp-drop body)
+          (emit-code #f (make-glil-call 'unwind-fluids 0))
+          ;; and fall through, or goto RA if there is one.
+          (if RA
+              (emit-branch #f 'br RA)))))
+
+      ((<dynref> src fluid)
+       (case context
+         ((drop)
+          (comp-drop fluid))
+         ((push vals tail)
+          (comp-push fluid)
+          (emit-code #f (make-glil-call 'fluid-ref 1))))
+       (maybe-emit-return))
+      
+      ((<dynset> src fluid exp)
+       (comp-push fluid)
+       (comp-push exp)
+       (emit-code #f (make-glil-call 'fluid-set 2))
+       (case context
+         ((push vals tail)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
+      
+      ;; What's the deal here? The deal is that we are compiling the start of a
+      ;; delimited continuation. We try to avoid heap allocation in the normal
+      ;; case; so the body is an expression, not a thunk, and we try to render
+      ;; the handler inline. Also we did some analysis, in analyze.scm, so that
+      ;; if the continuation isn't referenced, we don't reify it. This makes it
+      ;; possible to implement catch and throw with delimited continuations,
+      ;; without any overhead.
+      ((<prompt> src tag body handler)
+       (let ((H (make-label))
+             (POST (make-label))
+             (escape-only? (hashq-ref allocation x)))
+         ;; First, set up the prompt.
+         (comp-push tag)
+         (emit-code src (make-glil-prompt H escape-only?))
+
+         ;; Then we compile the body, with its normal return path, unwinding
+         ;; before proceeding.
+         (case context
+           ((tail)
+            (let ((MV (make-label)))
+              (comp-vals body MV)
+              ;; one value: unwind and return
+              (emit-code #f (make-glil-call 'unwind 0))
+              (emit-code #f (make-glil-call 'return 1))
+              ;; multiple values: unwind and return
+              (emit-label MV)
+              (emit-code #f (make-glil-call 'unwind 0))
+              (emit-code #f (make-glil-call 'return/nvalues 1))))
+         
+           ((push)
+            ;; we only want one value. so ask for one value, unwind, and jump to
+            ;; post
+            (comp-push body)
+            (emit-code #f (make-glil-call 'unwind 0))
+            (emit-branch #f 'br (or RA POST)))
+           
+           ((vals)
+            (let ((MV (make-label)))
+              (comp-vals body MV)
+              ;; one value: push 1 and fall through to MV case
+              (emit-code #f (make-glil-const 1))
+              ;; multiple values: unwind and goto MVRA
+              (emit-label MV)
+              (emit-code #f (make-glil-call 'unwind 0))
+              (emit-branch #f 'br MVRA)))
+         
+           ((drop)
+            ;; compile body, discarding values, then unwind & fall through.
+            (comp-drop body)
+            (emit-code #f (make-glil-call 'unwind 0))
+            (emit-branch #f 'br (or RA POST))))
+         
+         (emit-label H)
+         ;; Now the handler. The stack is now made up of the continuation, and
+         ;; then the args to the continuation (pushed separately), and then the
+         ;; number of args, including the continuation.
+         (record-case handler
+           ((<lambda-case> req opt kw rest gensyms body alternate)
+            (if (or opt kw alternate)
+                (error "unexpected lambda-case in prompt" x))
+            (emit-code src (make-glil-mv-bind
+                            (vars->bind-list
+                             (append req (if rest (list rest) '()))
+                             gensyms allocation self)
+                            (and rest #t)))
+            (for-each (lambda (v)
+                        (pmatch (hashq-ref (hashq-ref allocation v) self)
+                          ((#t #f . ,n)
+                           (emit-code src (make-glil-lexical #t #f 'set n)))
+                          ((#t #t . ,n)
+                           (emit-code src (make-glil-lexical #t #t 'box n)))
+                          (,loc
+                           (error "bad prompt handler arg allocation" x loc))))
+                      (reverse gensyms))
+            (comp-tail body)
+            (emit-code #f (make-glil-unbind))))
+
+         (if (and (not RA)
+                  (or (eq? context 'push) (eq? context 'drop)))
+             (emit-label POST))))
+
+      ((<abort> src tag args tail)
+       (comp-push tag)
+       (for-each comp-push args)
+       (comp-push tail)
+       (emit-code src (make-glil-call 'abort (length args)))
+       ;; so, the abort can actually return. if it does, the values will be on
+       ;; the stack, then the MV marker, just as in an MV context.
+       (case context
+         ((tail)
+          ;; Return values.
+          (emit-code #f (make-glil-call 'return/nvalues 1)))
+         ((drop)
+          ;; Drop all values and goto RA, or otherwise fall through.
+          (emit-code #f (make-glil-mv-bind 0 #f))
+          (if RA (emit-branch #f 'br RA)))
+         ((push)
+          ;; Truncate to one value.
+          (emit-code #f (make-glil-mv-bind 1 #f)))
+         ((vals)
+          ;; Go to MVRA.
+          (emit-branch #f 'br MVRA)))))))
+;;; Common Subexpression Elimination (CSE) on Tree-IL
+
+;; Copyright (C) 2011, 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 (language tree-il cse)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il primitives)
+  #\use-module (language tree-il effects)
+  #\use-module (ice-9 vlist)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\export (cse))
+
+;;;
+;;; This pass eliminates common subexpressions in Tree-IL.  It works
+;;; best locally -- within a function -- so it is meant to be run after
+;;; partial evaluation, which usually inlines functions and so opens up
+;;; a bigger space for CSE to work.
+;;;
+;;; The algorithm traverses the tree of expressions, returning two
+;;; values: the newly rebuilt tree, and a "database".  The database is
+;;; the set of expressions that will have been evaluated as part of
+;;; evaluating an expression.  For example, in:
+;;;
+;;;   (1- (+ (if a b c) (* x y)))
+;;;
+;;; We can say that when it comes time to evaluate (1- <>), that the
+;;; subexpressions +, x, y, and (* x y) must have been evaluated in
+;;; values context.  We know that a was evaluated in test context, but
+;;; we don't know if it was true or false.
+;;;
+;;; The expressions in the database /dominate/ any subsequent
+;;; expression: FOO dominates BAR if evaluation of BAR implies that any
+;;; effects associated with FOO have already occured.
+;;;
+;;; When adding expressions to the database, we record the context in
+;;; which they are evaluated.  We treat expressions in test context
+;;; specially: the presence of such an expression indicates that the
+;;; expression is true.  In this way we can elide duplicate predicates.
+;;;
+;;; Duplicate predicates are not common in code that users write, but
+;;; can occur quite frequently in macro-generated code.
+;;;
+;;; For example:
+;;;
+;;;   (and (foo? x) (foo-bar x))
+;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;          (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;              (struct-ref x 1)
+;;;              (throw 'not-a-foo))
+;;;          #f))
+;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;          (struct-ref x 1)
+;;;          #f)
+;;;
+;;; A conditional bailout in effect context also has the effect of
+;;; adding predicates to the database:
+;;;
+;;;   (begin (foo-bar x) (foo-baz x))
+;;;   => (begin
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 1)
+;;;            (throw 'not-a-foo))
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 2)
+;;;            (throw 'not-a-foo)))
+;;;   => (begin
+;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;;            (struct-ref x 1)
+;;;            (throw 'not-a-foo))
+;;;        (struct-ref x 2))
+;;;
+;;; When removing code, we have to ensure that the semantics of the
+;;; source program and the residual program are the same.  It's easy to
+;;; ensure that they have the same value, because those manipulations
+;;; are just algebraic, but the tricky thing is to ensure that the
+;;; expressions exhibit the same ordering of effects.  For that, we use
+;;; the effects analysis of (language tree-il effects).  We only
+;;; eliminate code if the duplicate code commutes with all of the
+;;; dominators on the path from the duplicate to the original.
+;;;
+;;; The implementation uses vhashes as the fundamental data structure.
+;;; This can be seen as a form of global value numbering.  This
+;;; algorithm currently spends most of its time in vhash-assoc.  I'm not
+;;; sure whether that is due to our bad hash function in Guile 2.0, an
+;;; inefficiency in vhashes, or what.  Overall though the complexity
+;;; should be linear, or N log N -- whatever vhash-assoc's complexity
+;;; is.  Walking the dominators is nonlinear, but that only happens when
+;;; we've actually found a common subexpression so that should be OK.
+;;;
+
+;; Logging helpers, as in peval.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+;; (define %logging #f)
+;; (define-syntax *logging* (identifier-syntax %logging))
+(define-syntax log
+  (syntax-rules (quote)
+    ((log 'event arg ...)
+     (if (and *logging*
+              (or (eq? *logging* #t)
+                  (memq 'event *logging*)))
+         (log* 'event arg ...)))))
+(define (log* event . args)
+  (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+                        'pretty-print)))
+    (pp `(log ,event . ,args))
+    (newline)
+    (values)))
+
+;; A pre-pass on the source program to determine the set of assigned
+;; lexicals.
+;;
+(define* (build-assigned-var-table exp #\optional (table vlist-null))
+  (tree-il-fold
+   (lambda (exp res)
+     res)
+   (lambda (exp res)
+     (match exp
+       (($ <lexical-set> src name gensym exp)
+        (vhash-consq gensym #t res))
+       (_ res)))
+   (lambda (exp res) res)
+   table exp))
+
+(define (boolean-valued-primitive? primitive)
+  (or (negate-primitive primitive)
+      (eq? primitive 'not)
+      (let ((chars (symbol->string primitive)))
+        (eqv? (string-ref chars (1- (string-length chars)))
+              #\?))))
+
+(define (boolean-valued-expression? x ctx)
+  (match x
+    (($ <application> _
+        ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+    (($ <const> _ (? boolean?)) #t)
+    (_ (eq? ctx 'test))))
+
+(define (singly-valued-expression? x ctx)
+  (match x
+    (($ <const>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <void>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <primitive-ref>) #t)
+    (($ <module-ref>) #t)
+    (($ <toplevel-ref>) #t)
+    (($ <application> _
+        ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
+    (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+    (($ <lambda>) #t)
+    (_ (eq? ctx 'value))))
+
+(define* (cse exp)
+  "Eliminate common subexpressions in EXP."
+
+  (define assigned-lexical?
+    (let ((table (build-assigned-var-table exp)))
+      (lambda (sym)
+        (vhash-assq sym table))))
+
+  (define %compute-effects
+    (make-effects-analyzer assigned-lexical?))
+
+  (define (negate exp ctx)
+    (match exp
+      (($ <const> src x)
+       (make-const src (not x)))
+      (($ <void> src)
+       (make-const src #f))
+      (($ <conditional> src test consequent alternate)
+       (make-conditional src test (negate consequent ctx) (negate alternate ctx)))
+      (($ <application> _ ($ <primitive-ref> _ 'not)
+          ((and x (? (cut boolean-valued-expression? <> ctx)))))
+       x)
+      (($ <application> src
+          ($ <primitive-ref> _ (and pred (? negate-primitive)))
+          args)
+       (make-application src
+                         (make-primitive-ref #f (negate-primitive pred))
+                         args))
+      (_
+       (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+
+  
+  (define (hasher n)
+    (lambda (x size) (modulo n size)))
+
+  (define (add-to-db exp effects ctx db)
+    (let ((v (vector exp effects ctx))
+          (h (tree-il-hash exp)))
+      (vhash-cons v h db (hasher h))))
+
+  (define (control-flow-boundary db)
+    (let ((h (hashq 'lambda most-positive-fixnum)))
+      (vhash-cons 'lambda h db (hasher h))))
+
+  (define (find-dominating-expression exp effects ctx db)
+    (define (entry-matches? v1 v2)
+      (match (if (vector? v1) v1 v2)
+        (#(exp* effects* ctx*)
+         (and (tree-il=? exp exp*)
+              (or (not ctx) (eq? ctx* ctx))))
+        (_ #f)))
+      
+    (let ((len (vlist-length db))
+          (h (tree-il-hash exp)))
+      (and (vhash-assoc #t db entry-matches? (hasher h))
+           (let lp ((n 0))
+             (and (< n len)
+                  (match (vlist-ref db n)
+                    (('lambda . h*)
+                     ;; We assume that lambdas can escape and thus be
+                     ;; called from anywhere.  Thus code inside a lambda
+                     ;; only has a dominating expression if it does not
+                     ;; depend on any effects.
+                     (and (not (depends-on-effects? effects &all-effects))
+                          (lp (1+ n))))
+                    ((#(exp* effects* ctx*) . h*)
+                     (log 'walk (unparse-tree-il exp) effects
+                          (unparse-tree-il exp*) effects* ctx*)
+                     (or (and (= h h*)
+                              (or (not ctx) (eq? ctx ctx*))
+                              (tree-il=? exp exp*))
+                         (and (effects-commute? effects effects*)
+                              (lp (1+ n)))))))))))
+
+  ;; Return #t if EXP is dominated by an instance of itself.  In that
+  ;; case, we can exclude *type-check* effects, because the first
+  ;; expression already caused them if needed.
+  (define (has-dominating-effect? exp effects db)
+    (or (constant? effects)
+        (and
+         (effect-free?
+          (exclude-effects effects
+                           (logior &zero-values
+                                   &allocation
+                                   &type-check)))
+         (find-dominating-expression exp effects #f db))))
+
+  (define (find-dominating-test exp effects db)
+    (and
+     (effect-free?
+      (exclude-effects effects (logior &allocation
+                                       &type-check)))
+     (match exp
+       (($ <const> src val)
+        (if (boolean? val)
+            exp
+            (make-const src (not (not val)))))
+       ;; For (not FOO), try to prove FOO, then negate the result.
+       (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+        (match (find-dominating-test exp* effects db)
+          (($ <const> _ val)
+           (log 'inferring exp (not val))
+           (make-const src (not val)))
+          (_
+           #f)))
+       (_
+        (cond
+         ((find-dominating-expression exp effects 'test db)
+          ;; We have an EXP fact, so we infer #t.
+          (log 'inferring exp #t)
+          (make-const (tree-il-src exp) #t))
+         ((find-dominating-expression (negate exp 'test) effects 'test db)
+          ;; We have a (not EXP) fact, so we infer #f.
+          (log 'inferring exp #f)
+          (make-const (tree-il-src exp) #f))
+         (else
+          ;; Otherwise we don't know.
+          #f))))))
+
+  (define (add-to-env exp name sym db env)
+    (let* ((v (vector exp name sym (vlist-length db)))
+           (h (tree-il-hash exp)))
+      (vhash-cons v h env (hasher h))))
+
+  (define (augment-env env names syms exps db)
+    (if (null? names)
+        env
+        (let ((name (car names)) (sym (car syms)) (exp (car exps)))
+          (augment-env (if (or (assigned-lexical? sym)
+                               (lexical-ref? exp))
+                           env
+                           (add-to-env exp name sym db env))
+                       (cdr names) (cdr syms) (cdr exps) db))))
+
+  (define (find-dominating-lexical exp effects env db)
+    (define (entry-matches? v1 v2)
+      (match (if (vector? v1) v1 v2)
+        (#(exp* name sym db)
+         (tree-il=? exp exp*))
+        (_ #f)))
+      
+    (define (unroll db base n)
+      (or (zero? n)
+          (match (vlist-ref db base)
+            (('lambda . h*)
+             ;; See note in find-dominating-expression.
+             (and (not (depends-on-effects? effects &all-effects))
+                  (unroll db (1+ base) (1- n))))
+            ((#(exp* effects* ctx*) . h*)
+             (and (effects-commute? effects effects*)
+                  (unroll db (1+ base) (1- n)))))))
+
+    (let ((h (tree-il-hash exp)))
+      (and (effect-free? (exclude-effects effects &type-check))
+           (vhash-assoc exp env entry-matches? (hasher h))
+           (let ((env-len (vlist-length env))
+                 (db-len (vlist-length db)))
+             (let lp ((n 0) (m 0))
+               (and (< n env-len)
+                    (match (vlist-ref env n)
+                      ((#(exp* name sym db-len*) . h*)
+                       (let ((niter (- (- db-len db-len*) m)))
+                         (and (unroll db m niter)
+                              (if (and (= h h*) (tree-il=? exp* exp))
+                                  (make-lexical-ref (tree-il-src exp) name sym)
+                                  (lp (1+ n) (- db-len db-len*)))))))))))))
+
+  (define (lookup-lexical sym env)
+    (let ((env-len (vlist-length env)))
+      (let lp ((n 0))
+        (and (< n env-len)
+             (match (vlist-ref env n)
+               ((#(exp _ sym* _) . _)
+                (if (eq? sym sym*)
+                    exp
+                    (lp (1+ n)))))))))
+
+  (define (intersection db+ db-)
+    (vhash-fold-right
+     (lambda (k h out)
+       (if (vhash-assoc k db- equal? (hasher h))
+           (vhash-cons k h out (hasher h))
+           out))
+     vlist-null
+     db+))
+
+  (define (concat db1 db2)
+    (vhash-fold-right (lambda (k h tail)
+                        (vhash-cons k h tail (hasher h)))
+                      db2 db1))
+
+  (let visit ((exp   exp)
+              (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash
+              (env vlist-null) ; named expressions: #(exp name sym db) -> hash
+              (ctx 'values)) ; test, effect, value, or values
+    
+    (define (parallel-visit exps db env ctx)
+      (let lp ((in exps) (out '()) (db* vlist-null))
+        (if (pair? in)
+            (call-with-values (lambda () (visit (car in) db env ctx))
+              (lambda (x db**)
+                (lp (cdr in) (cons x out) (concat db** db*))))
+            (values (reverse out) db*))))
+
+    (define (compute-effects exp)
+      (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+    (define (bailout? exp)
+      (causes-effects? (compute-effects exp) &definite-bailout))
+
+    (define (return exp db*)
+      (let ((effects (compute-effects exp)))
+        (cond
+         ((and (eq? ctx 'effect)
+               (not (lambda-case? exp))
+               (or (effect-free?
+                    (exclude-effects effects
+                                     (logior &zero-values
+                                             &allocation)))
+                   (has-dominating-effect? exp effects db)))
+          (cond
+           ((void? exp)
+            (values exp db*))
+           (else
+            (log 'elide ctx (unparse-tree-il exp))
+            (values (make-void #f) db*))))
+         ((and (boolean-valued-expression? exp ctx)
+               (find-dominating-test exp effects db))
+          => (lambda (exp)
+               (log 'propagate-test ctx (unparse-tree-il exp))
+               (values exp db*)))
+         ((and (singly-valued-expression? exp ctx)
+               (find-dominating-lexical exp effects env db))
+          => (lambda (exp)
+               (log 'propagate-value ctx (unparse-tree-il exp))
+               (values exp db*)))
+         ((and (constant? effects) (memq ctx '(value values)))
+          ;; Adds nothing to the db.
+          (values exp db*))
+         (else
+          (log 'return ctx effects (unparse-tree-il exp) db*)
+          (values exp
+                  (add-to-db exp effects ctx db*))))))
+
+    (log 'visit ctx (unparse-tree-il exp) db env)
+
+    (match exp
+      (($ <const>)
+       (return exp vlist-null))
+      (($ <void>)
+       (return exp vlist-null))
+      (($ <lexical-ref> _ _ gensym)
+       (return exp vlist-null))
+      (($ <lexical-set> src name gensym exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-lexical-set src name gensym exp)
+                 db*)))
+      (($ <let> src names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db)
+                                         (augment-env env names gensyms vals db)
+                                         ctx)))
+         (return (make-let src names gensyms vals body)
+                 (concat db** db*))))
+      (($ <letrec> src in-order? names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db)
+                                         (augment-env env names gensyms vals db)
+                                         ctx)))
+         (return (make-letrec src in-order? names gensyms vals body)
+                 (concat db** db*))))
+      (($ <fix> src names gensyms vals body)
+       (let*-values (((vals db*) (parallel-visit vals db env 'value))
+                     ((body db**) (visit body (concat db* db) env ctx)))
+         (return (make-fix src names gensyms vals body)
+                 (concat db** db*))))
+      (($ <let-values> src producer consumer)
+       (let*-values (((producer db*) (visit producer db env 'values))
+                     ((consumer db**) (visit consumer (concat db* db) env ctx)))
+         (return (make-let-values src producer consumer)
+                 (concat db** db*))))
+      (($ <dynwind> src winder body unwinder)
+       (let*-values (((pre db*) (visit winder db env 'value))
+                     ((body db**) (visit body (concat db* db) env ctx))
+                     ((post db***) (visit unwinder db env 'value)))
+         (return (make-dynwind src pre body post)
+                 (concat db* (concat db** db***)))))
+      (($ <dynlet> src fluids vals body)
+       (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
+                     ((vals db**) (parallel-visit vals db env 'value))
+                     ((body db***) (visit body (concat db** (concat db* db))
+                                          env ctx)))
+         (return (make-dynlet src fluids vals body)
+                 (concat db*** (concat db** db*)))))
+      (($ <dynref> src fluid)
+       (let*-values (((fluid db*) (visit fluid db env 'value)))
+         (return (make-dynref src fluid)
+                 db*)))
+      (($ <dynset> src fluid exp)
+       (let*-values (((fluid db*) (visit fluid db env 'value))
+                     ((exp db**) (visit exp db env 'value)))
+         (return (make-dynset src fluid exp)
+                 (concat db** db*))))
+      (($ <toplevel-ref>)
+       (return exp vlist-null))
+      (($ <module-ref>)
+       (return exp vlist-null))
+      (($ <module-set> src mod name public? exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-module-set src mod name public? exp)
+                 db*)))
+      (($ <toplevel-define> src name exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-toplevel-define src name exp)
+                 db*)))
+      (($ <toplevel-set> src name exp)
+       (let*-values (((exp db*) (visit exp db env 'value)))
+         (return (make-toplevel-set src name exp)
+                 db*)))
+      (($ <primitive-ref>)
+       (return exp vlist-null))
+      (($ <conditional> src test consequent alternate)
+       (let*-values
+           (((test db+) (visit test db env 'test))
+            ((converse db-) (visit (negate test 'test) db env 'test))
+            ((consequent db++) (visit consequent (concat db+ db) env ctx))
+            ((alternate db--) (visit alternate (concat db- db) env ctx)))
+         (match (make-conditional src test consequent alternate)
+           (($ <conditional> _ ($ <const> _ exp))
+            (if exp
+                (return consequent (concat db++ db+))
+                (return alternate (concat db-- db-))))
+           ;; (if FOO A A) => (begin FOO A)
+           (($ <conditional> src _
+               ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
+            (visit (make-sequence #f (list test (make-const #f a)))
+                   db env ctx))
+           ;; (if FOO #t #f) => FOO for boolean-valued FOO.
+           (($ <conditional> src
+               (? (cut boolean-valued-expression? <> ctx))
+               ($ <const> _ #t) ($ <const> _ #f))
+            (return test db+))
+           ;; (if FOO #f #t) => (not FOO)
+           (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
+            (visit (negate test ctx) db env ctx))
+
+           ;; Allow "and"-like conditions to accumulate in test context.
+           ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
+            (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
+           ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
+            (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
+
+           ;; Conditional bailouts turn expressions into predicates.
+           ((and c ($ <conditional> _ _ _ (? bailout?)))
+            (return c (concat db++ db+)))
+           ((and c ($ <conditional> _ _ (? bailout?) _))
+            (return c (concat db-- db-)))
+
+           (c
+            (return c (intersection (concat db++ db+) (concat db-- db-)))))))
+      (($ <application> src proc args)
+       (let*-values (((proc db*) (visit proc db env 'value))
+                     ((args db**) (parallel-visit args db env 'value)))
+         (return (make-application src proc args)
+                 (concat db** db*))))
+      (($ <lambda> src meta body)
+       (let*-values (((body _) (if body
+                                   (visit body (control-flow-boundary db)
+                                          env 'values)
+                                   (values #f #f))))
+         (return (make-lambda src meta body)
+                 vlist-null)))
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       (let*-values (((inits _) (parallel-visit inits db env 'value))
+                     ((body db*) (visit body db env ctx))
+                     ((alt _) (if alt
+                                  (visit alt db env ctx)
+                                  (values #f #f))))
+         (return (make-lambda-case src req opt rest kw inits gensyms body alt)
+                 (if alt vlist-null db*))))
+      (($ <sequence> src exps)
+       (let lp ((in exps) (out '()) (db* vlist-null))
+         (match in
+           ((last)
+            (let*-values (((last db**) (visit last (concat db* db) env ctx)))
+              (if (null? out)
+                  (return last (concat db** db*))
+                  (return (make-sequence src (reverse (cons last out)))
+                          (concat db** db*)))))
+           ((head . rest)
+            (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
+              (cond
+               ((sequence? head)
+                (lp (append (sequence-exps head) rest) out db*))
+               ((void? head)
+                (lp rest out db*))
+               (else
+                (lp rest (cons head out) (concat db** db*)))))))))
+      (($ <prompt> src tag body handler)
+       (let*-values (((tag db*) (visit tag db env 'value))
+                     ((body _) (visit body (concat db* db) env 'values))
+                     ((handler _) (visit handler (concat db* db) env ctx)))
+         (return (make-prompt src tag body handler)
+                 db*)))
+      (($ <abort> src tag args tail)
+       (let*-values (((tag db*) (visit tag db env 'value))
+                     ((args db**) (parallel-visit args db env 'value))
+                     ((tail db***) (visit tail db env 'value)))
+         (return (make-abort src tag args tail)
+                 (concat db* (concat db** db***))))))))
+;;; Tree-IL verifier
+
+;; Copyright (C) 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 (language tree-il debug)
+  #\use-module (language tree-il)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-26)
+  #\export (verify-tree-il))
+
+(define (verify-tree-il exp)
+  (define seen-gensyms (make-hash-table))
+  (define (add sym env)
+    (if (hashq-ref seen-gensyms sym)
+        (error "duplicate gensym" sym)
+        (begin
+          (hashq-set! seen-gensyms sym #t)
+          (cons sym env))))
+  (define (add-env new env)
+    (if (null? new)
+        env
+        (add-env (cdr new) (add (car new) env))))
+
+  (let visit ((exp exp)
+              (env '()))
+    (match exp
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       (cond
+        ((not (and (list? req) (and-map symbol? req)))
+         (error "bad required args (should be list of symbols)" exp))
+        ((and opt (not (and (list? opt) (and-map symbol? opt))))
+         (error "bad optionals (should be #f or list of symbols)" exp))
+        ((and rest (not (symbol? rest)))
+         (error "bad required args (should be #f or symbol)" exp))
+        ((and kw (not (match kw
+                        ((aok . kwlist)
+                         (and (list? kwlist)
+                              (and-map 
+                               (lambda (x)
+                                 (match x
+                                   (((? keyword?) (? symbol?) (? symbol? sym))
+                                    (memq sym gensyms))
+                                   (_ #f)))
+                               kwlist)))
+                        (_ #f))))
+         (error "bad keywords (should be #f or (aok (kw name sym) ...))" exp))
+        ((not (and (list? gensyms) (and-map symbol? gensyms)))
+         (error "bad gensyms (should be list of symbols)" exp))
+        ((not (and (list? gensyms) (and-map symbol? gensyms)))
+         (error "bad gensyms (should be list of symbols)" exp))
+        ((not (= (length gensyms) 
+                 (+ (length req)
+                    (if opt (length opt) 0)
+                    ;; FIXME: technically possible for kw gensyms to
+                    ;; alias other gensyms
+                    (if rest 1 0)
+                    (if kw (1- (length kw)) 0))))
+         (error "unexpected gensyms length" exp))
+        (else
+         (let lp ((env (add-env (take gensyms (length req)) env))
+                  (nopt (if opt (length opt) 0))
+                  (inits inits)
+                  (tail (drop gensyms (length req))))
+           (if (zero? nopt)
+               (let lp ((env (if rest (add (car tail) env) env))
+                        (inits inits)
+                        (tail (if rest (cdr tail) tail)))
+                 (if (pair? inits)
+                     (begin
+                       (visit (car inits) env)
+                       (lp (add (car tail) env) (cdr inits) 
+                           (cdr tail)))
+                     (visit body env)))
+               (begin
+                 (visit (car inits) env)
+                 (lp (add (car tail) env)
+                     (1- nopt)
+                     (cdr inits) 
+                     (cdr tail)))))
+         (if alt (visit alt env)))))
+      (($ <lexical-ref> src name gensym)
+       (cond
+        ((not (symbol? name))
+         (error "name should be a symbol" name))
+        ((not (hashq-ref seen-gensyms gensym))
+         (error "unbound lexical" exp))
+        ((not (memq gensym env))
+         (error "displaced lexical" exp))))
+      (($ <lexical-set> src name gensym exp)
+       (cond
+        ((not (symbol? name))
+         (error "name should be a symbol" name))
+        ((not (hashq-ref seen-gensyms gensym))
+         (error "unbound lexical" exp))
+        ((not (memq gensym env))
+         (error "displaced lexical" exp))
+        (else
+         (visit exp env))))
+      (($ <lambda> src meta body)
+       (cond
+        ((and meta (not (and (list? meta) (and-map pair? meta))))
+         (error "meta should be alist" meta))
+        ((and body (not (lambda-case? body)))
+         (error "lambda body should be lambda-case" exp))
+        (else
+         (if body
+             (visit body env)))))
+      (($ <let> src names gensyms vals body)
+       (cond
+        ((not (and (list? names) (and-map symbol? names)))
+         (error "names should be list of syms" exp))
+        ((not (and (list? gensyms) (and-map symbol? gensyms)))
+         (error "gensyms should be list of syms" exp))
+        ((not (list? vals))
+         (error "vals should be list" exp))
+        ((not (= (length names) (length gensyms) (length vals)))
+         (error "names, syms, vals should be same length" exp))
+        (else
+         (for-each (cut visit <> env) vals)
+         (visit body (add-env gensyms env)))))
+      (($ <letrec> src in-order? names gensyms vals body)
+       (cond
+        ((not (and (list? names) (and-map symbol? names)))
+         (error "names should be list of syms" exp))
+        ((not (and (list? gensyms) (and-map symbol? gensyms)))
+         (error "gensyms should be list of syms" exp))
+        ((not (list? vals))
+         (error "vals should be list" exp))
+        ((not (= (length names) (length gensyms) (length vals)))
+         (error "names, syms, vals should be same length" exp))
+        (else
+         (let ((env (add-env gensyms env)))
+           (for-each (cut visit <> env) vals)
+           (visit body env)))))
+      (($ <fix> src names gensyms vals body)
+       (cond
+        ((not (and (list? names) (and-map symbol? names)))
+         (error "names should be list of syms" exp))
+        ((not (and (list? gensyms) (and-map symbol? gensyms)))
+         (error "gensyms should be list of syms" exp))
+        ((not (list? vals))
+         (error "vals should be list" exp))
+        ((not (= (length names) (length gensyms) (length vals)))
+         (error "names, syms, vals should be same length" exp))
+        (else
+         (let ((env (add-env gensyms env)))
+           (for-each (cut visit <> env) vals)
+           (visit body env)))))
+      (($ <let-values> src exp body)
+       (cond
+        ((not (lambda-case? body))
+         (error "let-values body should be lambda-case" exp))
+        (else
+         (visit exp env)
+         (visit body env))))
+      (($ <const> src val) #t)
+      (($ <void> src) #t)
+      (($ <toplevel-ref> src name)
+       (cond
+        ((not (symbol? name))
+         (error "name should be a symbol" name))))
+      (($ <module-ref> src mod name public?)
+       (cond
+        ((not (and (list? mod) (and-map symbol? mod)))
+         (error "module name should be list of symbols" exp))
+        ((not (symbol? name))
+         (error "name should be symbol" exp))))
+      (($ <primitive-ref> src name)
+       (cond
+        ((not (symbol? name))
+         (error "name should be symbol" exp))))
+      (($ <toplevel-set> src name exp)
+       (cond
+        ((not (symbol? name))
+         (error "name should be a symbol" name))
+        (else
+         (visit exp env))))
+      (($ <toplevel-define> src name exp)
+       (cond
+        ((not (symbol? name))
+         (error "name should be a symbol" name))
+        (else
+         (visit exp env))))
+      (($ <module-set> src mod name public? exp)
+       (cond
+        ((not (and (list? mod) (and-map symbol? mod)))
+         (error "module name should be list of symbols" exp))
+        ((not (symbol? name))
+         (error "name should be symbol" exp))
+        (else
+         (visit exp env))))
+      (($ <dynlet> src fluids vals body)
+       (cond
+        ((not (list? fluids))
+         (error "fluids should be list" exp))
+        ((not (list? vals))
+         (error "vals should be list" exp))
+        ((not (= (length fluids) (length vals)))
+         (error "mismatch in fluids/vals" exp))
+        (else
+         (for-each (cut visit <> env) fluids)
+         (for-each (cut visit <> env) vals)
+         (visit body env))))
+      (($ <dynwind> src winder body unwinder)
+       (visit winder env)
+       (visit body env)
+       (visit unwinder env))
+      (($ <dynref> src fluid)
+       (visit fluid env))
+      (($ <dynset> src fluid exp)
+       (visit fluid env)
+       (visit exp env))
+      (($ <conditional> src condition subsequent alternate)
+       (visit condition env)
+       (visit subsequent env)
+       (visit alternate env))
+      (($ <application> src proc args)
+       (cond
+        ((not (list? args))
+         (error "expected list of args" args))
+        (else
+         (visit proc env)
+         (for-each (cut visit <> env) args))))
+      (($ <sequence> src exps)
+       (cond
+        ((not (list? exps))
+         (error "expected list of exps" exp))
+        ((null? exps)
+         (error "expected more than one exp" exp))
+        (else
+         (for-each (cut visit <> env) exps))))
+      (($ <prompt> src tag body handler)
+       (visit tag env)
+       (visit body env)
+       (visit handler env))
+      (($ <abort> src tag args tail)
+       (visit tag env)
+       (for-each (cut visit <> env) args)
+       (visit tail env))
+      (_
+       (error "unexpected tree-il" exp)))
+    (let ((src (tree-il-src exp)))
+      (if (and src (not (and (list? src) (and-map pair? src)
+                             (and-map symbol? (map car src)))))
+          (error "bad src"))
+      ;; Return it, why not.
+      exp)))
+;;; Effects analysis on Tree-IL
+
+;; Copyright (C) 2011, 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 (language tree-il effects)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il primitives)
+  #\use-module (ice-9 match)
+  #\export (make-effects-analyzer
+            &mutable-lexical
+            &toplevel
+            &fluid
+            &definite-bailout
+            &possible-bailout
+            &zero-values
+            &allocation
+            &mutable-data
+            &type-check
+            &all-effects
+            effects-commute?
+            exclude-effects
+            effect-free?
+            constant?
+            depends-on-effects?
+            causes-effects?))
+
+;;;
+;;; Hey, it's some effects analysis!  If you invoke
+;;; `make-effects-analyzer', you get a procedure that computes the set
+;;; of effects that an expression depends on and causes.  This
+;;; information is useful when writing algorithms that move code around,
+;;; while preserving the semantics of an input program.
+;;;
+;;; The effects set is represented by a bitfield, as a fixnum.  The set
+;;; of possible effects is modelled rather coarsely.  For example, a
+;;; toplevel reference to FOO is modelled as depending on the &toplevel
+;;; effect, and causing a &type-check effect.  If any intervening code
+;;; sets any toplevel variable, that will block motion of FOO.
+;;;
+;;; For each effect, two bits are reserved: one to indicate that an
+;;; expression depends on the effect, and the other to indicate that an
+;;; expression causes the effect.
+;;;
+
+(define-syntax define-effects
+  (lambda (x)
+    (syntax-case x ()
+      ((_ all name ...)
+       (with-syntax (((n ...) (iota (length #'(name ...)))))
+         #'(begin
+             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
+             ...
+             (define-syntax all (identifier-syntax (logior name ...)))))))))
+
+;; Here we define the effects, indicating the meaning of the effect.
+;;
+;; Effects that are described in a "depends on" sense can also be used
+;; in the "causes" sense.
+;;
+;; Effects that are described as causing an effect are not usually used
+;; in a "depends-on" sense.  Although the "depends-on" sense is used
+;; when checking for the existence of the "causes" effect, the effects
+;; analyzer will not associate the "depends-on" sense of these effects
+;; with any expression.
+;;
+(define-effects &all-effects
+  ;; Indicates that an expression depends on the value of a mutable
+  ;; lexical variable.
+  &mutable-lexical
+
+  ;; Indicates that an expression depends on the value of a toplevel
+  ;; variable.
+  &toplevel
+
+  ;; Indicates that an expression depends on the value of a fluid
+  ;; variable.
+  &fluid
+
+  ;; Indicates that an expression definitely causes a non-local,
+  ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
+  &definite-bailout
+
+  ;; Indicates that an expression may cause a bailout.
+  &possible-bailout
+
+  ;; Indicates than an expression may return zero values -- a "causes"
+  ;; effect.
+  &zero-values
+
+  ;; Indicates that an expression may return a fresh object -- a
+  ;; "causes" effect.
+  &allocation
+
+  ;; Indicates that an expression depends on the value of a mutable data
+  ;; structure.
+  &mutable-data
+
+  ;; Indicates that an expression may cause a type check.  A type check,
+  ;; for the purposes of this analysis, is the possibility of throwing
+  ;; an exception the first time an expression is evaluated.  If the
+  ;; expression did not cause an exception to be thrown, users can
+  ;; assume that evaluating the expression again will not cause an
+  ;; exception to be thrown.
+  ;;
+  ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
+  ;; it doesn't throw, it should be safe to elide a dominated, common
+  ;; subexpression (+ x y).
+  &type-check)
+
+(define-syntax &no-effects (identifier-syntax 0))
+
+;; Definite bailout is an oddball effect.  Since it indicates that an
+;; expression definitely causes bailout, it's not in the set of effects
+;; of a call to an unknown procedure.  At the same time, it's also
+;; special in that a definite bailout in a subexpression doesn't always
+;; cause an outer expression to include &definite-bailout in its
+;; effects.  For that reason we have to treat it specially.
+;;
+(define-syntax &all-effects-but-bailout
+  (identifier-syntax
+   (logand &all-effects (lognot &definite-bailout))))
+
+(define-inlinable (cause effect)
+  (ash effect 1))
+
+(define-inlinable (&depends-on a)
+  (logand a &all-effects))
+(define-inlinable (&causes a)
+  (logand a (cause &all-effects)))
+
+(define (exclude-effects effects exclude)
+  (logand effects (lognot (cause exclude))))
+(define (effect-free? effects)
+  (zero? (&causes effects)))
+(define (constant? effects)
+  (zero? effects))
+
+(define-inlinable (depends-on-effects? x effects)
+  (not (zero? (logand (&depends-on x) effects))))
+(define-inlinable (causes-effects? x effects)
+  (not (zero? (logand (&causes x) (cause effects)))))
+
+(define-inlinable (effects-commute? a b)
+  (and (not (causes-effects? a (&depends-on b)))
+       (not (causes-effects? b (&depends-on a)))))
+
+(define (make-effects-analyzer assigned-lexical?)
+  "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
+of an expression."
+
+  (let ((cache (make-hash-table)))
+    (define* (compute-effects exp #\optional (lookup (lambda (x) #f)))
+      (define (compute-effects exp)
+        (or (hashq-ref cache exp)
+            (let ((effects (visit exp)))
+              (hashq-set! cache exp effects)
+              effects)))
+
+      (define (accumulate-effects exps)
+        (let lp ((exps exps) (out &no-effects))
+          (if (null? exps)
+              out
+              (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+      (define (visit exp)
+        (match exp
+          (($ <const>)
+           &no-effects)
+          (($ <void>)
+           &no-effects)
+          (($ <lexical-ref> _ _ gensym)
+           (if (assigned-lexical? gensym)
+               &mutable-lexical
+               &no-effects))
+          (($ <lexical-set> _ name gensym exp)
+           (logior (cause &mutable-lexical)
+                   (compute-effects exp)))
+          (($ <let> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <letrec> _ in-order? names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <fix> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <let-values> _ producer consumer)
+           (logior (compute-effects producer)
+                   (compute-effects consumer)
+                   (cause &type-check)))
+          (($ <dynwind> _ winder body unwinder)
+           (logior (compute-effects winder)
+                   (compute-effects body)
+                   (compute-effects unwinder)))
+          (($ <dynlet> _ fluids vals body)
+           (logior (accumulate-effects fluids)
+                   (accumulate-effects vals)
+                   (cause &type-check)
+                   (cause &fluid)
+                   (compute-effects body)))
+          (($ <dynref> _ fluid)
+           (logior (compute-effects fluid)
+                   (cause &type-check)
+                   &fluid))
+          (($ <dynset> _ fluid exp)
+           (logior (compute-effects fluid)
+                   (compute-effects exp)
+                   (cause &type-check)
+                   (cause &fluid)))
+          (($ <toplevel-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-set> _ mod name public? exp)
+           (logior (cause &toplevel)
+                   (cause &type-check)
+                   (compute-effects exp)))
+          (($ <toplevel-define> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <toplevel-set> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <primitive-ref>)
+           &no-effects)
+          (($ <conditional> _ test consequent alternate)
+           (let ((tfx (compute-effects test))
+                 (cfx (compute-effects consequent))
+                 (afx (compute-effects alternate)))
+             (if (causes-effects? (logior tfx (logand afx cfx))
+                                  &definite-bailout)
+                 (logior tfx cfx afx)
+                 (exclude-effects (logior tfx cfx afx)
+                                  &definite-bailout))))
+
+          ;; Zero values.
+          (($ <application> _ ($ <primitive-ref> _ 'values) ())
+           (cause &zero-values))
+
+          ;; Effect-free primitives.
+          (($ <application> _
+              ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
+              args)
+           (accumulate-effects args))
+
+          (($ <application> _
+              ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
+                                       'vector? 'struct? 'string? 'number?
+                                       'char?))
+              (arg))
+           (compute-effects arg))
+
+          ;; Primitives that allocate memory.
+          (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+           (logior (compute-effects x) (compute-effects y)
+                   (cause &allocation)))
+
+          (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+           (logior (accumulate-effects args) (cause &allocation)))
+
+          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+           (cause &allocation))
+
+          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+           (logior (compute-effects arg) (cause &allocation)))
+
+          ;; Primitives that are normally effect-free, but which might
+          ;; cause type checks, allocate memory, or access mutable
+          ;; memory.  FIXME: expand, to be more precise.
+          (($ <application> _
+              ($ <primitive-ref> _ (and name
+                                        (? effect-free-primitive?)))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &type-check)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       (if (accessor-primitive? name)
+                           &mutable-data
+                           &no-effects))))
+      
+          ;; Lambda applications might throw wrong-number-of-args.
+          (($ <application> _ ($ <lambda> _ _ body) args)
+           (logior (accumulate-effects args)
+                   (match body
+                     (($ <lambda-case> _ req #f #f #f () syms body #f)
+                      (logior (compute-effects body)
+                              (if (= (length req) (length args))
+                                  0
+                                  (cause &type-check))))
+                     (($ <lambda-case>)
+                      (logior (compute-effects body)
+                              (cause &type-check)))
+                     (#f
+                      ;; Calling a case-lambda with no clauses
+                      ;; definitely causes bailout.
+                      (logior (cause &definite-bailout)
+                              (cause &possible-bailout))))))
+        
+          ;; Bailout primitives.
+          (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &definite-bailout)
+                   (cause &possible-bailout)))
+
+          ;; A call to a lexically bound procedure, perhaps labels
+          ;; allocated.
+          (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+           (cond
+            ((lookup sym)
+             => (lambda (proc)
+                  (compute-effects (make-application #f proc args))))
+            (else
+             (logior &all-effects-but-bailout
+                     (cause &all-effects-but-bailout)))))
+
+          ;; A call to an unknown procedure can do anything.
+          (($ <application> _ proc args)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))
+
+          (($ <lambda> _ meta body)
+           &no-effects)
+          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+           (logior (exclude-effects (accumulate-effects inits)
+                                    &definite-bailout)
+                   (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (compute-effects body)
+                   (if alt (compute-effects alt) &no-effects)))
+
+          (($ <sequence> _ exps)
+           (let lp ((exps exps) (effects &no-effects))
+             (match exps
+               ((tail)
+                (logior (compute-effects tail)
+                        ;; Returning zero values to a for-effect continuation is
+                        ;; not observable.
+                        (exclude-effects effects (cause &zero-values))))
+               ((head . tail)
+                (lp tail (logior (compute-effects head) effects))))))
+
+          (($ <prompt> _ tag body handler)
+           (logior (compute-effects tag)
+                   (compute-effects body)
+                   (compute-effects handler)))
+
+          (($ <abort> _ tag args tail)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))))
+
+      (compute-effects exp))
+
+    compute-effects))
+;;; transformation of letrec into simpler forms
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 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
+
+(define-module (language tree-il fix-letrec)
+  #\use-module (system base syntax)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-11)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il effects)
+  #\export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Scheme's Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+
+(define fix-fold
+  (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars simple-primcall?)
+  (record-case x
+    ((<void>) #t)
+    ((<const>) #t)
+    ((<lexical-ref> gensym)
+     (not (memq gensym bound-vars)))
+    ((<conditional> test consequent alternate)
+     (and (simple-expression? test bound-vars simple-primcall?)
+          (simple-expression? consequent bound-vars simple-primcall?)
+          (simple-expression? alternate bound-vars simple-primcall?)))
+    ((<sequence> exps)
+     (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
+              exps))
+    ((<application> proc args)
+     (and (primitive-ref? proc)
+          (simple-primcall? x)
+          (and-map (lambda (x)
+                     (simple-expression? x bound-vars simple-primcall?))
+                   args)))
+    (else #f)))
+
+(define (partition-vars x)
+  (let-values
+      (((unref ref set simple lambda* complex)
+        (fix-fold x
+                  (lambda (x unref ref set simple lambda* complex)
+                    (record-case x
+                      ((<lexical-ref> gensym)
+                       (values (delq gensym unref)
+                               (lset-adjoin eq? ref gensym)
+                               set
+                               simple
+                               lambda*
+                               complex))
+                      ((<lexical-set> gensym)
+                       (values unref
+                               ref
+                               (lset-adjoin eq? set gensym)
+                               simple
+                               lambda*
+                               complex))
+                      ((<letrec> gensyms)
+                       (values (append gensyms unref)
+                               ref
+                               set
+                               simple
+                               lambda*
+                               complex))
+                      ((<let> gensyms)
+                       (values (append gensyms unref)
+                               ref
+                               set
+                               simple
+                               lambda*
+                               complex))
+                      (else
+                       (values unref ref set simple lambda* complex))))
+                  (lambda (x unref ref set simple lambda* complex)
+                    (record-case x
+                      ((<letrec> in-order? (orig-gensyms gensyms) vals)
+                       (define compute-effects
+                         (make-effects-analyzer (lambda (x) (memq x set))))
+                       (define (effect-free-primcall? x)
+                         (let ((effects (compute-effects x)))
+                           (effect-free?
+                            (exclude-effects effects (logior &allocation
+                                                             &type-check)))))
+                       (define (effect+exception-free-primcall? x)
+                         (let ((effects (compute-effects x)))
+                           (effect-free?
+                            (exclude-effects effects &allocation))))
+                       (let lp ((gensyms orig-gensyms) (vals vals)
+                                (s '()) (l '()) (c '()))
+                         (cond
+                          ((null? gensyms)
+                           ;; Unreferenced complex vars are still
+                           ;; complex for letrec*.  We need to update
+                           ;; our algorithm to "Fixing letrec reloaded"
+                           ;; to fix this.
+                           (values (if in-order?
+                                       (lset-difference eq? unref c)
+                                       unref)
+                                   ref
+                                   set
+                                   (append s simple)
+                                   (append l lambda*)
+                                   (append c complex)))
+                          ((memq (car gensyms) unref)
+                           ;; See above note about unref and letrec*.
+                           (if (and in-order?
+                                    (not (lambda? (car vals)))
+                                    (not (simple-expression?
+                                          (car vals) orig-gensyms
+                                          effect+exception-free-primcall?)))
+                               (lp (cdr gensyms) (cdr vals)
+                                   s l (cons (car gensyms) c))
+                               (lp (cdr gensyms) (cdr vals)
+                                   s l c)))
+                          ((memq (car gensyms) set)
+                           (lp (cdr gensyms) (cdr vals)
+                               s l (cons (car gensyms) c)))
+                          ((lambda? (car vals))
+                           (lp (cdr gensyms) (cdr vals)
+                               s (cons (car gensyms) l) c))
+                          ((simple-expression?
+                            (car vals) orig-gensyms
+                            (if in-order?
+                                effect+exception-free-primcall?
+                                effect-free-primcall?))
+                           ;; For letrec*, we can't consider e.g. `car' to be
+                           ;; "simple", as it could raise an exception. Hence
+                           ;; effect+exception-free-primitive? above.
+                           (lp (cdr gensyms) (cdr vals)
+                               (cons (car gensyms) s) l c))
+                          (else
+                           (lp (cdr gensyms) (cdr vals)
+                               s l (cons (car gensyms) c))))))
+                      ((<let> (orig-gensyms gensyms) vals)
+                       ;; The point is to compile let-bound lambdas as
+                       ;; efficiently as we do letrec-bound lambdas, so
+                       ;; we use the same algorithm for analyzing the
+                       ;; gensyms. There is no problem recursing into the
+                       ;; bindings after the let, because all variables
+                       ;; have been renamed.
+                       (let lp ((gensyms orig-gensyms) (vals vals)
+                                (s '()) (l '()) (c '()))
+                         (cond
+                          ((null? gensyms)
+                           (values unref
+                                   ref
+                                   set
+                                   (append s simple)
+                                   (append l lambda*)
+                                   (append c complex)))
+                          ((memq (car gensyms) unref)
+                           (lp (cdr gensyms) (cdr vals)
+                               s l c))
+                          ((memq (car gensyms) set)
+                           (lp (cdr gensyms) (cdr vals)
+                               s l (cons (car gensyms) c)))
+                          ((and (lambda? (car vals))
+                                (not (memq (car gensyms) set)))
+                           (lp (cdr gensyms) (cdr vals)
+                               s (cons (car gensyms) l) c))
+                          ;; There is no difference between simple and
+                          ;; complex, for the purposes of let. Just lump
+                          ;; them all into complex.
+                          (else
+                           (lp (cdr gensyms) (cdr vals)
+                               s l (cons (car gensyms) c))))))
+                      (else
+                       (values unref ref set simple lambda* complex))))
+                  '()
+                  '()
+                  '()
+                  '()
+                  '()
+                  '())))
+    (values unref simple lambda* complex)))
+
+(define (make-sequence* src exps)
+  (let lp ((in exps) (out '()))
+    (if (null? (cdr in))
+        (if (null? out)
+            (car in)
+            (make-sequence src (reverse (cons (car in) out))))
+        (let ((head (car in)))
+          (record-case head
+            ((<lambda>) (lp (cdr in) out))
+            ((<const>) (lp (cdr in) out))
+            ((<lexical-ref>) (lp (cdr in) out))
+            ((<void>) (lp (cdr in) out))
+            (else (lp (cdr in) (cons head out))))))))
+
+(define (fix-letrec! x)
+  (let-values (((unref simple lambda* complex) (partition-vars x)))
+    (post-order!
+     (lambda (x)
+       (record-case x
+
+         ;; Sets to unreferenced variables may be replaced by their
+         ;; expression, called for effect.
+         ((<lexical-set> gensym exp)
+          (if (memq gensym unref)
+              (make-sequence* #f (list exp (make-void #f)))
+              x))
+
+         ((<letrec> src in-order? names gensyms vals body)
+          (let ((binds (map list gensyms names vals)))
+            ;; The bindings returned by this function need to appear in the same
+            ;; order that they appear in the letrec.
+            (define (lookup set)
+              (let lp ((binds binds))
+                (cond
+                 ((null? binds) '())
+                 ((memq (caar binds) set)
+                  (cons (car binds) (lp (cdr binds))))
+                 (else (lp (cdr binds))))))
+            (let ((u (lookup unref))
+                  (s (lookup simple))
+                  (l (lookup lambda*))
+                  (c (lookup complex)))
+              ;; Bind "simple" bindings, and locations for complex
+              ;; bindings.
+              (make-let
+               src
+               (append (map cadr s) (map cadr c))
+               (append (map car s) (map car c))
+               (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+               ;; Bind lambdas using the fixpoint operator.
+               (make-fix
+                src (map cadr l) (map car l) (map caddr l)
+                (make-sequence*
+                 src
+                 (append
+                  ;; The right-hand-sides of the unreferenced
+                  ;; bindings, for effect.
+                  (map caddr u)
+                  (cond
+                   ((null? c)
+                    ;; No complex bindings, just emit the body.
+                    (list body))
+                   (in-order?
+                    ;; For letrec*, assign complex bindings in order, then the
+                    ;; body.
+                    (append
+                     (map (lambda (c)
+                            (make-lexical-set #f (cadr c) (car c)
+                                              (caddr c)))
+                          c)
+                     (list body)))
+                   (else
+                    ;; Otherwise for plain letrec, evaluate the "complex"
+                    ;; bindings, in a `let' to indicate that order doesn't
+                    ;; matter, and bind to their variables.
+                    (list
+                     (let ((tmps (map (lambda (x)
+                                        (module-gensym "fixlr"))
+                                      c)))
+                       (make-let
+                        #f (map cadr c) tmps (map caddr c)
+                        (make-sequence
+                         #f
+                         (map (lambda (x tmp)
+                                (make-lexical-set
+                                 #f (cadr x) (car x)
+                                 (make-lexical-ref #f (cadr x) tmp)))
+                              c tmps))))
+                     body))))))))))
+
+         ((<let> src names gensyms vals body)
+          (let ((binds (map list gensyms names vals)))
+            (define (lookup set)
+              (map (lambda (v) (assq v binds))
+                   (lset-intersection eq? gensyms set)))
+            (let ((u (lookup unref))
+                  (l (lookup lambda*))
+                  (c (lookup complex)))
+              (make-sequence*
+               src
+               (append
+                ;; unreferenced bindings, called for effect.
+                (map caddr u)
+                (list
+                 ;; unassigned lambdas use fix.
+                 (make-fix src (map cadr l) (map car l) (map caddr l)
+                           ;; and the "complex" bindings.
+                           (make-let src (map cadr c) (map car c) (map caddr c)
+                                     body))))))))
+         
+         (else x)))
+     x)))
+
+;;; Local Variables:
+;;; eval: (put 'record-case 'scheme-indent-function 1)
+;;; End:
+;;; a simple inliner
+
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il inline)
+  #\export (inline!))
+
+(define (inline! x)
+  (issue-deprecation-warning
+   "`inline!' is deprecated.  Use (language tree-il peval) instead.")
+  x)
+;;; Tree-il optimizer
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language tree-il optimize)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il primitives)
+  #\use-module (language tree-il peval)
+  #\use-module (language tree-il cse)
+  #\use-module (language tree-il fix-letrec)
+  #\use-module (language tree-il debug)
+  #\use-module (ice-9 match)
+  #\export (optimize!))
+
+(define (optimize! x env opts)
+  (let ((peval (match (memq #\partial-eval? opts)
+                 ((#\partial-eval? #f _ ...)
+                  ;; Disable partial evaluation.
+                  (lambda (x e) x))
+                 (_ peval)))
+        (cse (match (memq #\cse? opts)
+               ((#\cse? #f _ ...)
+                ;; Disable CSE.
+                (lambda (x) x))
+               (_ cse))))
+    (fix-letrec!
+     (verify-tree-il
+      (cse
+       (verify-tree-il
+        (peval (expand-primitives! (resolve-primitives! x env))
+               env)))))))
+;;; Tree-IL partial evaluator
+
+;; Copyright (C) 2011-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
+
+(define-module (language tree-il peval)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il primitives)
+  #\use-module (language tree-il effects)
+  #\use-module (ice-9 vlist)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\use-module (ice-9 control)
+  #\export (peval))
+
+;;;
+;;; Partial evaluation is Guile's most important source-to-source
+;;; optimization pass.  It performs copy propagation, dead code
+;;; elimination, inlining, and constant folding, all while preserving
+;;; the order of effects in the residual program.
+;;;
+;;; For more on partial evaluation, see William Cook’s excellent
+;;; tutorial on partial evaluation at DSL 2011, called “Build your own
+;;; partial evaluator in 90 minutes”[0].
+;;;
+;;; Our implementation of this algorithm was heavily influenced by
+;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining",
+;;; IU CS Dept. TR 484.
+;;;
+;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/.  
+;;;
+
+;; First, some helpers.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+
+;; For efficiency we define *logging* to inline to #f, so that the call
+;; to log* gets optimized out.  If you want to log, uncomment these
+;; lines:
+;;
+;; (define %logging #f)
+;; (define-syntax *logging* (identifier-syntax %logging))
+;;
+;; Then you can change %logging at runtime.
+
+(define-syntax log
+  (syntax-rules (quote)
+    ((log 'event arg ...)
+     (if (and *logging*
+              (or (eq? *logging* #t)
+                  (memq 'event *logging*)))
+         (log* 'event arg ...)))))
+
+(define (log* event . args)
+  (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+                        'pretty-print)))
+    (pp `(log ,event . ,args))
+    (newline)
+    (values)))
+
+(define (tree-il-any proc exp)
+  (let/ec k
+    (tree-il-fold (lambda (exp res)
+                    (let ((res (proc exp)))
+                      (if res (k res) #f)))
+                  (lambda (exp res)
+                    (let ((res (proc exp)))
+                      (if res (k res) #f)))
+                  (lambda (exp res) #f)
+                  #f exp)))
+
+(define (vlist-any proc vlist)
+  (let ((len (vlist-length vlist)))
+    (let lp ((i 0))
+      (and (< i len)
+           (or (proc (vlist-ref vlist i))
+               (lp (1+ i)))))))
+
+(define (singly-valued-expression? exp)
+  (match exp
+    (($ <const>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <void>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <primitive-ref>) #t)
+    (($ <module-ref>) #t)
+    (($ <toplevel-ref>) #t)
+    (($ <application> _
+        ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
+    (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+    (($ <lambda>) #t)
+    (else #f)))
+
+(define (truncate-values x)
+  "Discard all but the first value of X."
+  (if (singly-valued-expression? x)
+      x
+      (make-application (tree-il-src x)
+                        (make-primitive-ref #f 'values)
+                        (list x))))
+
+;; Peval will do a one-pass analysis on the source program to determine
+;; the set of assigned lexicals, and to identify unreferenced and
+;; singly-referenced lexicals.
+;;
+(define-record-type <var>
+  (make-var name gensym refcount set?)
+  var?
+  (name var-name)
+  (gensym var-gensym)
+  (refcount var-refcount set-var-refcount!)
+  (set? var-set? set-var-set?!))
+
+(define* (build-var-table exp #\optional (table vlist-null))
+  (tree-il-fold
+   (lambda (exp res)
+     (match exp
+       (($ <lexical-ref> src name gensym)
+        (let ((var (cdr (vhash-assq gensym res))))
+          (set-var-refcount! var (1+ (var-refcount var)))
+          res))
+       (_ res)))
+   (lambda (exp res)
+     (match exp
+       (($ <lambda-case> src req opt rest kw init gensyms body alt)
+        (fold (lambda (name sym res)
+                (vhash-consq sym (make-var name sym 0 #f) res))
+              res
+              (append req (or opt '()) (if rest (list rest) '())
+                      (match kw
+                        ((aok? (kw name sym) ...) name)
+                        (_ '())))
+              gensyms))
+       (($ <let> src names gensyms vals body)
+        (fold (lambda (name sym res)
+                (vhash-consq sym (make-var name sym 0 #f) res))
+              res names gensyms))
+       (($ <letrec> src in-order? names gensyms vals body)
+        (fold (lambda (name sym res)
+                (vhash-consq sym (make-var name sym 0 #f) res))
+              res names gensyms))
+       (($ <fix> src names gensyms vals body)
+        (fold (lambda (name sym res)
+                (vhash-consq sym (make-var name sym 0 #f) res))
+              res names gensyms))
+       (($ <lexical-set> src name gensym exp)
+        (set-var-set?! (cdr (vhash-assq gensym res)) #t)
+        res)
+       (_ res)))
+   (lambda (exp res) res)
+   table exp))
+
+;; Counters are data structures used to limit the effort that peval
+;; spends on particular inlining attempts.  Each call site in the source
+;; program is allocated some amount of effort.  If peval exceeds the
+;; effort counter while attempting to inline a call site, it aborts the
+;; inlining attempt and residualizes a call instead.
+;;
+;; As there is a fixed number of call sites, that makes `peval' O(N) in
+;; the number of call sites in the source program.
+;;
+;; Counters should limit the size of the residual program as well, but
+;; currently this is not implemented.
+;;
+;; At the top level, before seeing any peval call, there is no counter,
+;; because inlining will terminate as there is no recursion.  When peval
+;; sees a call at the top level, it will make a new counter, allocating
+;; it some amount of effort and size.
+;;
+;; This top-level effort counter effectively "prints money".  Within a
+;; toplevel counter, no more effort is printed ex nihilo; for a nested
+;; inlining attempt to proceed, effort must be transferred from the
+;; toplevel counter to the nested counter.
+;;
+;; Via `data' and `prev', counters form a linked list, terminating in a
+;; toplevel counter.  In practice `data' will be the a pointer to the
+;; source expression of the procedure being inlined.
+;;
+;; In this way peval can detect a recursive inlining attempt, by walking
+;; back on the `prev' links looking for matching `data'.  Recursive
+;; counters receive a more limited effort allocation, as we don't want
+;; to spend all of the effort for a toplevel inlining site on loops.
+;; Also, recursive counters don't need a prompt at each inlining site:
+;; either the call chain folds entirely, or it will be residualized at
+;; its original call.
+;;
+(define-record-type <counter>
+  (%make-counter effort size continuation recursive? data prev)
+  counter?
+  (effort effort-counter)
+  (size size-counter)
+  (continuation counter-continuation)
+  (recursive? counter-recursive? set-counter-recursive?!)
+  (data counter-data)
+  (prev counter-prev))
+
+(define (abort-counter c)
+  ((counter-continuation c)))
+
+(define (record-effort! c)
+  (let ((e (effort-counter c)))
+    (if (zero? (variable-ref e))
+        (abort-counter c)
+        (variable-set! e (1- (variable-ref e))))))
+
+(define (record-size! c)
+  (let ((s (size-counter c)))
+    (if (zero? (variable-ref s))
+        (abort-counter c)
+        (variable-set! s (1- (variable-ref s))))))
+
+(define (find-counter data counter)
+  (and counter
+       (if (eq? data (counter-data counter))
+           counter
+           (find-counter data (counter-prev counter)))))
+
+(define* (transfer! from to #\optional
+                    (effort (variable-ref (effort-counter from)))
+                    (size (variable-ref (size-counter from))))
+  (define (transfer-counter! from-v to-v amount)
+    (let* ((from-balance (variable-ref from-v))
+           (to-balance (variable-ref to-v))
+           (amount (min amount from-balance)))
+      (variable-set! from-v (- from-balance amount))
+      (variable-set! to-v (+ to-balance amount))))
+
+  (transfer-counter! (effort-counter from) (effort-counter to) effort)
+  (transfer-counter! (size-counter from) (size-counter to) size))
+
+(define (make-top-counter effort-limit size-limit continuation data)
+  (%make-counter (make-variable effort-limit)
+                 (make-variable size-limit)
+                 continuation
+                 #t
+                 data
+                 #f))
+
+(define (make-nested-counter continuation data current)
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          continuation
+                          #f
+                          data
+                          current)))
+    (transfer! current c)
+    c))
+
+(define (make-recursive-counter effort-limit size-limit orig current)
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          (counter-continuation orig)
+                          #t
+                          (counter-data orig)
+                          current)))
+    (transfer! current c effort-limit size-limit)
+    c))
+
+;; Operand structures allow bindings to be processed lazily instead of
+;; eagerly.  By doing so, hopefully we can get process them in a way
+;; appropriate to their use contexts.  Operands also prevent values from
+;; being visited multiple times, wasting effort.
+;;
+;; TODO: Record value size in operand structure?
+;; 
+(define-record-type <operand>
+  (%make-operand var sym visit source visit-count use-count
+                 copyable? residual-value constant-value alias)
+  operand?
+  (var operand-var)
+  (sym operand-sym)
+  (visit %operand-visit)
+  (source operand-source)
+  (visit-count operand-visit-count set-operand-visit-count!)
+  (use-count operand-use-count set-operand-use-count!)
+  (copyable? operand-copyable? set-operand-copyable?!)
+  (residual-value operand-residual-value %set-operand-residual-value!)
+  (constant-value operand-constant-value set-operand-constant-value!)
+  (alias operand-alias set-operand-alias!))
+
+(define* (make-operand var sym #\optional source visit alias)
+  ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
+  ;; considered copyable until we prove otherwise.  If we have a source
+  ;; expression, truncate it to one value.  Copy propagation does not
+  ;; work on multiply-valued expressions.
+  (let ((source (and=> source truncate-values)))
+    (%make-operand var sym visit source 0 0
+                   (and source (not (var-set? var))) #f #f
+                   (and (not (var-set? var)) alias))))
+
+(define* (make-bound-operands vars syms sources visit #\optional aliases)
+  (if aliases
+      (map (lambda (name sym source alias)
+             (make-operand name sym source visit alias))
+           vars syms sources aliases)
+      (map (lambda (name sym source)
+             (make-operand name sym source visit #f))
+           vars syms sources)))
+
+(define (make-unbound-operands vars syms)
+  (map make-operand vars syms))
+
+(define (set-operand-residual-value! op val)
+  (%set-operand-residual-value!
+   op
+   (match val
+    (($ <application> src ($ <primitive-ref> _ 'values) (first))
+     ;; The continuation of a residualized binding does not need the
+     ;; introduced `values' node, so undo the effects of truncation.
+     first)
+    (else
+     val))))
+
+(define* (visit-operand op counter ctx #\optional effort-limit size-limit)
+  ;; Peval is O(N) in call sites of the source program.  However,
+  ;; visiting an operand can introduce new call sites.  If we visit an
+  ;; operand outside a counter -- i.e., outside an inlining attempt --
+  ;; this can lead to divergence.  So, if we are visiting an operand to
+  ;; try to copy it, and there is no counter, make a new one.
+  ;;
+  ;; This will only happen at most as many times as there are lexical
+  ;; references in the source program.
+  (and (zero? (operand-visit-count op))
+       (dynamic-wind
+         (lambda ()
+           (set-operand-visit-count! op (1+ (operand-visit-count op))))
+         (lambda ()
+           (and (operand-source op)
+                (if (or counter (and (not effort-limit) (not size-limit)))
+                    ((%operand-visit op) (operand-source op) counter ctx)
+                    (let/ec k
+                      (define (abort)
+                        ;; If we abort when visiting the value in a
+                        ;; fresh context, we won't succeed in any future
+                        ;; attempt, so don't try to copy it again.
+                        (set-operand-copyable?! op #f)
+                        (k #f))
+                      ((%operand-visit op)
+                       (operand-source op) 
+                       (make-top-counter effort-limit size-limit abort op)
+                       ctx)))))
+         (lambda ()
+           (set-operand-visit-count! op (1- (operand-visit-count op)))))))
+
+;; A helper for constant folding.
+;;
+(define (types-check? primitive-name args)
+  (case primitive-name
+    ((values) #t)
+    ((not pair? null? list? symbol? vector? struct?)
+     (= (length args) 1))
+    ((eq? eqv? equal?)
+     (= (length args) 2))
+    ;; FIXME: add more cases?
+    (else #f)))
+
+(define* (peval exp #\optional (cenv (current-module)) (env vlist-null)
+                #\key
+                (operator-size-limit 40)
+                (operand-size-limit 20)
+                (value-size-limit 10)
+                (effort-limit 500)
+                (recursive-effort-limit 100))
+  "Partially evaluate EXP in compilation environment CENV, with
+top-level bindings from ENV and return the resulting expression."
+
+  ;; This is a simple partial evaluator.  It effectively performs
+  ;; constant folding, copy propagation, dead code elimination, and
+  ;; inlining.
+
+  ;; TODO:
+  ;;
+  ;; Propagate copies across toplevel bindings, if we can prove the
+  ;; bindings to be immutable.
+  ;;
+  ;; Specialize lambda expressions with invariant arguments.
+
+  (define local-toplevel-env
+    ;; The top-level environment of the module being compiled.
+    (match exp
+      (($ <toplevel-define> _ name)
+       (vhash-consq name #t env))
+      (($ <sequence> _ exps)
+       (fold (lambda (x r)
+               (match x
+                 (($ <toplevel-define> _ name)
+                  (vhash-consq name #t r))
+                 (_ r)))
+             env
+             exps))
+      (_ env)))
+
+  (define (local-toplevel? name)
+    (vhash-assq name local-toplevel-env))
+
+  ;; gensym -> <var>
+  ;; renamed-term -> original-term
+  ;;
+  (define store (build-var-table exp))
+
+  (define (record-new-temporary! name sym refcount)
+    (set! store (vhash-consq sym (make-var name sym refcount #f) store)))
+
+  (define (lookup-var sym)
+    (let ((v (vhash-assq sym store)))
+      (if v (cdr v) (error "unbound var" sym (vlist->list store)))))
+
+  (define (fresh-gensyms vars)
+    (map (lambda (var)
+           (let ((new (gensym (string-append (symbol->string (var-name var))
+                                             " "))))
+             (set! store (vhash-consq new var store))
+             new))
+         vars))
+
+  (define (fresh-temporaries ls)
+    (map (lambda (elt)
+           (let ((new (gensym "tmp ")))
+             (record-new-temporary! 'tmp new 1)
+             new))
+         ls))
+
+  (define (assigned-lexical? sym)
+    (var-set? (lookup-var sym)))
+
+  (define (lexical-refcount sym)
+    (var-refcount (lookup-var sym)))
+
+  ;; ORIG has been alpha-renamed to NEW.  Analyze NEW and record a link
+  ;; from it to ORIG.
+  ;;
+  (define (record-source-expression! orig new)
+    (set! store (vhash-consq new (source-expression orig) store))
+    new)
+
+  ;; Find the source expression corresponding to NEW.  Used to detect
+  ;; recursive inlining attempts.
+  ;;
+  (define (source-expression new)
+    (let ((x (vhash-assq new store)))
+      (if x (cdr x) new)))
+
+  (define (record-operand-use op)
+    (set-operand-use-count! op (1+ (operand-use-count op))))
+
+  (define (unrecord-operand-uses op n)
+    (let ((count (- (operand-use-count op) n)))
+      (when (zero? count)
+        (set-operand-residual-value! op #f))
+      (set-operand-use-count! op count)))
+
+  (define* (residualize-lexical op #\optional ctx val)
+    (log 'residualize op)
+    (record-operand-use op)
+    (if (memq ctx '(value values))
+        (set-operand-residual-value! op val))
+    (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
+
+  (define (fold-constants src name args ctx)
+    (define (apply-primitive name args)
+      ;; todo: further optimize commutative primitives
+      (catch #t
+        (lambda ()
+          (call-with-values
+              (lambda ()
+                (case name
+                  ((eq? eqv?)
+                   ;; Constants will be deduplicated later, but eq?
+                   ;; folding can happen now.  Anticipate the
+                   ;; deduplication by using equal? instead of eq?.
+                   ;; Same for eqv?.
+                   (apply equal? args))
+                  (else
+                   (apply (module-ref the-scm-module name) args))))
+            (lambda results
+              (values #t results))))
+        (lambda _
+          (values #f '()))))
+
+    (define (make-values src values)
+      (match values
+        ((single) single)               ; 1 value
+        ((_ ...)                        ; 0, or 2 or more values
+         (make-application src (make-primitive-ref src 'values)
+                           values))))
+    (define (residualize-call)
+      (make-application src (make-primitive-ref #f name) args))
+    (cond
+     ((every const? args)
+      (let-values (((success? values)
+                    (apply-primitive name (map const-exp args))))
+        (log 'fold success? values name args)
+        (if success?
+            (case ctx
+              ((effect) (make-void src))
+              ((test)
+               ;; Values truncation: only take the first
+               ;; value.
+               (if (pair? values)
+                   (make-const src (car values))
+                   (make-values src '())))
+              (else
+               (make-values src (map (cut make-const src <>) values))))
+            (residualize-call))))
+     ((and (eq? ctx 'effect) (types-check? name args))
+      (make-void #f))
+     (else
+      (residualize-call))))
+
+  (define (inline-values src exp nmin nmax consumer)
+    (let loop ((exp exp))
+      (match exp
+        ;; Some expression types are always singly-valued.
+        ((or ($ <const>)
+             ($ <void>)
+             ($ <lambda>)
+             ($ <lexical-ref>)
+             ($ <toplevel-ref>)
+             ($ <module-ref>)
+             ($ <primitive-ref>)
+             ($ <dynref>)
+             ($ <lexical-set>)          ; FIXME: these set! expressions
+             ($ <toplevel-set>)         ; could return zero values in
+             ($ <toplevel-define>)      ; the future
+             ($ <module-set>)           ;
+             ($ <dynset>)               ;
+             ($ <application> src
+                ($ <primitive-ref> _ (? singly-valued-primitive?))))
+         (and (<= nmin 1) (or (not nmax) (>= nmax 1))
+              (make-application src (make-lambda #f '() consumer) (list exp))))
+
+        ;; Statically-known number of values.
+        (($ <application> src ($ <primitive-ref> _ 'values) vals)
+         (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
+              (make-application src (make-lambda #f '() consumer) vals)))
+
+        ;; Not going to copy code into both branches.
+        (($ <conditional>) #f)
+
+        ;; Bail on other applications.
+        (($ <application>) #f)
+
+        ;; Bail on prompt and abort.
+        (($ <prompt>) #f)
+        (($ <abort>) #f)
+        
+        ;; Propagate to tail positions.
+        (($ <let> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-let src names gensyms vals body))))
+        (($ <letrec> src in-order? names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-letrec src in-order? names gensyms vals body))))
+        (($ <fix> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-fix src names gensyms vals body))))
+        (($ <let-values> src exp
+            ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
+         (let ((body (loop body)))
+           (and body
+                (make-let-values src exp
+                                 (make-lambda-case src2 req opt rest kw
+                                                   inits gensyms body #f)))))
+        (($ <dynwind> src winder body unwinder)
+         (let ((body (loop body)))
+           (and body
+                (make-dynwind src winder body unwinder))))
+        (($ <dynlet> src fluids vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-dynlet src fluids vals body))))
+        (($ <sequence> src exps)
+         (match exps
+           ((head ... tail)
+            (let ((tail (loop tail)))
+              (and tail
+                   (make-sequence src (append head (list tail)))))))))))
+
+  (define compute-effects
+    (make-effects-analyzer assigned-lexical?))
+
+  (define (constant-expression? x)
+    ;; Return true if X is constant, for the purposes of copying or
+    ;; elision---i.e., if it is known to have no effects, does not
+    ;; allocate storage for a mutable object, and does not access
+    ;; mutable data (like `car' or toplevel references).
+    (constant? (compute-effects x)))
+
+  (define (prune-bindings ops in-order? body counter ctx build-result)
+    ;; This helper handles both `let' and `letrec'/`fix'.  In the latter
+    ;; cases we need to make sure that if referenced binding A needs
+    ;; as-yet-unreferenced binding B, that B is processed for value.
+    ;; Likewise if C, when processed for effect, needs otherwise
+    ;; unreferenced D, then D needs to be processed for value too.
+    ;;
+    (define (referenced? op)
+      ;; When we visit lambdas in operator context, we just copy them,
+      ;; as we will process their body later.  However this does have
+      ;; the problem that any free var referenced by the lambda is not
+      ;; marked as needing residualization.  Here we hack around this
+      ;; and treat all bindings as referenced if we are in operator
+      ;; context.
+      (or (eq? ctx 'operator)
+          (not (zero? (operand-use-count op)))))
+    
+    ;; values := (op ...)
+    ;; effects := (op ...)
+    (define (residualize values effects)
+      ;; Note, values and effects are reversed.
+      (cond
+       (in-order?
+        (let ((values (filter operand-residual-value ops)))
+          (if (null? values)
+              body
+              (build-result (map (compose var-name operand-var) values)
+                            (map operand-sym values)
+                            (map operand-residual-value values)
+                            body))))
+       (else
+        (let ((body
+               (if (null? effects)
+                   body
+                   (let ((effect-vals (map operand-residual-value effects)))
+                     (make-sequence #f (reverse (cons body effect-vals)))))))
+          (if (null? values)
+              body
+              (let ((values (reverse values)))
+                (build-result (map (compose var-name operand-var) values)
+                              (map operand-sym values)
+                              (map operand-residual-value values)
+                              body)))))))
+
+    ;; old := (bool ...)
+    ;; values := (op ...)
+    ;; effects := ((op . value) ...)
+    (let prune ((old (map referenced? ops)) (values '()) (effects '()))
+      (let lp ((ops* ops) (values values) (effects effects))
+        (cond
+         ((null? ops*)
+          (let ((new (map referenced? ops)))
+            (if (not (equal? new old))
+                (prune new values '())
+                (residualize values
+                             (map (lambda (op val)
+                                    (set-operand-residual-value! op val)
+                                    op)
+                                  (map car effects) (map cdr effects))))))
+         (else
+          (let ((op (car ops*)))
+            (cond
+             ((memq op values)
+              (lp (cdr ops*) values effects))
+             ((operand-residual-value op)
+              (lp (cdr ops*) (cons op values) effects))
+             ((referenced? op)
+              (set-operand-residual-value! op (visit-operand op counter 'value))
+              (lp (cdr ops*) (cons op values) effects))
+             (else
+              (lp (cdr ops*)
+                  values
+                  (let ((effect (visit-operand op counter 'effect)))
+                    (if (void? effect)
+                        effects
+                        (acons op effect effects))))))))))))
+  
+  (define (small-expression? x limit)
+    (let/ec k
+      (tree-il-fold
+       (lambda (x res)                  ; leaf
+         (1+ res))
+       (lambda (x res)                  ; down
+         (1+ res))
+       (lambda (x res)                  ; up
+         (if (< res limit)
+             res
+             (k #f)))
+       0 x)
+      #t))
+  
+  (define (extend-env sym op env)
+    (vhash-consq (operand-sym op) op (vhash-consq sym op env)))
+      
+  (let loop ((exp   exp)
+             (env   vlist-null)         ; vhash of gensym -> <operand>
+             (counter #f)               ; inlined call stack
+             (ctx 'values))   ; effect, value, values, test, operator, or call
+    (define (lookup var)
+      (cond 
+       ((vhash-assq var env) => cdr)
+       (else (error "unbound var" var))))
+
+    ;; Find a value referenced a specific number of times.  This is a hack
+    ;; that's used for propagating fresh data structures like rest lists and
+    ;; prompt tags.  Usually we wouldn't copy consed data, but we can do so in
+    ;; some special cases like `apply' or prompts if we can account
+    ;; for all of its uses.
+    ;;
+    ;; You don't want to use this in general because it introduces a slight
+    ;; nonlinearity by running peval again (though with a small effort and size
+    ;; counter).
+    ;;
+    (define (find-definition x n-aliases)
+      (cond
+       ((lexical-ref? x)
+        (cond
+         ((lookup (lexical-ref-gensym x))
+          => (lambda (op)
+               (if (var-set? (operand-var op))
+                   (values #f #f)
+                   (let ((y (or (operand-residual-value op)
+                                (visit-operand op counter 'value 10 10)
+                                (operand-source op))))
+                     (cond
+                      ((and (lexical-ref? y)
+                            (= (lexical-refcount (lexical-ref-gensym x)) 1))
+                       ;; X is a simple alias for Y.  Recurse, regardless of
+                       ;; the number of aliases we were expecting.
+                       (find-definition y n-aliases))
+                      ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+                       ;; We found a definition that is aliased the right
+                       ;; number of times.  We still recurse in case it is a
+                       ;; lexical.
+                       (values (find-definition y 1)
+                               op))
+                      (else
+                       ;; We can't account for our aliases.
+                       (values #f #f)))))))
+         (else
+          ;; A formal parameter.  Can't say anything about that.
+          (values #f #f))))
+       ((= n-aliases 1)
+        ;; Not a lexical: success, but only if we are looking for an
+        ;; unaliased value.
+        (values x #f))
+       (else (values #f #f))))
+
+    (define (visit exp ctx)
+      (loop exp env counter ctx))
+
+    (define (for-value exp)    (visit exp 'value))
+    (define (for-values exp)   (visit exp 'values))
+    (define (for-test exp)     (visit exp 'test))
+    (define (for-effect exp)   (visit exp 'effect))
+    (define (for-call exp)     (visit exp 'call))
+    (define (for-tail exp)     (visit exp ctx))
+
+    (if counter
+        (record-effort! counter))
+
+    (log 'visit ctx (and=> counter effort-counter)
+         (unparse-tree-il exp))
+
+    (match exp
+      (($ <const>)
+       (case ctx
+         ((effect) (make-void #f))
+         (else exp)))
+      (($ <void>)
+       (case ctx
+         ((test) (make-const #f #t))
+         (else exp)))
+      (($ <lexical-ref> _ _ gensym)
+       (log 'begin-copy gensym)
+       (let lp ((op (lookup gensym)))
+         (cond
+          ((eq? ctx 'effect)
+           (log 'lexical-for-effect gensym)
+           (make-void #f))
+          ((operand-alias op)
+           ;; This is an unassigned operand that simply aliases some
+           ;; other operand.  Recurse to avoid residualizing the leaf
+           ;; binding.
+           => lp)
+          ((eq? ctx 'call)
+           ;; Don't propagate copies if we are residualizing a call.
+           (log 'residualize-lexical-call gensym op)
+           (residualize-lexical op))
+          ((var-set? (operand-var op))
+           ;; Assigned lexicals don't copy-propagate.
+           (log 'assigned-var gensym op)
+           (residualize-lexical op))
+          ((not (operand-copyable? op))
+           ;; We already know that this operand is not copyable.
+           (log 'not-copyable gensym op)
+           (residualize-lexical op))
+          ((and=> (operand-constant-value op)
+                  (lambda (x) (or (const? x) (void? x) (primitive-ref? x))))
+           ;; A cache hit.
+           (let ((val (operand-constant-value op)))
+             (log 'memoized-constant gensym val)
+             (for-tail val)))
+          ((visit-operand op counter (if (eq? ctx 'values) 'value ctx)
+                          recursive-effort-limit operand-size-limit)
+           =>
+           ;; If we end up deciding to residualize this value instead of
+           ;; copying it, save that residualized value.
+           (lambda (val)
+             (cond
+              ((not (constant-expression? val))
+               (log 'not-constant gensym op)
+               ;; At this point, ctx is operator, test, or value.  A
+               ;; value that is non-constant in one context will be
+               ;; non-constant in the others, so it's safe to record
+               ;; that here, and avoid future visits.
+               (set-operand-copyable?! op #f)
+               (residualize-lexical op ctx val))
+              ((or (const? val)
+                   (void? val)
+                   (primitive-ref? val))
+               ;; Always propagate simple values that cannot lead to
+               ;; code bloat.
+               (log 'copy-simple gensym val)
+               ;; It could be this constant is the result of folding.
+               ;; If that is the case, cache it.  This helps loop
+               ;; unrolling get farther.
+               (if (or (eq? ctx 'value) (eq? ctx 'values))
+                   (begin
+                     (log 'memoize-constant gensym val)
+                     (set-operand-constant-value! op val)))
+               val)
+              ((= 1 (var-refcount (operand-var op)))
+               ;; Always propagate values referenced only once.
+               (log 'copy-single gensym val)
+               val)
+              ;; FIXME: do demand-driven size accounting rather than
+              ;; these heuristics.
+              ((eq? ctx 'operator)
+               ;; A pure expression in the operator position.  Inline
+               ;; if it's a lambda that's small enough.
+               (if (and (lambda? val)
+                        (small-expression? val operator-size-limit))
+                   (begin
+                     (log 'copy-operator gensym val)
+                     val)
+                   (begin
+                     (log 'too-big-for-operator gensym val)
+                     (residualize-lexical op ctx val))))
+              (else
+               ;; A pure expression, processed for call or for value.
+               ;; Don't inline lambdas, because they will probably won't
+               ;; fold because we don't know the operator.
+               (if (and (small-expression? val value-size-limit)
+                        (not (tree-il-any lambda? val)))
+                   (begin
+                     (log 'copy-value gensym val)
+                     val)
+                   (begin
+                     (log 'too-big-or-has-lambda gensym val)
+                     (residualize-lexical op ctx val)))))))
+          (else
+           ;; Visit failed.  Either the operand isn't bound, as in
+           ;; lambda formal parameters, or the copy was aborted.
+           (log 'unbound-or-aborted gensym op)
+           (residualize-lexical op)))))
+      (($ <lexical-set> src name gensym exp)
+       (let ((op (lookup gensym)))
+         (if (zero? (var-refcount (operand-var op)))
+             (let ((exp (for-effect exp)))
+               (if (void? exp)
+                   exp
+                   (make-sequence src (list exp (make-void #f)))))
+             (begin
+               (record-operand-use op)
+               (make-lexical-set src name (operand-sym op) (for-value exp))))))
+      (($ <let> src
+          (names ... rest)
+          (gensyms ... rest-sym)
+          (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
+          ($ <application> asrc
+             ($ <primitive-ref> _ (or 'apply '@apply))
+             (proc args ...
+                   ($ <lexical-ref> _
+                      (? (cut eq? <> rest))
+                      (? (lambda (sym)
+                           (and (eq? sym rest-sym)
+                                (= (lexical-refcount sym) 1))))))))
+       (let* ((tmps (make-list (length rest-args) 'tmp))
+              (tmp-syms (fresh-temporaries tmps)))
+         (for-tail
+          (make-let src
+                    (append names tmps)
+                    (append gensyms tmp-syms)
+                    (append vals rest-args)
+                    (make-application
+                     asrc
+                     proc
+                     (append args
+                             (map (cut make-lexical-ref #f <> <>)
+                                  tmps tmp-syms)))))))
+      (($ <let> src names gensyms vals body)
+       (define (lookup-alias exp)
+         ;; It's very common for macros to introduce something like:
+         ;;
+         ;;   ((lambda (x y) ...) x-exp y-exp)
+         ;;
+         ;; In that case you might end up trying to inline something like:
+         ;;
+         ;;   (let ((x x-exp) (y y-exp)) ...)
+         ;;
+         ;; But if x-exp is itself a lexical-ref that aliases some much
+         ;; larger expression, perhaps it will fail to inline due to
+         ;; size.  However we don't want to introduce a useless alias
+         ;; (in this case, x).  So if the RHS of a let expression is a
+         ;; lexical-ref, we record that expression.  If we end up having
+         ;; to residualize X, then instead we residualize X-EXP, as long
+         ;; as it isn't assigned.
+         ;;
+         (match exp
+           (($ <lexical-ref> _ _ sym)
+            (let ((op (lookup sym)))
+              (and (not (var-set? (operand-var op))) op)))
+           (_ #f)))
+
+       (let* ((vars (map lookup-var gensyms))
+              (new (fresh-gensyms vars))
+              (ops (make-bound-operands vars new vals
+                                        (lambda (exp counter ctx)
+                                          (loop exp env counter ctx))
+                                        (map lookup-alias vals)))
+              (env (fold extend-env env gensyms ops))
+              (body (loop body env counter ctx)))
+         (cond
+          ((const? body)
+           (for-tail (make-sequence src (append vals (list body)))))
+          ((and (lexical-ref? body)
+                (memq (lexical-ref-gensym body) new))
+           (let ((sym (lexical-ref-gensym body))
+                 (pairs (map cons new vals)))
+             ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
+             (for-tail
+              (make-sequence
+               src
+               (append (map cdr (alist-delete sym pairs eq?))
+                       (list (assq-ref pairs sym)))))))
+          (else
+           ;; Only include bindings for which lexical references
+           ;; have been residualized.
+           (prune-bindings ops #f body counter ctx
+                           (lambda (names gensyms vals body)
+                             (if (null? names) (error "what!" names))
+                             (make-let src names gensyms vals body)))))))
+      (($ <letrec> src in-order? names gensyms vals body)
+       ;; Note the difference from the `let' case: here we use letrec*
+       ;; so that the `visit' procedure for the new operands closes over
+       ;; an environment that includes the operands.  Also we don't try
+       ;; to elide aliases, because we can't sensibly reduce something
+       ;; like (letrec ((a b) (b a)) a).
+       (letrec* ((visit (lambda (exp counter ctx)
+                          (loop exp env* counter ctx)))
+                 (vars (map lookup-var gensyms))
+                 (new (fresh-gensyms vars))
+                 (ops (make-bound-operands vars new vals visit))
+                 (env* (fold extend-env env gensyms ops))
+                 (body* (visit body counter ctx)))
+         (if (and (const? body*) (every constant-expression? vals))
+             ;; We may have folded a loop completely, even though there
+             ;; might be cyclical references between the bound values.
+             ;; Handle this degenerate case specially.
+             body*
+             (prune-bindings ops in-order? body* counter ctx
+                             (lambda (names gensyms vals body)
+                               (make-letrec src in-order?
+                                            names gensyms vals body))))))
+      (($ <fix> src names gensyms vals body)
+       (letrec* ((visit (lambda (exp counter ctx)
+                          (loop exp env* counter ctx)))
+                 (vars (map lookup-var gensyms))
+                 (new (fresh-gensyms vars))
+                 (ops (make-bound-operands vars new vals visit))
+                 (env* (fold extend-env env gensyms ops))
+                 (body* (visit body counter ctx)))
+         (if (const? body*)
+             body*
+             (prune-bindings ops #f body* counter ctx
+                             (lambda (names gensyms vals body)
+                               (make-fix src names gensyms vals body))))))
+      (($ <let-values> lv-src producer consumer)
+       ;; Peval the producer, then try to inline the consumer into
+       ;; the producer.  If that succeeds, peval again.  Otherwise
+       ;; reconstruct the let-values, pevaling the consumer.
+       (let ((producer (for-values producer)))
+         (or (match consumer
+               (($ <lambda-case> src req opt rest #f inits gensyms body #f)
+                (let* ((nmin (length req))
+                       (nmax (and (not rest) (+ nmin (if opt (length opt) 0)))))
+                  (cond
+                   ((inline-values lv-src producer nmin nmax consumer)
+                    => for-tail)
+                   (else #f))))
+               (_ #f))
+             (make-let-values lv-src producer (for-tail consumer)))))
+      (($ <dynwind> src winder body unwinder)
+       (let ((pre (for-value winder))
+             (body (for-tail body))
+             (post (for-value unwinder)))
+         (cond
+          ((not (constant-expression? pre))
+           (cond
+            ((not (constant-expression? post))
+             (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (record-new-temporary! 'post post-sym 1)
+               (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       (make-lexical-ref #f 'post post-sym)))))
+            (else
+             (let ((pre-sym (gensym "pre-")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (make-let src '(pre) (list pre-sym) (list pre)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       post))))))
+          ((not (constant-expression? post))
+           (let ((post-sym (gensym "post-")))
+             (record-new-temporary! 'post post-sym 1)
+             (make-let src '(post) (list post-sym) (list post)
+                       (make-dynwind src
+                                     pre
+                                     body
+                                     (make-lexical-ref #f 'post post-sym)))))
+          (else
+           (make-dynwind src pre body post)))))
+      (($ <dynlet> src fluids vals body)
+       (make-dynlet src (map for-value fluids) (map for-value vals)
+                    (for-tail body)))
+      (($ <dynref> src fluid)
+       (make-dynref src (for-value fluid)))
+      (($ <dynset> src fluid exp)
+       (make-dynset src (for-value fluid) (for-value exp)))
+      (($ <toplevel-ref> src (? effect-free-primitive? name))
+       (if (local-toplevel? name)
+           exp
+           (let ((exp (resolve-primitives! exp cenv)))
+             (if (primitive-ref? exp)
+                 (for-tail exp)
+                 exp))))
+      (($ <toplevel-ref>)
+       ;; todo: open private local bindings.
+       exp)
+      (($ <module-ref> src module (? effect-free-primitive? name) #f)
+       (let ((module (false-if-exception
+                      (resolve-module module #\ensure #f))))
+         (if (module? module)
+             (let ((var (module-variable module name)))
+               (if (eq? var (module-variable the-scm-module name))
+                   (make-primitive-ref src name)
+                   exp))
+             exp)))
+      (($ <module-ref>)
+       exp)
+      (($ <module-set> src mod name public? exp)
+       (make-module-set src mod name public? (for-value exp)))
+      (($ <toplevel-define> src name exp)
+       (make-toplevel-define src name (for-value exp)))
+      (($ <toplevel-set> src name exp)
+       (make-toplevel-set src name (for-value exp)))
+      (($ <primitive-ref>)
+       (case ctx
+         ((effect) (make-void #f))
+         ((test) (make-const #f #t))
+         (else exp)))
+      (($ <conditional> src condition subsequent alternate)
+       (define (call-with-failure-thunk exp proc)
+         (match exp
+           (($ <application> _ _ ()) (proc exp))
+           (($ <const>) (proc exp))
+           (($ <void>) (proc exp))
+           (($ <lexical-ref>) (proc exp))
+           (_
+            (let ((t (gensym "failure-")))
+              (record-new-temporary! 'failure t 2)
+              (make-let
+               src (list 'failure) (list t)
+               (list
+                (make-lambda
+                 #f '()
+                 (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+               (proc (make-application #f (make-lexical-ref #f 'failure t)
+                                       '())))))))
+       (define (simplify-conditional c)
+         (match c
+           ;; Swap the arms of (if (not FOO) A B), to simplify.
+           (($ <conditional> src
+               ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+               subsequent alternate)
+            (simplify-conditional
+             (make-conditional src pred alternate subsequent)))
+           ;; Special cases for common tests in the predicates of chains
+           ;; of if expressions.
+           (($ <conditional> src
+               ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+               inner-subsequent
+               alternate)
+            (let lp ((alternate alternate))
+              (match alternate
+                ;; Lift a common repeated test out of a chain of if
+                ;; expressions.
+                (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+                    other-subsequent alternate)
+                 (make-conditional
+                  src outer-test
+                  (simplify-conditional
+                   (make-conditional src* inner-test inner-subsequent
+                                     other-subsequent))
+                  alternate))
+                ;; Likewise, but punching through any surrounding
+                ;; failure continuations.
+                (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+                 (make-let
+                  let-src (list name) (list sym) (list thunk)
+                  (lp body)))
+                ;; Otherwise, rotate AND tests to expose a simple
+                ;; condition in the front.  Although this may result in
+                ;; lexically binding failure thunks, the thunks will be
+                ;; compiled to labels allocation, so there's no actual
+                ;; code growth.
+                (_
+                 (call-with-failure-thunk
+                  alternate
+                  (lambda (failure)
+                    (make-conditional
+                     src outer-test
+                     (simplify-conditional
+                      (make-conditional src* inner-test inner-subsequent failure))
+                     failure)))))))
+           (_ c)))
+       (match (for-test condition)
+         (($ <const> _ val)
+          (if val
+              (for-tail subsequent)
+              (for-tail alternate)))
+         (c
+          (simplify-conditional
+           (make-conditional src c (for-tail subsequent)
+                             (for-tail alternate))))))
+      (($ <application> src
+          ($ <primitive-ref> _ '@call-with-values)
+          (producer
+           ($ <lambda> _ _
+              (and consumer
+                   ;; No optional or kwargs.
+                   ($ <lambda-case>
+                      _ req #f rest #f () gensyms body #f)))))
+       (for-tail (make-let-values src (make-application src producer '())
+                                  consumer)))
+      (($ <application> src ($ <primitive-ref> _ 'values) exps)
+       (cond
+        ((null? exps)
+         (if (eq? ctx 'effect)
+             (make-void #f)
+             exp))
+        (else
+         (let ((vals (map for-value exps)))
+           (if (and (case ctx
+                      ((value test effect) #t)
+                      (else (null? (cdr vals))))
+                    (every singly-valued-expression? vals))
+               (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
+               (make-application src (make-primitive-ref #f 'values) vals))))))
+      (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
+          (proc args ... tail))
+       (let lp ((tail* (find-definition tail 1)) (speculative? #t))
+         (define (copyable? x)
+           ;; Inlining a result from find-definition effectively copies it,
+           ;; relying on the let-pruning to remove its original binding.  We
+           ;; shouldn't copy non-constant expressions.
+           (or (not speculative?) (constant-expression? x)))
+         (match tail*
+           (($ <const> _ (args* ...))
+            (let ((args* (map (cut make-const #f <>) args*)))
+              (for-tail (make-application src proc (append args args*)))))
+           (($ <application> _ ($ <primitive-ref> _ 'cons)
+               ((and head (? copyable?)) (and tail (? copyable?))))
+            (for-tail (make-application src apply
+                                        (cons proc
+                                              (append args (list head tail))))))
+           (($ <application> _ ($ <primitive-ref> _ 'list)
+               (and args* ((? copyable?) ...)))
+            (for-tail (make-application src proc (append args args*))))
+           (tail*
+            (if speculative?
+                (lp (for-value tail) #f)
+                (let ((args (append (map for-value args) (list tail*))))
+                  (make-application src apply
+                                    (cons (for-value proc) args))))))))
+      (($ <application> src orig-proc orig-args)
+       ;; todo: augment the global env with specialized functions
+       (let revisit-proc ((proc (visit orig-proc 'operator)))
+         (match proc
+           (($ <primitive-ref> _ (? constructor-primitive? name))
+            (cond
+             ((and (memq ctx '(effect test))
+                   (match (cons name orig-args)
+                     ((or ('cons _ _)
+                          ('list . _)
+                          ('vector . _)
+                          ('make-prompt-tag)
+                          ('make-prompt-tag ($ <const> _ (? string?))))
+                      #t)
+                     (_ #f)))
+              ;; Some expressions can be folded without visiting the
+              ;; arguments for value.
+              (let ((res (if (eq? ctx 'effect)
+                             (make-void #f)
+                             (make-const #f #t))))
+                (for-tail (make-sequence src (append orig-args (list res))))))
+             (else
+              (match (cons name (map for-value orig-args))
+                (('cons head tail)
+                 (match tail
+                   (($ <const> src (? (cut eq? <> '())))
+                    (make-application src (make-primitive-ref #f 'list)
+                                      (list head)))
+                   (($ <application> src ($ <primitive-ref> _ 'list) elts)
+                    (make-application src (make-primitive-ref #f 'list)
+                                      (cons head elts)))
+                   (_ (make-application src proc (list head tail)))))
+                ((_ . args)
+                 (make-application src proc args))))))
+           (($ <primitive-ref> _ (? accessor-primitive? name))
+            (match (cons name (map for-value orig-args))
+              ;; FIXME: these for-tail recursions could take place outside
+              ;; an effort counter.
+              (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
+               (for-tail (make-sequence src (list tail head))))
+              (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
+               (for-tail (make-sequence src (list head tail))))
+              (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
+               (for-tail (make-sequence src (append tail (list head)))))
+              (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
+               (for-tail (make-sequence
+                          src
+                          (list head
+                                (make-application
+                                 src (make-primitive-ref #f 'list) tail)))))
+                  
+              (('car ($ <const> src (head . tail)))
+               (for-tail (make-const src head)))
+              (('cdr ($ <const> src (head . tail)))
+               (for-tail (make-const src tail)))
+              (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+               ;; FIXME: factor 
+               (case ctx
+                 ((effect)
+                  (for-tail
+                   (make-sequence src (list k (make-void #f)))))
+                 ((test)
+                  (cond
+                   ((const? k)
+                    ;; A shortcut.  The `else' case would handle it, but
+                    ;; this way is faster.
+                    (let ((member (case name ((memq) memq) ((memv) memv))))
+                      (make-const #f (and (member (const-exp k) elts) #t))))
+                   ((null? elts)
+                    (for-tail
+                     (make-sequence src (list k (make-const #f #f)))))
+                   (else
+                    (let ((t (gensym "t-"))
+                          (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+                      (record-new-temporary! 't t (length elts))
+                      (for-tail
+                       (make-let
+                        src (list 't) (list t) (list k)
+                        (let lp ((elts elts))
+                          (define test
+                            (make-application
+                             #f (make-primitive-ref #f eq)
+                             (list (make-lexical-ref #f 't t)
+                                   (make-const #f (car elts)))))
+                          (if (null? (cdr elts))
+                              test
+                              (make-conditional src test
+                                                (make-const #f #t)
+                                                (lp (cdr elts)))))))))))
+                 (else
+                  (cond
+                   ((const? k)
+                    (let ((member (case name ((memq) memq) ((memv) memv))))
+                      (make-const #f (member (const-exp k) elts))))
+                   ((null? elts)
+                    (for-tail (make-sequence src (list k (make-const #f #f)))))
+                   (else
+                    (make-application src proc (list k (make-const #f elts))))))))
+              ((_ . args)
+               (or (fold-constants src name args ctx)
+                   (make-application src proc args)))))
+           (($ <primitive-ref> _ (? effect-free-primitive? name))
+            (let ((args (map for-value orig-args)))
+              (or (fold-constants src name args ctx)
+                  (make-application src proc args))))
+           (($ <lambda> _ _
+               ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
+            ;; Simple case: no keyword arguments.
+            ;; todo: handle the more complex cases
+            (let* ((nargs (length orig-args))
+                   (nreq (length req))
+                   (nopt (if opt (length opt) 0))
+                   (key (source-expression proc)))
+              (define (inlined-application)
+                (cond
+                 ((= nargs (+ nreq nopt))
+                  (make-let src
+                            (append req
+                                    (or opt '())
+                                    (if rest (list rest) '()))
+                            gensyms
+                            (append orig-args
+                                    (if rest
+                                        (list (make-const #f '()))
+                                        '()))
+                            body))
+                 ((> nargs (+ nreq nopt))
+                  (make-let src
+                            (append req
+                                    (or opt '())
+                                    (list rest))
+                            gensyms
+                            (append (take orig-args (+ nreq nopt))
+                                    (list (make-application
+                                           #f
+                                           (make-primitive-ref #f 'list)
+                                           (drop orig-args (+ nreq nopt)))))
+                            body))
+                 (else
+                  ;; Here we handle the case where nargs < nreq + nopt,
+                  ;; so the rest argument (if any) will be empty, and
+                  ;; there will be optional arguments that rely on their
+                  ;; default initializers.
+                  ;;
+                  ;; The default initializers of optional arguments
+                  ;; may refer to earlier arguments, so in the general
+                  ;; case we must expand into a series of nested let
+                  ;; expressions.
+                  ;;
+                  ;; In the generated code, the outermost let
+                  ;; expression will bind all arguments provided by
+                  ;; the application's argument list, as well as the
+                  ;; empty rest argument, if any.  Each remaining
+                  ;; optional argument that relies on its default
+                  ;; initializer will be bound within an inner let.
+                  ;;
+                  ;; rest-gensyms, rest-vars and rest-inits will have
+                  ;; either 0 or 1 elements.  They are oddly named, but
+                  ;; allow simpler code below.
+                  (let*-values
+                      (((non-rest-gensyms rest-gensyms)
+                        (split-at gensyms (+ nreq nopt)))
+                       ((provided-gensyms default-gensyms)
+                        (split-at non-rest-gensyms nargs))
+                       ((provided-vars default-vars)
+                        (split-at (append req opt) nargs))
+                       ((rest-vars)
+                        (if rest (list rest) '()))
+                       ((rest-inits)
+                        (if rest
+                            (list (make-const #f '()))
+                            '()))
+                       ((default-inits)
+                        (drop inits (- nargs nreq))))
+                    (make-let src
+                              (append provided-vars rest-vars)
+                              (append provided-gensyms rest-gensyms)
+                              (append orig-args rest-inits)
+                              (fold-right (lambda (var gensym init body)
+                                            (make-let src
+                                                      (list var)
+                                                      (list gensym)
+                                                      (list init)
+                                                      body))
+                                          body
+                                          default-vars
+                                          default-gensyms
+                                          default-inits))))))
+
+              (cond
+               ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
+                ;; An error, or effecting arguments.
+                (make-application src (for-call orig-proc)
+                                  (map for-value orig-args)))
+               ((or (and=> (find-counter key counter) counter-recursive?)
+                    (lambda? orig-proc))
+                ;; A recursive call, or a lambda in the operator
+                ;; position of the source expression.  Process again in
+                ;; tail context.
+                ;;
+                ;; In the recursive case, mark intervening counters as
+                ;; recursive, so we can handle a toplevel counter that
+                ;; recurses mutually with some other procedure.
+                ;; Otherwise, the next time we see the other procedure,
+                ;; the effort limit would be clamped to 100.
+                ;;
+                (let ((found (find-counter key counter)))
+                  (if (and found (counter-recursive? found))
+                      (let lp ((counter counter))
+                        (if (not (eq? counter found))
+                            (begin
+                              (set-counter-recursive?! counter #t)
+                              (lp (counter-prev counter)))))))
+
+                (log 'inline-recurse key)
+                (loop (inlined-application) env counter ctx))
+               (else
+                ;; An integration at the top-level, the first
+                ;; recursion of a recursive procedure, or a nested
+                ;; integration of a procedure that hasn't been seen
+                ;; yet.
+                (log 'inline-begin exp)
+                (let/ec k
+                  (define (abort)
+                    (log 'inline-abort exp)
+                    (k (make-application src (for-call orig-proc)
+                                         (map for-value orig-args))))
+                  (define new-counter
+                    (cond
+                     ;; These first two cases will transfer effort
+                     ;; from the current counter into the new
+                     ;; counter.
+                     ((find-counter key counter)
+                      => (lambda (prev)
+                           (make-recursive-counter recursive-effort-limit
+                                                   operand-size-limit
+                                                   prev counter)))
+                     (counter
+                      (make-nested-counter abort key counter))
+                     ;; This case opens a new account, effectively
+                     ;; printing money.  It should only do so once
+                     ;; for each call site in the source program.
+                     (else
+                      (make-top-counter effort-limit operand-size-limit
+                                        abort key))))
+                  (define result
+                    (loop (inlined-application) env new-counter ctx))
+                      
+                  (if counter
+                      ;; The nested inlining attempt succeeded.
+                      ;; Deposit the unspent effort and size back
+                      ;; into the current counter.
+                      (transfer! new-counter counter))
+
+                  (log 'inline-end result exp)
+                  result)))))
+           (($ <let> _ _ _ vals _)
+            ;; Attempt to inline `let' in the operator position.
+            ;;
+            ;; We have to re-visit the proc in value mode, since the
+            ;; `let' bindings might have been introduced or renamed,
+            ;; whereas the lambda (if any) in operator position has not
+            ;; been renamed.
+            (if (or (and-map constant-expression? vals)
+                    (and-map constant-expression? orig-args))
+                ;; The arguments and the let-bound values commute.
+                (match (for-value orig-proc)
+                  (($ <let> lsrc names syms vals body)
+                   (log 'inline-let orig-proc)
+                   (for-tail
+                    (make-let lsrc names syms vals
+                              (make-application src body orig-args))))
+                  ;; It's possible for a `let' to go away after the
+                  ;; visit due to the fact that visiting a procedure in
+                  ;; value context will prune unused bindings, whereas
+                  ;; visiting in operator mode can't because it doesn't
+                  ;; traverse through lambdas.  In that case re-visit
+                  ;; the procedure.
+                  (proc (revisit-proc proc)))
+                (make-application src (for-call orig-proc)
+                                  (map for-value orig-args))))
+           (_
+            (make-application src (for-call orig-proc)
+                              (map for-value orig-args))))))
+      (($ <lambda> src meta body)
+       (case ctx
+         ((effect) (make-void #f))
+         ((test) (make-const #f #t))
+         ((operator) exp)
+         (else (record-source-expression!
+                exp
+                (make-lambda src meta (and body (for-values body)))))))
+      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+       (define (lift-applied-lambda body gensyms)
+         (and (not opt) rest (not kw)
+              (match body
+                (($ <application> _
+                    ($ <primitive-ref> _ '@apply)
+                    (($ <lambda> _ _ (and lcase ($ <lambda-case>)))
+                     ($ <lexical-ref> _ _ sym)
+                     ...))
+                 (and (equal? sym gensyms)
+                      (not (lambda-case-alternate lcase))
+                      lcase))
+                (_ #f))))
+       (let* ((vars (map lookup-var gensyms))
+              (new (fresh-gensyms vars))
+              (env (fold extend-env env gensyms
+                         (make-unbound-operands vars new)))
+              (new-sym (lambda (old)
+                         (operand-sym (cdr (vhash-assq old env)))))
+              (body (loop body env counter ctx)))
+         (or
+          ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+          (lift-applied-lambda body new)
+          (make-lambda-case src req opt rest
+                            (match kw
+                              ((aok? (kw name old) ...)
+                               (cons aok? (map list kw name (map new-sym old))))
+                              (_ #f))
+                            (map (cut loop <> env counter 'value) inits)
+                            new
+                            body
+                            (and alt (for-tail alt))))))
+      (($ <sequence> src exps)
+       (let lp ((exps exps) (effects '()))
+         (match exps
+           ((last)
+            (if (null? effects)
+                (for-tail last)
+                (make-sequence
+                 src
+                 (reverse (cons (for-tail last) effects)))))
+           ((head . rest)
+            (let ((head (for-effect head)))
+              (cond
+               ((sequence? head)
+                (lp (append (sequence-exps head) rest) effects))
+               ((void? head)
+                (lp rest effects))
+               (else
+                (lp rest (cons head effects)))))))))
+      (($ <prompt> src tag body handler)
+       (define (make-prompt-tag? x)
+         (match x
+           (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
+               (or () ((? constant-expression?))))
+            #t)
+           (_ #f)))
+
+       (let ((tag (for-value tag))
+             (body (for-values body)))
+         (cond
+          ((find-definition tag 1)
+           (lambda (val op)
+             (make-prompt-tag? val))
+           => (lambda (val op)
+                ;; There is no way that an <abort> could know the tag
+                ;; for this <prompt>, so we can elide the <prompt>
+                ;; entirely.
+                (unrecord-operand-uses op 1)
+                body))
+          ((find-definition tag 2)
+           (lambda (val op)
+             (and (make-prompt-tag? val)
+                  (abort? body)
+                  (tree-il=? (abort-tag body) tag)))
+           => (lambda (val op)
+                ;; (let ((t (make-prompt-tag)))
+                ;;   (call-with-prompt t
+                ;;     (lambda () (abort-to-prompt t val ...))
+                ;;     (lambda (k arg ...) e ...)))
+                ;; => (let-values (((k arg ...) (values values val ...)))
+                ;;      e ...)
+                (unrecord-operand-uses op 2)
+                (for-tail
+                 (make-let-values
+                  src
+                  (make-application #f (make-primitive-ref #f 'apply)
+                                    `(,(make-primitive-ref #f 'values)
+                                      ,(make-primitive-ref #f 'values)
+                                      ,@(abort-args body)
+                                      ,(abort-tail body)))
+                  (for-tail handler)))))
+          (else
+           (make-prompt src tag body (for-tail handler))))))
+      (($ <abort> src tag args tail)
+       (make-abort src (for-value tag) (map for-value args)
+                   (for-value tail))))))
+;;; open-coding primitive procedures
+
+;; Copyright (C) 2009, 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
+
+;;; Code:
+
+(define-module (language tree-il primitives)
+  #\use-module (system base pmatch)
+  #\use-module (ice-9 match)
+  #\use-module (rnrs bytevectors)
+  #\use-module (system base syntax)
+  #\use-module (language tree-il)
+  #\use-module (srfi srfi-4)
+  #\use-module (srfi srfi-16)
+  #\export (resolve-primitives! add-interesting-primitive!
+            expand-primitives!
+            effect-free-primitive? effect+exception-free-primitive?
+            constructor-primitive? accessor-primitive?
+            singly-valued-primitive? bailout-primitive?
+            negate-primitive))
+
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
+(define *interesting-primitive-names*
+  '(apply @apply
+    call-with-values @call-with-values
+    call-with-current-continuation @call-with-current-continuation
+    call/cc
+    dynamic-wind
+    @dynamic-wind
+    values
+    eq? eqv? equal?
+    memq memv
+    = < > <= >= zero? positive? negative?
+    + * - / 1- 1+ quotient remainder modulo
+    ash logand logior logxor lognot
+    not
+    pair? null? list? symbol? vector? string? struct? number? char?
+
+    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+    char<? char<=? char>=? char>?
+
+    integer->char char->integer number->string string->number
+
+    acons cons cons*
+
+    list vector
+
+    car cdr
+    set-car! set-cdr!
+
+    caar cadr cdar cddr
+
+    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+
+    vector-ref vector-set!
+    variable-ref variable-set!
+    variable-bound?
+
+    fluid-ref fluid-set!
+
+    @prompt call-with-prompt @abort abort-to-prompt
+    make-prompt-tag
+
+    throw error scm-error
+
+    string-length string-ref string-set!
+
+    struct-vtable make-struct struct-ref struct-set!
+
+    bytevector-u8-ref bytevector-u8-set!
+    bytevector-s8-ref bytevector-s8-set!
+    u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+    
+    bytevector-u16-ref bytevector-u16-set!
+    bytevector-u16-native-ref bytevector-u16-native-set!
+    bytevector-s16-ref bytevector-s16-set!
+    bytevector-s16-native-ref bytevector-s16-native-set!
+    u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+    
+    bytevector-u32-ref bytevector-u32-set!
+    bytevector-u32-native-ref bytevector-u32-native-set!
+    bytevector-s32-ref bytevector-s32-set!
+    bytevector-s32-native-ref bytevector-s32-native-set!
+    u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+    
+    bytevector-u64-ref bytevector-u64-set!
+    bytevector-u64-native-ref bytevector-u64-native-set!
+    bytevector-s64-ref bytevector-s64-set!
+    bytevector-s64-native-ref bytevector-s64-native-set!
+    u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+    
+    bytevector-ieee-single-ref bytevector-ieee-single-set!
+    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+    bytevector-ieee-double-ref bytevector-ieee-double-set!
+    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+
+(define (add-interesting-primitive! name)
+  (hashq-set! *interesting-primitive-vars*
+              (or (module-variable (current-module) name)
+                  (error "unbound interesting primitive" name))
+              name))
+
+(define *interesting-primitive-vars* (make-hash-table))
+
+(for-each add-interesting-primitive! *interesting-primitive-names*)
+
+(define *primitive-constructors*
+  ;; Primitives that return a fresh object.
+  '(acons cons cons* list vector make-struct make-struct/no-tail
+    make-prompt-tag))
+
+(define *primitive-accessors*
+  ;; Primitives that are pure, but whose result depends on the mutable
+  ;; memory pointed to by their operands.
+  '(vector-ref
+    car cdr
+    memq memv
+    struct-ref
+    string-ref
+    bytevector-u8-ref bytevector-s8-ref
+    bytevector-u16-ref bytevector-u16-native-ref
+    bytevector-s16-ref bytevector-s16-native-ref
+    bytevector-u32-ref bytevector-u32-native-ref
+    bytevector-s32-ref bytevector-s32-native-ref
+    bytevector-u64-ref bytevector-u64-native-ref
+    bytevector-s64-ref bytevector-s64-native-ref
+    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+(define *effect-free-primitives*
+  `(values
+    eq? eqv? equal?
+    = < > <= >= zero? positive? negative?
+    ash logand logior logxor lognot
+    + * - / 1- 1+ quotient remainder modulo
+    not
+    pair? null? list? symbol? vector? struct? string? number? char?
+    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+    char<? char<=? char>=? char>?
+    integer->char char->integer number->string string->number
+    struct-vtable
+    string-length
+    ;; These all should get expanded out by expand-primitives!.
+    caar cadr cdar cddr
+    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+    ,@*primitive-constructors*
+    ,@*primitive-accessors*))
+
+;; Like *effect-free-primitives* above, but further restricted in that they
+;; cannot raise exceptions.
+(define *effect+exception-free-primitives*
+  '(values
+    eq? eqv? equal?
+    not
+    pair? null? list? symbol? vector? struct? string? number? char?
+    acons cons cons* list vector))
+
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives* 
+  '(apply @apply
+    call-with-values @call-with-values
+    call-with-current-continuation @call-with-current-continuation
+    call/cc
+    dynamic-wind
+    @dynamic-wind
+    values
+    @prompt call-with-prompt @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+  '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+  '((even? . odd?)
+    (exact? . inexact?)
+    ;; (< <= > >=) are not negatable because of NaNs.
+    (char<? . char>=?)
+    (char>? . char<=?)))
+
+(define *effect-free-primitive-table* (make-hash-table))
+(define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
+
+(for-each (lambda (x)
+            (hashq-set! *effect-free-primitive-table* x #t))
+          *effect-free-primitives*)
+(for-each (lambda (x) 
+            (hashq-set! *effect+exceptions-free-primitive-table* x #t))
+          *effect+exception-free-primitives*)
+(for-each (lambda (x) 
+            (hashq-set! *multiply-valued-primitive-table* x #t))
+          *multiply-valued-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *bailout-primitive-table* x #t))
+          *bailout-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+            (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+          *negatable-primitives*)
+
+(define (constructor-primitive? prim)
+  (memq prim *primitive-constructors*))
+(define (accessor-primitive? prim)
+  (memq prim *primitive-accessors*))
+(define (effect-free-primitive? prim)
+  (hashq-ref *effect-free-primitive-table* prim))
+(define (effect+exception-free-primitive? prim)
+  (hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+  (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+  (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+  (hashq-ref *negatable-primitive-table* prim))
+
+(define (resolve-primitives! x mod)
+  (post-order!
+   (lambda (x)
+     (record-case x
+       ((<toplevel-ref> src name)
+        (and=> (hashq-ref *interesting-primitive-vars*
+                          (module-variable mod name))
+               (lambda (name) (make-primitive-ref src name))))
+       ((<module-ref> src mod name public?)
+        (and=> (and=> (resolve-module mod)
+                      (if public?
+                          module-public-interface
+                          identity))
+               (lambda (m)
+                 (and=> (hashq-ref *interesting-primitive-vars*
+                                   (module-variable m name))
+                        (lambda (name)
+                          (make-primitive-ref src name))))))
+       (else #f)))
+   x))
+
+
+
+(define *primitive-expand-table* (make-hash-table))
+
+(define (expand-primitives! x)
+  (pre-order!
+   (lambda (x)
+     (record-case x
+       ((<application> src proc args)
+        (and (primitive-ref? proc)
+             (let ((expand (hashq-ref *primitive-expand-table*
+                                      (primitive-ref-name proc))))
+               (and expand (apply expand src args)))))
+       (else #f)))
+   x))
+
+;;; I actually did spend about 10 minutes trying to redo this with
+;;; syntax-rules. Patches appreciated.
+;;;
+(define-macro (define-primitive-expander sym . clauses)
+  (define (inline-args args)
+    (let lp ((in args) (out '()))
+      (cond ((null? in) `(list ,@(reverse out)))
+            ((symbol? in) `(cons* ,@(reverse out) ,in))
+            ((pair? (car in))
+             (lp (cdr in)
+                 (cons (if (eq? (caar in) 'quote)
+                           `(make-const src ,@(cdar in))
+                           `(make-application src (make-primitive-ref src ',(caar in))
+                                              ,(inline-args (cdar in))))
+                       out)))
+            ((symbol? (car in))
+             ;; assume it's locally bound
+             (lp (cdr in) (cons (car in) out)))
+            ((self-evaluating? (car in))
+             (lp (cdr in) (cons `(make-const src ,(car in)) out)))
+            (else
+             (error "what what" (car in))))))
+  (define (consequent exp)
+    (cond
+     ((pair? exp)
+      (pmatch exp
+        ((if ,test ,then ,else)
+         `(if ,test
+              ,(consequent then)
+              ,(consequent else)))
+        (else
+         `(make-application src (make-primitive-ref src ',(car exp))
+                            ,(inline-args (cdr exp))))))
+     ((symbol? exp)
+      ;; assume locally bound
+      exp)
+     ((number? exp)
+      `(make-const src ,exp))
+     ((not exp)
+      ;; failed match
+      #f)
+     (else (error "bad consequent yall" exp))))
+  `(hashq-set! *primitive-expand-table*
+               ',sym
+               (match-lambda*
+                ,@(let lp ((in clauses) (out '()))
+                    (if (null? in)
+                        (reverse (cons '(_ #f) out))
+                        (lp (cddr in)
+                            (cons `((src . ,(car in))
+                                    ,(consequent (cadr in)))
+                                  out)))))))
+
+(define-primitive-expander zero? (x)
+  (= x 0))
+
+(define-primitive-expander positive? (x)
+  (> x 0))
+
+(define-primitive-expander negative? (x)
+  (< x 0))
+
+;; FIXME: All the code that uses `const?' is redundant with `peval'.
+
+(define-primitive-expander +
+  () 0
+  (x) (values x)
+  (x y) (if (and (const? y) (eqv? (const-exp y) 1))
+            (1+ x)
+            (if (and (const? y) (eqv? (const-exp y) -1))
+                (1- x)
+                (if (and (const? x) (eqv? (const-exp x) 1))
+                    (1+ y)
+                    (if (and (const? x) (eqv? (const-exp x) -1))
+                        (1- y)
+                        (+ x y)))))
+  (x y z ... last) (+ (+ x y . z) last))
+
+(define-primitive-expander *
+  () 1
+  (x) (values x)
+  (x y z ... last) (* (* x y . z) last))
+  
+(define-primitive-expander -
+  (x) (- 0 x)
+  (x y) (if (and (const? y) (eqv? (const-exp y) 1))
+            (1- x)
+            (- x y))
+  (x y z ... last) (- (- x y . z) last))
+  
+(define-primitive-expander /
+  (x) (/ 1 x)
+  (x y z ... last) (/ (/ x y . z) last))
+  
+(define-primitive-expander logior
+  () 0
+  (x) (logior x 0)
+  (x y) (logior x y)
+  (x y z ... last) (logior (logior x y . z) last))
+
+(define-primitive-expander logand
+  () -1
+  (x) (logand x -1)
+  (x y) (logand x y)
+  (x y z ... last) (logand (logand x y . z) last))
+
+(define-primitive-expander caar (x) (car (car x)))
+(define-primitive-expander cadr (x) (car (cdr x)))
+(define-primitive-expander cdar (x) (cdr (car x)))
+(define-primitive-expander cddr (x) (cdr (cdr x)))
+(define-primitive-expander caaar (x) (car (car (car x))))
+(define-primitive-expander caadr (x) (car (car (cdr x))))
+(define-primitive-expander cadar (x) (car (cdr (car x))))
+(define-primitive-expander caddr (x) (car (cdr (cdr x))))
+(define-primitive-expander cdaar (x) (cdr (car (car x))))
+(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
+(define-primitive-expander cddar (x) (cdr (cdr (car x))))
+(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
+(define-primitive-expander caaaar (x) (car (car (car (car x)))))
+(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
+(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
+(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
+(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
+(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
+(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
+(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
+(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
+(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
+(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
+(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-primitive-expander cons*
+  (x) (values x)
+  (x y) (cons x y)
+  (x y . rest) (cons x (cons* y . rest)))
+
+(define-primitive-expander acons (x y z)
+  (cons (cons x y) z))
+
+(define-primitive-expander apply (f a0 . args)
+  (@apply f a0 . args))
+
+(define-primitive-expander call-with-values (producer consumer)
+  (@call-with-values producer consumer))
+
+(define-primitive-expander call-with-current-continuation (proc)
+  (@call-with-current-continuation proc))
+
+(define-primitive-expander call/cc (proc)
+  (@call-with-current-continuation proc))
+
+(define-primitive-expander make-struct (vtable tail-size . args)
+  (if (and (const? tail-size)
+           (let ((n (const-exp tail-size)))
+             (and (number? n) (exact? n) (zero? n))))
+      (make-struct/no-tail vtable . args)
+      #f))
+
+(define-primitive-expander u8vector-ref (vec i)
+  (bytevector-u8-ref vec i))
+(define-primitive-expander u8vector-set! (vec i x)
+  (bytevector-u8-set! vec i x))
+(define-primitive-expander s8vector-ref (vec i)
+  (bytevector-s8-ref vec i))
+(define-primitive-expander s8vector-set! (vec i x)
+  (bytevector-s8-set! vec i x))
+
+(define-primitive-expander u16vector-ref (vec i)
+  (bytevector-u16-native-ref vec (* i 2)))
+(define-primitive-expander u16vector-set! (vec i x)
+  (bytevector-u16-native-set! vec (* i 2) x))
+(define-primitive-expander s16vector-ref (vec i)
+  (bytevector-s16-native-ref vec (* i 2)))
+(define-primitive-expander s16vector-set! (vec i x)
+  (bytevector-s16-native-set! vec (* i 2) x))
+
+(define-primitive-expander u32vector-ref (vec i)
+  (bytevector-u32-native-ref vec (* i 4)))
+(define-primitive-expander u32vector-set! (vec i x)
+  (bytevector-u32-native-set! vec (* i 4) x))
+(define-primitive-expander s32vector-ref (vec i)
+  (bytevector-s32-native-ref vec (* i 4)))
+(define-primitive-expander s32vector-set! (vec i x)
+  (bytevector-s32-native-set! vec (* i 4) x))
+
+(define-primitive-expander u64vector-ref (vec i)
+  (bytevector-u64-native-ref vec (* i 8)))
+(define-primitive-expander u64vector-set! (vec i x)
+  (bytevector-u64-native-set! vec (* i 8) x))
+(define-primitive-expander s64vector-ref (vec i)
+  (bytevector-s64-native-ref vec (* i 8)))
+(define-primitive-expander s64vector-set! (vec i x)
+  (bytevector-s64-native-set! vec (* i 8) x))
+
+(define-primitive-expander f32vector-ref (vec i)
+  (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+  (bytevector-ieee-single-native-set! vec (* i 4) x))
+(define-primitive-expander f32vector-ref (vec i)
+  (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+  (bytevector-ieee-single-native-set! vec (* i 4) x))
+
+(define-primitive-expander f64vector-ref (vec i)
+  (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+  (bytevector-ieee-double-native-set! vec (* i 8) x))
+(define-primitive-expander f64vector-ref (vec i)
+  (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+  (bytevector-ieee-double-native-set! vec (* i 8) x))
+
+(define (chained-comparison-expander prim-name)
+  (case-lambda
+    ((src) (make-const src #t))
+    ((src a) #f)
+    ((src a b) #f)
+    ((src a b . rest)
+     (let* ((prim (make-primitive-ref src prim-name))
+            (b-sym (gensym "b"))
+            (b* (make-lexical-ref src 'b b-sym)))
+       (make-let src
+                 '(b)
+                 (list b-sym)
+                 (list b)
+                 (make-conditional src
+                                   (make-application src prim (list a b*))
+                                   (make-application src prim (cons b* rest))
+                                   (make-const src #f)))))))
+
+(for-each (lambda (prim-name)
+            (hashq-set! *primitive-expand-table* prim-name
+                        (chained-comparison-expander prim-name)))
+          '(< > <= >= =))
+
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+  (case-lambda
+    ((src a b)
+     ;; Simplify cases where either A or B is constant.
+     (define (maybe-simplify a b)
+       (and (const? a)
+            (let ((v (const-exp a)))
+              (and (or (memq v '(#f #t () #nil))
+                       (symbol? v)
+                       (and (integer? v)
+                            (exact? v)
+                            (<= most-negative-fixnum v most-positive-fixnum)))
+                   (make-application src (make-primitive-ref #f 'eq?)
+                                     (list a b))))))
+     (or (maybe-simplify a b) (maybe-simplify b a)))
+    (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
+(hashq-set! *primitive-expand-table*
+            'dynamic-wind
+            (case-lambda
+              ((src pre thunk post)
+               (let ((PRE (gensym "pre-"))
+                     (THUNK (gensym "thunk-"))
+                     (POST (gensym "post-")))
+                 (make-let
+                  src
+                  '(pre thunk post)
+                  (list PRE THUNK POST)
+                  (list pre thunk post)
+                  (make-dynwind
+                   src
+                   (make-lexical-ref #f 'pre PRE)
+                   (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
+                   (make-lexical-ref #f 'post POST)))))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
+            '@dynamic-wind
+            (case-lambda
+              ((src pre expr post)
+               (let ((PRE (gensym "pre-"))
+                     (POST (gensym "post-")))
+                 (make-let
+                  src
+                  '(pre post)
+                  (list PRE POST)
+                  (list pre post)
+                  (make-dynwind
+                   src
+                   (make-lexical-ref #f 'pre PRE)
+                   expr
+                   (make-lexical-ref #f 'post POST)))))))
+
+(hashq-set! *primitive-expand-table*
+            'fluid-ref
+            (case-lambda
+              ((src fluid) (make-dynref src fluid))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
+            'fluid-set!
+            (case-lambda
+              ((src fluid exp) (make-dynset src fluid exp))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
+            '@prompt
+            (case-lambda
+              ((src tag exp handler)
+               (let ((args-sym (gensym)))
+                 (make-prompt
+                  src tag exp
+                  ;; If handler itself is a lambda, the inliner can do some
+                  ;; trickery here.
+                  (make-lambda-case
+                   (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+                   (make-application #f (make-primitive-ref #f 'apply)
+                                     (list handler
+                                           (make-lexical-ref #f 'args args-sym)))
+                   #f))))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
+            'call-with-prompt
+            (case-lambda
+              ((src tag thunk handler)
+               (let ((handler-sym (gensym))
+                     (args-sym (gensym)))
+                 (make-let
+                  src '(handler) (list handler-sym) (list handler)
+                  (make-prompt
+                   src tag (make-application #f thunk '())
+                   ;; If handler itself is a lambda, the inliner can do some
+                   ;; trickery here.
+                   (make-lambda-case
+                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+                    (make-application
+                     #f (make-primitive-ref #f 'apply)
+                     (list (make-lexical-ref #f 'handler handler-sym)
+                           (make-lexical-ref #f 'args args-sym)))
+                    #f)))))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
+            '@abort
+            (case-lambda
+              ((src tag tail-args)
+               (make-abort src tag '() tail-args))
+              (else #f)))
+(hashq-set! *primitive-expand-table*
+            'abort-to-prompt
+            (case-lambda
+              ((src tag . args)
+               (make-abort src tag args (make-const #f '())))
+              (else #f)))
+;;; Tree Intermediate Language
+
+;; Copyright (C) 2009, 2010, 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
+
+;;; Code:
+
+(define-module (language tree-il spec)
+  #\use-module (system base language)
+  #\use-module (system base pmatch)
+  #\use-module (language glil)
+  #\use-module (language tree-il)
+  #\use-module (language tree-il compile-glil)
+  #\export (tree-il))
+
+(define (write-tree-il exp . port)
+  (apply write (unparse-tree-il exp) port))
+
+(define (join exps env)
+  (pmatch exps
+    (() (make-void #f))
+    ((,x) x)
+    (else (make-sequence #f exps))))
+
+(define-language tree-il
+  #\title	"Tree Intermediate Language"
+  #\reader	(lambda (port env) (read port))
+  #\printer	write-tree-il
+  #\parser      parse-tree-il
+  #\joiner      join
+  #\compilers   `((glil . ,compile-glil))
+  #\for-humans? #f
+  )
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001, 2010, 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
+
+;;; Code:
+
+(define-module (language value spec)
+  #\use-module (system base language)
+  #\export (value))
+
+(define-language value
+  #\title	"Values"
+  #\reader	#f
+  #\printer	write
+  #\for-humans? #f
+  )
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+;;;;
+;;;; This file was based upon stklos.stk from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops)
+  #\use-module (srfi srfi-1)
+  #\use-module (ice-9 match)
+  #\use-module (oop goops util)
+  #\export-syntax (define-class class standard-define-class
+                   define-generic define-accessor define-method
+                   define-extended-generic define-extended-generics
+                   method)
+  #\export (is-a? class-of
+           ensure-metaclass ensure-metaclass-with-supers
+	   make-class
+	   make-generic ensure-generic
+	   make-extended-generic
+	   make-accessor ensure-accessor
+	   add-method!
+	   class-slot-ref class-slot-set! slot-unbound slot-missing 
+	   slot-definition-name  slot-definition-options
+	   slot-definition-allocation
+	   slot-definition-getter slot-definition-setter
+	   slot-definition-accessor
+	   slot-definition-init-value slot-definition-init-form
+	   slot-definition-init-thunk slot-definition-init-keyword 
+	   slot-init-function class-slot-definition
+	   method-source
+	   compute-cpl compute-std-cpl compute-get-n-set compute-slots
+	   compute-getter-method compute-setter-method
+	   allocate-instance initialize make-instance make
+	   no-next-method  no-applicable-method no-method
+	   change-class update-instance-for-different-class
+	   shallow-clone deep-clone
+	   class-redefinition
+	   apply-generic apply-method apply-methods
+	   compute-applicable-methods %compute-applicable-methods
+	   method-more-specific? sort-applicable-methods
+	   class-subclasses class-methods
+	   goops-error
+	   min-fixnum max-fixnum
+	   ;;; *fixme* Should go into goops.c
+	   instance?  slot-ref-using-class
+	   slot-set-using-class! slot-bound-using-class?
+	   slot-exists-using-class? slot-ref slot-set! slot-bound?
+	   class-name class-direct-supers class-direct-subclasses
+	   class-direct-methods class-direct-slots class-precedence-list
+	   class-slots
+	   generic-function-name
+	   generic-function-methods method-generic-function
+	   method-specializers method-formals
+	   primitive-generic-generic enable-primitive-generic!
+	   method-procedure accessor-method-slot-definition
+	   slot-exists? make find-method get-keyword))
+
+(define *goops-module* (current-module))
+
+;; First initialize the builtin part of GOOPS
+(eval-when (expand load eval)
+  (%init-goops-builtins))
+
+(eval-when (expand load eval)
+  (use-modules ((language tree-il primitives) \:select (add-interesting-primitive!)))
+  (add-interesting-primitive! 'class-of))
+
+;; Then load the rest of GOOPS
+(use-modules (oop goops dispatch))
+
+;;;
+;;; Compiling next methods into method bodies
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compute-cmethod methods types)
+  (match methods
+    ((method . methods)
+     (let ((make-procedure (slot-ref method 'make-procedure)))
+       (if make-procedure
+           (make-procedure
+            (if (null? methods)
+                (lambda args
+                  (no-next-method (method-generic-function method) args))
+                (compute-cmethod methods types)))
+           (method-procedure method))))))
+
+
+(eval-when (expand load eval)
+  (define min-fixnum (- (expt 2 29)))
+  (define max-fixnum (- (expt 2 29) 1)))
+
+;;
+;; goops-error
+;;
+(define (goops-error format-string . args)
+  (scm-error 'goops-error #f format-string args '()))
+
+;;
+;; is-a?
+;;
+(define (is-a? obj class)
+  (and (memq class (class-precedence-list (class-of obj))) #t))
+
+
+;;;
+;;; {Meta classes}
+;;;
+
+(define ensure-metaclass-with-supers
+  (let ((table-of-metas '()))
+    (lambda (meta-supers)
+      (let ((entry (assoc meta-supers table-of-metas)))
+	(if entry
+	    ;; Found a previously created metaclass
+	    (cdr entry)
+	    ;; Create a new meta-class which inherit from "meta-supers"
+	    (let ((new (make <class> #\dsupers meta-supers
+			             #\slots   '()
+				     #\name   (gensym "metaclass"))))
+	      (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
+	      new))))))
+
+(define (ensure-metaclass supers)
+  (if (null? supers)
+      <class>
+      (let* ((all-metas (map (lambda (x) (class-of x)) supers))
+	     (all-cpls  (append-map (lambda (m)
+                                      (cdr (class-precedence-list m))) 
+                                    all-metas))
+	     (needed-metas '()))
+	;; Find the most specific metaclasses.  The new metaclass will be
+	;; a subclass of these.
+	(for-each
+	 (lambda (meta)
+	   (if (and (not (member meta all-cpls))
+		      (not (member meta needed-metas)))
+	     (set! needed-metas (append needed-metas (list meta)))))
+	 all-metas)
+	;; Now return a subclass of the metaclasses we found.
+	(if (null? (cdr needed-metas))
+	    (car needed-metas)  ; If there's only one, just use it.
+	    (ensure-metaclass-with-supers needed-metas)))))
+
+;;;
+;;; {Classes}
+;;;
+
+;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;;   OPTION ::= KEYWORD VALUE
+;;;
+
+(define (kw-do-map mapper f kwargs)
+  (define (keywords l)
+    (cond
+     ((null? l) '())
+     ((or (null? (cdr l)) (not (keyword? (car l))))
+      (goops-error "malformed keyword arguments: ~a" kwargs))
+     (else (cons (car l) (keywords (cddr l))))))
+  (define (args l)
+    (if (null? l) '() (cons (cadr l) (args (cddr l)))))
+  ;; let* to check keywords first
+  (let* ((k (keywords kwargs))
+         (a (args kwargs)))
+    (mapper f k a)))
+
+(define (make-class supers slots . options)
+  (let* ((name (get-keyword #\name options (make-unbound)))
+         (supers (if (not (or-map (lambda (class)
+                                    (memq <object>
+                                          (class-precedence-list class)))
+                                  supers))
+                     (append supers (list <object>))
+                     supers))
+         (metaclass (or (get-keyword #\metaclass options #f)
+                        (ensure-metaclass supers))))
+
+    ;; Verify that all direct slots are different and that we don't inherit
+    ;; several time from the same class
+    (let ((tmp1 (find-duplicate supers))
+          (tmp2 (find-duplicate (map slot-definition-name slots))))
+      (if tmp1
+          (goops-error "make-class: super class ~S is duplicate in class ~S"
+                       tmp1 name))
+      (if tmp2
+          (goops-error "make-class: slot ~S is duplicate in class ~S"
+                       tmp2 name)))
+
+    ;; Everything seems correct, build the class
+    (apply make metaclass
+           #\dsupers supers
+           #\slots slots 
+           #\name name
+           options)))
+
+;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;;   OPTION ::= KEYWORD VALUE
+;;;
+(define-macro (class supers . slots)
+  (define (make-slot-definition-forms slots)
+    (map
+     (lambda (def)
+       (cond
+        ((pair? def)
+         `(list ',(car def)
+                ,@(kw-do-map append-map
+                             (lambda (kw arg)
+                               (case kw
+                                 ((#\init-form)
+                                  `(#\init-form ',arg
+                                    #\init-thunk (lambda () ,arg)))
+                                 (else (list kw arg))))
+                             (cdr def))))
+        (else
+         `(list ',def))))
+     slots))
+  (if (not (list? supers))
+      (goops-error "malformed superclass list: ~S" supers))
+  (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
+        (options (or (find-tail keyword? slots) '())))
+    `(make-class
+      ;; evaluate super class variables
+      (list ,@supers)
+      ;; evaluate slot definitions, except the slot name!
+      (list ,@(make-slot-definition-forms slots))
+      ;; evaluate class options
+      ,@options)))
+
+(define-syntax define-class-pre-definition
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (k arg rest ...) out ...)
+       (keyword? (syntax->datum #'k))
+       (case (syntax->datum #'k)
+         ((#\getter #\setter)
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <generic>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
+         ((#\accessor)
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <accessor>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
+         (else
+          #'(define-class-pre-definition (rest ...) out ...))))
+      ((_ () out ...)
+       #'(begin out ...)))))
+       
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+  (lambda (x)
+    (syntax-case x ()
+      ((_ () out ...)
+       #'(begin out ...))
+      ((_ (slot rest ...) out ...)
+       (keyword? (syntax->datum #'slot))
+       #'(begin out ...))
+      ((_ (slot rest ...) out ...)
+       (identifier? #'slot)
+       #'(define-class-pre-definitions (rest ...)
+         out ...))
+      ((_ ((slotname slotopt ...) rest ...) out ...)
+       #'(define-class-pre-definitions (rest ...) 
+         out ... (define-class-pre-definition (slotopt ...)))))))
+
+(define-syntax-rule (define-class name supers slot ...)
+  (begin
+    (define-class-pre-definitions (slot ...))
+    (if (and (defined? 'name)
+             (is-a? name <class>)
+             (memq <object> (class-precedence-list name)))
+        (class-redefinition name
+                            (class supers slot ... #\name 'name))
+        (toplevel-define! 'name (class supers slot ... #\name 'name)))))
+       
+(define-syntax-rule (standard-define-class arg ...)
+  (define-class arg ...))
+
+;;;
+;;; {Generic functions and accessors}
+;;;
+
+;; Apparently the desired semantics are that we extend previous
+;; procedural definitions, but that if `name' was already a generic, we
+;; overwrite its definition.
+(define-macro (define-generic name)
+  (if (not (symbol? name))
+      (goops-error "bad generic function name: ~S" name))
+  `(define ,name
+     (if (and (defined? ',name) (is-a? ,name <generic>))
+         (make <generic> #\name ',name)
+         (ensure-generic (if (defined? ',name) ,name #f) ',name))))
+
+(define-macro (define-extended-generic name val)
+  (if (not (symbol? name))
+      (goops-error "bad generic function name: ~S" name))
+  `(define ,name (make-extended-generic ,val ',name)))
+
+(define-macro (define-extended-generics names . args)
+  (let ((prefixes (get-keyword #\prefix args #f)))
+    (if prefixes
+        `(begin
+           ,@(map (lambda (name)
+                    `(define-extended-generic ,name
+                       (list ,@(map (lambda (prefix)
+                                      (symbol-append prefix name))
+                                    prefixes))))
+                  names))
+        (goops-error "no prefixes supplied"))))
+
+(define* (make-generic #\optional name)
+  (make <generic> #\name name))
+
+(define* (make-extended-generic gfs #\optional name)
+  (let* ((gfs (if (list? gfs) gfs (list gfs)))
+	 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
+    (let ((ans (if gws?
+		   (let* ((sname (and name (make-setter-name name)))
+			  (setters
+			   (append-map (lambda (gf)
+					 (if (is-a? gf <generic-with-setter>)
+					     (list (ensure-generic (setter gf)
+								   sname))
+					     '()))
+				       gfs))
+			  (es (make <extended-generic-with-setter>
+				#\name name
+				#\extends gfs
+				#\setter (make <extended-generic>
+					   #\name sname
+					   #\extends setters))))
+		     (extended-by! setters (setter es))
+		     es)
+		   (make <extended-generic>
+		     #\name name
+		     #\extends gfs))))
+      (extended-by! gfs ans)
+      ans)))
+
+(define (extended-by! gfs eg)
+  (for-each (lambda (gf)
+	      (slot-set! gf 'extended-by
+			 (cons eg (slot-ref gf 'extended-by))))
+	    gfs)
+  (invalidate-method-cache! eg))
+
+(define (not-extended-by! gfs eg)
+  (for-each (lambda (gf)
+	      (slot-set! gf 'extended-by
+			 (delq! eg (slot-ref gf 'extended-by))))
+	    gfs)
+  (invalidate-method-cache! eg))
+
+(define* (ensure-generic old-definition #\optional name)
+  (cond ((is-a? old-definition <generic>) old-definition)
+        ((procedure-with-setter? old-definition)
+         (make <generic-with-setter>
+           #\name name
+           #\default (procedure old-definition)
+           #\setter (setter old-definition)))
+        ((procedure? old-definition)
+         (if (generic-capability? old-definition) old-definition
+             (make <generic> #\name name #\default old-definition)))
+        (else (make <generic> #\name name))))
+
+;; same semantics as <generic>
+(define-syntax-rule (define-accessor name)
+  (define name
+    (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
+          ((is-a? name <accessor>) (make <accessor> #\name 'name))
+          (else                    (ensure-accessor name 'name)))))
+
+(define (make-setter-name name)
+  (string->symbol (string-append "setter:" (symbol->string name))))
+
+(define* (make-accessor #\optional name)
+  (make <accessor>
+    #\name name
+    #\setter (make <generic>
+               #\name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #\optional name)
+  (cond ((and (is-a? proc <accessor>)
+              (is-a? (setter proc) <generic>))
+         proc)
+        ((is-a? proc <generic-with-setter>)
+         (upgrade-accessor proc (setter proc)))
+        ((is-a? proc <generic>)
+         (upgrade-accessor proc (make-generic name)))
+        ((procedure-with-setter? proc)
+         (make <accessor>
+           #\name name
+           #\default (procedure proc)
+           #\setter (ensure-generic (setter proc) name)))
+        ((procedure? proc)
+         (ensure-accessor (if (generic-capability? proc)
+                              (make <generic> #\name name #\default proc)
+                              (ensure-generic proc name))
+                          name))
+        (else
+         (make-accessor name))))
+
+(define (upgrade-accessor generic setter)
+  (let ((methods (slot-ref generic 'methods))
+	(gws (make (if (is-a? generic <extended-generic>)
+		       <extended-generic-with-setter>
+		       <accessor>)
+		   #\name (generic-function-name generic)
+		   #\extended-by (slot-ref generic 'extended-by)
+		   #\setter setter)))
+    (if (is-a? generic <extended-generic>)
+	(let ((gfs (slot-ref generic 'extends)))
+	  (not-extended-by! gfs generic)
+	  (slot-set! gws 'extends gfs)
+	  (extended-by! gfs gws)))
+    ;; Steal old methods
+    (for-each (lambda (method)
+		(slot-set! method 'generic-function gws))
+	      methods)
+    (slot-set! gws 'methods methods)
+    (invalidate-method-cache! gws)
+    gws))
+
+;;;
+;;; {Methods}
+;;;
+
+(define (toplevel-define! name val)
+  (module-define! (current-module) name val))
+
+(define-syntax define-method
+  (syntax-rules (setter)
+    ((_ ((setter name) . args) body ...)
+     (begin
+       (if (or (not (defined? 'name))
+               (not (is-a? name <accessor>)))
+           (toplevel-define! 'name
+                             (ensure-accessor
+                              (if (defined? 'name) name #f) 'name)))
+       (add-method! (setter name) (method args body ...))))
+    ((_ (name . args) body ...)
+     (begin
+       ;; FIXME: this code is how it always was, but it's quite cracky:
+       ;; it will only define the generic function if it was undefined
+       ;; before (ok), or *was defined to #f*. The latter is crack. But
+       ;; there are bootstrap issues about fixing this -- change it to
+       ;; (is-a? name <generic>) and see.
+       (if (or (not (defined? 'name))
+               (not name))
+           (toplevel-define! 'name (make <generic> #\name 'name)))
+       (add-method! name (method args body ...))))))
+
+(define-syntax method
+  (lambda (x)
+    (define (parse-args args)
+      (let lp ((ls args) (formals '()) (specializers '()))
+        (syntax-case ls ()
+          (((f s) . rest)
+           (and (identifier? #'f) (identifier? #'s))
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'s specializers)))
+          ((f . rest)
+           (identifier? #'f)
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'<top> specializers)))
+          (()
+           (list (reverse formals)
+                 (reverse (cons #''() specializers))))
+          (tail
+           (identifier? #'tail)
+           (list (append (reverse formals) #'tail)
+                 (reverse (cons #'<top> specializers)))))))
+
+    (define (find-free-id exp referent)
+      (syntax-case exp ()
+        ((x . y)
+         (or (find-free-id #'x referent)
+             (find-free-id #'y referent)))
+        (x
+         (identifier? #'x)
+         (let ((id (datum->syntax #'x referent)))
+           (and (free-identifier=? #'x id) id)))
+        (_ #f)))
+
+    (define (compute-procedure formals body)
+      (syntax-case body ()
+        ((body0 ...)
+         (with-syntax ((formals formals))
+           #'(lambda formals body0 ...)))))
+
+    (define (->proper args)
+      (let lp ((ls args) (out '()))
+        (syntax-case ls ()
+          ((x . xs)        (lp #'xs (cons #'x out)))
+          (()              (reverse out))
+          (tail            (reverse (cons #'tail out))))))
+
+    (define (compute-make-procedure formals body next-method)
+      (syntax-case body ()
+        ((body ...)
+         (with-syntax ((next-method next-method))
+           (syntax-case formals ()
+             ((formal ...)
+              #'(lambda (real-next-method)
+                  (lambda (formal ...)
+                    (let ((next-method (lambda args
+                                         (if (null? args)
+                                             (real-next-method formal ...)
+                                             (apply real-next-method args)))))
+                      body ...))))
+             (formals
+              (with-syntax (((formal ...) (->proper #'formals)))
+                #'(lambda (real-next-method)
+                    (lambda formals
+                      (let ((next-method (lambda args
+                                           (if (null? args)
+                                               (apply real-next-method formal ...)
+                                               (apply real-next-method args)))))
+                        body ...))))))))))
+
+    (define (compute-procedures formals body)
+      ;; So, our use of this is broken, because it operates on the
+      ;; pre-expansion source code. It's equivalent to just searching
+      ;; for referent in the datums. Ah well.
+      (let ((id (find-free-id body 'next-method)))
+        (if id
+            ;; return a make-procedure
+            (values #'#f
+                    (compute-make-procedure formals body id))
+            (values (compute-procedure formals body)
+                    #'#f))))
+
+    (syntax-case x ()
+      ((_ args) #'(method args (if #f #f)))
+      ((_ args body0 body1 ...)
+       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
+         (call-with-values
+             (lambda ()
+               (compute-procedures #'formals #'(body0 body1 ...)))
+           (lambda (procedure make-procedure)
+             (with-syntax ((procedure procedure)
+                           (make-procedure make-procedure))
+               #'(make <method>
+                   #\specializers (cons* specializer ...)
+                   #\formals 'formals
+                   #\body '(body0 body1 ...)
+                   #\make-procedure make-procedure
+                   #\procedure procedure)))))))))
+
+;;;
+;;; {add-method!}
+;;;
+
+(define (add-method-in-classes! m)
+  ;; Add method in all the classes which appears in its specializers list
+  (for-each* (lambda (x)
+	       (let ((dm (class-direct-methods x)))
+		 (if (not (memq m dm))
+		     (slot-set! x 'direct-methods (cons m dm)))))
+	     (method-specializers m)))
+
+(define (remove-method-in-classes! m)
+  ;; Remove method in all the classes which appears in its specializers list
+  (for-each* (lambda (x)
+	       (slot-set! x
+			  'direct-methods
+			  (delv! m (class-direct-methods x))))
+	     (method-specializers m)))
+
+(define (compute-new-list-of-methods gf new)
+  (let ((new-spec (method-specializers new))
+	(methods  (slot-ref gf 'methods)))
+    (let loop ((l methods))
+      (if (null? l)
+	  (cons new methods)
+	  (if (equal? (method-specializers (car l)) new-spec)
+	      (begin 
+		;; This spec. list already exists. Remove old method from dependents
+		(remove-method-in-classes! (car l))
+		(set-car! l new) 
+		methods)
+	      (loop (cdr l)))))))
+
+(define (method-n-specializers m)
+  (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+  (fold (lambda (m n) (max n (method-n-specializers m)))
+        0
+        (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+  (%invalidate-method-cache! gf)
+  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+  (for-each (lambda (gf) (invalidate-method-cache! gf))
+            (slot-ref gf 'extended-by)))
+
+(define internal-add-method!
+  (method ((gf <generic>) (m <method>))
+    (slot-set! m  'generic-function gf)
+    (slot-set! gf 'methods (compute-new-list-of-methods gf m))
+    (invalidate-method-cache! gf)
+    (add-method-in-classes! m)
+    *unspecified*))
+
+(define-generic add-method!)
+
+((method-procedure internal-add-method!) add-method! internal-add-method!)
+
+(define-method (add-method! (proc <procedure>) (m <method>))
+  (if (generic-capability? proc)
+      (begin
+	(enable-primitive-generic! proc)
+	(add-method! proc m))
+      (next-method)))
+
+(define-method (add-method! (pg <primitive-generic>) (m <method>))
+  (add-method! (primitive-generic-generic pg) m))
+
+(define-method (add-method! obj (m <method>))
+  (goops-error "~S is not a valid generic function" obj))
+
+;;;
+;;; {Access to meta objects}
+;;;
+
+;;;
+;;; Methods
+;;;
+(define-method (method-source (m <method>))
+  (let* ((spec (map* class-name (slot-ref m 'specializers)))
+	 (src (procedure-source (slot-ref m 'procedure))))
+    (and src
+         (let ((args (cadr src))
+               (body (cddr src)))
+           (cons 'method
+                 (cons (map* list args spec)
+                       body))))))
+
+(define-method (method-formals (m <method>))
+  (slot-ref m 'formals))
+
+;;;
+;;; Slots
+;;;
+(define slot-definition-name car)
+
+(define slot-definition-options cdr)
+
+(define (slot-definition-allocation s)
+  (get-keyword #\allocation (cdr s) #\instance))
+
+(define (slot-definition-getter s)
+  (get-keyword #\getter (cdr s) #f))
+
+(define (slot-definition-setter s)
+  (get-keyword #\setter (cdr s) #f))
+
+(define (slot-definition-accessor s)
+  (get-keyword #\accessor (cdr s) #f))
+
+(define (slot-definition-init-value s)
+  ;; can be #f, so we can't use #f as non-value
+  (get-keyword #\init-value (cdr s) (make-unbound)))
+
+(define (slot-definition-init-form s)
+  (get-keyword #\init-form (cdr s) (make-unbound)))
+
+(define (slot-definition-init-thunk s)
+  (get-keyword #\init-thunk (cdr s) #f))
+
+(define (slot-definition-init-keyword s)
+  (get-keyword #\init-keyword (cdr s) #f))
+
+(define (class-slot-definition class slot-name)
+  (assq slot-name (class-slots class)))
+
+(define (slot-init-function class slot-name)
+  (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+
+(define (accessor-method-slot-definition obj)
+  "Return the slot definition of the accessor @var{obj}."
+  (slot-ref obj 'slot-definition))
+
+
+;;;
+;;; {Standard methods used by the C runtime}
+;;;
+
+;;; Methods to compare objects
+;;;
+
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f)) 
+(set-primitive-generic! equal? g-equal?)
+
+;;;
+;;; methods to display/write an object
+;;;
+
+;     Code for writing objects must test that the slots they use are
+;     bound. Otherwise a slot-unbound method will be called and will 
+;     conduct to an infinite loop.
+
+;; Write
+(define (display-address o file)
+  (display (number->string (object-address o) 16) file))
+
+(define-method (write o file)
+  (display "#<instance " file)
+  (display-address o file)
+  (display #\> file))
+
+(define write-object (primitive-generic-generic write))
+
+(define-method (write (o <object>) file)
+  (let ((class (class-of o)))
+    (if (slot-bound? class 'name)
+	(begin
+	  (display "#<" file)
+	  (display (class-name class) file)
+	  (display #\space file)
+	  (display-address o file)
+	  (display #\> file))
+	(next-method))))
+
+(define-method (write (class <class>) file)
+  (let ((meta (class-of class)))
+    (if (and (slot-bound? class 'name)
+	     (slot-bound? meta 'name))
+	(begin
+	  (display "#<" file)
+	  (display (class-name meta) file)
+	  (display #\space file)
+	  (display (class-name class) file)
+	  (display #\space file)
+	  (display-address class file)
+	  (display #\> file))
+	(next-method))))
+
+(define-method (write (gf <generic>) file)
+  (let ((meta (class-of gf)))
+    (if (and (slot-bound? meta 'name)
+	     (slot-bound? gf 'methods))
+	(begin
+	  (display "#<" file)
+	  (display (class-name meta) file)
+	  (let ((name (generic-function-name gf)))
+	    (if name
+		(begin
+		  (display #\space file)
+		  (display name file))))
+	  (display " (" file)
+	  (display (length (generic-function-methods gf)) file)
+	  (display ")>" file))
+	(next-method))))
+
+(define-method (write (o <method>) file)
+  (let ((meta (class-of o)))
+    (if (and (slot-bound? meta 'name)
+	     (slot-bound? o 'specializers))
+	(begin
+	  (display "#<" file)
+	  (display (class-name meta) file)
+	  (display #\space file)
+	  (display (map* (lambda (spec)
+			   (if (slot-bound? spec 'name)
+			       (slot-ref spec 'name)
+			       spec))
+			 (method-specializers o))
+		   file)
+	  (display #\space file)
+	  (display-address o file)
+	  (display #\> file))
+	(next-method))))
+
+;; Display (do the same thing as write by default)
+(define-method (display o file) 
+  (write-object o file))
+
+;;;
+;;; Handling of duplicate bindings in the module system
+;;;
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <top>)
+			       (int2 <module>)
+			       (val2 <top>)
+			       (var <top>)
+			       (val <top>))
+  #f)
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <generic>)
+			       (int2 <module>)
+			       (val2 <generic>)
+			       (var <top>)
+			       (val <boolean>))
+  (and (not (eq? val1 val2))
+       (make-variable (make-extended-generic (list val2 val1) name))))
+
+(define-method (merge-generics (module <module>)
+			       (name <symbol>)
+			       (int1 <module>)
+			       (val1 <generic>)
+			       (int2 <module>)
+			       (val2 <generic>)
+			       (var <top>)
+			       (gf <extended-generic>))
+  (and (not (memq val2 (slot-ref gf 'extends)))
+       (begin
+	 (slot-set! gf
+		    'extends
+		    (cons val2 (delq! val2 (slot-ref gf 'extends))))
+	 (slot-set! val2
+		    'extended-by
+		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (invalidate-method-cache! gf)
+	 var)))
+
+(module-define! duplicate-handlers 'merge-generics merge-generics)
+
+(define-method (merge-accessors (module <module>)
+				(name <symbol>)
+				(int1 <module>)
+				(val1 <top>)
+				(int2 <module>)
+				(val2 <top>)
+				(var <top>)
+				(val <top>))
+  #f)
+
+(define-method (merge-accessors (module <module>)
+				(name <symbol>)
+				(int1 <module>)
+				(val1 <accessor>)
+				(int2 <module>)
+				(val2 <accessor>)
+				(var <top>)
+				(val <top>))
+  (merge-generics module name int1 val1 int2 val2 var val))
+
+(module-define! duplicate-handlers 'merge-accessors merge-accessors)
+
+;;;
+;;; slot access
+;;;
+
+(define (class-slot-g-n-s class slot-name)
+  (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
+	 (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
+			  (slot-missing class slot-name)))))
+    (if (not (memq (slot-definition-allocation this-slot)
+		   '(#\class #\each-subclass)))
+	(slot-missing class slot-name))
+    g-n-s))
+
+(define (class-slot-ref class slot)
+  (let ((x ((car (class-slot-g-n-s class slot)) #f)))
+    (if (unbound? x)
+	(slot-unbound class slot)
+	x)))
+
+(define (class-slot-set! class slot value)
+  ((cadr (class-slot-g-n-s class slot)) #f value))
+
+(define-method (slot-unbound (c <class>) (o <object>) s)
+  (goops-error "Slot `~S' is unbound in object ~S" s o))
+
+(define-method (slot-unbound (c <class>) s)
+  (goops-error "Slot `~S' is unbound in class ~S" s c))
+
+(define-method (slot-unbound (o <object>))
+  (goops-error "Unbound slot in object ~S" o))
+
+(define-method (slot-missing (c <class>) (o <object>) s)
+  (goops-error "No slot with name `~S' in object ~S" s o))
+  
+(define-method (slot-missing (c <class>) s)
+  (goops-error "No class slot with name `~S' in class ~S" s c))
+  
+
+(define-method (slot-missing (c <class>) (o <object>) s value)
+  (slot-missing c o s))
+
+;;; Methods for the possible error we can encounter when calling a gf
+
+(define-method (no-next-method (gf <generic>) args)
+  (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
+
+(define-method (no-applicable-method (gf <generic>) args)
+  (goops-error "No applicable method for ~S in call ~S"
+	       gf (cons (generic-function-name gf) args)))
+
+(define-method (no-method (gf <generic>) args)
+  (goops-error "No method defined for ~S"  gf))
+
+;;;
+;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
+;;;
+
+(define-method (shallow-clone (self <object>))
+  (let ((clone (%allocate-instance (class-of self) '()))
+	(slots (map slot-definition-name
+		    (class-slots (class-of self)))))
+    (for-each (lambda (slot)
+		(if (slot-bound? self slot)
+		    (slot-set! clone slot (slot-ref self slot))))
+	      slots)
+    clone))
+
+(define-method (deep-clone  (self <object>))
+  (let ((clone (%allocate-instance (class-of self) '()))
+	(slots (map slot-definition-name
+		    (class-slots (class-of self)))))
+    (for-each (lambda (slot)
+		(if (slot-bound? self slot)
+		    (slot-set! clone slot
+			       (let ((value (slot-ref self slot)))
+				 (if (instance? value)
+				     (deep-clone value)
+				     value)))))
+	      slots)
+    clone))
+
+;;;
+;;; {Class redefinition utilities}
+;;;
+
+;;; (class-redefinition OLD NEW)
+;;;
+
+;;; Has correct the following conditions:
+
+;;; Methods
+;;; 
+;;; 1. New accessor specializers refer to new header
+;;; 
+;;; Classes
+;;; 
+;;; 1. New class cpl refers to the new class header
+;;; 2. Old class header exists on old super classes direct-subclass lists
+;;; 3. New class header exists on new super classes direct-subclass lists
+
+(define-method (class-redefinition (old <class>) (new <class>))
+  ;; Work on direct methods:
+  ;;		1. Remove accessor methods from the old class 
+  ;;		2. Patch the occurences of new in the specializers by old
+  ;;		3. Displace the methods from old to new
+  (remove-class-accessors! old)					;; -1-
+  (let ((methods (class-direct-methods new)))
+    (for-each (lambda (m)
+     	         (update-direct-method! m new old))	;; -2-
+              methods)
+    (slot-set! new
+	       'direct-methods
+	       (append methods (class-direct-methods old))))
+
+  ;; Substitute old for new in new cpl
+  (set-car! (slot-ref new 'cpl) old)
+  
+  ;; Remove the old class from the direct-subclasses list of its super classes
+  (for-each (lambda (c) (slot-set! c 'direct-subclasses
+				   (delv! old (class-direct-subclasses c))))
+	    (class-direct-supers old))
+
+  ;; Replace the new class with the old in the direct-subclasses of the supers
+  (for-each (lambda (c)
+	      (slot-set! c 'direct-subclasses
+			 (cons old (delv! new (class-direct-subclasses c)))))
+	    (class-direct-supers new))
+
+  ;; Swap object headers
+  (%modify-class old new)
+
+  ;; Now old is NEW!
+
+  ;; Redefine all the subclasses of old to take into account modification
+  (for-each 
+       (lambda (c)
+	 (update-direct-subclass! c new old))
+       (class-direct-subclasses new))
+
+  ;; Invalidate class so that subsequent instances slot accesses invoke
+  ;; change-object-class
+  (slot-set! new 'redefined old)
+  (%invalidate-class new) ;must come after slot-set!
+
+  old)
+
+;;;
+;;; remove-class-accessors!
+;;;
+
+(define-method (remove-class-accessors! (c <class>))
+  (for-each (lambda (m)
+	      (if (is-a? m <accessor-method>)
+		  (let ((gf (slot-ref m 'generic-function)))
+		    ;; remove the method from its GF
+		    (slot-set! gf 'methods
+			       (delq1! m (slot-ref gf 'methods)))
+		    (invalidate-method-cache! gf)
+		    ;; remove the method from its specializers
+		    (remove-method-in-classes! m))))
+	    (class-direct-methods c)))
+
+;;;
+;;; update-direct-method!
+;;;
+
+(define-method (update-direct-method! (m  <method>)
+				      (old <class>)
+				      (new <class>))
+  (let loop ((l (method-specializers m)))
+    ;; Note: the <top> in dotted list is never used. 
+    ;; So we can work as if we had only proper lists.
+    (if (pair? l)       	  
+	(begin
+	  (if (eqv? (car l) old)  
+	      (set-car! l new))
+	  (loop (cdr l))))))
+
+;;;
+;;; update-direct-subclass!
+;;;
+
+(define-method (update-direct-subclass! (c <class>)
+					(old <class>)
+					(new <class>))
+  (class-redefinition c
+		      (make-class (class-direct-supers c)
+				  (class-direct-slots c)
+				  #\name (class-name c)
+				  #\metaclass (class-of c))))
+
+;;;
+;;; {Utilities for INITIALIZE methods}
+;;;
+
+;;; compute-slot-accessors
+;;;
+(define (compute-slot-accessors class slots)
+  (for-each
+      (lambda (s g-n-s)
+	(let ((getter-function (slot-definition-getter   s))
+	      (setter-function (slot-definition-setter   s))
+	      (accessor        (slot-definition-accessor s)))
+	  (if getter-function
+	      (add-method! getter-function
+			   (compute-getter-method class g-n-s)))
+	  (if setter-function
+	      (add-method! setter-function
+			   (compute-setter-method class g-n-s)))
+	  (if accessor
+	      (begin
+		(add-method! accessor
+			     (compute-getter-method class g-n-s))
+		(add-method! (setter accessor)
+			     (compute-setter-method class g-n-s))))))
+      slots (slot-ref class 'getters-n-setters)))
+
+(define-method (compute-getter-method (class <class>) g-n-s)
+  (let ((init-thunk (cadr g-n-s))
+        (g-n-s (cddr g-n-s)))
+    (make <accessor-method>
+          #\specializers (list class)
+          #\procedure (cond ((pair? g-n-s)
+                             (make-generic-bound-check-getter (car g-n-s)))
+                            (init-thunk
+                             (standard-get g-n-s))
+                            (else
+                             (bound-check-get g-n-s)))
+          #\slot-definition g-n-s)))
+
+(define-method (compute-setter-method (class <class>) g-n-s)
+  (let ((init-thunk (cadr g-n-s))
+        (g-n-s (cddr g-n-s)))
+    (make <accessor-method>
+      #\specializers (list class <top>)
+      #\procedure (if (pair? g-n-s)
+                      (cadr g-n-s)
+                      (standard-set g-n-s))
+      #\slot-definition g-n-s)))
+
+(define (make-generic-bound-check-getter proc)
+  (lambda (o) (assert-bound (proc o) o)))
+
+;; the idea is to compile the index into the procedure, for fastest
+;; lookup.
+
+(eval-when (expand load eval)
+  (define num-standard-pre-cache 20))
+
+(define-macro (define-standard-accessor-method form . body)
+  (let ((name (caar form))
+        (n-var (cadar form))
+        (args (cdr form)))
+    (define (make-one x)
+      (define (body-trans form)
+        (cond ((not (pair? form)) form)
+              ((eq? (car form) 'struct-ref)
+               `(,(car form) ,(cadr form) ,x))
+              ((eq? (car form) 'struct-set!)
+               `(,(car form) ,(cadr form) ,x ,(cadddr form)))
+              (else
+               (map body-trans form))))
+      `(lambda ,args ,@(map body-trans body)))
+    `(define ,name
+       (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
+         (lambda (n)
+           (if (< n ,num-standard-pre-cache)
+               (vector-ref cache n)
+               ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+
+(define-standard-accessor-method ((bound-check-get n) o)
+  (let ((x (struct-ref o n)))
+    (if (unbound? x)
+        (slot-unbound o)
+        x)))
+
+(define-standard-accessor-method ((standard-get n) o)
+  (struct-ref o n))
+
+(define-standard-accessor-method ((standard-set n) o v)
+  (struct-set! o n v))
+
+;;; compute-getters-n-setters
+;;;
+(define (compute-getters-n-setters class slots)
+
+  (define (compute-slot-init-function name s)
+    (or (let ((thunk (slot-definition-init-thunk s)))
+	  (and thunk
+	       (if (thunk? thunk)
+                   thunk
+                   (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+                                name class thunk))))
+	(let ((init (slot-definition-init-value s)))
+	  (and (not (unbound? init))
+	       (lambda () init)))))
+
+  (define (verify-accessors slot l)
+    (cond ((integer? l))
+	  ((not (and (list? l) (= (length l) 2)))
+	   (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+			slot class l))
+	  (else
+	   (let ((get (car l)) 
+		 (set (cadr l)))
+	     (if (not (procedure? get))
+                 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+			      slot class get))
+	     (if (not (procedure? set))
+                 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+			      slot class set))))))
+
+  (map (lambda (s)
+	 ;; The strange treatment of nfields is due to backward compatibility.
+	 (let* ((index (slot-ref class 'nfields))
+		(g-n-s (compute-get-n-set class s))
+		(size (- (slot-ref class 'nfields) index))
+		(name  (slot-definition-name s)))
+	   ;; NOTE: The following is interdependent with C macros
+	   ;; defined above goops.c:scm_sys_prep_layout_x.
+	   ;;
+	   ;; For simple instance slots, we have the simplest form
+	   ;; '(name init-function . index)
+	   ;; For other slots we have
+	   ;; '(name init-function getter setter . alloc)
+	   ;; where alloc is:
+	   ;;   '(index size) for instance allocated slots
+	   ;;   '() for other slots
+	   (verify-accessors name g-n-s)
+           (case (slot-definition-allocation s)
+             ((#\each-subclass #\class)
+              (unless (and (zero? size) (pair? g-n-s))
+                (error "Class-allocated slots should not reserve fields"))
+              ;; Don't initialize the slot; that's handled when the slot
+              ;; is allocated, in compute-get-n-set.
+              (cons name (cons #f g-n-s)))
+             (else
+              (cons name
+                    (cons (compute-slot-init-function name s)
+                          (if (or (integer? g-n-s)
+                                  (zero? size))
+                              g-n-s
+                              (append g-n-s (list index size)))))))))
+       slots))
+
+;;; compute-cpl
+;;;
+;;; Correct behaviour:
+;;;
+;;; (define-class food ())
+;;; (define-class fruit (food))
+;;; (define-class spice (food))
+;;; (define-class apple (fruit))
+;;; (define-class cinnamon (spice))
+;;; (define-class pie (apple cinnamon))
+;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
+;;;
+;;; (define-class d ())
+;;; (define-class e ())
+;;; (define-class f ())
+;;; (define-class b (d e))
+;;; (define-class c (e f))
+;;; (define-class a (b c))
+;;; => cpl (a) = a b d c e f object top
+;;;
+
+(define-method (compute-cpl (class <class>))
+  (compute-std-cpl class class-direct-supers))
+
+;; Support
+
+(define (only-non-null lst)
+  (filter (lambda (l) (not (null? l))) lst))
+
+(define (compute-std-cpl c get-direct-supers)
+  (let ((c-direct-supers (get-direct-supers c)))
+    (merge-lists (list c)
+                 (only-non-null (append (map class-precedence-list
+					     c-direct-supers)
+                                        (list c-direct-supers))))))
+
+(define (merge-lists reversed-partial-result inputs)
+  (cond
+   ((every null? inputs)
+    (reverse! reversed-partial-result))
+   (else
+    (let* ((candidate (lambda (c)
+                        (and (not (any (lambda (l)
+                                         (memq c (cdr l)))
+                                       inputs))
+                             c)))
+           (candidate-car (lambda (l)
+                            (and (not (null? l))
+                                 (candidate (car l)))))
+           (next (any candidate-car inputs)))
+      (if (not next)
+          (goops-error "merge-lists: Inconsistent precedence graph"))
+      (let ((remove-next (lambda (l)
+                           (if (eq? (car l) next)
+                               (cdr l)
+                             l))))
+        (merge-lists (cons next reversed-partial-result)
+                     (only-non-null (map remove-next inputs))))))))
+
+;; Modified from TinyClos:
+;;
+;; A simple topological sort.
+;;
+;; It's in this file so that both TinyClos and Objects can use it.
+;;
+;; This is a fairly modified version of code I originally got from Anurag
+;; Mendhekar <anurag@moose.cs.indiana.edu>.
+;;
+
+(define (compute-clos-cpl c get-direct-supers)
+  (top-sort ((build-transitive-closure get-direct-supers) c)
+	    ((build-constraints get-direct-supers) c)
+	    (std-tie-breaker get-direct-supers)))
+
+
+(define (top-sort elements constraints tie-breaker)
+  (let loop ((elements    elements)
+	     (constraints constraints)
+	     (result      '()))
+    (if (null? elements)
+	result
+	(let ((can-go-in-now
+	       (filter
+		(lambda (x)
+		  (every (lambda (constraint)
+			   (or (not (eq? (cadr constraint) x))
+			       (memq (car constraint) result)))
+			 constraints))
+		elements)))
+	  (if (null? can-go-in-now)
+	      (goops-error "top-sort: Invalid constraints")
+	      (let ((choice (if (null? (cdr can-go-in-now))
+				(car can-go-in-now)
+				(tie-breaker result
+					     can-go-in-now))))
+		(loop
+		 (filter (lambda (x) (not (eq? x choice)))
+			 elements)
+		 constraints
+		 (append result (list choice)))))))))
+
+(define (std-tie-breaker get-supers)
+  (lambda (partial-cpl min-elts)
+    (let loop ((pcpl (reverse partial-cpl)))
+      (let ((current-elt (car pcpl)))
+	(let ((ds-of-ce (get-supers current-elt)))
+	  (let ((common (filter (lambda (x)
+				      (memq x ds-of-ce))
+				    min-elts)))
+	    (if (null? common)
+		(if (null? (cdr pcpl))
+		    (goops-error "std-tie-breaker: Nothing valid")
+		    (loop (cdr pcpl)))
+		(car common))))))))
+
+
+(define (build-transitive-closure get-follow-ons)
+  (lambda (x)
+    (let track ((result '())
+		(pending (list x)))
+      (if (null? pending)
+	  result
+	  (let ((next (car pending)))
+	    (if (memq next result)
+		(track result (cdr pending))
+		(track (cons next result)
+		       (append (get-follow-ons next)
+			       (cdr pending)))))))))
+
+(define (build-constraints get-follow-ons)
+  (lambda (x)
+    (let loop ((elements ((build-transitive-closure get-follow-ons) x))
+	       (this-one '())
+	       (result '()))
+      (if (or (null? this-one) (null? (cdr this-one)))
+	  (if (null? elements)
+	      result
+	      (loop (cdr elements)
+		    (cons (car elements)
+			  (get-follow-ons (car elements)))
+		    result))
+	  (loop elements
+		(cdr this-one)
+		(cons (list (car this-one) (cadr this-one))
+		      result))))))
+
+;;; compute-get-n-set
+;;;
+(define-method (compute-get-n-set (class <class>) s)
+  (define (class-slot-init-value)
+    (let ((thunk (slot-definition-init-thunk s)))
+      (if thunk
+          (thunk)
+          (slot-definition-init-value s))))
+
+  (case (slot-definition-allocation s)
+    ((#\instance) ;; Instance slot
+     ;; get-n-set is just its offset
+     (let ((already-allocated (slot-ref class 'nfields)))
+       (slot-set! class 'nfields (+ already-allocated 1))
+       already-allocated))
+
+    ((#\class)  ;; Class slot
+     ;; Class-slots accessors are implemented as 2 closures around 
+     ;; a Scheme variable. As instance slots, class slots must be
+     ;; unbound at init time.
+     (let ((name (slot-definition-name s)))
+       (if (memq name (map slot-definition-name (class-direct-slots class)))
+	   ;; This slot is direct; create a new shared variable
+	   (make-closure-variable class (class-slot-init-value))
+	   ;; Slot is inherited. Find its definition in superclass
+	   (let loop ((l (cdr (class-precedence-list class))))
+	     (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
+	       (if r
+		   (cddr r)
+		   (loop (cdr l))))))))
+
+    ((#\each-subclass) ;; slot shared by instances of direct subclass.
+     ;; (Thomas Buerger, April 1998)
+     (make-closure-variable class (class-slot-init-value)))
+
+    ((#\virtual) ;; No allocation
+     ;; slot-ref and slot-set! function must be given by the user
+     (let ((get (get-keyword #\slot-ref  (slot-definition-options s) #f))
+	   (set (get-keyword #\slot-set! (slot-definition-options s) #f)))
+       (if (not (and get set))
+	   (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
+			s))
+       (list get set)))
+    (else    (next-method))))
+
+(define (make-closure-variable class value)
+  (list (lambda (o) value)
+        (lambda (o v) (set! value v))))
+
+(define-method (compute-get-n-set (o <object>) s)
+  (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
+
+(define-method (compute-slots (class <class>))
+  (%compute-slots class))
+
+;;;
+;;; {Initialize}
+;;;
+
+(define-method (initialize (object <object>) initargs)
+  (%initialize-object object initargs))
+
+(define-method (initialize (class <class>) initargs)
+  (next-method)
+  (let ((dslots (get-keyword #\slots initargs '()))
+	(supers (get-keyword #\dsupers	  initargs '())))
+    (slot-set! class 'name	  	(get-keyword #\name initargs '???))
+    (slot-set! class 'direct-supers 	supers)
+    (slot-set! class 'direct-slots  	dslots)
+    (slot-set! class 'direct-subclasses '())
+    (slot-set! class 'direct-methods    '())
+    (slot-set! class 'cpl		(compute-cpl class))
+    (slot-set! class 'redefined		#f)
+    (let ((slots (compute-slots class)))
+      (slot-set! class 'slots	  	  slots)
+      (slot-set! class 'nfields	  	  0)
+      (slot-set! class 'getters-n-setters (compute-getters-n-setters class 
+								     slots))
+      ;; Build getters - setters - accessors
+      (compute-slot-accessors class slots))
+
+    ;; Update the "direct-subclasses" of each inherited classes
+    (for-each (lambda (x)
+		(slot-set! x
+			   'direct-subclasses 
+			   (cons class (slot-ref x 'direct-subclasses))))
+	      supers)
+
+    ;; Support for the underlying structs:
+    
+    ;; Set the layout slot
+    (%prep-layout! class)
+    ;; Inherit class flags (invisible on scheme level) from supers
+    (%inherit-magic! class supers)))
+
+(define (initialize-object-procedure object initargs)
+  (let ((proc (get-keyword #\procedure initargs #f)))
+    (cond ((not proc))
+	  ((pair? proc)
+	   (apply slot-set! object 'procedure proc))
+	  (else
+           (slot-set! object 'procedure proc)))))
+
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
+  (next-method)
+  (initialize-object-procedure applicable-struct initargs))
+
+(define-method (initialize (generic <generic>) initargs)
+  (let ((previous-definition (get-keyword #\default initargs #f))
+	(name (get-keyword #\name initargs #f)))
+    (next-method)
+    (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
+				    (list (method args
+                                            (apply previous-definition args)))
+				    '()))
+    (if name
+	(set-procedure-property! generic 'name name))
+    ))
+
+(define-method (initialize (gws <generic-with-setter>) initargs)
+  (next-method)
+  (%set-object-setter! gws (get-keyword #\setter initargs #f)))
+
+(define-method (initialize (eg <extended-generic>) initargs)
+  (next-method)
+  (slot-set! eg 'extends (get-keyword #\extends initargs '())))
+
+(define dummy-procedure (lambda args *unspecified*))
+
+(define-method (initialize (method <method>) initargs)
+  (next-method)
+  (slot-set! method 'generic-function (get-keyword #\generic-function initargs #f))
+  (slot-set! method 'specializers (get-keyword #\specializers initargs '()))
+  (slot-set! method 'procedure
+	     (get-keyword #\procedure initargs #f))
+  (slot-set! method 'formals (get-keyword #\formals initargs '()))
+  (slot-set! method 'body (get-keyword #\body initargs '()))
+  (slot-set! method 'make-procedure (get-keyword #\make-procedure initargs #f)))
+             
+
+;;;
+;;; {Change-class}
+;;;
+
+(define (change-object-class old-instance old-class new-class)
+  (let ((new-instance (allocate-instance new-class '())))
+    ;; Initialize the slots of the new instance
+    (for-each (lambda (slot)
+		(if (and (slot-exists-using-class? old-class old-instance slot)
+			 (eq? (slot-definition-allocation
+			       (class-slot-definition old-class slot))
+			      #\instance)
+			 (slot-bound-using-class? old-class old-instance slot))
+		    ;; Slot was present and allocated in old instance; copy it 
+		    (slot-set-using-class!
+		     new-class 
+		     new-instance 
+		     slot 
+		     (slot-ref-using-class old-class old-instance slot))
+		    ;; slot was absent; initialize it with its default value
+		    (let ((init (slot-init-function new-class slot)))
+		      (if init
+			  (slot-set-using-class!
+			       new-class 
+			       new-instance 
+			       slot
+			       (apply init '()))))))
+	      (map slot-definition-name (class-slots new-class)))
+    ;; Exchange old and new instance in place to keep pointers valid
+    (%modify-instance old-instance new-instance)
+    ;; Allow class specific updates of instances (which now are swapped)
+    (update-instance-for-different-class new-instance old-instance)
+    old-instance))
+
+
+(define-method (update-instance-for-different-class (old-instance <object>)
+						    (new-instance
+						     <object>))
+  ;;not really important what we do, we just need a default method
+  new-instance)
+
+(define-method (change-class (old-instance <object>) (new-class <class>))
+  (change-object-class old-instance (class-of old-instance) new-class))
+
+;;;
+;;; {make}
+;;;
+;;; A new definition which overwrites the previous one which was built-in
+;;;
+
+(define-method (allocate-instance (class <class>) initargs)
+  (%allocate-instance class initargs))
+
+(define-method (make-instance (class <class>) . initargs)
+  (let ((instance (allocate-instance class initargs)))
+    (initialize instance initargs)
+    instance))
+
+(define make make-instance)
+
+;;;
+;;; {apply-generic}
+;;;
+;;; Protocol for calling standard generic functions.  This protocol is
+;;; not used for real <generic> functions (in this case we use a
+;;; completely C hard-coded protocol).  Apply-generic is used by
+;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
+;;; The code below is similar to the first MOP described in AMOP. In
+;;; particular, it doesn't used the currified approach to gf
+;;; call. There are 2 reasons for that:
+;;;   - the protocol below is exposed to mimic completely the one written in C
+;;;   - the currified protocol would be imho inefficient in C.
+;;;
+
+(define-method (apply-generic (gf <generic>) args)
+  (if (null? (slot-ref gf 'methods))
+      (no-method gf args))
+  (let ((methods (compute-applicable-methods gf args)))
+    (if methods
+	(apply-methods gf (sort-applicable-methods gf methods args) args)
+	(no-applicable-method gf args))))
+
+;; compute-applicable-methods is bound to %compute-applicable-methods.
+;; *fixme* use let
+(define %%compute-applicable-methods
+  (make <generic> #\name 'compute-applicable-methods))
+
+(define-method (%%compute-applicable-methods (gf <generic>) args)
+  (%compute-applicable-methods gf args))
+
+(set! compute-applicable-methods %%compute-applicable-methods)
+
+(define-method (sort-applicable-methods (gf <generic>) methods args)
+  (let ((targs (map class-of args)))
+    (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
+
+(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
+  (%method-more-specific? m1 m2 targs))
+
+(define-method (apply-method (gf <generic>) methods build-next args)
+  (apply (method-procedure (car methods))
+	 (build-next (cdr methods) args)
+	 args))
+
+(define-method (apply-methods (gf <generic>) (l <list>) args)
+  (letrec ((next (lambda (procs args)
+		   (lambda new-args
+		     (let ((a (if (null? new-args) args new-args)))
+		       (if (null? procs)
+			   (no-next-method gf a)
+			   (apply-method gf procs next a)))))))
+    (apply-method gf l next args)))
+
+;; We don't want the following procedure to turn up in backtraces:
+(for-each (lambda (proc)
+	    (set-procedure-property! proc 'system-procedure #t))
+	  (list slot-unbound
+		slot-missing
+		no-next-method
+		no-applicable-method
+		no-method
+		))
+
+;;;
+;;; {<composite-metaclass> and <active-metaclass>}
+;;;
+
+;(autoload "active-slot"    <active-metaclass>)
+;(autoload "composite-slot" <composite-metaclass>)
+;(export <composite-metaclass> <active-metaclass>)
+
+;;;
+;;; {Tools}
+;;;
+
+;; list2set
+;;
+;; duplicate the standard list->set function but using eq instead of
+;; eqv which really sucks a lot, uselessly here
+;;
+(define (list2set l)	       
+  (let loop ((l l)
+	     (res '()))
+    (cond		       
+     ((null? l) res)
+     ((memq (car l) res) (loop (cdr l) res))
+     (else (loop (cdr l) (cons (car l) res))))))
+
+(define (class-subclasses c)
+  (letrec ((allsubs (lambda (c)
+		      (cons c (mapappend allsubs
+					 (class-direct-subclasses c))))))
+    (list2set (cdr (allsubs c)))))
+
+(define (class-methods c)
+  (list2set (mapappend class-direct-methods
+		       (cons c (class-subclasses c)))))
+
+;;;
+;;; {Final initialization}
+;;;
+
+;; Tell C code that the main bulk of Goops has been loaded
+(%goops-loaded)
+;;;; 	Copyright (C) 1999, 2000, 2005, 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 (oop goops accessors)
+  \:use-module (oop goops)
+  \:re-export (standard-define-class)
+  \:export (define-class-with-accessors
+	   define-class-with-accessors-keywords))
+
+(define-macro (define-class-with-accessors name supers . slots)
+  (let ((eat? #f))
+    `(standard-define-class
+      ,name ,supers
+      ,@(map-in-order
+         (lambda (slot)
+           (cond (eat?
+                  (set! eat? #f)
+                  slot)
+                 ((keyword? slot)
+                  (set! eat? #t)
+                  slot)
+                 ((pair? slot)
+                  (if (get-keyword #\accessor (cdr slot) #f)
+                      slot
+                      (let ((name (car slot)))
+                        `(,name #\accessor ,name ,@(cdr slot)))))
+                 (else
+                  `(,slot #\accessor ,slot))))
+         slots))))
+
+(define-macro (define-class-with-accessors-keywords name supers . slots)
+  (let ((eat? #f))
+    `(standard-define-class
+      ,name ,supers
+      ,@(map-in-order
+         (lambda (slot)
+           (cond (eat?
+                  (set! eat? #f)
+                  slot)
+                 ((keyword? slot)
+                  (set! eat? #t)
+                  slot)
+                 ((pair? slot)
+                  (let ((slot
+                         (if (get-keyword #\accessor (cdr slot) #f)
+                             slot
+                             (let ((name (car slot)))
+                               `(,name #\accessor ,name ,@(cdr slot))))))
+                    (if (get-keyword #\init-keyword (cdr slot) #f)
+                        slot
+                        (let* ((name (car slot))
+                               (keyword (symbol->keyword name)))
+                          `(,name #\init-keyword ,keyword ,@(cdr slot))))))
+                 (else
+                  `(,slot #\accessor ,slot
+                          #\init-keyword ,(symbol->keyword slot)))))
+         slots))))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+;;;;
+;;;; This file was based upon active-slot.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops active-slot)
+  \:use-module (oop goops internal)
+  \:export (<active-class>))
+
+(define-class <active-class> (<class>))
+
+(define-method (compute-get-n-set (class <active-class>) slot)
+  (if (eq? (slot-definition-allocation slot) #\active)
+      (let* ((index 	  (slot-ref class 'nfields))
+	     (s		  (cdr slot))
+	     (before-ref  (get-keyword #\before-slot-ref  s #f))
+	     (after-ref   (get-keyword #\after-slot-ref   s #f))
+	     (before-set! (get-keyword #\before-slot-set! s #f))
+	     (after-set!  (get-keyword #\after-slot-set!  s #f))
+	     (unbound	  (make-unbound)))
+	(slot-set! class 'nfields (+ index 1))
+	(list (lambda (o)
+		(if before-ref
+		    (if (before-ref o)
+			(let ((res (%fast-slot-ref o index)))
+			  (and after-ref (not (eqv? res unbound)) (after-ref o))
+			  res)
+			(make-unbound))
+		    (let ((res (%fast-slot-ref o index)))
+		      (and after-ref (not (eqv? res unbound)) (after-ref o))
+		      res)))
+
+	      (lambda (o v) 
+		(if before-set!
+		    (if (before-set! o v)
+			(begin
+			  (%fast-slot-set! o index v)
+			  (and after-set! (after-set! o v))))
+		    (begin
+		      (%fast-slot-set! o index v)
+		      (and after-set! (after-set! o v)))))))
+      (next-method)))
+;;;; 	Copyright (C) 1999, 2001, 2006, 2009, 2015 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 (oop goops compile)
+  #\use-module (oop goops internal)
+  #\re-export (compute-cmethod))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+;;;;
+;;;; This file was based upon composite-slot.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops composite-slot)
+  \:use-module (oop goops)
+  \:export (<composite-class>))
+
+;;;
+;;; (define-class CLASS SUPERS
+;;;   ...
+;;;   (OBJECT ...)
+;;;   ...
+;;;   (SLOT #\allocation #\propagated
+;;;         #\propagate-to '(PROPAGATION ...))
+;;;   ...
+;;;   #\metaclass <composite-class>)
+;;;
+;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT)
+;;;
+;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object
+;;; stored in slot OBJECT.  If TARGETSLOT is omitted, assume that the target
+;;; slot is named SLOT.
+;;;
+
+(define-class <composite-class> (<class>))
+
+(define-method (compute-get-n-set (class <composite-class>) slot)
+  (if (eq? (slot-definition-allocation slot) #\propagated)
+      (compute-propagated-get-n-set slot)
+      (next-method)))
+
+(define (compute-propagated-get-n-set s)
+  (let ((prop   	(get-keyword #\propagate-to (cdr s) #f))
+	(s-name   	(slot-definition-name s)))
+    
+    (if (not prop)
+	(goops-error "Propagation not specified for slot ~S" s-name))
+    (if (not (pair? prop))
+	(goops-error "Bad propagation list for slot ~S" s-name))
+
+    (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop))
+	  (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop)))
+      (let ((first-object (car objects))
+	    (first-slot (car slots)))
+	(list
+	 ;; The getter
+	 (lambda (o) 
+	   (slot-ref (slot-ref o first-object) first-slot))
+
+	 ;; The setter
+	 (if (null? (cdr objects))
+	     (lambda (o v)
+	       (slot-set! (slot-ref o first-object) first-slot v))
+	     (lambda (o v)
+	       (for-each (lambda (object slot)
+			   (slot-set! (slot-ref o object) slot v))
+			 objects
+			 slots))))))))
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+;;;;
+;;;; This file was based upon describe.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops describe)
+  \:use-module (oop goops)
+  \:use-module (ice-9 session)
+  \:use-module (ice-9 format)
+  \:export (describe))			; Export the describe generic function
+
+;;;
+;;; describe for simple objects
+;;;
+(define-method (describe (x <top>))
+  (format #t "~s is " x)
+  (cond
+     ((integer? x)      (format #t "an integer"))
+     ((real?    x)      (format #t "a real"))
+     ((complex? x)	(format #t "a complex number"))
+     ((null?	x)      (format #t "an empty list"))
+     ((boolean?	x)      (format #t "a boolean value (~s)" (if x 'true 'false)))
+     ((char?	x)      (format #t "a character, ascii value is ~s" 
+				(char->integer x)))
+     ((symbol?	x)      (format #t "a symbol"))
+     ((list?	x)	(format #t "a list"))
+     ((pair?    x)	(if (pair? (cdr x))
+			    (format #t "an improper list")
+			    (format #t "a pair")))
+     ((string?	x)	(if (eqv? x "")
+			    (format #t "an empty string")
+			    (format #t "a string of length ~s" (string-length x))))
+     ((vector?  x)   	(if (eqv? x '#())
+			    (format #t "an empty vector")
+			    (format #t "a vector of length ~s" (vector-length x))))
+     ((eof-object? x)	(format #t "the end-of-file object"))
+     (else	     	(format #t "an unknown object (~s)" x)))
+  (format #t ".~%")
+  *unspecified*)
+
+(define-method (describe (x <procedure>))
+  (let ((name (procedure-name x)))
+    (if name
+	(format #t "`~s'" name)
+	(display x))
+    (display " is ")
+    (display (if name #\a "an anonymous"))
+    (display " procedure")
+    (display " with ")
+    (arity x)))
+
+;;;
+;;; describe for GOOPS instances
+;;;
+(define (safe-class-name class)
+  (if (slot-bound? class 'name)
+      (class-name class)
+      class))
+
+(define-method (describe (x <object>))
+  (format #t "~S is an instance of class ~A~%"
+	  x (safe-class-name (class-of x)))
+
+  ;; print all the instance slots
+  (format #t "Slots are: ~%")
+  (for-each (lambda (slot)
+	      (let ((name (slot-definition-name slot)))
+		(format #t "     ~S = ~A~%"
+			name
+			(if (slot-bound? x name) 
+			    (format #f "~S" (slot-ref x name))
+			    "#<unbound>"))))
+	    (class-slots (class-of x)))
+  *unspecified*)
+
+;;;
+;;; Describe for classes
+;;;
+(define-method (describe (x <class>))
+  (format #t "~S is a class. It's an instance of ~A~%" 
+	  (safe-class-name x) (safe-class-name (class-of x)))
+  
+  ;; Super classes 
+  (format #t "Superclasses are:~%")
+  (for-each (lambda (class) (format #t "    ~A~%" (safe-class-name class)))
+       (class-direct-supers x))
+
+  ;; Direct slots
+  (let ((slots (class-direct-slots x)))
+    (if (null? slots) 
+	(format #t "(No direct slot)~%")
+	(begin
+	  (format #t "Directs slots are:~%")
+	  (for-each (lambda (s) 
+		      (format #t "    ~A~%" (slot-definition-name s)))
+		    slots))))
+
+ 
+  ;; Direct subclasses
+  (let ((classes (class-direct-subclasses x)))
+    (if (null? classes)
+	(format #t "(No direct subclass)~%")
+	(begin
+	  (format #t "Directs subclasses are:~%") 
+	  (for-each (lambda (s) 
+		      (format #t "    ~A~%" (safe-class-name s)))
+		    classes))))
+
+  ;; CPL
+  (format #t "Class Precedence List is:~%")
+  (for-each (lambda (s) (format #t "    ~A~%" (safe-class-name s))) 
+	    (class-precedence-list x))
+
+  ;; Direct Methods
+  (let ((methods (class-direct-methods x)))
+    (if (null? methods)
+	(format #t "(No direct method)~%")
+	(begin
+	  (format #t "Class direct methods are:~%")
+	  (for-each describe methods))))
+
+;  (format #t "~%Field Initializers ~%    ")
+;  (write (slot-ref x 'initializers)) (newline)
+
+;  (format #t "~%Getters and Setters~%    ")
+;  (write (slot-ref x 'getters-n-setters)) (newline)
+)
+
+;;;
+;;; Describe for generic functions
+;;;
+(define-method (describe (x <generic>))
+  (let ((name    (generic-function-name x))
+	(methods (generic-function-methods x)))
+    ;; Title
+    (format #t "~S is a generic function. It's an instance of ~A.~%" 
+	    name (safe-class-name (class-of x)))
+    ;; Methods
+    (if (null? methods)
+	(format #t "(No method defined for ~S)~%" name)
+	(begin
+	  (format #t "Methods defined for ~S~%" name)
+	  (for-each (lambda (x) (describe x #t)) methods)))))
+
+;;;
+;;; Describe for methods
+;;;
+(define-method (describe (x <method>) . omit-generic)
+  (letrec ((print-args (lambda (args)
+			 ;; take care of dotted arg lists
+			 (cond ((null? args) (newline))
+			       ((pair? args)
+				(display #\space)
+				(display (safe-class-name (car args)))
+				(print-args (cdr args)))
+			       (else
+				(display #\space)
+				(display (safe-class-name args))
+				(newline))))))
+
+    ;; Title
+    (format #t "    Method ~A~%" x)
+    
+    ;; Associated generic
+    (if (null? omit-generic)
+      (let ((gf (method-generic-function x)))
+	(if gf
+	    (format #t "\t     Generic: ~A~%" (generic-function-name gf))
+	    (format #t "\t(No generic)~%"))))
+
+    ;; GF specializers
+    (format #t "\tSpecializers:")
+    (print-args (method-specializers x))))
+
+(provide 'describe)
+;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012, 2015 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
+;;;;
+
+
+;; There are circularities here; you can't import (oop goops compile)
+;; before (oop goops). So when compiling, make sure that things are
+;; kosher.
+(eval-when (expand) (resolve-module '(oop goops)))
+
+(define-module (oop goops dispatch)
+  #\use-module (oop goops)
+  #\use-module (oop goops util)
+  #\use-module (system base target)
+  #\export (memoize-method!)
+  #\no-backtrace)
+
+
+(define *dispatch-module* (current-module))
+
+;;;
+;;; Generic functions have an applicable-methods cache associated with
+;;; them. Every distinct set of types that is dispatched through a
+;;; generic adds an entry to the cache. This cache gets compiled out to
+;;; a dispatch procedure. In steady-state, this dispatch procedure is
+;;; never recompiled; but during warm-up there is some churn, both to
+;;; the cache and to the dispatch procedure.
+;;;
+;;; So what is the deal if warm-up happens in a multithreaded context?
+;;; There is indeed a window between missing the cache for a certain set
+;;; of arguments, and then updating the cache with the newly computed
+;;; applicable methods. One of the updaters is liable to lose their new
+;;; entry.
+;;;
+;;; This is actually OK though, because a subsequent cache miss for the
+;;; race loser will just cause memoization to try again. The cache will
+;;; eventually be consistent. We're not mutating the old part of the
+;;; cache, just consing on the new entry.
+;;;
+;;; It doesn't even matter if the dispatch procedure and the cache are
+;;; inconsistent -- most likely the type-set that lost the dispatch
+;;; procedure race will simply re-trigger a memoization, but since the
+;;; winner isn't in the effective-methods cache, it will likely also
+;;; re-trigger a memoization, and the cache will finally be consistent.
+;;; As you can see there is a possibility for ping-pong effects, but
+;;; it's unlikely given the shortness of the window between slot-set!
+;;; invocations. We could add a mutex, but it is strictly unnecessary,
+;;; and would add runtime cost and complexity.
+;;;
+
+(define (emit-linear-dispatch gf-sym nargs methods free rest?)
+  (define (gen-syms n stem)
+    (let lp ((n (1- n)) (syms '()))
+      (if (< n 0)
+          syms
+          (lp (1- n) (cons (gensym stem) syms)))))
+  (let* ((args (gen-syms nargs "a"))
+         (types (gen-syms nargs "t")))
+    (let lp ((methods methods)
+             (free free)
+             (exp `(cache-miss ,gf-sym
+                               ,(if rest?
+                                    `(cons* ,@args rest)
+                                    `(list ,@args)))))
+      (cond
+       ((null? methods)
+        (values `(,(if rest? `(,@args . rest) args)
+                  (let ,(map (lambda (t a)
+                               `(,t (class-of ,a)))
+                             types args)
+                    ,exp))
+                free))
+       (else
+        ;; jeez
+        (let preddy ((free free)
+                     (types types)
+                     (specs (vector-ref (car methods) 1))
+                     (checks '()))
+          (if (null? types)
+              (let ((m-sym (gensym "p")))
+                (lp (cdr methods)
+                    (acons (vector-ref (car methods) 3)
+                           m-sym
+                           free)
+                    `(if (and . ,checks)
+                         ,(if rest?
+                              `(apply ,m-sym ,@args rest)
+                              `(,m-sym . ,args))
+                         ,exp)))
+              (let ((var (assq-ref free (car specs))))
+                (if var
+                    (preddy free
+                            (cdr types)
+                            (cdr specs)
+                            (cons `(eq? ,(car types) ,var)
+                                  checks))
+                    (let ((var (gensym "c")))
+                      (preddy (acons (car specs) var free)
+                              (cdr types)
+                              (cdr specs)
+                              (cons `(eq? ,(car types) ,var)
+                                    checks))))))))))))
+
+(define (compute-dispatch-procedure gf cache)
+  (define (scan)
+    (let lp ((ls cache) (nreq -1) (nrest -1))
+      (cond
+       ((null? ls)
+        (collate (make-vector (1+ nreq) '())
+                 (make-vector (1+ nrest) '())))
+       ((vector-ref (car ls) 2)         ; rest
+        (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
+       (else                            ; req
+        (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
+  (define (collate req rest)
+    (let lp ((ls cache))
+      (cond
+       ((null? ls)
+        (emit req rest))
+       ((vector-ref (car ls) 2)         ; rest
+        (let ((n (vector-ref (car ls) 0)))
+          (vector-set! rest n (cons (car ls) (vector-ref rest n)))
+          (lp (cdr ls))))
+       (else                            ; req
+        (let ((n (vector-ref (car ls) 0)))
+          (vector-set! req n (cons (car ls) (vector-ref req n)))
+          (lp (cdr ls)))))))
+  (define (emit req rest)
+    (let ((gf-sym (gensym "g")))
+      (define (emit-rest n clauses free)
+        (if (< n (vector-length rest))
+            (let ((methods (vector-ref rest n)))
+              (cond
+               ((null? methods)
+                (emit-rest (1+ n) clauses free))
+               ;; FIXME: hash dispatch
+               (else
+                (call-with-values
+                    (lambda ()
+                      (emit-linear-dispatch gf-sym n methods free #t))
+                  (lambda (clause free)
+                    (emit-rest (1+ n) (cons clause clauses) free))))))
+            (emit-req (1- (vector-length req)) clauses free)))
+      (define (emit-req n clauses free)
+        (if (< n 0)
+            (comp `(lambda ,(map cdr free)
+                     (case-lambda ,@clauses))
+                  (map car free))
+            (let ((methods (vector-ref req n)))
+              (cond
+               ((null? methods)
+                (emit-req (1- n) clauses free))
+               ;; FIXME: hash dispatch
+               (else
+                (call-with-values
+                    (lambda ()
+                      (emit-linear-dispatch gf-sym n methods free #f))
+                  (lambda (clause free)
+                    (emit-req (1- n) (cons clause clauses) free))))))))
+
+      (emit-rest 0
+                 (if (or (zero? (vector-length rest))
+                         (null? (vector-ref rest 0)))
+                     (list `(args (cache-miss ,gf-sym args)))
+                     '())
+                 (acons gf gf-sym '()))))
+  (define (comp exp vals)
+    ;; When cross-compiling Guile itself, the native Guile must generate
+    ;; code for the host.
+    (with-target %host-type
+      (lambda ()
+        (let ((p ((@ (system base compile) compile) exp
+                  #\env *dispatch-module*
+                  #\from 'scheme
+                  #\opts '(#\partial-eval? #f #\cse? #f))))
+          (apply p vals)))))
+
+  ;; kick it.
+  (scan))
+
+;; o/~  ten, nine, eight
+;;        sometimes that's just how it goes
+;;          three, two, one
+;;
+;;            get out before it blows    o/~
+;;
+(define timer-init 30)
+(define (delayed-compile gf)
+  (let ((timer timer-init))
+    (lambda args
+      (set! timer (1- timer))
+      (cond
+       ((zero? timer)
+        (let ((dispatch (compute-dispatch-procedure
+                         gf (slot-ref gf 'effective-methods))))
+          (slot-set! gf 'procedure dispatch)
+          (apply dispatch args)))
+       (else
+        ;; interestingly, this catches recursive compilation attempts as
+        ;; well; in that case, timer is negative
+        (cache-dispatch gf args))))))
+
+(define (cache-dispatch gf args)
+  (define (map-until n f ls)
+    (if (or (zero? n) (null? ls))
+        '()
+        (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
+  (define (equal? x y) ; can't use the stock equal? because it's a generic...
+    (cond ((pair? x) (and (pair? y)
+                          (eq? (car x) (car y))
+                          (equal? (cdr x) (cdr y))))
+          ((null? x) (null? y))
+          (else #f)))
+  (if (slot-ref gf 'n-specialized)
+      (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+        (let lp ((cache (slot-ref gf 'effective-methods)))
+          (cond ((null? cache)
+                 (cache-miss gf args))
+                ((equal? (vector-ref (car cache) 1) types)
+                 (apply (vector-ref (car cache) 3) args))
+                (else (lp (cdr cache))))))
+      (cache-miss gf args)))
+
+(define (cache-miss gf args)
+  (apply (memoize-method! gf args) args))
+
+(define (memoize-effective-method! gf args applicable)
+  (define (first-n ls n)
+    (if (or (zero? n) (null? ls))
+        '()
+        (cons (car ls) (first-n (cdr ls) (- n 1)))))
+  (define (parse n ls)
+    (cond ((null? ls)
+           (memoize n #f (map class-of args)))
+          ((= n (slot-ref gf 'n-specialized))
+           (memoize n #t (map class-of (first-n args n))))
+          (else
+           (parse (1+ n) (cdr ls)))))
+  (define (memoize len rest? types)
+    (let* ((cmethod ((@@ (oop goops) compute-cmethod) applicable types))
+           (cache (cons (vector len types rest? cmethod)
+                        (slot-ref gf 'effective-methods))))
+      (slot-set! gf 'effective-methods cache)
+      (slot-set! gf 'procedure (delayed-compile gf))
+      cmethod))
+  (parse 0 args))
+
+
+;;;
+;;; Memoization
+;;;
+
+(define (memoize-method! gf args)
+  (let ((applicable ((if (eq? gf compute-applicable-methods)
+			 %compute-applicable-methods
+			 compute-applicable-methods)
+		     gf args)))
+    (cond (applicable
+           (memoize-effective-method! gf args applicable))
+	  (else
+	   (no-applicable-method gf args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
+;;; installed-scm-file
+
+;;;; 	Copyright (C) 1999, 2001, 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 (oop goops internal)
+  \:use-module (oop goops))
+
+;; Export all the bindings that are internal to `(oop goops)'.
+(let ((public-i (module-public-interface (current-module))))
+  (module-for-each (lambda (name var)
+                     (if (eq? name '%module-public-interface)
+                         #t
+                         (module-add! public-i name var)))
+                   (resolve-module '(oop goops))))
+;;; installed-scm-file
+
+;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 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 (oop goops save)
+  \:use-module (oop goops internal)
+  \:use-module (oop goops util)
+  \:re-export (make-unbound)
+  \:export (save-objects load-objects restore
+	   enumerate! enumerate-component!
+	   write-readably write-component write-component-procedure
+	   literal? readable make-readable))
+
+;;;
+;;; save-objects ALIST PORT [EXCLUDED] [USES]
+;;;
+;;; ALIST ::= ((NAME . OBJECT) ...)
+;;;
+;;; Save OBJECT ... to PORT so that when the data is read and evaluated
+;;; OBJECT ... are re-created under names NAME ... .
+;;; Exclude any references to objects in the list EXCLUDED.
+;;; Add a (use-modules . USES) line to the top of the saved text.
+;;;
+;;; In some instances, when `save-object' doesn't know how to produce
+;;; readable syntax for an object, you can explicitly register read
+;;; syntax for an object using the special form `readable'.
+;;;
+;;; Example:
+;;;
+;;;   The function `foo' produces an object of obscure structure.
+;;;   Only `foo' can construct such objects.  Because of this, an
+;;;   object such as
+;;;
+;;;     (define x (vector 1 (foo)))
+;;;
+;;;   cannot be saved by `save-objects'.  But if you instead write
+;;;
+;;;     (define x (vector 1 (readable (foo))))
+;;;
+;;;   `save-objects' will happily produce the necessary read syntax.
+;;;
+;;; To add new read syntax, hang methods on `enumerate!' and
+;;; `write-readably'.
+;;;
+;;; enumerate! OBJECT ENV
+;;;   Should call `enumerate-component!' (which takes same args) on
+;;;   each component object.  Should return #t if the composite object
+;;;   can be written as a literal.  (`enumerate-component!' returns #t
+;;;   if the component is a literal.
+;;;
+;;; write-readably OBJECT PORT ENV
+;;;   Should write a readable representation of OBJECT to PORT.
+;;;   Should use `write-component' to print each component object.
+;;;   Use `literal?' to decide if a component is a literal.
+;;;
+;;; Utilities:
+;;;
+;;; enumerate-component! OBJECT ENV
+;;;
+;;; write-component OBJECT PATCHER PORT ENV
+;;;   PATCHER is an expression which, when evaluated, stores OBJECT
+;;;   into its current location.
+;;;
+;;;   Example:
+;;;
+;;;     (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+;;;
+;;;   write-component is a macro.
+;;;
+;;; literal? COMPONENT ENV
+;;;
+
+(define-method (immediate? (o <top>)) #f)
+
+(define-method (immediate? (o <null>)) #t)
+(define-method (immediate? (o <number>)) #t)
+(define-method (immediate? (o <boolean>)) #t)
+(define-method (immediate? (o <symbol>)) #t)
+(define-method (immediate? (o <char>)) #t)
+(define-method (immediate? (o <keyword>)) #t)
+
+;;; enumerate! OBJECT ENVIRONMENT
+;;;
+;;; Return #t if object is a literal.
+;;;
+(define-method (enumerate! (o <top>) env) #t)
+
+(define-method (write-readably (o <top>) file env)
+  ;;(goops-error "No read-syntax defined for object `~S'" o)
+  (write o file) ;doesn't catch bugs, but is much more flexible
+  )
+
+;;;
+;;; Readables
+;;;
+
+(define readables (make-weak-key-hash-table 61))
+
+(define-macro (readable exp)
+  `(make-readable ,exp ',(copy-tree exp)))
+
+(define (make-readable obj expr)
+  (hashq-set! readables obj expr)
+  obj)
+
+(define (readable-expression obj)
+  `(readable ,(hashq-ref readables obj)))
+
+;; FIXME: if obj is nil or false, this can return a false value.  OTOH
+;; usually this is only for non-immediates.
+(define (readable? obj)
+  (hashq-ref readables obj))
+
+;;;
+;;; Writer helpers
+;;;
+
+(define (write-component-procedure o file env)
+  "Return #f if circular reference"
+  (cond ((immediate? o) (write o file) #t)
+	((readable? o) (write (readable-expression o) file) #t)
+	((excluded? o env) (display #f file) #t)
+	(else
+	 (let ((info (object-info o env)))
+	   (cond ((not (binding? info)) (write-readably o file env) #t)
+		 ((not (eq? (visiting info) #\defined)) #f) ;forward reference
+		 (else (display (binding info) file) #t))))))
+
+;;; write-component OBJECT PATCHER FILE ENV
+;;;
+(define-macro (write-component object patcher file env)
+  `(or (write-component-procedure ,object ,file ,env)
+       (begin
+         (display #f ,file)
+         (add-patcher! ,patcher ,env))))
+
+;;;
+;;; Strings
+;;;
+
+(define-method (enumerate! (o <string>) env) #f)
+
+;;;
+;;; Vectors
+;;;
+
+(define-method (enumerate! (o <vector>) env)
+  (or (not (vector? o))
+      (let ((literal? #t))
+	(array-for-each (lambda (o)
+			  (if (not (enumerate-component! o env))
+			      (set! literal? #f)))
+			o)
+	literal?)))
+
+(define-method (write-readably (o <vector>) file env)
+  (if (not (vector? o))
+      (write o file)
+      (let ((n (vector-length o)))
+	(if (zero? n)
+	    (display "#()" file)
+	    (let ((not-literal? (not (literal? o env))))
+	      (display (if not-literal?
+			   "(vector "
+			   "#(")
+		       file)
+	      (if (and not-literal?
+		       (literal? (vector-ref o 0) env))
+		  (display #\' file))
+	      (write-component (vector-ref o 0)
+			       `(vector-set! ,o 0 ,(vector-ref o 0))
+			       file
+			       env)
+	      (do ((i 1 (+ 1 i)))
+		  ((= i n))
+		(display #\space file)
+		(if (and not-literal?
+			 (literal? (vector-ref o i) env))
+		    (display #\' file))
+		(write-component (vector-ref o i)
+				 `(vector-set! ,o ,i ,(vector-ref o i))
+				 file
+				 env))
+	      (display #\) file))))))
+
+
+;;;
+;;; Arrays
+;;;
+
+(define-method (enumerate! (o <array>) env)
+  (enumerate-component! (shared-array-root o) env))
+
+(define (make-mapper array)
+  (let* ((n (array-rank array))
+	 (indices (reverse (if (<= n 11)
+			       (list-tail '(t s r q p n m l k j i)  (- 11 n))
+			       (let loop ((n n)
+					  (ls '()))
+				 (if (zero? n)
+				     ls
+				     (loop (- n 1)
+					   (cons (gensym "i") ls))))))))
+    `(lambda ,indices
+       (+ ,(shared-array-offset array)
+	  ,@(map (lambda (ind dim inc)
+		   `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
+		 indices
+		 (array-dimensions array)
+		 (shared-array-increments array))))))
+
+(define (write-array prefix o not-literal? file env)
+  (letrec ((inner (lambda (n indices)
+		    (if (not (zero? n))
+			(let ((el (apply array-ref o
+					 (reverse (cons 0 indices)))))
+			  (if (and not-literal?
+				   (literal? el env))
+			      (display #\' file))
+			  (write-component
+			   el
+			   `(array-set! ,o ,el ,@indices)
+			   file
+			   env)))
+		    (do ((i 1 (+ 1 i)))
+			((= i n))
+		      (display #\space file)
+		      (let ((el (apply array-ref o
+					 (reverse (cons i indices)))))
+			  (if (and not-literal?
+				   (literal? el env))
+			      (display #\' file))
+			  (write-component
+			   el
+			   `(array-set! ,o ,el ,@indices)
+			   file
+			   env))))))
+    (display prefix file)
+    (let loop ((dims (array-dimensions o))
+	       (indices '()))
+      (cond ((null? (cdr dims))
+	     (inner (car dims) indices))
+	    (else
+	     (let ((n (car dims)))
+	       (do ((i 0 (+ 1 i)))
+		   ((= i n))
+		 (if (> i 0)
+		     (display #\space file))
+		 (display prefix file)
+		 (loop (cdr dims) (cons i indices))
+		 (display #\) file))))))
+    (display #\) file)))
+
+(define-method (write-readably (o <array>) file env)
+  (let ((root (shared-array-root o)))
+    (cond ((literal? o env)
+	   (if (not (vector? root))
+	       (write o file)
+	       (begin
+		 (display #\# file)
+		 (display (array-rank o) file)
+		 (write-array #\( o #f file env))))
+	  ((binding? root env)
+	   (display "(make-shared-array " file)
+	   (if (literal? root env)
+	       (display #\' file))
+	   (write-component root
+			    (goops-error "write-readably(<array>): internal error")
+			    file
+			    env)
+	   (display #\space file)
+	   (display (make-mapper o) file)
+	   (for-each (lambda (dim)
+		       (display #\space file)
+		       (display dim file))
+		     (array-dimensions o))
+	   (display #\) file))
+	  (else
+	   (display "(list->uniform-array " file)
+	   (display (array-rank o) file)
+	   (display " '() " file)
+	   (write-array "(list " o #f file env)))))
+
+;;;
+;;; Pairs
+;;;
+
+;;; These methods have more complex structure than is required for
+;;; most objects, since they take over some of the logic of
+;;; `write-component'.
+;;;
+
+(define-method (enumerate! (o <pair>) env)
+  (let ((literal? (enumerate-component! (car o) env)))
+    (and (enumerate-component! (cdr o) env)
+	 literal?)))
+
+(define-method (write-readably (o <pair>) file env)
+  (let ((proper? (let loop ((ls o))
+		   (or (null? ls)
+		       (and (pair? ls)
+			    (not (binding? (cdr ls) env))
+			    (loop (cdr ls))))))
+	(1? (or (not (pair? (cdr o)))
+		(binding? (cdr o) env)))
+	(not-literal? (not (literal? o env)))
+	(infos '())
+	(refs (ref-stack env)))
+    (display (cond ((not not-literal?) #\()
+		   (proper? "(list ")
+		   (1? "(cons ")
+		   (else "(cons* "))
+	     file)
+    (if (and not-literal?
+	     (literal? (car o) env))
+	(display #\' file))
+    (write-component (car o) `(set-car! ,o ,(car o)) file env)
+    (do ((ls (cdr o) (cdr ls))
+	 (prev o ls))
+	((or (not (pair? ls))
+	     (binding? ls env))
+	 (if (not (null? ls))
+	     (begin
+	       (if (not not-literal?)
+		   (display " ." file))
+	       (display #\space file)
+	       (if (and not-literal?
+			(literal? ls env))
+		   (display #\' file))
+	       (write-component ls `(set-cdr! ,prev ,ls) file env)))
+	 (display #\) file))
+      (display #\space file)
+      (set! infos (cons (object-info ls env) infos))
+      (push-ref! ls env) ;*fixme* optimize
+      (set! (visiting? (car infos)) #t)
+      (if (and not-literal?
+	       (literal? (car ls) env))
+	  (display #\' file))
+      (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+      )
+    (for-each (lambda (info)
+		(set! (visiting? info) #f))
+	      infos)
+    (set! (ref-stack env) refs)
+    ))
+
+;;;
+;;; Objects
+;;;
+
+;;; Doesn't yet handle unbound slots
+
+;; Don't export this function!  This is all very temporary.
+;;
+(define (get-set-for-each proc class)
+  (for-each (lambda (slotdef g-n-s)
+	      (let ((g-n-s (cddr g-n-s)))
+		(cond ((integer? g-n-s)
+		       (proc (standard-get g-n-s) (standard-set g-n-s)))
+		      ((not (memq (slot-definition-allocation slotdef)
+				  '(#\class #\each-subclass)))
+		       (proc (car g-n-s) (cadr g-n-s))))))
+	    (class-slots class)
+	    (slot-ref class 'getters-n-setters)))
+
+(define (access-for-each proc class)
+  (for-each (lambda (slotdef g-n-s)
+	      (let ((g-n-s (cddr g-n-s))
+		    (a (slot-definition-accessor slotdef)))
+		(cond ((integer? g-n-s)
+		       (proc (slot-definition-name slotdef)
+			     (and a (generic-function-name a))
+			     (standard-get g-n-s)
+			     (standard-set g-n-s)))
+		      ((not (memq (slot-definition-allocation slotdef)
+				  '(#\class #\each-subclass)))
+		       (proc (slot-definition-name slotdef)
+			     (and a (generic-function-name a))
+			     (car g-n-s)
+			     (cadr g-n-s))))))
+	    (class-slots class)
+	    (slot-ref class 'getters-n-setters)))
+
+(define-macro (restore class slots . exps)
+  "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
+  `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
+     (for-each (lambda (name val)
+                 (slot-set! o name val))
+               ',slots
+               (list ,@exps))
+     o))
+
+(define-method (enumerate! (o <object>) env)
+  (get-set-for-each (lambda (get set)
+		      (let ((val (get o)))
+			(if (not (unbound? val))
+			    (enumerate-component! val env))))
+		    (class-of o))
+  #f)
+
+(define-method (write-readably (o <object>) file env)
+  (let ((class (class-of o)))
+    (display "(restore " file)
+    (display (class-name class) file)
+    (display " (" file)
+    (let ((slotdefs
+	   (filter (lambda (slotdef)
+		     (not (or (memq (slot-definition-allocation slotdef)
+				    '(#\class #\each-subclass))
+			      (and (slot-bound? o (slot-definition-name slotdef))
+				   (excluded?
+				    (slot-ref o (slot-definition-name slotdef))
+				    env)))))
+		   (class-slots class))))
+      (if (not (null? slotdefs))
+	  (begin
+	    (display (slot-definition-name (car slotdefs)) file)
+	    (for-each (lambda (slotdef)
+			(display #\space file)
+			(display (slot-definition-name slotdef) file))
+		      (cdr slotdefs)))))
+    (display #\) file)
+    (access-for-each (lambda (name aname get set)
+		       (display #\space file)
+		       (let ((val (get o)))
+			 (cond ((unbound? val)
+				(display '(make-unbound) file))
+			       ((excluded? val env))
+			       (else
+				(if (literal? val env)
+				    (display #\' file))
+				(write-component val
+						 (if aname
+						     `(set! (,aname ,o) ,val)
+						     `(slot-set! ,o ',name ,val))
+						 file env)))))
+		     class)
+    (display #\) file)))
+
+;;;
+;;; Classes
+;;;
+
+;;; Currently, we don't support reading in class objects
+;;;
+
+(define-method (enumerate! (o <class>) env) #f)
+
+(define-method (write-readably (o <class>) file env)
+  (display (class-name o) file))
+
+;;;
+;;; Generics
+;;;
+
+;;; Currently, we don't support reading in generic functions
+;;;
+
+(define-method (enumerate! (o <generic>) env) #f)
+
+(define-method (write-readably (o <generic>) file env)
+  (display (generic-function-name o) file))
+
+;;;
+;;; Method
+;;;
+
+;;; Currently, we don't support reading in methods
+;;;
+
+(define-method (enumerate! (o <method>) env) #f)
+
+(define-method (write-readably (o <method>) file env)
+  (goops-error "No read-syntax for <method> defined"))
+
+;;;
+;;; Environments
+;;;
+
+(define-class <environment> ()
+  (object-info 	  #\accessor object-info
+	       	  #\init-form (make-hash-table 61))
+  (excluded	  #\accessor excluded
+		  #\init-form (make-hash-table 61))
+  (pass-2?	  #\accessor pass-2?
+		  #\init-value #f)
+  (ref-stack	  #\accessor ref-stack
+		  #\init-value '())
+  (objects	  #\accessor objects
+		  #\init-value '())
+  (pre-defines	  #\accessor pre-defines
+		  #\init-value '())
+  (locals	  #\accessor locals
+		  #\init-value '())
+  (stand-ins	  #\accessor stand-ins
+		  #\init-value '())
+  (post-defines	  #\accessor post-defines
+		  #\init-value '())
+  (patchers	  #\accessor patchers
+		  #\init-value '())
+  (multiple-bound #\accessor multiple-bound
+		  #\init-value '())
+  )
+
+(define-method (initialize (env <environment>) initargs)
+  (next-method)
+  (cond ((get-keyword #\excluded initargs #f)
+	 => (lambda (excludees)
+	      (for-each (lambda (e)
+			  (hashq-create-handle! (excluded env) e #f))
+			excludees)))))
+
+(define-method (object-info o env)
+  (hashq-ref (object-info env) o))
+
+(define-method ((setter object-info) o env x)
+  (hashq-set! (object-info env) o x))
+
+(define (excluded? o env)
+  (hashq-get-handle (excluded env) o))
+
+(define (add-patcher! patcher env)
+  (set! (patchers env) (cons patcher (patchers env))))
+
+(define (push-ref! o env)
+  (set! (ref-stack env) (cons o (ref-stack env))))
+
+(define (pop-ref! env)
+  (set! (ref-stack env) (cdr (ref-stack env))))
+
+(define (container env)
+  (car (ref-stack env)))
+
+(define-class <object-info> ()
+  (visiting  #\accessor visiting
+	     #\init-value #f)
+  (binding   #\accessor binding
+	     #\init-value #f)
+  (literal?  #\accessor literal?
+	     #\init-value #f)
+  )
+
+(define visiting? visiting)
+
+(define-method (binding (info <boolean>))
+  #f)
+
+(define-method (binding o env)
+  (binding (object-info o env)))
+
+(define binding? binding)
+
+(define-method (literal? (info <boolean>))
+  #t)
+
+;;; Note that this method is intended to be used only during the
+;;; writing pass
+;;;
+(define-method (literal? o env)
+  (or (immediate? o)
+      (excluded? o env)
+      (let ((info (object-info o env)))
+	;; write-component sets all bindings first to #\defining,
+	;; then to #\defined
+	(and (or (not (binding? info))
+		 ;; we might be using `literal?' in a write-readably method
+		 ;; to query about the object being defined
+		 (and (eq? (visiting info) #\defining)
+		      (null? (cdr (ref-stack env)))))
+	     (literal? info)))))
+
+;;;
+;;; Enumeration
+;;;
+
+;;; Enumeration has two passes.
+;;;
+;;; Pass 1: Detect common substructure, circular references and order
+;;;
+;;; Pass 2: Detect literals
+
+(define (enumerate-component! o env)
+  (cond ((immediate? o) #t)
+	((readable? o) #f)
+	((excluded? o env) #t)
+	((pass-2? env)
+	 (let ((info (object-info o env)))
+	   (if (binding? info)
+	       ;; if circular reference, we print as a literal
+	       ;; (note that during pass-2, circular references are
+	       ;;  forward references, i.e. *not* yet marked with #\pass-2
+	       (not (eq? (visiting? info) #\pass-2))
+	       (and (enumerate! o env)
+		    (begin
+		      (set! (literal? info) #t)
+		      #t)))))
+	((object-info o env)
+	 => (lambda (info)
+	      (set! (binding info) #t)
+	      (if (visiting? info)
+		  ;; circular reference--mark container
+		  (set! (binding (object-info (container env) env)) #t))))
+	(else
+	 (let ((info (make <object-info>)))
+	   (set! (object-info o env) info)
+	   (push-ref! o env)
+	   (set! (visiting? info) #t)
+	   (enumerate! o env)
+	   (set! (visiting? info) #f)
+	   (pop-ref! env)
+	   (set! (objects env) (cons o (objects env)))))))
+
+
+;;;
+;;; Main engine
+;;;
+
+(define binding-name car)
+(define binding-object cdr)
+
+(define (pass-1! alist env)
+  ;; Determine object order and necessary bindings
+  (for-each (lambda (binding)
+	      (enumerate-component! (binding-object binding) env))
+	    alist))
+
+(define (make-local i)
+  (string->symbol (string-append "%o" (number->string i))))
+
+(define (name-bindings! alist env)
+  ;; Name top-level bindings
+  (for-each (lambda (b)
+	      (let ((o (binding-object b)))
+		(if (not (or (immediate? o)
+			     (readable? o)
+			     (excluded? o env)))
+		    (let ((info (object-info o env)))
+		      (if (symbol? (binding info))
+			  ;; already bound to a variable
+			  (set! (multiple-bound env)
+				(acons (binding info)
+				       (binding-name b)
+				       (multiple-bound env)))
+			  (set! (binding info)
+				(binding-name b)))))))
+	    alist)
+  ;; Name rest of bindings and create stand-in and definition lists
+  (let post-loop ((ls (objects env))
+		  (post-defs '()))
+    (cond ((or (null? ls)
+	       (eq? (binding (car ls) env) #t))
+	   (set! (post-defines env) post-defs)
+	   (set! (objects env) ls))
+	  ((not (binding (car ls) env))
+	   (post-loop (cdr ls) post-defs))
+	  (else
+	   (post-loop (cdr ls) (cons (car ls) post-defs)))))
+  (let pre-loop ((ls (reverse (objects env)))
+		 (i 0)
+		 (pre-defs '())
+		 (locs '())
+		 (sins '()))
+    (if (null? ls)
+	(begin
+	  (set! (pre-defines env) (reverse pre-defs))
+	  (set! (locals env) (reverse locs))
+	  (set! (stand-ins env) (reverse sins)))
+	(let ((info (object-info (car ls) env)))
+	  (cond ((not (binding? info))
+		 (pre-loop (cdr ls) i pre-defs locs sins))
+		((boolean? (binding info))
+		 ;; local
+		 (set! (binding info) (make-local i))
+		 (pre-loop (cdr ls)
+			   (+ 1 i)
+			   pre-defs
+			   (cons (car ls) locs)
+			   sins))
+		((null? locs)
+		 (pre-loop (cdr ls)
+			   i
+			   (cons (car ls) pre-defs)
+			   locs
+			   sins))
+		(else
+		 (let ((real-name (binding info)))
+		   (set! (binding info) (make-local i))
+		   (pre-loop (cdr ls)
+			     (+ 1 i)
+			     pre-defs
+			     (cons (car ls) locs)
+			     (acons (binding info) real-name sins)))))))))
+
+(define (pass-2! env)
+  (set! (pass-2? env) #t)
+  (for-each (lambda (o)
+	      (let ((info (object-info o env)))
+		(set! (literal? info) (enumerate! o env))
+		(set! (visiting info) #\pass-2)))
+	    (append (pre-defines env)
+		    (locals env)
+		    (post-defines env))))
+
+(define (write-define! name val literal? file)
+  (display "(define " file)
+  (display name file)
+  (display #\space file)
+  (if literal? (display #\' file))
+  (write val file)
+  (display ")\n" file))
+
+(define (write-empty-defines! file env)
+  (for-each (lambda (stand-in)
+	      (write-define! (cdr stand-in) #f #f file))
+	    (stand-ins env))
+  (for-each (lambda (o)
+	      (write-define! (binding o env) #f #f file))
+	    (post-defines env)))
+
+(define (write-definition! prefix o file env)
+  (display prefix file)
+  (let ((info (object-info o env)))
+    (display (binding info) file)
+    (display #\space file)
+    (if (literal? info)
+	(display #\' file))
+    (push-ref! o env)
+    (set! (visiting info) #\defining)
+    (write-readably o file env)
+    (set! (visiting info) #\defined)
+    (pop-ref! env)
+    (display #\) file)))
+
+(define (write-let*-head! file env)
+  (display "(let* (" file)
+  (write-definition! "(" (car (locals env)) file env)
+  (for-each (lambda (o)
+	      (write-definition! "\n       (" o file env))
+	    (cdr (locals env)))
+  (display ")\n" file))
+
+(define (write-rebindings! prefix bindings file env)
+  (for-each (lambda (patch)
+	      (display prefix file)
+	      (display (cdr patch) file)
+	      (display #\space file)
+	      (display (car patch) file)
+	      (display ")\n" file))
+	    bindings))
+
+(define (write-definitions! selector prefix file env)
+  (for-each (lambda (o)
+	      (write-definition! prefix o file env)
+	      (newline file))
+	    (selector env)))
+
+(define (write-patches! prefix file env)
+  (for-each (lambda (patch)
+	      (display prefix file)
+	      (display (let name-objects ((patcher patch))
+			 (cond ((binding patcher env)
+				=> (lambda (name)
+				     (cond ((assq name (stand-ins env))
+					    => cdr)
+					   (else name))))
+			       ((pair? patcher)
+				(cons (name-objects (car patcher))
+				      (name-objects (cdr patcher))))
+			       (else patcher)))
+		       file)
+	      (newline file))
+	    (reverse (patchers env))))
+
+(define (write-immediates! alist file)
+  (for-each (lambda (b)
+	      (if (immediate? (binding-object b))
+		  (write-define! (binding-name b)
+				 (binding-object b)
+				 #t
+				 file)))
+	    alist))
+
+(define (write-readables! alist file env)
+  (let ((written '()))
+    (for-each (lambda (b)
+		(cond ((not (readable? (binding-object b))))
+		      ((assq (binding-object b) written)
+		       => (lambda (p)
+			    (set! (multiple-bound env)
+				  (acons (cdr p)
+					 (binding-name b)
+					 (multiple-bound env)))))
+		      (else
+		       (write-define! (binding-name b)
+				      (readable-expression (binding-object b))
+				      #f
+				      file)
+		       (set! written (acons (binding-object b)
+					    (binding-name b)
+					    written)))))
+	      alist)))
+
+(define-method (save-objects (alist <pair>) (file <string>) . rest)
+  (let ((port (open-output-file file)))
+    (apply save-objects alist port rest)
+    (close-port port)
+    *unspecified*))
+
+(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
+  (let ((excluded (if (>= (length rest) 1) (car rest) '()))
+	(uses     (if (>= (length rest) 2) (cadr rest) '())))
+    (let ((env (make <environment> #\excluded excluded)))
+      (pass-1! alist env)
+      (name-bindings! alist env)
+      (pass-2! env)
+      (if (not (null? uses))
+	  (begin
+	    (write `(use-modules ,@uses) file)
+	    (newline file)))
+      (write-immediates! alist file)
+      (if (null? (locals env))
+	  (begin
+	    (write-definitions! post-defines "(define " file env)
+	    (write-patches! "" file env))
+	  (begin
+	    (write-definitions! pre-defines "(define " file env)
+	    (write-empty-defines! file env)
+	    (write-let*-head! file env)
+	    (write-rebindings! "  (set! " (stand-ins env) file env)
+	    (write-definitions! post-defines "  (set! " file env)
+	    (write-patches! "  " file env)
+	    (display "  )\n" file)))
+      (write-readables! alist file env)
+      (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))
+
+(define-method (load-objects (file <string>))
+  (let* ((port (open-input-file file))
+	 (objects (load-objects port)))
+    (close-port port)
+    objects))
+
+(define iface (module-public-interface (current-module)))
+
+(define-method (load-objects (file <input-port>))
+  (let ((m (make-module)))
+    (module-use! m the-scm-module)
+    (module-use! m iface)
+    (save-module-excursion
+     (lambda ()
+       (set-current-module m)
+       (let loop ((sexp (read file)))
+	 (if (not (eof-object? sexp))
+	     (begin
+	       (eval sexp m)
+	       (loop (read file)))))))
+    (module-map (lambda (name var)
+		  (cons name (variable-ref var)))
+		m)))
+;;; installed-scm-file
+
+;;;; Copyright (C) 2005, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+(define-module (oop goops simple)
+  \:use-module (oop goops accessors)
+  \:export (define-class)
+  \:no-backtrace)
+
+(define-syntax-rule (define-class arg ...)
+  (define-class-with-accessors-keywords arg ...))
+
+(module-use! (module-public-interface (current-module))
+             (resolve-interface '(oop goops)))
+;;;; Copyright (C) 1999,2002, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+(define-module (oop goops stklos)
+  \:use-module (oop goops internal)
+  \:no-backtrace
+  )
+
+;;;
+;;; This is the stklos compatibility module.
+;;;
+;;; WARNING: This module is under construction.  While we expect to be able
+;;; to run most stklos code without problems in the future, this is not the
+;;; case now.  The current compatibility is only superficial.
+;;;
+;;; Any comments/complaints/patches are welcome.  Tell us about
+;;; your incompatibility problems (bug-guile@gnu.org).
+;;;
+
+;; Export all bindings that are exported from (oop goops)...
+(module-for-each (lambda (sym var)
+		   (module-add! (module-public-interface (current-module))
+                                sym var))
+		 (resolve-interface '(oop goops)))
+
+;; ...but replace the following bindings:
+(export define-class define-method)
+
+;; Also export the following
+(export write-object)
+
+;;; Enable keyword support (*fixme*---currently this has global effect)
+(read-set! keywords 'prefix)
+
+(define-syntax-rule (define-class name supers (slot ...) rest ...)
+  (standard-define-class name supers slot ... rest ...))
+
+(define (toplevel-define! name val)
+  (module-define! (current-module) name val))
+
+(define-syntax define-method
+  (syntax-rules (setter)
+    ((_ (setter name) rest ...)
+     (begin
+       (if (or (not (defined? 'name))
+               (not (is-a? name <generic-with-setter>)))
+           (toplevel-define! 'name
+                             (ensure-accessor
+                              (if (defined? 'name) name #f) 'name)))
+       (add-method! (setter name) (method rest ...))))
+    ((_ name rest ...)
+     (begin
+       (if (or (not (defined? 'name))
+               (not (or (is-a? name <generic>)
+                        (is-a? name <primitive-generic>))))
+           (toplevel-define! 'name
+                             (ensure-generic
+                              (if (defined? 'name) name #f) 'name)))
+       (add-method! name (method rest ...))))))
+;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 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 (oop goops util)
+  \:export (mapappend find-duplicate
+	   map* for-each* length* improper->proper)
+  \:use-module (srfi srfi-1)
+  \:re-export  (any every)
+  \:no-backtrace
+  )
+
+
+;;;
+;;; {Utilities}
+;;;
+
+(define mapappend append-map)
+
+(define (find-duplicate l)	; find a duplicate in a list; #f otherwise
+  (cond 
+    ((null? l)			#f)
+    ((memv (car l) (cdr l))	(car l))
+    (else 			(find-duplicate (cdr l)))))
+
+(begin-deprecated
+ (define (top-level-env)
+   (let ((mod (current-module)))
+     (if mod
+         (module-eval-closure mod)
+         '())))
+
+ (define (top-level-env? env)
+   (or (null? env)
+       (procedure? (car env))))
+
+ (export top-level-env? top-level-env))
+
+(define (map* fn . l) 		; A map which accepts dotted lists (arg lists  
+  (cond 			; must be "isomorph"
+   ((null? (car l)) '())
+   ((pair? (car l)) (cons (apply fn      (map car l))
+			  (apply map* fn (map cdr l))))
+   (else            (apply fn l))))
+
+(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists  
+  (cond 			; must be "isomorph"
+   ((null? (car l)) '())
+   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
+   (else            (apply fn l))))
+
+(define (length* ls)
+  (do ((n 0 (+ 1 n))
+       (ls ls (cdr ls)))
+      ((not (pair? ls)) n)))
+
+(define (improper->proper ls)
+  (if (pair? ls)
+      (cons (car ls) (improper->proper (cdr ls)))
+      (list ls)))
+;;; rnrs.scm --- The R6RS composite library
+
+;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs (6))
+  (export ;; (rnrs arithmetic bitwise)
+
+          bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if 
+	  bitwise-bit-count bitwise-length bitwise-first-bit-set 
+	  bitwise-bit-set? bitwise-copy-bit bitwise-bit-field 
+	  bitwise-copy-bit-field bitwise-arithmetic-shift 
+	  bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
+	  bitwise-rotate-bit-field bitwise-reverse-bit-field
+          
+	  ;; (rnrs arithmetic fixnums)
+
+	  fixnum? fixnum-width least-fixnum greatest-fixnum fx=? fx>? fx<? fx>=?
+	  fx<=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+
+	  fx* fx- fxdiv-and-mod fxdiv fxmod fxdiv0-and-mod0 fxdiv0 fxmod0
+	  fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxif fxbit-count
+	  fxlength fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field
+	  fxcopy-bit-field fxarithmetic-shift fxarithmetic-shift-left
+	  fxarithmetic-shift-right fxrotate-bit-field fxreverse-bit-field
+
+	  ;; (rnrs arithmetic flonums)
+
+	  flonum? real->flonum fl=? fl<? fl<=? fl>? fl>=? flinteger? flzero? 
+	  flpositive? flnegative? flodd? fleven? flfinite? flinfinite? flnan?
+	  flmax flmin fl+ fl* fl- fl/ flabs fldiv-and-mod fldiv flmod
+	  fldiv0-and-mod0 fldiv0 flmod0 flnumerator fldenominator flfloor 
+	  flceiling fltruncate flround flexp fllog flsin flcos fltan flacos 
+	  flasin flatan flsqrt flexpt &no-infinities
+	  make-no-infinities-violation no-infinities-violation? &no-nans
+	  make-no-nans-violation no-nans-violation? fixnum->flonum
+	  
+	  ;; (rnrs base)
+
+	  boolean? symbol? char? vector? null? pair? number? string? procedure?
+	  define define-syntax syntax-rules lambda let let* let-values
+	  let*-values letrec letrec* begin quote lambda if set! cond case or 
+          and not eqv? equal? eq? + - * / max min abs numerator denominator gcd
+          lcm floor ceiling truncate round rationalize real-part imag-part 
+	  make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
+	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan 
+	  make-polar magnitude angle complex? real? rational? integer? exact? 
+	  inexact? real-valued? rational-valued? integer-valued? zero? 
+	  positive? negative? odd? even? nan? finite? infinite? exact inexact =
+	  < > <= >= number->string string->number boolean=? cons car cdr caar 
+          cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar
+          caaadr caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar
+          cadddr cdaddr cddadr cdddar cddddr list? list length append reverse 
+	  list-tail list-ref map for-each symbol->string string->symbol symbol=?
+	  char->integer integer->char char=? char<? char>? char<=? char>=?
+	  make-string string string-length string-ref string=? string<? string>?
+	  string<=? string>=? substring string-append string->list list->string
+	  string-for-each string-copy vector? make-vector vector vector-length 
+	  vector-ref vector-set! vector->list list->vector vector-fill! 
+	  vector-map vector-for-each error assertion-violation assert
+	  call-with-current-continuation call/cc call-with-values dynamic-wind
+	  values apply quasiquote unquote unquote-splicing let-syntax 
+	  letrec-syntax syntax-rules identifier-syntax
+
+	  ;; (rnrs bytevectors)
+	  
+	  endianness native-endianness bytevector? make-bytevector 
+	  bytevector-length bytevector=? bytevector-fill! bytevector-copy! 
+	  bytevector-copy uniform-array->bytevector bytevector-u8-ref 
+	  bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! 
+	  bytevector->u8-list u8-list->bytevector bytevector-uint-ref 
+	  bytevector-uint-set! bytevector-sint-ref bytevector-sint-set!
+	  bytevector->sint-list bytevector->uint-list uint-list->bytevector 
+	  sint-list->bytevector bytevector-u16-ref bytevector-s16-ref
+	  bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref 
+	  bytevector-s16-native-ref bytevector-u16-native-set! 
+	  bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref
+	  bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref 
+	  bytevector-s32-native-ref bytevector-u32-native-set! 
+	  bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref
+	  bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref 
+	  bytevector-s64-native-ref bytevector-u64-native-set! 
+	  bytevector-s64-native-set! bytevector-ieee-single-ref
+	  bytevector-ieee-single-set! bytevector-ieee-single-native-ref
+	  bytevector-ieee-single-native-set! bytevector-ieee-double-ref
+	  bytevector-ieee-double-set! bytevector-ieee-double-native-ref
+	  bytevector-ieee-double-native-set! string->utf8 string->utf16 
+	  string->utf32 utf8->string utf16->string utf32->string
+
+	  ;; (rnrs conditions)
+
+	  &condition condition simple-conditions condition? condition-predicate
+	  condition-accessor define-condition-type &message
+	  make-message-condition message-condition? condition-message &warning
+	  make-warning warning? &serious make-serious-condition
+	  serious-condition? &error make-error error? &violation make-violation
+	  violation? &assertion make-assertion-violation assertion-violation?
+	  &irritants make-irritants-condition irritants-condition?
+	  condition-irritants &who make-who-condition who-condition?
+	  condition-who &non-continuable make-non-continuable-violation
+	  non-continuable-violation? &implementation-restriction
+	  make-implementation-restriction-violation
+	  implementation-restriction-violation? &lexical make-lexical-violation
+	  lexical-violation? &syntax make-syntax-violation syntax-violation?
+	  syntax-violation-form syntax-violation-subform &undefined
+	  make-undefined-violation undefined-violation?
+
+	  ;; (rnrs control)
+
+	  when unless do case-lambda
+
+	  ;; (rnrs enums)
+
+	  make-enumeration enum-set-universe enum-set-indexer 
+	  enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+	  enum-set=? enum-set-union enum-set-intersection enum-set-difference
+	  enum-set-complement enum-set-projection define-enumeration
+
+	  ;; (rnrs exceptions)
+
+	  guard with-exception-handler raise raise-continuable
+
+	  ;; (rnrs files)
+
+	  file-exists? delete-file &i/o make-i/o-error i/o-error? &i/o-read 
+	  make-i/o-read-error i/o-read-error? &i/o-write make-i/o-write-error 
+	  i/o-write-error? &i/o-invalid-position 
+	  make-i/o-invalid-position-error i/o-invalid-position-error? 
+	  i/o-error-position &i/o-filename make-i/o-filename-error
+	  i/o-filename-error? i/o-error-filename &i/o-file-protection 
+	  make-i/o-file-protection-error i/o-file-protection-error?
+	  &i/o-file-is-read-only make-i/o-file-is-read-only-error
+	  i/o-file-is-read-only-error? &i/o-file-already-exists
+	  make-i/o-file-already-exists-error i/o-file-already-exists-error?
+	  &i/o-file-does-not-exist make-i/o-file-does-not-exist-error
+	  i/o-file-does-not-exist-error? &i/o-port make-i/o-port-error
+	  i/o-port-error? i/o-error-port
+
+	  ;; (rnrs hashtables)
+
+	  make-eq-hashtable make-eqv-hashtable make-hashtable hashtable?
+	  hashtable-size hashtable-ref hashtable-set! hashtable-delete!
+	  hashtable-contains? hashtable-update! hashtable-copy hashtable-clear!
+	  hashtable-keys hashtable-entries hashtable-equivalence-function
+	  hashtable-hash-function hashtable-mutable? equal-hash string-hash
+	  string-ci-hash symbol-hash
+
+	  ;; (rnrs io ports)
+
+	  file-options buffer-mode buffer-mode?
+	  eol-style native-eol-style error-handling-mode
+	  make-transcoder transcoder-codec transcoder-eol-style
+          transcoder-error-handling-mode native-transcoder
+	  latin-1-codec utf-8-codec utf-16-codec
+	  
+	  eof-object? port? input-port? output-port? eof-object port-eof?
+	  port-transcoder
+	  binary-port? textual-port? transcoded-port
+	  port-position set-port-position!
+	  port-has-port-position? port-has-set-port-position!?
+          close-port call-with-port
+	  open-bytevector-input-port make-custom-binary-input-port get-u8 
+	  lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some 
+	  get-bytevector-all open-bytevector-output-port
+	  make-custom-binary-output-port put-u8 put-bytevector
+          open-string-input-port open-string-output-port
+          call-with-bytevector-output-port
+          call-with-string-output-port
+          latin-1-codec utf-8-codec utf-16-codec
+          open-file-input-port open-file-output-port open-file-input/output-port
+          make-custom-textual-output-port
+          call-with-string-output-port
+	  flush-output-port put-string
+          get-char get-datum get-line get-string-all get-string-n get-string-n!
+          lookahead-char
+          put-char put-datum put-string
+          standard-input-port standard-output-port standard-error-port
+          
+	  ;; (rnrs io simple)
+	  
+	  call-with-input-file call-with-output-file current-input-port
+	  current-output-port current-error-port with-input-from-file
+	  with-output-to-file open-input-file open-output-file close-input-port
+	  close-output-port read-char peek-char read write-char newline display
+	  write
+
+	  ;; (rnrs lists)
+
+	  find for-all exists filter partition fold-left fold-right remp remove 
+	  remv remq memp member memv memq assp assoc assv assq cons*
+
+	  ;; (rnrs programs)
+
+	  command-line exit
+
+	  ;; (rnrs records inspection)
+
+	  record? record-rtd record-type-name record-type-parent
+	  record-type-uid record-type-generative? record-type-sealed? 
+	  record-type-opaque? record-type-field-names record-field-mutable?
+
+	  ;; (rnrs records procedural)
+
+	  make-record-type-descriptor record-type-descriptor?
+	  make-record-constructor-descriptor record-constructor record-predicate
+	  record-accessor record-mutator
+
+	  ;; (rnrs records syntactic)
+
+	  define-record-type record-type-descriptor 
+	  record-constructor-descriptor
+
+	  ;; (rnrs sorting)
+	  
+	  list-sort vector-sort vector-sort!
+
+	  ;; (rnrs syntax-case)
+
+	  make-variable-transformer syntax
+          ;; Until the deprecated support for a unified modules and
+          ;; bindings namespace is removed, we need to manually resolve
+          ;; a conflict between two bindings: that of the (rnrs
+          ;; syntax-case) module, and the imported `syntax-case'
+          ;; binding. We do so here and below by renaming the macro
+          ;; import.
+          (rename (syntax-case-hack syntax-case))
+          identifier?  bound-identifier=? free-identifier=?
+          syntax->datum datum->syntax generate-temporaries with-syntax
+          quasisyntax unsyntax unsyntax-splicing syntax-violation
+
+	  ;; (rnrs unicode)
+	  
+	  char-upcase char-downcase char-titlecase char-foldcase
+	  char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+	  char-alphabetic? char-numeric? char-whitespace? char-upper-case?
+	  char-lower-case? char-title-case? char-general-category
+	  string-upcase string-downcase string-titlecase string-foldcase
+	  string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+	  string-normalize-nfd string-normalize-nfkd string-normalize-nfc
+	  string-normalize-nfkc)
+
+  (import (rnrs arithmetic bitwise (6))
+	  (rnrs arithmetic fixnums (6))
+	  (rnrs arithmetic flonums (6))
+	  (rnrs base (6))
+
+	  (rnrs bytevectors (6))
+          
+	  (rnrs conditions (6))
+	  (rnrs control (6))
+	  (rnrs enums (6))
+	  (rnrs exceptions (6))
+
+          (rnrs files (6))
+
+	  (rnrs hashtables (6))
+
+	  (rnrs io ports (6))
+
+	  (rnrs io simple (6))
+	  (rnrs lists (6))
+	  (rnrs programs (6))
+	  (rnrs records inspection (6))
+	  (rnrs records procedural (6))
+	  (rnrs records syntactic (6))
+	  (rnrs sorting (6))
+          ;; See note above on exporting syntax-case.
+	  (rename (rnrs syntax-case (6))
+                  (syntax-case syntax-case-hack))
+	  (rnrs unicode (6))))
+;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
+
+;;      Copyright (C) 2010, 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
+
+
+(library (rnrs arithmetic bitwise (6))
+  (export bitwise-not
+	  
+	  bitwise-and
+	  bitwise-ior
+	  bitwise-xor
+	  
+	  bitwise-if
+	  bitwise-bit-count
+	  bitwise-length
+
+	  bitwise-first-bit-set
+	  bitwise-bit-set?
+	  bitwise-copy-bit
+	  bitwise-bit-field
+	  bitwise-copy-bit-field
+
+	  bitwise-arithmetic-shift
+	  bitwise-arithmetic-shift-left
+	  bitwise-arithmetic-shift-right
+	  bitwise-rotate-bit-field
+	  bitwise-reverse-bit-field)
+  (import (rnrs base (6))
+	  (rnrs control (6))
+          (rename (only (srfi srfi-60) bitwise-if
+                                       integer-length
+                                       first-set-bit
+                                       copy-bit
+                                       bit-field
+                                       copy-bit-field
+                                       rotate-bit-field
+                                       reverse-bit-field)
+                  (integer-length bitwise-length)
+                  (first-set-bit bitwise-first-bit-set)
+                  (bit-field bitwise-bit-field)
+                  (reverse-bit-field bitwise-reverse-bit-field))
+	  (rename (only (guile) lognot 
+			        logand 
+				logior
+				logxor 
+				logcount 
+				logbit?
+				modulo
+				ash)
+		  (lognot bitwise-not)
+		  (logand bitwise-and) 
+		  (logior bitwise-ior) 
+		  (logxor bitwise-xor)
+		  (ash bitwise-arithmetic-shift)))
+
+  (define (bitwise-bit-count ei)
+    (if (negative? ei)
+        (bitwise-not (logcount ei))
+        (logcount ei)))
+
+  (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))
+
+  (define (bitwise-copy-bit ei1 ei2 ei3)
+    ;; The specification states that ei3 should be either 0 or 1.
+    ;; However, other values have been tolerated by both Guile 2.0.x and
+    ;; the sample implementation given the R6RS library document, so for
+    ;; backward compatibility we continue to permit it.
+    (copy-bit ei2 ei1 (logbit? 0 ei3)))
+
+  (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
+    (copy-bit-field ei1 ei4 ei2 ei3))
+
+  (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+    (rotate-bit-field ei1 ei4 ei2 ei3))
+
+  (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
+  (define (bitwise-arithmetic-shift-right ei1 ei2)
+    (bitwise-arithmetic-shift ei1 (- ei2))))
+;;; fixnums.scm --- The R6RS fixnums arithmetic library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs arithmetic fixnums (6))
+  (export fixnum?
+	  
+	  fixnum-width
+	  least-fixnum
+	  greatest-fixnum
+
+	  fx=?
+	  fx>?
+	  fx<?
+	  fx>=?
+	  fx<=?
+
+	  fxzero?
+	  fxpositive?
+	  fxnegative?
+	  fxodd?
+	  fxeven?
+
+	  fxmax
+	  fxmin
+	  
+	  fx+
+	  fx*
+	  fx-
+
+	  fxdiv-and-mod
+	  fxdiv
+	  fxmod
+	  fxdiv0-and-mod0
+	  fxdiv0
+	  fxmod0
+
+	  fx+/carry
+	  fx-/carry
+	  fx*/carry
+
+	  fxnot
+	  fxand
+	  fxior
+	  fxxor
+	  fxif
+
+	  fxbit-count
+	  fxlength
+	  fxfirst-bit-set
+	  fxbit-set?
+	  fxcopy-bit
+	  fxbit-field
+	  fxcopy-bit-field
+
+	  fxarithmetic-shift
+	  fxarithmetic-shift-left
+	  fxarithmetic-shift-right
+
+	  fxrotate-bit-field
+	  fxreverse-bit-field)
+  (import (only (guile) ash
+		        cons*
+			define-inlinable
+			inexact->exact
+			logand
+			logbit?
+			logcount
+			logior
+			lognot
+			logxor
+			most-positive-fixnum 
+			most-negative-fixnum
+			object-address)
+	  (ice-9 optargs)
+	  (rnrs base (6))
+	  (rnrs control (6))
+	  (rnrs arithmetic bitwise (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6))
+	  (rnrs lists (6)))
+
+  (define fixnum-width
+    (let ((w (do ((i 0 (+ 1 i))
+                  (n 1 (* 2 n)))
+                 ((> n most-positive-fixnum)
+                  (+ 1 i)))))
+      (lambda () w)))
+
+  (define (greatest-fixnum) most-positive-fixnum)
+  (define (least-fixnum) most-negative-fixnum)
+
+  (define (fixnum? obj)
+    (not (= 0 (logand 2 (object-address obj)))))
+
+  (define-inlinable (inline-fixnum? obj)
+    (not (= 0 (logand 2 (object-address obj)))))
+
+  (define-syntax assert-fixnum
+    (syntax-rules ()
+      ((_ arg ...)
+       (or (and (inline-fixnum? arg) ...)
+	   (raise (make-assertion-violation))))))
+
+  (define (assert-fixnums args)
+    (or (for-all inline-fixnum? args) (raise (make-assertion-violation))))
+
+  (define-syntax define-fxop*
+    (syntax-rules ()
+      ((_ name op)
+       (define name
+	(case-lambda
+	  ((x y)
+	   (assert-fixnum x y)
+	   (op x y))
+	  (args
+	   (assert-fixnums args)
+           (apply op args)))))))
+
+  ;; All these predicates don't check their arguments for fixnum-ness,
+  ;; as this doesn't seem to be strictly required by R6RS.
+
+  (define fx=? =)
+  (define fx>? >)
+  (define fx<? <)
+  (define fx>=? >=)
+  (define fx<=? <=)
+
+  (define fxzero? zero?)
+  (define fxpositive? positive?)
+  (define fxnegative? negative?)
+  (define fxodd? odd?)
+  (define fxeven? even?)
+
+  (define-fxop* fxmax max)
+  (define-fxop* fxmin min)
+
+  (define (fx+ fx1 fx2)
+    (assert-fixnum fx1 fx2) 
+    (let ((r (+ fx1 fx2))) 
+      (or (inline-fixnum? r)
+          (raise (make-implementation-restriction-violation)))
+      r))
+
+  (define (fx* fx1 fx2)
+    (assert-fixnum fx1 fx2) 
+    (let ((r (* fx1 fx2))) 
+      (or (inline-fixnum? r)
+          (raise (make-implementation-restriction-violation)))
+      r))
+
+  (define* (fx- fx1 #\optional fx2)
+    (assert-fixnum fx1)
+    (if fx2 
+	(begin 
+	  (assert-fixnum fx2) 
+	  (let ((r (- fx1 fx2))) 
+	    (or (inline-fixnum? r) (raise (make-assertion-violation)))
+	    r))
+	(let ((r (- fx1))) 
+	  (or (inline-fixnum? r) (raise (make-assertion-violation)))
+	  r)))
+
+  (define (fxdiv fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (div fx1 fx2))
+
+  (define (fxmod fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (mod fx1 fx2))
+
+  (define (fxdiv-and-mod fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (div-and-mod fx1 fx2))
+
+  (define (fxdiv0 fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (div0 fx1 fx2))
+  
+  (define (fxmod0 fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (mod0 fx1 fx2))
+
+  (define (fxdiv0-and-mod0 fx1 fx2)
+    (assert-fixnum fx1 fx2)
+    (div0-and-mod0 fx1 fx2))
+
+  (define (fx+/carry fx1 fx2 fx3)
+    (assert-fixnum fx1 fx2 fx3)
+    (let* ((s (+ fx1 fx2 fx3))
+	   (s0 (mod0 s (expt 2 (fixnum-width))))
+	   (s1 (div0 s (expt 2 (fixnum-width)))))
+      (values s0 s1)))
+
+  (define (fx-/carry fx1 fx2 fx3)
+    (assert-fixnum fx1 fx2 fx3)
+    (let* ((d (- fx1 fx2 fx3))
+	   (d0 (mod0 d (expt 2 (fixnum-width))))
+	   (d1 (div0 d (expt 2 (fixnum-width)))))
+      (values d0 d1)))
+
+  (define (fx*/carry fx1 fx2 fx3)
+    (assert-fixnum fx1 fx2 fx3)
+    (let* ((s (+ (* fx1 fx2) fx3))
+	   (s0 (mod0 s (expt 2 (fixnum-width))))
+	   (s1 (div0 s (expt 2 (fixnum-width)))))
+      (values s0 s1)))
+
+  (define (fxnot fx) (assert-fixnum fx) (lognot fx))
+  (define-fxop* fxand logand)
+  (define-fxop* fxior logior)
+  (define-fxop* fxxor logxor)
+
+  (define (fxif fx1 fx2 fx3) 
+    (assert-fixnum fx1 fx2 fx3) 
+    (bitwise-if fx1 fx2 fx3))
+
+  (define (fxbit-count fx)
+    (assert-fixnum fx)
+    (if (negative? fx)
+        (bitwise-not (logcount fx))
+        (logcount fx)))
+
+  (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
+  (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
+  (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
+
+  (define (fxcopy-bit fx1 fx2 fx3) 
+    (assert-fixnum fx1 fx2 fx3) 
+    (bitwise-copy-bit fx1 fx2 fx3))
+
+  (define (fxbit-field fx1 fx2 fx3)
+    (assert-fixnum fx1 fx2 fx3)
+    (bitwise-bit-field fx1 fx2 fx3))
+
+  (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
+    (assert-fixnum fx1 fx2 fx3 fx4)
+    (bitwise-copy-bit-field fx1 fx2 fx3 fx4))
+
+  (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
+  (define fxarithmetic-shift-left fxarithmetic-shift)
+
+  (define (fxarithmetic-shift-right fx1 fx2)
+    (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
+
+  (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
+    (assert-fixnum fx1 fx2 fx3 fx4)
+    (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
+  
+  (define (fxreverse-bit-field fx1 fx2 fx3)
+    (assert-fixnum fx1 fx2 fx3)
+    (bitwise-reverse-bit-field fx1 fx2 fx3))
+
+)
+;;; flonums.scm --- The R6RS flonums arithmetic library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs arithmetic flonums (6))
+  (export flonum?
+	  real->flonum
+
+	  fl=? fl<? fl<=? fl>? fl>=?
+
+	  flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
+	  flinfinite? flnan?
+
+	  flmax flmin
+
+	  fl+ fl* fl- fl/
+
+	  flabs
+
+	  fldiv-and-mod
+	  fldiv
+	  flmod
+	  fldiv0-and-mod0
+	  fldiv0
+	  flmod0
+
+	  flnumerator
+	  fldenominator
+
+	  flfloor flceiling fltruncate flround
+
+	  flexp fllog flsin flcos fltan flacos flasin flatan
+
+	  flsqrt flexpt
+
+	  &no-infinities
+	  make-no-infinities-violation
+	  no-infinities-violation?
+	  
+	  &no-nans
+	  make-no-nans-violation
+	  no-nans-violation?
+
+	  fixnum->flonum)
+  (import (ice-9 optargs)
+	  (only (guile) inf?)
+	  (rnrs arithmetic fixnums (6))
+	  (rnrs base (6))
+	  (rnrs control (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6))
+	  (rnrs lists (6))
+	  (rnrs r5rs (6)))
+
+  (define (flonum? obj) (and (real? obj) (inexact? obj)))
+  (define (assert-flonum . args)
+    (or (for-all flonum? args) (raise (make-assertion-violation))))
+  (define (assert-iflonum . args)
+    (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
+	(raise (make-assertion-violation))))
+
+  (define (ensure-flonum z)
+    (cond ((real? z) z)
+          ((zero? (imag-part z)) (real-part z))
+          (else +nan.0)))
+
+  (define (real->flonum x) 
+    (or (real? x) (raise (make-assertion-violation)))
+    (exact->inexact x))
+
+  (define (fl=? . args) (apply assert-flonum args) (apply = args))
+  (define (fl<? . args) (apply assert-flonum args) (apply < args))
+  (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
+  (define (fl>? . args) (apply assert-flonum args) (apply > args))
+  (define (fl>=? . args) (apply assert-flonum args) (apply >= args))
+
+  (define (flinteger? fl) (assert-flonum fl) (integer? fl))
+  (define (flzero? fl) (assert-flonum fl) (zero? fl))
+  (define (flpositive? fl) (assert-flonum fl) (positive? fl))
+  (define (flnegative? fl) (assert-flonum fl) (negative? fl))
+  (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
+  (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
+  (define (flfinite? fl) (assert-flonum fl) (not (or (inf? fl) (nan? fl))))
+  (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
+  (define (flnan? fl) (assert-flonum fl) (nan? fl))
+
+  (define (flmax fl1 . args)
+    (let ((flargs (cons fl1 args)))
+      (apply assert-flonum flargs)
+      (apply max flargs)))
+
+  (define (flmin fl1 . args)
+    (let ((flargs (cons fl1 args)))
+      (apply assert-flonum flargs)
+      (apply min flargs)))
+
+  (define (fl+ . args)
+    (apply assert-flonum args)
+    (if (null? args) 0.0 (apply + args)))
+
+  (define (fl* . args)
+    (apply assert-flonum args)
+    (if (null? args) 1.0 (apply * args)))
+
+  (define (fl- fl1 . args)
+    (let ((flargs (cons fl1 args)))
+      (apply assert-flonum flargs)
+      (apply - flargs)))
+
+  (define (fl/ fl1 . args)
+    (let ((flargs (cons fl1 args)))
+      (apply assert-flonum flargs)
+      (apply / flargs)))
+
+  (define (flabs fl) (assert-flonum fl) (abs fl))
+
+  (define (fldiv-and-mod fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (div-and-mod fl1 fl2))
+
+  (define (fldiv fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (div fl1 fl2))
+
+  (define (flmod fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (mod fl1 fl2))
+
+  (define (fldiv0-and-mod0 fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (div0-and-mod0 fl1 fl2))
+
+  (define (fldiv0 fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (div0 fl1 fl2))
+
+  (define (flmod0 fl1 fl2)
+    (assert-iflonum fl1 fl2)
+    (mod0 fl1 fl2))
+
+  (define (flnumerator fl) (assert-flonum fl) (numerator fl))
+  (define (fldenominator fl) (assert-flonum fl) (denominator fl))
+  
+  (define (flfloor fl) (assert-flonum fl) (floor fl))
+  (define (flceiling fl) (assert-flonum fl) (ceiling fl))
+  (define (fltruncate fl) (assert-flonum fl) (truncate fl))
+  (define (flround fl) (assert-flonum fl) (round fl))
+
+  (define (flexp fl) (assert-flonum fl) (exp fl))
+  (define fllog
+    (case-lambda
+      ((fl)
+       (assert-flonum fl)
+       ;; add 0.0 to fl, to change -0.0 to 0.0,
+       ;; so that (fllog -0.0) will be -inf.0, not -inf.0+pi*i.
+       (ensure-flonum (log (+ fl 0.0))))
+      ((fl fl2)
+       (assert-flonum fl fl2)
+       (ensure-flonum (/ (log (+ fl 0.0))
+                         (log (+ fl2 0.0)))))))
+
+  (define (flsin fl) (assert-flonum fl) (sin fl))
+  (define (flcos fl) (assert-flonum fl) (cos fl))
+  (define (fltan fl) (assert-flonum fl) (tan fl))
+  (define (flasin fl) (assert-flonum fl) (ensure-flonum (asin fl)))
+  (define (flacos fl) (assert-flonum fl) (ensure-flonum (acos fl)))
+  (define flatan
+    (case-lambda
+      ((fl) (assert-flonum fl) (atan fl))
+      ((fl fl2) (assert-flonum fl fl2) (atan fl fl2))))
+
+  (define (flsqrt fl) (assert-flonum fl) (ensure-flonum (sqrt fl)))
+  (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (ensure-flonum (expt fl1 fl2)))
+
+  (define-condition-type &no-infinities
+    &implementation-restriction
+    make-no-infinities-violation
+    no-infinities-violation?)
+
+  (define-condition-type &no-nans
+    &implementation-restriction
+    make-no-nans-violation
+    no-nans-violation?)
+
+  (define (fixnum->flonum fx)
+    (or (fixnum? fx) (raise (make-assertion-violation))) 
+    (exact->inexact fx))
+)
+;;; base.scm --- The R6RS base library
+
+;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs base (6))
+  (export boolean? symbol? char? vector? null? pair? number? string? procedure?
+	 
+	  define define-syntax syntax-rules lambda let let* let-values 
+	  let*-values letrec letrec* begin 
+
+	  quote lambda if set! cond case 
+	 
+	  or and not
+	 
+	  eqv? equal? eq?
+	 
+	  + - * / max min abs numerator denominator gcd lcm floor ceiling
+	  truncate round rationalize real-part imag-part make-rectangular angle
+	  div mod div-and-mod div0 mod0 div0-and-mod0
+	  
+	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan 
+	  make-polar magnitude angle
+	 
+	  complex? real? rational? integer? exact? inexact? real-valued?
+	  rational-valued? integer-valued? zero? positive? negative? odd? even?
+	  nan? finite? infinite?
+
+	  exact inexact = < > <= >= 
+
+	  number->string string->number
+
+          boolean=?
+
+	  cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr 
+	  cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr 
+	  cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
+
+	  list? list length append reverse list-tail list-ref map for-each
+
+	  symbol->string string->symbol symbol=?
+
+	  char->integer integer->char char=? char<? char>? char<=? char>=?
+
+	  make-string string string-length string-ref string=? string<? string>?
+	  string<=? string>=? substring string-append string->list list->string
+	  string-for-each string-copy
+
+	  vector? make-vector vector vector-length vector-ref vector-set! 
+	  vector->list list->vector vector-fill! vector-map vector-for-each
+
+	  error assertion-violation assert
+
+	  call-with-current-continuation call/cc call-with-values dynamic-wind
+	  values apply
+
+	  quasiquote unquote unquote-splicing
+
+	  let-syntax letrec-syntax
+
+	  syntax-rules identifier-syntax)
+  (import (rename (except (guile) error raise map string-for-each)
+                  (log log-internal)
+                  (euclidean-quotient div)
+                  (euclidean-remainder mod)
+                  (euclidean/ div-and-mod)
+                  (centered-quotient div0)
+                  (centered-remainder mod0)
+                  (centered/ div0-and-mod0)
+                  (inf? infinite?)
+                  (exact->inexact inexact)
+                  (inexact->exact exact))
+          (srfi srfi-11))
+
+ (define string-for-each
+   (case-lambda
+     ((proc string)
+      (let ((end (string-length string)))
+        (let loop ((i 0))
+          (unless (= i end)
+            (proc (string-ref string i))
+            (loop (+ i 1))))))
+     ((proc string1 string2)
+      (let ((end1 (string-length string1))
+            (end2 (string-length string2)))
+        (unless (= end1 end2)
+          (assertion-violation 'string-for-each
+                               "string arguments must all have the same length"
+                               string1 string2))
+        (let loop ((i 0))
+          (unless (= i end1)
+            (proc (string-ref string1 i)
+                  (string-ref string2 i))
+            (loop (+ i 1))))))
+     ((proc string . strings)
+      (let ((end (string-length string))
+            (ends (map string-length strings)))
+        (for-each (lambda (x)
+                    (unless (= end x)
+                      (apply assertion-violation
+                             'string-for-each
+                             "string arguments must all have the same length"
+                             string strings)))
+                  ends)
+        (let loop ((i 0))
+          (unless (= i end)
+            (apply proc
+                   (string-ref string i)
+                   (map (lambda (s) (string-ref s i)) strings))
+            (loop (+ i 1))))))))
+
+ (define map
+   (case-lambda
+     ((f l)
+      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+        (if (pair? hare)
+            (if move?
+                (if (eq? tortoise hare)
+                    (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                               (list l) #f)
+                    (map1 (cdr hare) (cdr tortoise) #f
+                          (cons (f (car hare)) out)))
+                (map1 (cdr hare) tortoise #t
+                      (cons (f (car hare)) out)))
+            (if (null? hare)
+                (reverse out)
+                (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                           (list l) #f)))))
+    
+     ((f l1 l2)
+      (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
+        (cond
+         ((pair? h1)
+          (cond
+           ((not (pair? h2))
+            (scm-error 'wrong-type-arg "map"
+                       (if (list? h2)
+                           "List of wrong length: ~S"
+                           "Not a list: ~S")
+                       (list l2) #f))
+           ((not move?)
+            (map2 (cdr h1) (cdr h2) t1 t2 #t
+                  (cons (f (car h1) (car h2)) out)))
+           ((eq? t1 h1)
+            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                       (list l1) #f))
+           ((eq? t2 h2)
+            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                       (list l2) #f))
+           (else
+            (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
+                  (cons (f (car h1) (car h2)) out)))))
+
+         ((and (null? h1) (null? h2))
+          (reverse out))
+        
+         ((null? h1)
+          (scm-error 'wrong-type-arg "map"
+                     (if (list? h2)
+                         "List of wrong length: ~S"
+                         "Not a list: ~S")
+                     (list l2) #f))
+         (else
+          (scm-error 'wrong-type-arg "map"
+                     "Not a list: ~S"
+                     (list l1) #f)))))
+
+     ((f l1 . rest)
+      (let ((len (length l1)))
+        (let mapn ((rest rest))
+          (or (null? rest)
+              (if (= (length (car rest)) len)
+                  (mapn (cdr rest))
+                  (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                             (list (car rest)) #f)))))
+      (let mapn ((l1 l1) (rest rest) (out '()))
+        (if (null? l1)
+            (reverse out)
+            (mapn (cdr l1) (map cdr rest)
+                  (cons (apply f (car l1) (map car rest)) out)))))))
+
+ (define log
+   (case-lambda
+     ((n)
+      (log-internal n))
+     ((n base)
+      (/ (log n)
+         (log base)))))
+
+ (define (boolean=? . bools)
+   (define (boolean=?-internal lst last)
+     (or (null? lst)
+         (let ((bool (car lst))) 
+           (and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
+   (or (null? bools)
+       (let ((bool (car bools)))
+         (and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
+
+ (define (symbol=? . syms)
+   (define (symbol=?-internal lst last)
+     (or (null? lst)
+         (let ((sym (car lst))) 
+           (and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
+   (or (null? syms)
+       (let ((sym (car syms)))
+         (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
+
+ (define (real-valued? x)
+   (and (complex? x)
+        (zero? (imag-part x))))
+
+ (define (rational-valued? x)
+   (and (real-valued? x)
+        (rational? (real-part x))))
+
+ (define (integer-valued? x)
+   (and (rational-valued? x)
+        (= x (floor (real-part x)))))
+
+ (define (vector-for-each proc . vecs)
+   (apply for-each (cons proc (map vector->list vecs))))
+ (define (vector-map proc . vecs)
+   (list->vector (apply map (cons proc (map vector->list vecs)))))
+
+ (define-syntax define-proxy
+   (syntax-rules (@)
+     ;; Define BINDING to point to (@ MODULE ORIGINAL).  This hack is to
+     ;; make sure MODULE is loaded lazily, at run-time, when BINDING is
+     ;; encountered, rather than being loaded while compiling and
+     ;; loading (rnrs base).
+     ;; This avoids circular dependencies among modules and makes
+     ;; (rnrs base) more lightweight.
+     ((_ binding (@ module original))
+      (define-syntax binding
+        (identifier-syntax
+         (module-ref (resolve-interface 'module) 'original))))))
+
+ (define-proxy raise
+   (@ (rnrs exceptions) raise))
+
+ (define-proxy condition
+   (@ (rnrs conditions) condition))
+ (define-proxy make-error
+   (@ (rnrs conditions) make-error))
+ (define-proxy make-assertion-violation
+   (@ (rnrs conditions) make-assertion-violation))
+ (define-proxy make-who-condition
+   (@ (rnrs conditions) make-who-condition))
+ (define-proxy make-message-condition
+   (@ (rnrs conditions) make-message-condition))
+ (define-proxy make-irritants-condition
+   (@ (rnrs conditions) make-irritants-condition))
+
+ (define (error who message . irritants)
+   (raise (apply condition
+                 (append (list (make-error))
+                         (if who (list (make-who-condition who)) '())
+                         (list (make-message-condition message)
+                               (make-irritants-condition irritants))))))
+ 
+ (define (assertion-violation who message . irritants)
+   (raise (apply condition
+                 (append (list (make-assertion-violation))
+                         (if who (list (make-who-condition who)) '())
+                         (list (make-message-condition message)
+                               (make-irritants-condition irritants))))))
+
+ (define-syntax assert
+   (syntax-rules ()
+     ((_ expression)
+      (or expression
+          (raise (condition
+                  (make-assertion-violation)
+                  (make-message-condition
+                   (format #f "assertion failed: ~s" 'expression))))))))
+
+)
+;;;; bytevectors.scm --- R6RS bytevector API           -*- coding: utf-8 -*-
+
+;;;;	Copyright (C) 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:
+;;;
+;;; A "bytevector" is a raw bit string.  This module provides procedures to
+;;; manipulate bytevectors and interpret their contents in a number of ways:
+;;; bytevector contents can be accessed as signed or unsigned integer of
+;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
+;;; strings.  It is a useful tool to decode binary data.
+;;;
+;;; Code:
+
+(define-module (rnrs bytevectors)
+  #\version (6)
+  #\export-syntax (endianness)
+  #\export (native-endianness bytevector?
+           make-bytevector bytevector-length bytevector=? bytevector-fill!
+           bytevector-copy! bytevector-copy
+           uniform-array->bytevector
+           bytevector-u8-ref bytevector-s8-ref
+           bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+           u8-list->bytevector
+           bytevector-uint-ref bytevector-uint-set!
+           bytevector-sint-ref bytevector-sint-set!
+           bytevector->sint-list bytevector->uint-list
+           uint-list->bytevector sint-list->bytevector
+
+           bytevector-u16-ref bytevector-s16-ref
+           bytevector-u16-set! bytevector-s16-set!
+           bytevector-u16-native-ref bytevector-s16-native-ref
+           bytevector-u16-native-set! bytevector-s16-native-set!
+
+           bytevector-u32-ref bytevector-s32-ref
+           bytevector-u32-set! bytevector-s32-set!
+           bytevector-u32-native-ref bytevector-s32-native-ref
+           bytevector-u32-native-set! bytevector-s32-native-set!
+
+           bytevector-u64-ref bytevector-s64-ref
+           bytevector-u64-set! bytevector-s64-set!
+           bytevector-u64-native-ref bytevector-s64-native-ref
+           bytevector-u64-native-set! bytevector-s64-native-set!
+
+           bytevector-ieee-single-ref
+           bytevector-ieee-single-set!
+           bytevector-ieee-single-native-ref
+           bytevector-ieee-single-native-set!
+
+           bytevector-ieee-double-ref
+           bytevector-ieee-double-set!
+           bytevector-ieee-double-native-ref
+           bytevector-ieee-double-native-set!
+
+           string->utf8 string->utf16 string->utf32
+           utf8->string utf16->string utf32->string))
+
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_bytevectors")
+
+(define-macro (endianness sym)
+  (if (memq sym '(big little))
+      `(quote ,sym)
+      (error "unsupported endianness" sym)))
+
+;;; bytevector.scm ends here
+;;; conditions.scm --- The R6RS conditions library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs conditions (6))
+  (export &condition
+	  condition
+	  simple-conditions
+	  condition?
+	  condition-predicate
+	  condition-accessor
+	  define-condition-type
+	  
+	  &message
+	  make-message-condition
+	  message-condition?
+	  condition-message
+
+	  &warning
+	  make-warning
+	  warning?
+
+	  &serious
+	  make-serious-condition
+	  serious-condition?
+
+	  &error
+	  make-error
+	  error?
+
+	  &violation
+	  make-violation
+	  violation?
+
+	  &assertion
+	  make-assertion-violation
+	  assertion-violation?
+
+	  &irritants
+	  make-irritants-condition
+	  irritants-condition?
+	  condition-irritants
+
+	  &who
+	  make-who-condition
+	  who-condition?
+	  condition-who
+
+	  &non-continuable
+	  make-non-continuable-violation
+	  non-continuable-violation?
+
+	  &implementation-restriction
+	  make-implementation-restriction-violation
+	  implementation-restriction-violation?
+
+	  &lexical
+	  make-lexical-violation
+	  lexical-violation?
+
+	  &syntax
+	  make-syntax-violation
+	  syntax-violation?
+	  syntax-violation-form
+	  syntax-violation-subform
+
+	  &undefined
+	  make-undefined-violation
+	  undefined-violation?)
+  (import (only (guile) and=> @@)
+	  (rnrs base (6))
+	  (rnrs lists (6))
+	  (rnrs records procedural (6)))
+
+  (define &compound-condition (make-record-type-descriptor 
+			       '&compound-condition #f #f #f #f
+			       '#((immutable components))))
+  (define compound-condition? (record-predicate &compound-condition))
+  
+  (define make-compound-condition 
+    (record-constructor (make-record-constructor-descriptor 
+			 &compound-condition #f #f)))
+  (define simple-conditions
+    (let ((compound-ref (record-accessor &compound-condition 0)))
+      (lambda (condition)
+        (cond ((compound-condition? condition)
+               (compound-ref condition))
+              ((condition-internal? condition)
+               (list condition))
+              (else
+               (assertion-violation 'simple-conditions
+                                    "not a condition"
+                                    condition))))))
+
+  (define (condition? obj) 
+    (or (compound-condition? obj) (condition-internal? obj)))
+
+  (define condition
+    (lambda conditions
+      (define (flatten cond)
+	(if (compound-condition? cond) (simple-conditions cond) (list cond)))
+      (or (for-all condition? conditions)
+	  (assertion-violation 'condition "non-condition argument" conditions))
+      (if (or (null? conditions) (> (length conditions) 1))
+	  (make-compound-condition (apply append (map flatten conditions)))
+	  (car conditions))))
+  
+  (define-syntax define-condition-type
+    (syntax-rules ()
+      ((_ condition-type supertype constructor predicate
+	  (field accessor) ...)
+       (letrec-syntax
+	   ((transform-fields
+	     (syntax-rules ()
+	       ((_ (f a) . rest)
+		(cons '(immutable f a) (transform-fields . rest)))
+	       ((_) '())))
+
+	    (generate-accessors
+	     (syntax-rules ()
+	       ((_ counter (f a) . rest)
+		(begin (define a 
+                         (condition-accessor 
+                          condition-type
+                          (record-accessor condition-type counter)))
+		       (generate-accessors (+ counter 1) . rest)))
+	       ((_ counter) (begin)))))
+	 (begin
+	   (define condition-type 
+	     (make-record-type-descriptor 
+	      'condition-type supertype #f #f #f 
+	      (list->vector (transform-fields (field accessor) ...))))
+	   (define constructor
+	     (record-constructor 
+	      (make-record-constructor-descriptor condition-type #f #f)))
+	   (define predicate (condition-predicate condition-type))
+	   (generate-accessors 0 (field accessor) ...))))))
+
+  (define &condition (@@ (rnrs records procedural) &condition))
+  (define &condition-constructor-descriptor
+    (make-record-constructor-descriptor &condition #f #f))
+  (define condition-internal? (record-predicate &condition))
+
+  (define (condition-predicate rtd)
+    (let ((rtd-predicate (record-predicate rtd)))
+      (lambda (obj)
+	(cond ((compound-condition? obj) 
+	       (exists rtd-predicate (simple-conditions obj)))
+	      ((condition-internal? obj) (rtd-predicate obj))
+	      (else #f)))))
+
+  (define (condition-accessor rtd proc)
+    (let ((rtd-predicate (record-predicate rtd)))
+      (lambda (obj)
+	(cond ((rtd-predicate obj) (proc obj))
+	      ((compound-condition? obj) 
+	       (and=> (find rtd-predicate (simple-conditions obj)) proc))
+	      (else #f)))))
+
+  (define-condition-type &message &condition 
+    make-message-condition message-condition? 
+    (message condition-message))
+
+  (define-condition-type &warning &condition make-warning warning?)
+
+  (define &serious (@@ (rnrs records procedural) &serious))
+  (define make-serious-condition 
+    (@@ (rnrs records procedural) make-serious-condition))
+  (define serious-condition? (condition-predicate &serious))
+
+  (define-condition-type &error &serious make-error error?)
+
+  (define &violation (@@ (rnrs records procedural) &violation))
+  (define make-violation (@@ (rnrs records procedural) make-violation))
+  (define violation? (condition-predicate &violation))
+
+  (define &assertion (@@ (rnrs records procedural) &assertion))
+  (define make-assertion-violation 
+    (@@ (rnrs records procedural) make-assertion-violation))
+  (define assertion-violation? (condition-predicate &assertion))
+
+  (define-condition-type &irritants &condition 
+    make-irritants-condition irritants-condition?
+    (irritants condition-irritants))
+
+  (define-condition-type &who &condition
+    make-who-condition who-condition?
+    (who condition-who))
+
+  (define-condition-type &non-continuable &violation
+    make-non-continuable-violation
+    non-continuable-violation?)
+
+  (define-condition-type &implementation-restriction
+    &violation
+    make-implementation-restriction-violation
+    implementation-restriction-violation?)
+
+  (define-condition-type &lexical &violation
+    make-lexical-violation lexical-violation?)
+
+  (define-condition-type &syntax &violation
+    make-syntax-violation syntax-violation?
+    (form syntax-violation-form)
+    (subform syntax-violation-subform))
+
+  (define-condition-type &undefined &violation
+    make-undefined-violation undefined-violation?)
+  
+)
+;;; control.scm --- The R6RS control structures library
+
+;;      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
+
+
+(library (rnrs control (6))
+  (export when unless do case-lambda)
+  (import (only (guile) when unless do case-lambda)))
+;;; enums.scm --- The R6RS enumerations library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs enums (6))
+  (export make-enumeration enum-set-universe enum-set-indexer 
+	  enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+	  enum-set=? enum-set-union enum-set-intersection enum-set-difference
+	  enum-set-complement enum-set-projection define-enumeration)
+  (import (only (guile) and=>)
+	  (rnrs base (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6))
+          (rnrs records procedural (6))
+	  (rnrs syntax-case (6))
+	  (srfi 1))
+
+  (define enum-set-rtd (make-record-type-descriptor 
+			'enum-set #f #f #f #f '#((mutable universe)
+						 (immutable set))))
+  
+  (define make-enum-set
+    (record-constructor 
+     (make-record-constructor-descriptor enum-set-rtd #f #f)))
+
+  (define enum-set-universe-internal (record-accessor enum-set-rtd 0))
+  (define enum-set-universe-set! (record-mutator enum-set-rtd 0))
+
+  (define enum-set-set (record-accessor enum-set-rtd 1))
+
+  (define (make-enumeration symbol-list) 
+    (let ((es (make-enum-set #f symbol-list)))
+      (enum-set-universe-set! es es)))
+
+  (define (enum-set-universe enum-set)
+    (or (enum-set-universe-internal enum-set) 
+	enum-set))
+  
+  (define (enum-set-indexer enum-set)
+    (let* ((symbols (enum-set->list (enum-set-universe enum-set)))
+	   (cardinality (length symbols)))
+      (lambda (x)
+	(and=> (memq x symbols) 
+	       (lambda (probe) (- cardinality (length probe)))))))
+
+  (define (enum-set-constructor enum-set)
+    (lambda (symbol-list)
+      (make-enum-set (enum-set-universe enum-set) 
+		     (list-copy symbol-list))))
+
+  (define (enum-set->list enum-set)
+    (lset-intersection eq? 
+		       (enum-set-set (enum-set-universe enum-set))
+		       (enum-set-set enum-set)))
+
+  (define (enum-set-member? symbol enum-set)
+    (and (memq symbol (enum-set-set enum-set)) #t))
+
+  (define (enum-set-subset? enum-set-1 enum-set-2)
+    (and (lset<= eq? 
+		 (enum-set-set (enum-set-universe enum-set-1))
+		 (enum-set-set (enum-set-universe enum-set-2)))
+	 (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2))))
+
+  (define (enum-set=? enum-set-1 enum-set-2)
+    (and (enum-set-subset? enum-set-1 enum-set-2)
+	 (enum-set-subset? enum-set-2 enum-set-1)))
+
+  (define (enum-set-union enum-set-1 enum-set-2)
+    (if (equal? (enum-set-universe enum-set-1) 
+                (enum-set-universe enum-set-2))
+	(make-enum-set (enum-set-universe enum-set-1)
+		       (lset-union eq? 
+				   (enum-set-set enum-set-1) 
+				   (enum-set-set enum-set-2)))
+	(raise (make-assertion-violation))))
+
+  (define (enum-set-intersection enum-set-1 enum-set-2)
+    (if (equal? (enum-set-universe enum-set-1) 
+                (enum-set-universe enum-set-2))
+	(make-enum-set (enum-set-universe enum-set-1)
+		       (lset-intersection eq? 
+					  (enum-set-set enum-set-1) 
+					  (enum-set-set enum-set-2)))
+	(raise (make-assertion-violation))))
+
+  (define (enum-set-difference enum-set-1 enum-set-2)
+    (if (equal? (enum-set-universe enum-set-1) 
+                (enum-set-universe enum-set-2))
+	(make-enum-set (enum-set-universe enum-set-1)
+		       (lset-difference eq? 
+					(enum-set-set enum-set-1) 
+					(enum-set-set enum-set-2)))
+	(raise (make-assertion-violation))))
+  
+  (define (enum-set-complement enum-set)
+    (let ((universe (enum-set-universe enum-set)))
+      (make-enum-set universe 
+		     (lset-difference 
+		      eq? (enum-set->list universe) (enum-set-set enum-set)))))
+
+  (define (enum-set-projection enum-set-1 enum-set-2)
+    (make-enum-set (enum-set-universe enum-set-2)
+		   (lset-intersection eq?
+				      (enum-set-set enum-set-1)
+				      (enum-set->list 
+				       (enum-set-universe enum-set-2)))))
+
+  (define-syntax define-enumeration
+    (syntax-rules ()
+      ((_ type-name (symbol ...) constructor-syntax)
+       (begin
+	 (define-syntax type-name
+	   (lambda (s) 
+	     (syntax-case s ()
+	       ((type-name sym)
+		(if (memq (syntax->datum #'sym) '(symbol ...))
+		    #'(quote sym)
+		    (syntax-violation (symbol->string 'type-name) 
+				      "not a member of the set"
+				      #f))))))
+	 (define-syntax constructor-syntax
+	   (lambda (s)
+	     (syntax-case s ()
+	       ((_ sym (... ...))
+		(let* ((universe '(symbol ...))
+		       (syms (syntax->datum #'(sym (... ...))))
+		       (quoted-universe 
+			(datum->syntax s (list 'quote universe)))
+		       (quoted-syms (datum->syntax s (list 'quote syms))))
+		  (or (every (lambda (x) (memq x universe)) syms)
+		      (syntax-violation (symbol->string 'constructor-syntax)
+					"not a subset of the universe"
+					#f))
+		  #`((enum-set-constructor (make-enumeration #,quoted-universe))
+		     #,quoted-syms))))))))))
+)
+;;; eval.scm --- The R6RS `eval' library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs eval (6))
+  (export eval environment)
+  (import (only (guile) eval 
+		        make-module 
+			module-uses
+			beautify-user-module! 
+			set-module-uses!)
+	  (rnrs base (6))
+	  (rnrs io simple (6))
+	  (rnrs lists (6)))
+
+  (define (environment . import-specs)
+    (let ((module (make-module))
+	  (needs-purify? (not (member '(guile) import-specs))))
+      (beautify-user-module! module)
+      (for-each (lambda (import-spec) (eval (list 'import import-spec) module))
+		import-specs)
+      (if needs-purify? (set-module-uses! module (cdr (module-uses module))))
+      module))
+)
+;;; exceptions.scm --- The R6RS exceptions library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs exceptions (6))
+  (export guard with-exception-handler raise raise-continuable)
+  (import (rnrs base (6))
+          (rnrs control (6))
+          (rnrs conditions (6))
+	  (rnrs records procedural (6))
+	  (rnrs records inspection (6))
+	  (only (guile)
+                format
+                newline
+                display
+                filter
+                acons
+                assv-ref
+                throw
+                set-exception-printer!
+                with-throw-handler
+                *unspecified*
+                @@))
+
+  ;; When a native guile exception is caught by an R6RS exception
+  ;; handler, we convert it to an R6RS compound condition that includes
+  ;; not only the standard condition objects expected by R6RS code, but
+  ;; also a special &guile condition that preserves the original KEY and
+  ;; ARGS passed to the native Guile catch handler.
+
+  (define-condition-type &guile &condition
+    make-guile-condition guile-condition?
+    (key  guile-condition-key)
+    (args guile-condition-args))
+
+  (define (default-guile-condition-converter key args)
+    (condition (make-serious-condition)
+               (guile-common-conditions key args)))
+
+  (define (guile-common-conditions key args)
+    (apply (case-lambda
+             ((subr msg margs . _)
+              (condition (make-who-condition subr)
+                         (make-message-condition msg)
+                         (make-irritants-condition margs)))
+             (_ (make-irritants-condition args)))
+           args))
+
+  (define (convert-guile-condition key args)
+    (let ((converter (assv-ref guile-condition-converters key)))
+      (condition (or (and converter (converter key args))
+                     (default-guile-condition-converter key args))
+                 ;; Preserve the original KEY and ARGS in the R6RS
+                 ;; condition object.
+                 (make-guile-condition key args))))
+
+  ;; If an R6RS exception handler chooses not to handle a given
+  ;; condition, it will re-raise the condition to pass it on to the next
+  ;; handler.  If the condition was converted from a native Guile
+  ;; exception, we must re-raise using the native Guile facilities and
+  ;; the original exception KEY and ARGS.  We arrange for this in
+  ;; 'raise' so that native Guile exception handlers will continue to
+  ;; work when mixed with R6RS code.
+
+  (define (raise obj)
+    (if (guile-condition? obj)
+        (apply throw (guile-condition-key obj) (guile-condition-args obj))
+        ((@@ (rnrs records procedural) r6rs-raise) obj)))
+  (define raise-continuable
+    (@@ (rnrs records procedural) r6rs-raise-continuable))
+
+  (define raise-object-wrapper? 
+    (@@ (rnrs records procedural) raise-object-wrapper?))
+  (define raise-object-wrapper-obj
+    (@@ (rnrs records procedural) raise-object-wrapper-obj))
+  (define raise-object-wrapper-continuation
+    (@@ (rnrs records procedural) raise-object-wrapper-continuation))
+
+  (define (with-exception-handler handler thunk)
+    (with-throw-handler #t
+     thunk
+     (lambda (key . args)
+       (cond ((not (eq? key 'r6rs:exception))
+              (let ((obj (convert-guile-condition key args)))
+                (handler obj)
+                (raise (make-non-continuable-violation))))
+             ((and (not (null? args))
+                   (raise-object-wrapper? (car args)))
+              (let* ((cargs (car args))
+                     (obj (raise-object-wrapper-obj cargs))
+                     (continuation (raise-object-wrapper-continuation cargs))
+                     (handler-return (handler obj)))
+                (if continuation
+                    (continuation handler-return)
+                    (raise (make-non-continuable-violation)))))))))
+
+  (define-syntax guard0
+    (syntax-rules ()
+      ((_ (variable cond-clause ...) . body)
+       (call/cc (lambda (continuation)
+		  (with-exception-handler
+		   (lambda (variable)
+		     (continuation (cond cond-clause ...)))
+		   (lambda () . body)))))))
+
+  (define-syntax guard
+    (syntax-rules (else)
+      ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
+       (guard0 (variable cond-clause ... (else else-clause ...)) . body))
+      ((_ (variable cond-clause ...) . body)
+       (guard0 (variable cond-clause ... (else (raise variable))) . body))))
+
+  ;;; Exception printing
+
+  (define (exception-printer port key args punt)
+    (cond ((and (= 1 (length args))
+                (raise-object-wrapper? (car args)))
+           (let ((obj (raise-object-wrapper-obj (car args))))
+             (cond ((condition? obj)
+                    (display "ERROR: R6RS exception:\n" port)
+                    (format-condition port obj))
+                   (else
+                    (format port "ERROR: R6RS exception: `~s'" obj)))))
+          (else
+           (punt))))
+
+  (define (format-condition port condition)
+    (let ((components (simple-conditions condition)))
+      (if (null? components)
+          (format port "Empty condition object")
+          (let loop ((i 1) (components components))
+            (cond ((pair? components)
+                   (format port "  ~a. " i)
+                   (format-simple-condition port (car components))
+                   (when (pair? (cdr components))
+                     (newline port))
+                   (loop (+ i 1) (cdr components))))))))
+
+  (define (format-simple-condition port condition)
+    (define (print-rtd-fields rtd field-names)
+      (let ((n-fields (vector-length field-names)))
+        (do ((i 0 (+ i 1)))
+            ((>= i n-fields))
+          (format port "      ~a: ~s"
+                  (vector-ref field-names i)
+                  ((record-accessor rtd i) condition))
+          (unless (= i (- n-fields 1))
+            (newline port)))))
+    (let ((condition-name (record-type-name (record-rtd condition))))
+      (let loop ((rtd (record-rtd condition))
+                 (rtd.fields-list '())
+                 (n-fields 0))
+        (cond (rtd
+               (let ((field-names (record-type-field-names rtd)))
+                 (loop (record-type-parent rtd)
+                       (cons (cons rtd field-names) rtd.fields-list)
+                       (+ n-fields (vector-length field-names)))))
+              (else
+               (let ((rtd.fields-list
+                      (filter (lambda (rtd.fields)
+                                (not (zero? (vector-length (cdr rtd.fields)))))
+                              (reverse rtd.fields-list))))
+                 (case n-fields
+                   ((0) (format port "~a" condition-name))
+                   ((1) (format port "~a: ~s"
+                                condition-name
+                                ((record-accessor (caar rtd.fields-list) 0)
+                                 condition)))
+                   (else
+                    (format port "~a:\n" condition-name)
+                    (let loop ((lst rtd.fields-list))
+                      (when (pair? lst)
+                        (let ((rtd.fields (car lst)))
+                          (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
+                          (when (pair? (cdr lst))
+                            (newline port))
+                          (loop (cdr lst)))))))))))))
+
+  (set-exception-printer! 'r6rs:exception exception-printer)
+
+  ;; Guile condition converters
+  ;;
+  ;; Each converter is a procedure (converter KEY ARGS) that returns
+  ;; either an R6RS condition or #f.  If #f is returned,
+  ;; 'default-guile-condition-converter' will be used.
+
+  (define (guile-syntax-violation-converter key args)
+    (apply (case-lambda
+             ((who what where form subform . extra)
+              (condition (make-syntax-violation form subform)
+                         (make-who-condition who)
+                         (make-message-condition what)))
+             (_ #f))
+           args))
+
+  (define (guile-lexical-violation-converter key args)
+    (condition (make-lexical-violation) (guile-common-conditions key args)))
+
+  (define (guile-assertion-violation-converter key args)
+    (condition (make-assertion-violation) (guile-common-conditions key args)))
+
+  (define (guile-undefined-violation-converter key args)
+    (condition (make-undefined-violation) (guile-common-conditions key args)))
+
+  (define (guile-implementation-restriction-converter key args)
+    (condition (make-implementation-restriction-violation)
+               (guile-common-conditions key args)))
+
+  (define (guile-error-converter key args)
+    (condition (make-error) (guile-common-conditions key args)))
+
+  (define (guile-system-error-converter key args)
+    (apply (case-lambda
+             ((subr msg msg-args errno . rest)
+              ;; XXX TODO we should return a more specific error
+              ;; (usually an I/O error) as expected by R6RS programs.
+              ;; Unfortunately this often requires the 'filename' (or
+              ;; other?) which is not currently provided by the native
+              ;; Guile exceptions.
+              (condition (make-error) (guile-common-conditions key args)))
+             (_ (guile-error-converter key args)))
+           args))
+
+  ;; TODO: Arrange to have the needed information included in native
+  ;;       Guile I/O exceptions, and arrange here to convert them to the
+  ;;       proper conditions.  Remove the earlier exception conversion
+  ;;       mechanism: search for 'with-throw-handler' in the 'rnrs'
+  ;;       tree, e.g. 'with-i/o-filename-conditions' and
+  ;;       'with-i/o-port-error' in (rnrs io ports).
+
+  ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
+  ;;           'signal' native Guile exceptions?
+
+  ;; XXX TODO: Should we handle the 'quit' exception specially?
+
+  ;; An alist mapping native Guile exception keys to converters.
+  (define guile-condition-converters
+    `((read-error                . ,guile-lexical-violation-converter)
+      (syntax-error              . ,guile-syntax-violation-converter)
+      (unbound-variable          . ,guile-undefined-violation-converter)
+      (wrong-number-of-args      . ,guile-assertion-violation-converter)
+      (wrong-type-arg            . ,guile-assertion-violation-converter)
+      (keyword-argument-error    . ,guile-assertion-violation-converter)
+      (out-of-range              . ,guile-assertion-violation-converter)
+      (regular-expression-syntax . ,guile-assertion-violation-converter)
+      (program-error             . ,guile-assertion-violation-converter)
+      (goops-error               . ,guile-assertion-violation-converter)
+      (null-pointer-error        . ,guile-assertion-violation-converter)
+      (system-error              . ,guile-system-error-converter)
+      (host-not-found            . ,guile-error-converter)
+      (getaddrinfo-error         . ,guile-error-converter)
+      (no-data                   . ,guile-error-converter)
+      (no-recovery               . ,guile-error-converter)
+      (try-again                 . ,guile-error-converter)
+      (stack-overflow            . ,guile-implementation-restriction-converter)
+      (numerical-overflow        . ,guile-implementation-restriction-converter)
+      (memory-allocation-error   . ,guile-implementation-restriction-converter)))
+
+  (define (set-guile-condition-converter! key proc)
+    (set! guile-condition-converters
+          (acons key proc guile-condition-converters))))
+;;; files.scm --- The R6RS file system library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs files (6))
+  (export file-exists? 
+	  delete-file
+
+	  &i/o make-i/o-error i/o-error?
+	  &i/o-read make-i/o-read-error i/o-read-error?
+	  &i/o-write make-i/o-write-error i/o-write-error?
+
+	  &i/o-invalid-position 
+	  make-i/o-invalid-position-error 
+	  i/o-invalid-position-error? 
+	  i/o-error-position
+	  
+	  &i/o-filename
+	  make-i/o-filename-error
+	  i/o-filename-error?
+	  i/o-error-filename
+	  
+	  &i/o-file-protection 
+	  make-i/o-file-protection-error
+	  i/o-file-protection-error?
+
+	  &i/o-file-is-read-only
+	  make-i/o-file-is-read-only-error
+	  i/o-file-is-read-only-error?
+
+	  &i/o-file-already-exists
+	  make-i/o-file-already-exists-error
+	  i/o-file-already-exists-error?
+
+	  &i/o-file-does-not-exist
+	  make-i/o-file-does-not-exist-error
+	  i/o-file-does-not-exist-error?
+
+	  &i/o-port
+	  make-i/o-port-error
+	  i/o-port-error?
+	  i/o-error-port)
+
+  (import (rename (only (guile) file-exists? delete-file catch @@) 
+		  (delete-file delete-file-internal))
+	  (rnrs base (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6)))
+
+  (define (delete-file filename)
+    (catch #t 
+	   (lambda () (delete-file-internal filename))
+	   (lambda (key . args) (raise (make-i/o-filename-error filename)))))
+
+  ;; Condition types that are used by (rnrs files), (rnrs io ports), and
+  ;; (rnrs io simple).  These are defined here so as to be easily shareable by
+  ;; these three libraries.
+  
+  (define-condition-type &i/o &error make-i/o-error i/o-error?)
+  (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
+  (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
+  (define-condition-type &i/o-invalid-position
+    &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
+    (position i/o-error-position))
+  (define-condition-type &i/o-filename 
+    &i/o make-i/o-filename-error i/o-filename-error?
+    (filename i/o-error-filename))
+  (define-condition-type &i/o-file-protection
+    &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
+  (define-condition-type &i/o-file-is-read-only
+    &i/o-file-protection make-i/o-file-is-read-only-error 
+    i/o-file-is-read-only-error?)
+  (define-condition-type &i/o-file-already-exists
+    &i/o-filename make-i/o-file-already-exists-error 
+    i/o-file-already-exists-error?)
+  (define-condition-type &i/o-file-does-not-exist
+    &i/o-filename make-i/o-file-does-not-exist-error
+    i/o-file-does-not-exist-error?)
+  (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
+    (port i/o-error-port))
+)
+;;; hashtables.scm --- The R6RS hashtables library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs hashtables (6))
+  (export make-eq-hashtable
+	  make-eqv-hashtable
+	  make-hashtable
+
+	  hashtable?
+	  hashtable-size
+	  hashtable-ref
+	  hashtable-set!
+	  hashtable-delete!
+	  hashtable-contains?
+	  hashtable-update!
+	  hashtable-copy
+	  hashtable-clear!
+	  hashtable-keys
+	  hashtable-entries
+	  
+	  hashtable-equivalence-function
+	  hashtable-hash-function
+	  hashtable-mutable?
+
+	  equal-hash
+	  string-hash
+	  string-ci-hash
+	  symbol-hash)
+  (import (rename (only (guile) string-hash-ci 
+                                string-hash 
+                                hashq 
+                                hashv
+                                modulo
+                                *unspecified*
+                                @@)
+		  (string-hash-ci string-ci-hash))
+	  (only (ice-9 optargs) define*)
+	  (rename (only (srfi 69) make-hash-table
+			           hash
+				   hash-by-identity
+			           hash-table-size
+				   hash-table-ref/default
+				   hash-table-set!
+				   hash-table-delete!
+				   hash-table-exists?
+				   hash-table-update!/default
+				   hash-table-copy
+				   hash-table-equivalence-function
+				   hash-table-hash-function
+				   hash-table-keys
+				   hash-table-fold)
+		  (hash equal-hash)
+		  (hash-by-identity symbol-hash))
+	  (rnrs base (6))
+	  (rnrs records procedural (6)))
+  
+  (define r6rs:hashtable 
+    (make-record-type-descriptor 
+     'r6rs:hashtable #f #f #t #t 
+     '#((mutable wrapped-table)
+	(immutable orig-hash-function)
+	(immutable mutable))))
+
+  (define hashtable? (record-predicate r6rs:hashtable))
+  (define make-r6rs-hashtable 
+    (record-constructor (make-record-constructor-descriptor 
+			 r6rs:hashtable #f #f)))
+  (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
+  (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
+  (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
+  (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+
+  (define hashtable-mutable? r6rs:hashtable-mutable?)
+
+  (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
+  (define (wrap-hash-function proc) 
+    (lambda (key capacity) (modulo (proc key) capacity)))
+
+  (define* (make-eq-hashtable #\optional k)
+    (make-r6rs-hashtable 
+     (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
+     symbol-hash
+     #t))
+
+  (define* (make-eqv-hashtable #\optional k)
+    (make-r6rs-hashtable 
+     (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
+     hash-by-value
+     #t))
+
+  (define* (make-hashtable hash-function equiv #\optional k)
+    (let ((wrapped-hash-function (wrap-hash-function hash-function)))
+      (make-r6rs-hashtable
+       (if k 
+	   (make-hash-table equiv wrapped-hash-function k)
+	   (make-hash-table equiv wrapped-hash-function))
+       hash-function
+       #t)))
+ 
+  (define (hashtable-size hashtable)
+    (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
+
+  (define (hashtable-ref hashtable key default)
+    (hash-table-ref/default 
+     (r6rs:hashtable-wrapped-table hashtable) key default))
+
+  (define (hashtable-set! hashtable key obj)
+    (if (r6rs:hashtable-mutable? hashtable)
+	(hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
+    *unspecified*)
+
+  (define (hashtable-delete! hashtable key)
+    (if (r6rs:hashtable-mutable? hashtable)
+	(hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
+    *unspecified*)
+
+  (define (hashtable-contains? hashtable key)
+    (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
+
+  (define (hashtable-update! hashtable key proc default)
+    (if (r6rs:hashtable-mutable? hashtable)
+	(hash-table-update!/default 
+	 (r6rs:hashtable-wrapped-table hashtable) key proc default))
+    *unspecified*)
+
+  (define* (hashtable-copy hashtable #\optional mutable)
+    (make-r6rs-hashtable 
+     (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
+     (r6rs:hashtable-orig-hash-function hashtable)
+     (and mutable #t)))
+
+  (define* (hashtable-clear! hashtable #\optional k)
+    (if (r6rs:hashtable-mutable? hashtable)
+	(let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+	       (equiv (hash-table-equivalence-function ht))
+	       (hash-function (r6rs:hashtable-orig-hash-function hashtable))
+	       (wrapped-hash-function (wrap-hash-function hash-function)))
+	  (r6rs:hashtable-set-wrapped-table!
+	   hashtable
+	   (if k 
+	       (make-hash-table equiv wrapped-hash-function k)
+	       (make-hash-table equiv wrapped-hash-function)))))
+    *unspecified*)
+
+  (define (hashtable-keys hashtable)
+    (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
+
+  (define (hashtable-entries hashtable)
+    (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+	   (size (hash-table-size ht))
+	   (keys (make-vector size))
+	   (vals (make-vector size)))
+      (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
+		       (lambda (k v i)
+			 (vector-set! keys i k)
+			 (vector-set! vals i v)
+			 (+ i 1))
+		       0)
+      (values keys vals)))
+
+  (define (hashtable-equivalence-function hashtable)
+    (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
+
+  (define (hashtable-hash-function hashtable)
+    (r6rs:hashtable-orig-hash-function hashtable)))
+;;;; ports.scm --- R6RS port API                    -*- coding: utf-8 -*-
+
+;;;;	Copyright (C) 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module.  In many areas
+;;; it complements or refines Guile's own historical port API.  For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(library (rnrs io ports (6))
+  (export eof-object eof-object?
+
+          ;; auxiliary types
+          file-options buffer-mode buffer-mode?
+          eol-style native-eol-style error-handling-mode
+          make-transcoder transcoder-codec transcoder-eol-style
+          transcoder-error-handling-mode native-transcoder
+          latin-1-codec utf-8-codec utf-16-codec
+           
+          ;; input & output ports
+          port? input-port? output-port?
+          port-eof?
+          port-transcoder binary-port? textual-port? transcoded-port
+          port-position set-port-position!
+          port-has-port-position? port-has-set-port-position!?
+          call-with-port close-port
+
+          ;; input ports
+          open-bytevector-input-port
+          open-string-input-port
+          open-file-input-port
+          make-custom-binary-input-port
+
+          ;; binary input
+          get-u8 lookahead-u8
+          get-bytevector-n get-bytevector-n!
+          get-bytevector-some get-bytevector-all
+
+          ;; output ports
+          open-bytevector-output-port
+          open-string-output-port
+          open-file-output-port
+          make-custom-binary-output-port
+          call-with-bytevector-output-port
+          call-with-string-output-port
+          make-custom-textual-output-port
+          flush-output-port
+
+          ;; input/output ports
+          open-file-input/output-port
+
+          ;; binary output
+          put-u8 put-bytevector
+
+          ;; textual input
+          get-char get-datum get-line get-string-all get-string-n get-string-n!
+          lookahead-char
+
+          ;; textual output
+          put-char put-datum put-string
+
+          ;; standard ports
+          standard-input-port standard-output-port standard-error-port
+          current-input-port current-output-port current-error-port
+
+          ;; condition types
+          &i/o i/o-error? make-i/o-error
+          &i/o-read i/o-read-error? make-i/o-read-error
+          &i/o-write i/o-write-error? make-i/o-write-error
+          &i/o-invalid-position i/o-invalid-position-error?
+          make-i/o-invalid-position-error
+          &i/o-filename i/o-filename-error? make-i/o-filename-error
+          i/o-error-filename
+          &i/o-file-protection i/o-file-protection-error?
+          make-i/o-file-protection-error
+          &i/o-file-is-read-only i/o-file-is-read-only-error?
+          make-i/o-file-is-read-only-error
+          &i/o-file-already-exists i/o-file-already-exists-error?
+          make-i/o-file-already-exists-error
+          &i/o-file-does-not-exist i/o-file-does-not-exist-error?
+          make-i/o-file-does-not-exist-error
+          &i/o-port i/o-port-error? make-i/o-port-error
+          i/o-error-port
+          &i/o-decoding-error i/o-decoding-error?
+          make-i/o-decoding-error
+          &i/o-encoding-error i/o-encoding-error?
+          make-i/o-encoding-error i/o-encoding-error-char)
+  (import (ice-9 binary-ports)
+          (only (rnrs base) assertion-violation)
+          (rnrs enums)
+          (rnrs records syntactic)
+          (rnrs exceptions)
+          (rnrs conditions)
+          (rnrs files) ;for the condition types
+          (srfi srfi-8)
+          (ice-9 rdelim)
+          (except (guile) raise display)
+          (prefix (only (guile) display)
+                  guile\:))
+
+
+
+;;;
+;;; Auxiliary types
+;;;
+
+(define-enumeration file-option
+  (no-create no-fail no-truncate)
+  file-options)
+
+(define-enumeration buffer-mode
+  (none line block)
+  buffer-modes)
+
+(define (buffer-mode? symbol)
+  (enum-set-member? symbol (enum-set-universe (buffer-modes))))
+
+(define-enumeration eol-style
+  (lf cr crlf nel crnel ls none)
+  eol-styles)
+
+(define (native-eol-style)
+  (eol-style none))
+
+(define-enumeration error-handling-mode
+  (ignore raise replace)
+  error-handling-modes)
+
+(define-record-type (transcoder %make-transcoder transcoder?)
+  (fields codec eol-style error-handling-mode))
+
+(define* (make-transcoder codec
+                          #\optional
+                          (eol-style (native-eol-style))
+                          (handling-mode (error-handling-mode replace)))
+  (%make-transcoder codec eol-style handling-mode))
+
+(define (native-transcoder)
+  (make-transcoder (or (fluid-ref %default-port-encoding)
+                       (latin-1-codec))))
+
+(define (latin-1-codec)
+  "ISO-8859-1")
+
+(define (utf-8-codec)
+  "UTF-8")
+
+(define (utf-16-codec)
+  "UTF-16")
+
+
+;;;
+;;; Internal helpers
+;;;
+
+(define (with-i/o-filename-conditions filename thunk)
+  (with-throw-handler 'system-error
+      thunk
+    (lambda args
+      (let ((errno (system-error-errno args)))
+        (let ((construct-condition
+               (cond ((= errno EACCES)
+                      make-i/o-file-protection-error)
+                     ((= errno EEXIST)
+                      make-i/o-file-already-exists-error)
+                     ((= errno ENOENT)
+                      make-i/o-file-does-not-exist-error)
+                     ((= errno EROFS)
+                      make-i/o-file-is-read-only-error)
+                     (else
+                      make-i/o-filename-error))))
+          (raise (construct-condition filename)))))))
+
+(define (with-i/o-port-error port make-primary-condition thunk)
+  (with-throw-handler 'system-error
+      thunk
+    (lambda args
+      (let ((errno (system-error-errno args)))
+        (if (memv errno (list EIO EFBIG ENOSPC EPIPE))
+            (raise (condition (make-primary-condition)
+                              (make-i/o-port-error port)))
+            (apply throw args))))))
+
+(define-syntax with-textual-output-conditions
+  (syntax-rules ()
+    ((_ port body0 body ...)
+     (with-i/o-port-error port make-i/o-write-error
+       (lambda () (with-i/o-encoding-error body0 body ...))))))
+
+(define-syntax with-textual-input-conditions
+  (syntax-rules ()
+    ((_ port body0 body ...)
+     (with-i/o-port-error port make-i/o-read-error
+       (lambda () (with-i/o-decoding-error body0 body ...))))))
+
+
+;;;
+;;; Input and output ports.
+;;;
+
+(define (port-transcoder port)
+  "Return the transcoder object associated with @var{port}, or @code{#f}
+if the port has no transcoder."
+  (cond ((port-encoding port)
+         => (lambda (encoding)
+              (make-transcoder
+               encoding
+               (native-eol-style)
+               (case (port-conversion-strategy port)
+                 ((error) 'raise)
+                 ((substitute) 'replace)
+                 (else
+                  (assertion-violation 'port-transcoder
+                                       "unsupported error handling mode"))))))
+        (else
+         #f)))
+
+(define (binary-port? port)
+  "Returns @code{#t} if @var{port} does not have an associated encoding,
+@code{#f} otherwise."
+  (not (port-encoding port)))
+
+(define (textual-port? port)
+  "Always returns @code{#t}, as all ports can be used for textual I/O in
+Guile."
+  #t)
+
+(define (port-eof? port)
+  (eof-object? (if (binary-port? port)
+                   (lookahead-u8 port)
+                   (lookahead-char port))))
+
+(define (transcoded-port port transcoder)
+  "Return a new textual port based on @var{port}, using
+@var{transcoder} to encode and decode data written to or
+read from its underlying binary port @var{port}."
+  ;; Hackily get at %make-transcoded-port.
+  (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port)))
+    (set-port-encoding! result (transcoder-codec transcoder))
+    (case (transcoder-error-handling-mode transcoder)
+      ((raise)
+       (set-port-conversion-strategy! result 'error))
+      ((replace)
+       (set-port-conversion-strategy! result 'substitute))
+      (else
+       (error "unsupported error handling mode"
+              (transcoder-error-handling-mode transcoder))))
+    result))
+
+(define (port-position port)
+  "Return the offset (an integer) indicating where the next octet will be
+read from/written to in @var{port}."
+
+  ;; FIXME: We should raise an `&assertion' error when not supported.
+  (seek port 0 SEEK_CUR))
+
+(define (set-port-position! port offset)
+  "Set the position where the next octet will be read from/written to
+@var{port}."
+
+  ;; FIXME: We should raise an `&assertion' error when not supported.
+  (seek port offset SEEK_SET))
+
+(define (port-has-port-position? port)
+  "Return @code{#t} is @var{port} supports @code{port-position}."
+  (and (false-if-exception (port-position port)) #t))
+
+(define (port-has-set-port-position!? port)
+  "Return @code{#t} is @var{port} supports @code{set-port-position!}."
+  (and (false-if-exception (set-port-position! port (port-position port)))
+       #t))
+
+(define (call-with-port port proc)
+  "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
+@var{proc}.  Return the return values of @var{proc}."
+  (call-with-values
+      (lambda () (proc port))
+    (lambda vals
+      (close-port port)
+      (apply values vals))))
+
+(define* (call-with-bytevector-output-port proc #\optional (transcoder #f))
+  (receive (port extract) (open-bytevector-output-port transcoder)
+    (call-with-port port proc)
+    (extract)))
+
+(define (open-string-input-port str)
+  "Open an input port that will read from @var{str}."
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (open-input-string str)))
+
+(define (r6rs-open filename mode buffer-mode transcoder)
+  (let ((port (with-i/o-filename-conditions filename
+                (lambda ()
+                  (with-fluids ((%default-port-encoding #f))
+                    (open filename mode))))))
+    (cond (transcoder
+           (set-port-encoding! port (transcoder-codec transcoder))))
+    port))
+
+(define (file-options->mode file-options base-mode)
+  (logior base-mode
+          (if (enum-set-member? 'no-create file-options)
+              0
+              O_CREAT)
+          (if (enum-set-member? 'no-truncate file-options)
+              0
+              O_TRUNC)
+          (if (enum-set-member? 'no-fail file-options)
+              0
+              O_EXCL)))
+
+(define* (open-file-input-port filename
+                               #\optional
+                               (file-options (file-options))
+                               (buffer-mode (buffer-mode block))
+                               transcoder)
+  "Return an input port for reading from @var{filename}."
+  (r6rs-open filename O_RDONLY buffer-mode transcoder))
+
+(define* (open-file-input/output-port filename
+                                      #\optional
+                                      (file-options (file-options))
+                                      (buffer-mode (buffer-mode block))
+                                      transcoder)
+  "Return a port for reading from and writing to @var{filename}."
+  (r6rs-open filename
+             (file-options->mode file-options O_RDWR)
+             buffer-mode
+             transcoder))
+
+(define (open-string-output-port)
+  "Return two values: an output port that will collect characters written to it
+as a string, and a thunk to retrieve the characters associated with that port."
+  (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
+                (open-output-string))))
+    (values port
+            (lambda ()
+              (let ((s (get-output-string port)))
+                (seek port 0 SEEK_SET)
+                (truncate-file port 0)
+                s)))))
+
+(define* (open-file-output-port filename
+                                #\optional
+                                (file-options (file-options))
+                                (buffer-mode (buffer-mode block))
+                                maybe-transcoder)
+  "Return an output port for writing to @var{filename}."
+  (r6rs-open filename
+             (file-options->mode file-options O_WRONLY)
+             buffer-mode
+             maybe-transcoder))
+
+(define (call-with-string-output-port proc)
+  "Call @var{proc}, passing it a string output port. When @var{proc} returns,
+return the characters accumulated in that port."
+  (let ((port (open-output-string)))
+    (proc port)
+    (get-output-string port)))
+
+(define (make-custom-textual-output-port id
+                                         write!
+                                         get-position
+                                         set-position!
+                                         close)
+  (make-soft-port (vector (lambda (c) (write! (string c) 0 1))
+                          (lambda (s) (write! s 0 (string-length s)))
+                          #f ;flush
+                          #f ;read character
+                          close)
+                  "w"))
+
+(define (flush-output-port port)
+  (force-output port))
+
+
+;;;
+;;; Textual output.
+;;;
+
+(define-condition-type &i/o-encoding &i/o-port
+  make-i/o-encoding-error i/o-encoding-error?
+  (char i/o-encoding-error-char))
+
+(define-syntax with-i/o-encoding-error
+  (syntax-rules ()
+    "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'."
+    ((_ body ...)
+     ;; XXX: This is heavyweight for small functions like `put-char'.
+     (with-throw-handler 'encoding-error
+       (lambda ()
+         (begin body ...))
+       (lambda (key subr message errno port chr)
+         (raise (make-i/o-encoding-error port chr)))))))
+
+(define (put-char port char)
+  (with-textual-output-conditions port (write-char char port)))
+
+(define (put-datum port datum)
+  (with-textual-output-conditions port (write datum port)))
+
+(define* (put-string port s #\optional start count)
+  (with-textual-output-conditions port
+   (cond ((not (string? s))
+          (assertion-violation 'put-string "expected string" s))
+         ((and start count)
+          (display (substring/shared s start (+ start count)) port))
+         (start
+          (display (substring/shared s start (string-length s)) port))
+         (else
+          (display s port)))))
+
+;; Defined here to be able to make use of `with-i/o-encoding-error', but
+;; not exported from here, but from `(rnrs io simple)'.
+(define* (display object #\optional (port (current-output-port)))
+  (with-textual-output-conditions port (guile:display object port)))
+
+
+;;;
+;;; Textual input.
+;;;
+
+(define-condition-type &i/o-decoding &i/o-port
+  make-i/o-decoding-error i/o-decoding-error?)
+
+(define-syntax with-i/o-decoding-error
+  (syntax-rules ()
+    "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'."
+    ((_ body ...)
+     ;; XXX: This is heavyweight for small functions like `get-char' and
+     ;; `lookahead-char'.
+     (with-throw-handler 'decoding-error
+       (lambda ()
+         (begin body ...))
+       (lambda (key subr message errno port)
+         (raise (make-i/o-decoding-error port)))))))
+
+(define (get-char port)
+  (with-textual-input-conditions port (read-char port)))
+
+(define (get-datum port)
+  (with-textual-input-conditions port (read port)))
+
+(define (get-line port)
+  (with-textual-input-conditions port (read-line port 'trim)))
+
+(define (get-string-all port)
+  (with-textual-input-conditions 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)))))
+
+(define (lookahead-char port)
+  (with-textual-input-conditions port (peek-char port)))
+
+
+;;;
+;;; Standard ports.
+;;;
+
+(define (standard-input-port)
+  (with-fluids ((%default-port-encoding #f))
+    (dup->inport 0)))
+
+(define (standard-output-port)
+  (with-fluids ((%default-port-encoding #f))
+    (dup->outport 1)))
+
+(define (standard-error-port)
+  (with-fluids ((%default-port-encoding #f))
+    (dup->outport 2)))
+
+)
+
+;;; ports.scm ends here
+;;; simple.scm --- The R6RS simple I/O library
+
+;;      Copyright (C) 2010, 2011, 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
+
+
+(library (rnrs io simple (6))
+  (export eof-object 
+          eof-object?
+
+	  call-with-input-file
+	  call-with-output-file
+	  
+	  input-port?
+	  output-port?
+
+	  current-input-port
+	  current-output-port
+	  current-error-port
+
+	  with-input-from-file
+	  with-output-to-file
+
+	  open-input-file
+	  open-output-file
+
+	  close-input-port
+	  close-output-port
+
+	  read-char
+	  peek-char
+	  read
+	  write-char
+	  newline
+	  display
+	  write
+
+	  &i/o make-i/o-error i/o-error?
+	  &i/o-read make-i/o-read-error i/o-read-error?
+	  &i/o-write make-i/o-write-error i/o-write-error?
+
+	  &i/o-invalid-position 
+	  make-i/o-invalid-position-error 
+	  i/o-invalid-position-error? 
+	  i/o-error-position
+	  
+	  &i/o-filename
+	  make-i/o-filename-error
+	  i/o-filename-error?
+	  i/o-error-filename
+	  
+	  &i/o-file-protection 
+	  make-i/o-file-protection-error
+	  i/o-file-protection-error?
+
+	  &i/o-file-is-read-only
+	  make-i/o-file-is-read-only-error
+	  i/o-file-is-read-only-error?
+
+	  &i/o-file-already-exists
+	  make-i/o-file-already-exists-error
+	  i/o-file-already-exists-error?
+
+	  &i/o-file-does-not-exist
+	  make-i/o-file-does-not-exist-error
+	  i/o-file-does-not-exist-error?
+
+	  &i/o-port
+	  make-i/o-port-error
+	  i/o-port-error?
+	  i/o-error-port)	  
+
+  (import (only (rnrs io ports)
+                call-with-port
+                close-port
+                open-file-input-port
+                open-file-output-port
+                eof-object 
+                eof-object?
+                file-options
+                buffer-mode
+                native-transcoder
+                get-char
+                lookahead-char
+                get-datum
+                put-char
+                put-datum
+
+                input-port? 
+                output-port?)
+          (only (guile)
+                @@
+                current-input-port
+                current-output-port
+                current-error-port
+
+                define*
+
+                with-input-from-port
+                with-output-to-port)
+	  (rnrs base (6))
+          (rnrs files (6)) ;for the condition types
+          )
+
+  (define display (@@ (rnrs io ports) display))
+
+  (define (call-with-input-file filename proc)
+    (call-with-port (open-file-input-port filename) proc))
+
+  (define (call-with-output-file filename proc)
+    (call-with-port (open-file-output-port filename) proc))
+
+  (define (with-input-from-file filename thunk)
+    (call-with-input-file filename
+      (lambda (port) (with-input-from-port port thunk))))
+
+  (define (with-output-to-file filename thunk)
+    (call-with-output-file filename
+      (lambda (port) (with-output-to-port port thunk))))
+
+  (define (open-input-file filename)
+    (open-file-input-port filename
+                          (file-options)
+                          (buffer-mode block)
+                          (native-transcoder)))
+
+  (define (open-output-file filename)
+    (open-file-output-port filename
+                           (file-options)
+                           (buffer-mode block)
+                           (native-transcoder)))
+
+  (define close-input-port close-port)
+  (define close-output-port close-port)
+
+  (define* (read-char #\optional (port (current-input-port)))
+    (get-char port))
+
+  (define* (peek-char #\optional (port (current-input-port)))
+    (lookahead-char port))
+
+  (define* (read #\optional (port (current-input-port)))
+    (get-datum port))
+
+  (define* (write-char char #\optional (port (current-output-port)))
+    (put-char port char))
+
+  (define* (newline #\optional (port (current-output-port)))
+    (put-char port #\newline))
+
+  (define* (write object #\optional (port (current-output-port)))
+    (put-datum port object))
+
+  )
+;;; lists.scm --- The R6RS list utilities library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs lists (6))
+  (export find for-all exists filter partition fold-left fold-right remp remove 
+	  remv remq memp member memv memq assp assoc assv assq cons*)
+  (import (rnrs base (6))
+          (only (guile) filter member memv memq assoc assv assq cons*)
+	  (rename (only (srfi srfi-1) any 
+				      every 
+				      remove 
+				      member 
+				      assoc 
+				      find 
+				      partition
+				      fold-right 
+				      filter-map)
+		  (any exists) 
+		  (every for-all)
+		  (remove remp)
+		  
+		  (member memp-internal)
+		  (assoc assp-internal)))
+
+  (define (fold-left combine nil list . lists)
+    (define (fold nil lists)
+      (if (exists null? lists)
+          nil
+          (fold (apply combine nil (map car lists))
+                (map cdr lists))))
+    (fold nil (cons list lists)))
+
+  (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
+  (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
+  (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
+
+  (define (memp pred list) (memp-internal #f list (lambda (x y) (pred y))))
+  (define (assp pred list) (assp-internal #f list (lambda (x y) (pred y))))
+)
+;;; mutable-pairs.scm --- The R6RS mutable pair library
+
+;;      Copyright (C) 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
+
+
+
+(library (rnrs mutable-pairs (6))
+  (export set-car! set-cdr!)
+  (import (only (guile) set-car! set-cdr!)))
+;;; mutable-strings.scm --- The R6RS mutable string library
+
+;;      Copyright (C) 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
+
+
+
+(library (rnrs mutable-strings (6))
+  (export string-set! string-fill!)
+  (import (only (guile) string-set! string-fill!)))
+;;; programs.scm --- The R6RS process management library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs programs (6))
+  (export command-line exit)
+  (import (only (guile) command-line exit)))
+;;; r5rs.scm --- The R6RS / R5RS compatibility library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs r5rs (6))
+  (export exact->inexact inexact->exact 
+
+	  quotient remainder modulo 
+
+	  delay force 
+
+	  null-environment scheme-report-environment)
+  (import (only (guile) exact->inexact inexact->exact
+			
+			quotient remainder modulo
+			
+			delay force)
+          (only (ice-9 r5rs) scheme-report-environment)
+          (only (ice-9 safe-r5rs) null-environment)))
+;;; inspection.scm --- Inspection support for R6RS records
+
+;;      Copyright (C) 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
+
+
+(library (rnrs records inspection (6))
+  (export record? 
+          record-rtd 
+	  record-type-name 
+	  record-type-parent 
+	  record-type-uid 
+	  record-type-generative? 
+	  record-type-sealed? 
+	  record-type-opaque? 
+	  record-type-field-names 
+	  record-field-mutable?)
+  (import (rnrs arithmetic bitwise (6))
+          (rnrs base (6))
+	  (rnrs records procedural (6))
+	  (only (guile) struct-ref struct-vtable vtable-index-layout @@))
+
+  (define record-internal? (@@ (rnrs records procedural) record-internal?))
+
+  (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
+  (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
+  (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
+  (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
+  (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
+  (define rtd-index-field-names 
+    (@@ (rnrs records procedural) rtd-index-field-names))
+  (define rtd-index-field-bit-field
+    (@@ (rnrs records procedural) rtd-index-field-bit-field))
+
+  (define (record? obj)
+    (and (record-internal? obj)
+	 (not (record-type-opaque? (struct-vtable obj)))))
+
+  (define (record-rtd record)
+    (or (and (record-internal? record)
+	     (let ((rtd (struct-vtable record)))
+	       (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
+	(assertion-violation 'record-rtd "not a record" record)))
+
+  (define (guarantee-rtd who rtd)
+    (if (record-type-descriptor? rtd)
+        rtd
+        (assertion-violation who "not a record type descriptor" rtd)))
+
+  (define (record-type-name rtd) 
+    (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
+  (define (record-type-parent rtd) 
+    (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+  (define (record-type-uid rtd)
+    (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
+  (define (record-type-generative? rtd) 
+    (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
+  (define (record-type-sealed? rtd) 
+    (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
+  (define (record-type-opaque? rtd) 
+    (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
+  (define (record-type-field-names rtd)
+    (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
+  (define (record-field-mutable? rtd k)
+    (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+                                  rtd-index-field-bit-field)
+                      k))
+)
+;;; procedural.scm --- Procedural interface to R6RS records
+
+;;      Copyright (C) 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
+
+
+(library (rnrs records procedural (6))
+  (export make-record-type-descriptor 
+	  record-type-descriptor?
+	  make-record-constructor-descriptor
+	  
+	  record-constructor
+	  record-predicate
+	  record-accessor	  
+	  record-mutator)
+	  
+  (import (rnrs base (6))
+          (only (guile) cons*
+                        logand 
+                        logior
+                        ash
+
+                        and=>
+			throw
+			display
+		        make-struct 
+			make-vtable 
+			map
+			simple-format
+			string-append 
+                        symbol-append
+			
+			struct? 
+                        struct-layout
+			struct-ref 
+			struct-set! 
+			struct-vtable
+			vtable-index-layout
+
+                        make-hash-table
+			hashq-ref
+			hashq-set!
+
+			vector->list)
+	  (ice-9 receive)
+	  (only (srfi 1) fold split-at take))
+
+  (define (record-internal? obj)
+    (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
+
+  (define rtd-index-name 8)
+  (define rtd-index-uid 9)
+  (define rtd-index-parent 10)
+  (define rtd-index-sealed? 11)
+  (define rtd-index-opaque? 12)
+  (define rtd-index-predicate 13)
+  (define rtd-index-field-names 14)
+  (define rtd-index-field-bit-field 15)
+  (define rtd-index-field-binder 16)
+
+  (define rctd-index-rtd 0)
+  (define rctd-index-parent 1)
+  (define rctd-index-protocol 2)
+
+  (define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
+
+  (define record-type-vtable 
+    (make-vtable (string-append vtable-base-layout "prprprprprprprprprpr")
+		 (lambda (obj port) 
+		   (simple-format port "#<r6rs:record-type:~A>"
+				  (struct-ref obj rtd-index-name)))))
+
+  (define record-constructor-vtable 
+    (make-vtable "prprpr"
+		 (lambda (obj port) 
+		   (simple-format port "#<r6rs:record-constructor:~A>" 
+				  (struct-ref (struct-ref obj rctd-index-rtd)
+					      rtd-index-name)))))
+
+  (define uid-table (make-hash-table))    
+
+  (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+    (define fields-pair
+      (let loop ((field-list (vector->list fields))
+                 (layout-sym 'pr)
+                 (layout-bit-field 0)
+                 (counter 0))
+        (if (null? field-list)
+            (cons layout-sym layout-bit-field)
+            (case (caar field-list)
+              ((immutable) 
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pr) 
+                     layout-bit-field 
+                     (+ counter 1)))
+              ((mutable)
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pw)
+                     (logior layout-bit-field (ash 1 counter))
+                     (+ counter 1)))
+              (else (r6rs-raise (make-assertion-violation)))))))
+
+    (define fields-layout (car fields-pair))
+    (define fields-bit-field (cdr fields-pair))
+
+    (define field-names (list->vector (map cadr (vector->list fields))))
+    (define late-rtd #f)
+
+    (define (private-record-predicate obj)       
+      (and (record-internal? obj)
+           (or (eq? (struct-vtable obj) late-rtd)
+               (and=> (struct-ref obj 0) private-record-predicate))))
+
+    (define (field-binder parent-struct . args)
+      (apply make-struct (cons* late-rtd 0 parent-struct args)))
+
+    (if (and parent (struct-ref parent rtd-index-sealed?))
+	(r6rs-raise (make-assertion-violation)))
+
+    (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
+	  (opaque? (or opaque? (and parent (struct-ref 
+					    parent rtd-index-opaque?)))))
+      (if matching-rtd
+	  (if (equal? (list name 
+			    parent 
+			    sealed? 
+			    opaque?                            
+			    field-names
+                            fields-bit-field)
+		      (list (struct-ref matching-rtd rtd-index-name)
+			    (struct-ref matching-rtd rtd-index-parent)
+			    (struct-ref matching-rtd rtd-index-sealed?)
+			    (struct-ref matching-rtd rtd-index-opaque?)
+			    (struct-ref matching-rtd rtd-index-field-names)
+                            (struct-ref matching-rtd 
+                                        rtd-index-field-bit-field)))
+	      matching-rtd
+	      (r6rs-raise (make-assertion-violation)))
+          
+	  (let ((rtd (make-struct record-type-vtable 0
+
+                                  fields-layout
+                                  (lambda (obj port)
+                                    (simple-format 
+                                     port "#<r6rs:record:~A>" name))
+				  
+				  name
+				  uid
+				  parent 
+				  sealed? 
+				  opaque?
+				  
+				  private-record-predicate
+				  field-names
+                                  fields-bit-field
+				  field-binder)))
+	    (set! late-rtd rtd)
+	    (if uid (hashq-set! uid-table uid rtd))
+	    rtd))))
+
+  (define (record-type-descriptor? obj)
+    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
+
+  (define (make-record-constructor-descriptor rtd 
+					      parent-constructor-descriptor
+					      protocol)
+    (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
+    (define (default-inherited-protocol n)
+      (lambda args
+	(receive 
+          (n-args p-args) 
+	  (split-at args (- (length args) rtd-arity))
+	  (let ((p (apply n n-args)))
+	    (apply p p-args)))))
+    (define (default-protocol p) p)
+    
+    (let* ((prtd (struct-ref rtd rtd-index-parent))
+	   (pcd (or parent-constructor-descriptor
+		    (and=> prtd (lambda (d) (make-record-constructor-descriptor 
+					     prtd #f #f)))))
+	   (prot (or protocol (if pcd 
+				  default-inherited-protocol 
+				  default-protocol))))
+      (make-struct record-constructor-vtable 0 rtd pcd prot)))
+
+  (define (record-constructor rctd)
+    (let* ((rtd (struct-ref rctd rctd-index-rtd))
+	   (parent-rctd (struct-ref rctd rctd-index-parent))
+	   (protocol (struct-ref rctd rctd-index-protocol)))
+      (protocol 
+       (if parent-rctd
+	   (let ((parent-record-constructor (record-constructor parent-rctd))
+		 (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
+	     (lambda args
+	       (let ((struct (apply parent-record-constructor args)))
+		 (lambda args
+		   (apply (struct-ref rtd rtd-index-field-binder)
+			  (cons struct args))))))
+	   (lambda args (apply (struct-ref rtd rtd-index-field-binder)
+			       (cons #f args)))))))
+		    
+  (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
+
+  (define (record-accessor rtd k)
+    (define (record-accessor-inner obj)
+      (if (eq? (struct-vtable obj) rtd)
+	  (struct-ref obj (+ k 1))
+          (and=> (struct-ref obj 0) record-accessor-inner)))
+    (lambda (obj) 
+      (if (not (record-internal? obj))
+          (r6rs-raise (make-assertion-violation)))
+      (record-accessor-inner obj)))
+
+  (define (record-mutator rtd k)
+    (define (record-mutator-inner obj val)
+      (and obj (or (and (eq? (struct-vtable obj) rtd)
+                        (struct-set! obj (+ k 1) val))
+                   (record-mutator-inner (struct-ref obj 0) val))))
+    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
+      (if (zero? (logand bit-field (ash 1 k)))
+	  (r6rs-raise (make-assertion-violation))))
+    (lambda (obj val) (record-mutator-inner obj val)))
+
+  ;; Condition types that are used in the current library.  These are defined
+  ;; here and not in (rnrs conditions) to avoid a circular dependency.
+
+  (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
+  (define &condition-constructor-descriptor 
+    (make-record-constructor-descriptor &condition #f #f))
+
+  (define &serious (make-record-type-descriptor 
+		    '&serious &condition #f #f #f '#()))
+  (define &serious-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &serious &condition-constructor-descriptor #f))
+
+  (define make-serious-condition 
+    (record-constructor &serious-constructor-descriptor))
+
+  (define &violation (make-record-type-descriptor
+		      '&violation &serious #f #f #f '#()))
+  (define &violation-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &violation &serious-constructor-descriptor #f))
+  (define make-violation (record-constructor &violation-constructor-descriptor))
+
+  (define &assertion (make-record-type-descriptor
+		      '&assertion &violation #f #f #f '#()))
+  (define make-assertion-violation 
+    (record-constructor 
+     (make-record-constructor-descriptor
+      &assertion &violation-constructor-descriptor #f)))
+
+  ;; Exception wrapper type, along with a wrapping `throw' implementation.
+  ;; These are used in the current library, and so they are defined here and not
+  ;; in (rnrs exceptions) to avoid a circular dependency.
+
+  (define &raise-object-wrapper
+    (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
+				 '#((immutable obj) (immutable continuation))))
+  (define make-raise-object-wrapper 
+    (record-constructor (make-record-constructor-descriptor 
+			 &raise-object-wrapper #f #f)))
+  (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
+  (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
+  (define raise-object-wrapper-continuation 
+    (record-accessor &raise-object-wrapper 1))
+
+  (define (r6rs-raise obj) 
+    (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
+  (define (r6rs-raise-continuable obj)
+    (define (r6rs-raise-continuable-internal continuation)
+      (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
+    (call/cc r6rs-raise-continuable-internal))
+)
+;;; syntactic.scm --- Syntactic support for R6RS records
+
+;;      Copyright (C) 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
+
+
+(library (rnrs records syntactic (6))
+  (export define-record-type 
+	  record-type-descriptor 
+	  record-constructor-descriptor)
+  (import (only (guile) and=> gensym)
+          (rnrs base (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6))
+	  (rnrs hashtables (6))
+	  (rnrs lists (6))
+	  (rnrs records procedural (6))
+	  (rnrs syntax-case (6))
+	  (only (srfi 1) take))
+
+  (define record-type-registry (make-eq-hashtable))
+
+  (define (guess-constructor-name record-name)
+    (string->symbol (string-append "make-" (symbol->string record-name))))
+  (define (guess-predicate-name record-name)
+    (string->symbol (string-append (symbol->string record-name) "?")))
+  (define (register-record-type name rtd rcd)
+    (hashtable-set! record-type-registry name (cons rtd rcd)))
+  (define (lookup-record-type-descriptor name)
+    (and=> (hashtable-ref record-type-registry name #f) car))
+  (define (lookup-record-constructor-descriptor name)
+    (and=> (hashtable-ref record-type-registry name #f) cdr))
+  
+  (define-syntax define-record-type
+    (lambda (stx)
+      (syntax-case stx ()
+	((_ (record-name constructor-name predicate-name) record-clause ...)
+	 #'(define-record-type0 
+	     (record-name constructor-name predicate-name)
+	     record-clause ...))
+	((_ record-name record-clause ...)
+	 (let* ((record-name-sym (syntax->datum #'record-name))
+		(constructor-name 
+		 (datum->syntax 
+		  #'record-name (guess-constructor-name record-name-sym)))
+		(predicate-name 
+		 (datum->syntax 
+		  #'record-name (guess-predicate-name record-name-sym))))
+	   #`(define-record-type0 
+	       (record-name #,constructor-name #,predicate-name) 
+	       record-clause ...))))))
+
+  (define (sequence n)
+    (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
+    (reverse (seq-inner n)))
+  (define (number-fields fields)
+    (define (number-fields-inner fields counter)
+      (if (null? fields)
+	  '()
+	  (cons (cons fields counter) 
+		(number-fields-inner (cdr fields) (+ counter 1)))))
+    (number-fields-inner fields 0))
+  
+  (define (process-fields record-name fields)
+    (define (wrap x) (datum->syntax record-name x))
+    (define (id->string x)
+      (symbol->string (syntax->datum x)))
+    (define record-name-str (id->string record-name))
+    (define (guess-accessor-name field-name)
+      (wrap
+       (string->symbol (string-append
+                        record-name-str "-" (id->string field-name)))))
+    (define (guess-mutator-name field-name)
+      (wrap
+       (string->symbol
+        (string-append
+         record-name-str "-" (id->string field-name) "-set!"))))
+    (define (f x)
+      (syntax-case x (immutable mutable)
+        [(immutable name)
+         (list (wrap `(immutable ,(syntax->datum #'name)))
+               (guess-accessor-name #'name)
+               #f)]
+        [(immutable name accessor)
+         (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
+        [(mutable name)
+         (list (wrap `(mutable ,(syntax->datum #'name)))
+               (guess-accessor-name #'name)
+               (guess-mutator-name #'name))]
+        [(mutable name accessor mutator)
+         (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
+        [name
+         (identifier? #'name)
+         (list (wrap `(immutable ,(syntax->datum #'name)))
+               (guess-accessor-name #'name)
+               #f)]
+        [else
+         (syntax-violation 'define-record-type "invalid field specifier" x)]))
+    (map f fields))
+  
+  (define-syntax define-record-type0
+    (lambda (stx)	  
+      (define *unspecified* (cons #f #f))
+      (define (unspecified? obj)
+        (eq? *unspecified* obj))
+      (syntax-case stx ()
+        ((_ (record-name constructor-name predicate-name) record-clause ...)
+         (let loop ((_fields *unspecified*)
+                    (_parent *unspecified*)
+                    (_protocol *unspecified*)
+                    (_sealed *unspecified*)
+                    (_opaque *unspecified*)
+                    (_nongenerative *unspecified*)
+                    (_constructor *unspecified*)
+                    (_parent-rtd *unspecified*)
+                    (record-clauses #'(record-clause ...)))
+           (syntax-case record-clauses
+               (fields parent protocol sealed opaque nongenerative
+                       constructor parent-rtd)
+             [()
+              (let* ((fields (if (unspecified? _fields) '() _fields))
+                     (field-names (list->vector (map car fields)))
+                     (field-accessors
+                      (fold-left (lambda (lst x c)
+                                   (cons #`(define #,(cadr x)
+                                             (record-accessor record-name #,c))
+                                         lst))
+                                 '() fields (sequence (length fields))))
+                     (field-mutators
+                      (fold-left (lambda (lst x c)
+                                   (if (caddr x)
+                                       (cons #`(define #,(caddr x)
+                                                 (record-mutator record-name
+                                                                 #,c))
+                                             lst)
+                                       lst))
+                                 '() fields (sequence (length fields))))
+                     (parent-cd (cond ((not (unspecified? _parent))
+                                       #`(record-constructor-descriptor
+                                          #,_parent))
+                                      ((not (unspecified? _parent-rtd))
+                                       (cadr _parent-rtd))
+                                      (else #f)))
+                     (parent-rtd (cond ((not (unspecified? _parent))
+                                        #`(record-type-descriptor #,_parent))
+                                       ((not (unspecified? _parent-rtd))
+                                        (car _parent-rtd))
+                                       (else #f)))
+                     (protocol (if (unspecified? _protocol) #f _protocol))
+                     (uid (if (unspecified? _nongenerative) #f _nongenerative))
+                     (sealed? (if (unspecified? _sealed) #f _sealed))
+                     (opaque? (if (unspecified? _opaque) #f _opaque)))
+                #`(begin
+                    (define record-name
+                      (make-record-type-descriptor
+                       (quote record-name)
+                       #,parent-rtd #,uid #,sealed? #,opaque?
+                       #,field-names))
+                    (define constructor-name
+                      (record-constructor
+                       (make-record-constructor-descriptor
+                        record-name #,parent-cd #,protocol)))
+                    (define dummy
+                      (let ()
+                        (register-record-type 
+                         (quote record-name)
+                         record-name (make-record-constructor-descriptor 
+                                      record-name #,parent-cd #,protocol))
+                        'dummy))
+                    (define predicate-name (record-predicate record-name))
+                    #,@field-accessors
+                    #,@field-mutators))]
+             [((fields record-fields ...) . rest)
+              (if (unspecified? _fields)
+                  (loop (process-fields #'record-name #'(record-fields ...))
+                        _parent _protocol _sealed _opaque _nongenerative
+                        _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((parent parent-name) . rest)
+              (if (not (unspecified? _parent-rtd))
+                  (raise (make-assertion-violation))
+                  (if (unspecified? _parent)
+                      (loop _fields #'parent-name _protocol _sealed _opaque
+                            _nongenerative _constructor _parent-rtd #'rest)
+                      (raise (make-assertion-violation))))]
+             [((protocol expression) . rest)
+              (if (unspecified? _protocol)
+                  (loop _fields _parent #'expression _sealed _opaque
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((sealed sealed?) . rest)
+              (if (unspecified? _sealed)
+                  (loop _fields _parent _protocol #'sealed? _opaque
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((opaque opaque?) . rest)
+              (if (unspecified? _opaque)
+                  (loop _fields _parent _protocol _sealed #'opaque?
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((nongenerative) . rest)
+              (if (unspecified? _nongenerative)
+                  (loop _fields _parent _protocol _sealed _opaque
+                        #`(quote #,(datum->syntax #'record-name (gensym)))
+                        _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((nongenerative uid) . rest)
+              (if (unspecified? _nongenerative)
+                  (loop _fields _parent _protocol _sealed
+                        _opaque #''uid _constructor
+                        _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((parent-rtd rtd cd) . rest)
+              (if (not (unspecified? _parent))
+                  (raise (make-assertion-violation))
+                  (if (unspecified? _parent-rtd)
+                      (loop _fields _parent _protocol _sealed _opaque
+                            _nongenerative _constructor #'(rtd cd)
+                            #'rest)
+                      (raise (make-assertion-violation))))]))))))
+
+  (define-syntax record-type-descriptor
+    (lambda (stx)
+      (syntax-case stx ()
+	((_ name) #`(lookup-record-type-descriptor 
+		     #,(datum->syntax 
+			stx (list 'quote (syntax->datum #'name))))))))
+
+  (define-syntax record-constructor-descriptor
+    (lambda (stx)
+      (syntax-case stx ()
+	((_ name) #`(lookup-record-constructor-descriptor 
+		     #,(datum->syntax 
+			stx (list 'quote (syntax->datum #'name))))))))
+)
+;;; sorting.scm --- The R6RS sorting library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs sorting (6))
+  (export list-sort vector-sort vector-sort!)
+  (import (rnrs base (6))
+          (only (guile) *unspecified* stable-sort sort!))
+
+  (define (list-sort proc list) (stable-sort list proc))
+  (define (vector-sort proc vector) (stable-sort vector proc))
+  (define (vector-sort! proc vector) (sort! vector proc) *unspecified*))
+;;; syntax-case.scm --- R6RS support for `syntax-case' macros
+
+;;      Copyright (C) 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
+
+
+(library (rnrs syntax-case (6))
+  (export make-variable-transformer
+	  syntax-case
+	  syntax
+	  
+	  identifier?
+	  bound-identifier=?
+	  free-identifier=?
+
+	  syntax->datum
+	  datum->syntax
+	  generate-temporaries
+	  with-syntax
+
+	  quasisyntax
+	  unsyntax
+	  unsyntax-splicing
+
+	  syntax-violation)
+  (import (only (guile) make-variable-transformer
+		        syntax-case
+		        syntax
+		        
+		        identifier?
+			bound-identifier=?
+			free-identifier=?
+			
+			syntax->datum
+			datum->syntax
+			generate-temporaries
+			with-syntax
+
+			quasisyntax
+			unsyntax
+			unsyntax-splicing)
+	  (ice-9 optargs)
+	  (rnrs base (6))
+	  (rnrs conditions (6))
+	  (rnrs exceptions (6))
+	  (rnrs records procedural (6)))
+
+  (define* (syntax-violation who message form #\optional subform)
+    (let* ((conditions (list (make-message-condition message)
+			     (make-syntax-violation form subform)))
+	   (conditions (if who
+			   (cons (make-who-condition who) conditions)
+			   conditions)))
+      (raise (apply condition conditions))))
+)
+;;; unicode.scm --- The R6RS Unicode library
+
+;;      Copyright (C) 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
+
+
+(library (rnrs unicode (6))
+  (export char-upcase
+	  char-downcase
+	  char-titlecase
+	  char-foldcase
+	  
+	  char-ci=?
+	  char-ci<?
+	  char-ci>?
+	  char-ci<=?
+	  char-ci>=?
+	   
+	  char-alphabetic?
+	  char-numeric?
+	  char-whitespace?
+	  char-upper-case?
+	  char-lower-case?
+	  char-title-case?
+	  
+	  char-general-category
+	  
+	  string-upcase
+	  string-downcase
+	  string-titlecase
+	  string-foldcase
+	  
+	  string-ci=?
+	  string-ci<?
+	  string-ci>?
+	  string-ci<=?
+	  string-ci>=?
+	  
+	  string-normalize-nfd
+	  string-normalize-nfkd
+	  string-normalize-nfc
+	  string-normalize-nfkc)
+  (import (only (guile) char-upcase
+		        char-downcase
+			char-titlecase
+
+			char-ci=?
+			char-ci<?
+			char-ci>?
+			char-ci<=?
+			char-ci>=?
+
+			char-alphabetic?
+			char-numeric?
+			char-whitespace?
+			char-upper-case?
+			char-lower-case?
+
+			char-set-contains?
+			char-set:title-case
+
+			char-general-category
+
+			char-upcase
+			char-downcase
+			char-titlecase
+
+			string-upcase
+			string-downcase
+			string-titlecase
+	  
+			string-ci=?
+			string-ci<?
+			string-ci>?
+			string-ci<=?
+			string-ci>=?
+	  
+			string-normalize-nfd
+			string-normalize-nfkd
+			string-normalize-nfc
+			string-normalize-nfkc)
+	  (rnrs base (6)))
+
+  (define (char-foldcase char)
+    (if (or (eqv? char #\460) (eqv? char #\461))
+	char (char-downcase (char-upcase char))))
+
+  (define (char-title-case? char) (char-set-contains? char-set:title-case char))
+
+  (define (string-foldcase str) (string-downcase (string-upcase str)))
+)
+;;; api-diff --- diff guile-api.alist files
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
+;;
+;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
+;; and display a (count) summary of the groups defined therein.
+;; Optional arg "--details" (or "-d") specifies a comma-separated
+;; list of groups, in which case api-diff displays instead the
+;; elements added and deleted for each of the specified groups.
+;;
+;; For scheme programming, this module exports the proc:
+;;  (api-diff A-file B-file)
+;;
+;; Note that the convention is that the "older" alist/file is
+;; specified first.
+;;
+;; TODO: Develop scheme interface.
+
+;;; Code:
+
+(define-module (scripts api-diff)
+  \:use-module (ice-9 common-list)
+  \:use-module (ice-9 format)
+  \:use-module (ice-9 getopt-long)
+  \:autoload (srfi srfi-13) (string-tokenize)
+  \:export (api-diff))
+
+(define %include-in-guild-list #f)
+(define %summary "Show differences between two scan-api files.")
+
+(define (read-alist-file file)
+  (with-input-from-file file
+    (lambda () (read))))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (read-api-alist-file file)
+  (let* ((alist (read-alist-file file))
+         (meta (assq-ref alist 'meta))
+         (interface (assq-ref alist 'interface)))
+    (put interface 'meta meta)
+    (put interface 'groups (let ((ht (make-hash-table 31)))
+                             (for-each (lambda (group)
+                                         (hashq-set! ht group '()))
+                                       (assq-ref meta 'groups))
+                             ht))
+    interface))
+
+(define (hang-by-the-roots interface)
+  (let ((ht (get interface 'groups)))
+    (for-each (lambda (x)
+                (for-each (lambda (group)
+                            (hashq-set! ht group
+                                        (cons (car x)
+                                              (hashq-ref ht group))))
+                          (assq-ref x 'groups)))
+              interface))
+  interface)
+
+(define (diff? a b)
+  (let ((result (set-difference a b)))
+    (if (null? result)
+        #f                              ; CL weenies bite me
+        result)))
+
+(define (diff+note! a b note-removals note-additions note-same)
+  (let ((same? #t))
+    (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
+    (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
+    (and same? (note-same))))
+
+(define (group-diff i-old i-new . options)
+  (let* ((i-old (hang-by-the-roots i-old))
+         (g-old (hash-fold acons '() (get i-old 'groups)))
+         (g-old-names (map car g-old))
+         (i-new (hang-by-the-roots i-new))
+         (g-new (hash-fold acons '() (get i-new 'groups)))
+         (g-new-names (map car g-new)))
+    (cond ((null? options)
+           (diff+note! g-old-names g-new-names
+                       (lambda (removals)
+                         (format #t "groups-removed: ~A\n" removals))
+                       (lambda (additions)
+                         (format #t "groups-added: ~A\n" additions))
+                       (lambda () #t))
+           (for-each (lambda (group)
+                       (let* ((old (assq-ref g-old group))
+                              (new (assq-ref g-new group))
+                              (old-count (and old (length old)))
+                              (new-count (and new (length new)))
+                              (delta (and old new (- new-count old-count))))
+                         (format #t " ~5@A  ~5@A  :  "
+                                 (or old-count "-")
+                                 (or new-count "-"))
+                         (cond ((and old new)
+                                (let ((add-count 0) (sub-count 0))
+                                  (diff+note!
+                                   old new
+                                   (lambda (subs)
+                                     (set! sub-count (length subs)))
+                                   (lambda (adds)
+                                     (set! add-count (length adds)))
+                                   (lambda () #t))
+                                  (format #t "~5@D ~5@D : ~5@D"
+                                          add-count (- sub-count) delta)))
+                               (else
+                                (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
+                         (format #t "     ~A\n" group)))
+                     (sort (union g-old-names g-new-names)
+                           (lambda (a b)
+                             (string<? (symbol->string a)
+                                       (symbol->string b))))))
+          ((assq-ref options 'details)
+           => (lambda (groups)
+                (for-each (lambda (group)
+                            (let* ((old (or (assq-ref g-old group) '()))
+                                   (new (or (assq-ref g-new group) '()))
+                                   (>>! (lambda (label ls)
+                                          (format #t "~A ~A:\n" group label)
+                                          (for-each (lambda (x)
+                                                      (format #t " ~A\n" x))
+                                                    ls))))
+                              (diff+note! old new
+                                          (lambda (removals)
+                                            (>>! 'removals removals))
+                                          (lambda (additions)
+                                            (>>! 'additions additions))
+                                          (lambda ()
+                                            (format #t "~A: no changes\n"
+                                                    group)))))
+                          groups)))
+          (else
+           (error "api-diff: group-diff: bad options")))))
+
+(define (api-diff . args)
+  (let* ((p (getopt-long (cons 'api-diff args)
+                         '((details (single-char #\d)
+                                    (value #t))
+                           ;; Add options here.
+                           )))
+         (rest (option-ref p '() '("/dev/null" "/dev/null")))
+         (i-old (read-api-alist-file (car rest)))
+         (i-new (read-api-alist-file (cadr rest)))
+         (options '()))
+    (cond ((option-ref p 'details #f)
+           => (lambda (groups)
+                (set! options (cons (cons 'details
+                                          (map string->symbol
+                                               (string-tokenize
+                                                groups
+                                                #\,)))
+                                    options)))))
+    (apply group-diff i-old i-new options)))
+
+(define main api-diff)
+
+;;; api-diff ends here
+;;; autofrisk --- Generate module checks for use with auto* tools
+
+;; 	Copyright (C) 2002, 2006, 2009, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: autofrisk [file]
+;;
+;; This program looks for the file modules.af in the current directory
+;; and writes out modules.af.m4 containing autoconf definitions.
+;; If given, look for FILE instead of modules.af and output to FILE.m4.
+;;
+;; After running autofrisk, you should add to configure.ac the lines:
+;;   AUTOFRISK_CHECKS
+;;   AUTOFRISK_SUMMARY
+;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
+;;
+;; The modules.af file consists of a series of configuration forms (Scheme
+;; lists), which have one of the following formats:
+;;   (files-glob PATTERN ...)
+;;   (non-critical-external MODULE ...)
+;;   (non-critical-internal MODULE ...)
+;;   (programs (MODULE PROG ...) ...)
+;;   (pww-varname VARNAME)
+;; PATTERN is a string that may contain "*" and "?" characters to be
+;; expanded into filenames.  MODULE is a list of symbols naming a
+;; module, such as `(srfi srfi-1)'.  VARNAME is a shell-safe name to use
+;; instead of "probably_wont_work", the default.  This var is passed to
+;; `AC_SUBST'.  PROG is a string.
+;;
+;; Only the `files-glob' form is required.
+;;
+;; TODO: Write better commentary.
+;;       Make "please see README" configurable.
+
+;;; Code:
+
+(define-module (scripts autofrisk)
+  \:autoload (ice-9 popen) (open-input-pipe)
+  \:use-module (srfi srfi-1)
+  \:use-module (srfi srfi-8)
+  \:use-module (srfi srfi-13)
+  \:use-module (srfi srfi-14)
+  \:use-module (scripts read-scheme-source)
+  \:use-module (scripts frisk)
+  \:export (autofrisk))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate snippets for use in configure.ac files.")
+
+(define *recognized-keys* '(files-glob
+                            non-critical-external
+                            non-critical-internal
+                            programs
+                            pww-varname))
+
+(define (canonical-configuration forms)
+  (let ((chk (lambda (condition . x)
+               (or condition (apply error "syntax error:" x)))))
+    (chk (list? forms) "input not a list")
+    (chk (every list? forms) "non-list element")
+    (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
+    (let ((un #f))
+      (chk (every (lambda (form)
+                    (let ((key (car form)))
+                      (and (symbol? key)
+                           (or (eq? 'quote key)
+                               (memq key *recognized-keys*)
+                               (begin
+                                 (set! un key)
+                                 #f)))))
+                  forms)
+           "unrecognized key:" un))
+    (let ((bunched (map (lambda (key)
+                          (fold (lambda (form so-far)
+                                  (or (and (eq? (car form) key)
+                                           (cdr form)
+                                           (append so-far (cdr form)))
+                                      so-far))
+                                (list key)
+                                forms))
+                        *recognized-keys*)))
+      (lambda (key)
+        (assq-ref bunched key)))))
+
+(define (>>strong modules)
+  (for-each (lambda (module)
+              (format #t "GUILE_MODULE_REQUIRED~A\n" module))
+            modules))
+
+(define (safe-name module)
+  (let ((var (object->string module)))
+    (string-map! (lambda (c)
+                   (if (char-set-contains? char-set:letter+digit c)
+                       c
+                       #\_))
+                 var)
+    var))
+
+(define *pww* "probably_wont_work")
+
+(define (>>weak weak-edges)
+  (for-each (lambda (edge)
+              (let* ((up (edge-up edge))
+                     (down (edge-down edge))
+                     (var (format #f "have_guile_module~A" (safe-name up))))
+                (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
+                (format #t "test \"$~A\" = no &&\n  ~A=\"~A $~A\"~A"
+                        var *pww* down *pww* "\n\n")))
+            weak-edges))
+
+(define (>>program module progs)
+  (let ((vars (map (lambda (prog)
+                     (format #f "guile_module~Asupport_~A"
+                             (safe-name module)
+                             prog))
+                   progs)))
+    (for-each (lambda (var prog)
+                (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
+              vars progs)
+    (format #t "test \\\n")
+    (for-each (lambda (var)
+                (format #t " \"$~A\" = \"\" -o \\\n" var))
+              vars)
+    (format #t "~A &&\n~A=\"~A $~A\"\n\n"
+            (list-ref (list "war = peace"
+                            "freedom = slavery"
+                            "ignorance = strength")
+                      (random 3))
+            *pww* module *pww*)))
+
+(define (>>programs programs)
+  (for-each (lambda (form)
+              (>>program (car form) (cdr form)))
+            programs))
+
+(define (unglob pattern)
+  (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
+    (map symbol->string (read p))))
+
+(define (>>checks forms)
+  (let* ((cfg (canonical-configuration forms))
+         (files (apply append (map unglob (cfg 'files-glob))))
+         (ncx (cfg 'non-critical-external))
+         (nci (cfg 'non-critical-internal))
+         (report ((make-frisker) files))
+         (external (report 'external)))
+    (let ((pww-varname (cfg 'pww-varname)))
+      (or (null? pww-varname) (set! *pww* (car pww-varname))))
+    (receive (weak strong)
+        (partition (lambda (module)
+                     (or (member module ncx)
+                         (every (lambda (i)
+                                  (member i nci))
+                                (map edge-down (mod-down-ls module)))))
+                   external)
+      (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
+      (>>strong strong)
+      (format #t "\n~A=~S\n\n" *pww* "")
+      (>>weak (fold (lambda (module so-far)
+                      (append so-far (mod-down-ls module)))
+                    (list)
+                    weak))
+      (>>programs (cfg 'programs))
+      (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
+
+(define (>>summary)
+  (format #t
+          (symbol->string
+           '#{
+AC_DEFUN([AUTOFRISK_SUMMARY],[
+if test ! "$~A" = "" ; then
+    p="         ***"
+    echo "$p"
+    echo "$p NOTE:"
+    echo "$p The following modules probably won't work:"
+    echo "$p   $~A"
+    echo "$p They can be installed anyway, and will work if their"
+    echo "$p dependencies are installed later.  Please see README."
+    echo "$p"
+fi
+])
+})
+          *pww* *pww*))
+
+(define (autofrisk . args)
+  (let ((file (if (null? args) "modules.af" (car args))))
+    (or (file-exists? file)
+        (error "could not find input file:" file))
+    (with-output-to-file (format #f "~A.m4" file)
+      (lambda ()
+        (>>checks (read-scheme-source-silently file))
+        (>>summary)))))
+
+(define main autofrisk)
+
+;; Local variables:
+;; eval: (put 'receive 'scheme-indent-function 2)
+;; End:
+
+;;; autofrisk ends here
+;;; Compile --- Command-line Guile Scheme compiler  -*- coding: iso-8859-1 -*-
+
+;; Copyright 2005, 2008, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  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>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: compile [ARGS]
+;;
+;; A command-line interface to the Guile compiler.
+
+;;; Code:
+
+(define-module (scripts compile)
+  #\use-module ((system base compile) #\select (compile-file))
+  #\use-module (system base target)
+  #\use-module (system base message)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-13)
+  #\use-module (srfi srfi-37)
+  #\use-module (ice-9 format)
+  #\export (compile))
+
+(define %summary "Compile a file.")
+
+
+(define (fail . messages)
+  (format (current-error-port) "error: ~{~a~}~%" messages)
+  (exit 1))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda (opt name arg result)
+		  (alist-cons 'help? #t result)))
+        (option '("version") #f #f
+                (lambda (opt name arg result)
+                  (show-version)
+                  (exit 0)))
+
+	(option '(#\L "load-path") #t #f
+		(lambda (opt name arg result)
+		  (let ((load-path (assoc-ref result 'load-path)))
+		    (alist-cons 'load-path (cons arg load-path)
+				result))))
+	(option '(#\o "output") #t #f
+		(lambda (opt name arg result)
+		  (if (assoc-ref result 'output-file)
+		      (fail "`-o' option cannot be specified more than once")
+		      (alist-cons 'output-file arg result))))
+
+        (option '(#\W "warn") #t #f
+                (lambda (opt name arg result)
+                  (if (string=? arg "help")
+                      (begin
+                        (show-warning-help)
+                        (exit 0))
+                      (let ((warnings (assoc-ref result 'warnings)))
+                        (alist-cons 'warnings
+                                    (cons (string->symbol arg) warnings)
+                                    (alist-delete 'warnings result))))))
+
+	(option '(#\O "optimize") #f #f
+		(lambda (opt name arg result)
+		  (alist-cons 'optimize? #t result)))
+	(option '(#\f "from") #t #f
+		(lambda (opt name arg result)
+                  (if (assoc-ref result 'from)
+                      (fail "`--from' option cannot be specified more than once")
+                      (alist-cons 'from (string->symbol arg) result))))
+	(option '(#\t "to") #t #f
+		(lambda (opt name arg result)
+                  (if (assoc-ref result 'to)
+                      (fail "`--to' option cannot be specified more than once")
+                      (alist-cons 'to (string->symbol arg) result))))
+        (option '(#\T "target") #t #f
+                (lambda (opt name arg result)
+                  (if (assoc-ref result 'target)
+                      (fail "`--target' option cannot be specified more than once")
+                      (alist-cons 'target arg result))))))
+
+(define (parse-args args)
+  "Parse argument list @var{args} and return an alist with all the relevant
+options."
+  (args-fold args %options
+             (lambda (opt name arg result)
+               (format (current-error-port) "~A: unrecognized option" name)
+	       (exit 1))
+             (lambda (file result)
+	       (let ((input-files (assoc-ref result 'input-files)))
+		 (alist-cons 'input-files (cons file input-files)
+			     result)))
+
+	     ;; default option values
+             '((input-files)
+	       (load-path)
+               (warnings unsupported-warning))))
+
+(define (show-version)
+  (format #t "compile (GNU Guile) ~A~%" (version))
+  (format #t "Copyright (C) 2009, 2011 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
+(define (show-warning-help)
+  (format #t "The available warning types are:~%~%")
+  (for-each (lambda (wt)
+              (format #t "  ~22A ~A~%"
+                      (format #f "`~A'" (warning-type-name wt))
+                      (warning-type-description wt)))
+            %warning-types)
+  (format #t "~%"))
+
+
+(define (compile . args)
+  (let* ((options         (parse-args args))
+         (help?           (assoc-ref options 'help?))
+         (compile-opts    (let ((o `(#\warnings
+                                     ,(assoc-ref options 'warnings))))
+                            (if (assoc-ref options 'optimize?)
+                                (cons #\O o)
+                                o)))
+         (from            (or (assoc-ref options 'from) 'scheme))
+         (to              (or (assoc-ref options 'to) 'objcode))
+         (target          (or (assoc-ref options 'target) %host-type))
+	 (input-files     (assoc-ref options 'input-files))
+	 (output-file     (assoc-ref options 'output-file))
+	 (load-path       (assoc-ref options 'load-path)))
+    (if (or help? (null? input-files))
+        (begin
+          (format #t "Usage: compile [OPTION] FILE...
+Compile each Guile source file FILE into a Guile object.
+
+  -h, --help           print this help message
+
+  -L, --load-path=DIR  add DIR to the front of the module load path
+  -o, --output=OFILE   write output to OFILE
+
+  -W, --warn=WARNING   emit warnings of type WARNING; use `--warn=help'
+                       for a list of available warnings
+
+  -f, --from=LANG      specify a source language other than `scheme'
+  -t, --to=LANG        specify a target language other than `objcode'
+  -T, --target=TRIPLET produce bytecode for host TRIPLET
+
+Note that auto-compilation will be turned off.
+
+Report bugs to <~A>.~%"
+                  %guile-bug-report-address)
+          (exit 0)))
+
+    (set! %load-path (append load-path %load-path))
+    (set! %load-should-auto-compile #f)
+
+    (if (and output-file
+             (or (null? input-files)
+                 (not (null? (cdr input-files)))))
+        (fail "`-o' option can only be specified "
+              "when compiling a single file"))
+
+    ;; Install a SIGINT handler.  As a side effect, this gives unwind
+    ;; handlers an opportunity to run upon SIGINT; this includes that of
+    ;; 'call-with-output-file/atomic', called by 'compile-file', which
+    ;; removes the temporary output file.
+    (sigaction SIGINT
+      (lambda args
+        (fail "interrupted by the user")))
+
+    (for-each (lambda (file)
+                (format #t "wrote `~A'\n"
+                        (with-fluids ((*current-warning-prefix* ""))
+                          (with-target target
+                            (lambda ()
+                              (compile-file file
+                                            #\output-file output-file
+                                            #\from from
+                                            #\to to
+                                            #\opts compile-opts))))))
+              input-files)))
+
+(define main compile)
+;;; Disassemble --- Disassemble .go files into something human-readable
+
+;; Copyright 2005, 2008, 2009, 2011, 2014 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  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>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: disassemble [ARGS]
+
+;;; Code:
+
+(define-module (scripts disassemble)
+  #\use-module (system vm objcode)
+  #\use-module ((language assembly disassemble) #\prefix asm\:)
+  #\export (disassemble))
+
+(define %summary "Disassemble a compiled .go file.")
+
+(define (disassemble . files)
+  (for-each (lambda (file)
+              (asm:disassemble (load-objcode file)))
+            files))
+
+(define main disassemble)
+;;; display-commentary --- As advertized
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: display-commentary REF1 REF2 ...
+;;
+;; Display Commentary section from REF1, REF2 and so on.
+;; Each REF may be a filename or module name (list of symbols).
+;; In the latter case, a filename is computed by searching `%load-path'.
+
+;;; Code:
+
+(define-module (scripts display-commentary)
+  \:use-module (ice-9 documentation)
+  \:export (display-commentary))
+
+(define %summary "Display the Commentary section from a file or module.")
+
+(define (display-commentary-one file)
+  (format #t "~A commentary:\n~A" file (file-commentary file)))
+
+(define (module-name->filename-frag ls) ; todo: export or move
+  (let ((ls (map symbol->string ls)))
+    (let loop ((ls (cdr ls)) (acc (car ls)))
+      (if (null? ls)
+          acc
+          (loop (cdr ls) (string-append acc "/" (car ls)))))))
+
+(define (display-module-commentary module-name)
+  (cond ((%search-load-path (module-name->filename-frag module-name))
+         => (lambda (file)
+              (format #t "module ~A\n" module-name)
+              (display-commentary-one file)))))
+
+(define (display-commentary . refs)
+  (for-each (lambda (ref)
+              (cond ((string? ref)
+                     (if (equal? 0 (string-index ref #\())
+                         (display-module-commentary
+                          (with-input-from-string ref read))
+                         (display-commentary-one ref)))
+                    ((list? ref)
+                     (display-module-commentary ref))))
+            refs))
+
+(define main display-commentary)
+
+;;; display-commentary ends here
+;;; doc-snarf --- Extract documentation from source files
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller
+
+;;; Commentary:
+
+;; Usage: doc-snarf FILE
+;;
+;; This program reads in a Scheme source file and extracts docstrings
+;; in the format specified below.  Additionally, a procedure protoype
+;; is infered from the procedure definition line starting with
+;; (define... ).
+;;
+;; Currently, two output modi are implemented: texinfo and plaintext.
+;; Default is plaintext, texinfo can be switched on with the
+;; `--texinfo, -t' command line option.
+;;
+;; Format: A docstring can span multiple lines and a docstring line
+;; begins with `;; ' (two semicoli and a space). A docstring is ended
+;; by either a line beginning with (define ...) or one or more lines
+;; beginning with `;;-' (two semicoli and a dash). These lines are
+;; called `options' and begin with a keyword, followed by a colon and
+;; a string.
+;;
+;; Additionally, "standard internal docstrings" (for Scheme source) are
+;; recognized and output as "options".  The output formatting is likely
+;; to change in the future.
+;;
+;; Example:
+
+;; This procedure foos, or bars, depending on the argument @var{braz}.
+;;-Author: Martin Grabmueller
+(define (foo/bar braz)
+  (if braz 'foo 'bar))
+
+;;; Which results in the following docstring if texinfo output is
+;;; enabled:
+
+;; TODO: Convert option lines to alist.
+;;       More parameterization.
+;;       (maybe) Use in Guile build itself.
+
+(define doc-snarf-version "0.0.2") ; please update before publishing!
+
+;;; Code:
+
+(define-module (scripts doc-snarf)
+  \:use-module (ice-9 getopt-long)
+  \:use-module (ice-9 regex)
+  \:use-module (ice-9 string-fun)
+  \:use-module (ice-9 rdelim)
+  \:export (doc-snarf))
+
+(define %summary "Snarf out documentation from a file.")
+
+(define command-synopsis
+  '((version (single-char #\v) (value #f))
+    (help    (single-char #\h) (value #f))
+    (output  (single-char #\o) (value #t))
+    (texinfo (single-char #\t) (value #f))
+    (lang    (single-char #\l) (value #t))))
+
+;; Display version information and exit.
+;;-ttn-mod: use var
+(define (display-version)
+  (display "doc-snarf ") (display doc-snarf-version) (newline))
+
+;; Display the usage help message and exit.
+;;-ttn-mod: change option "source" to "lang"
+(define (display-help)
+  (display "Usage: doc-snarf [options...] inputfile\n")
+  (display "  --help, -h              Show this usage information\n")
+  (display "  --version, -v           Show version information\n")
+  (display
+   "  --output=FILE, -o       Specify output file [default=stdout]\n")
+  (display "  --texinfo, -t           Format output as texinfo\n")
+  (display "  --lang=[c,scheme], -l   Specify the input language\n"))
+
+;; Main program.
+;;-ttn-mod: canonicalize lang
+(define (doc-snarf . args)
+  (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
+    (let ((help-wanted (option-ref options 'help #f))
+	  (version-wanted (option-ref options 'version #f))
+	  (texinfo-wanted (option-ref options 'texinfo #f))
+	  (lang (string->symbol
+                 (string-downcase (option-ref options 'lang "scheme")))))
+      (cond
+       (version-wanted (display-version))
+       (help-wanted (display-help))
+       (else
+	(let ((input (option-ref options '() #f))
+	      (output (option-ref options 'output #f)))
+	  (if
+           ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
+           ;; (and input (pair? input))
+           (pair? input)
+           (snarf-file (car input) output texinfo-wanted lang)
+           (display-help))))))))
+
+(define main doc-snarf)
+
+;; Supported languages and their parameters.  Each element has form:
+;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
+;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
+;; LANG supports "standard internal docstring" (a string after the formals),
+;; everything else is a string specifying a regexp.
+;;-ttn-mod: new var
+(define supported-languages
+  '((c
+     "^/\\*(.*)"
+     "^ \\*/"
+     "^ \\* (.*)"
+     "^ \\*-(.*)"
+     "NOTHING AT THIS TIME!!!"
+     #f
+     )
+    (scheme
+     "^;; (.*)"
+     "^;;\\."
+     "^;; (.*)"
+     "^;;-(.*)"
+     "^\\(define"
+     #t
+     )))
+
+;; Get @var{lang}'s @var{parameter}.  Both args are symbols.
+;;-ttn-mod: new proc
+(define (lang-parm lang parm)
+  (list-ref (assq-ref supported-languages lang)
+            (case parm
+              ((docstring-start)  0)
+              ((docstring-end)    1)
+              ((docstring-prefix) 2)
+              ((option-prefix)    3)
+              ((signature-start)  4)
+              ((std-int-doc?)     5))))
+
+;; Snarf all docstrings from the file @var{input} and write them to
+;; file @var{output}.  Use texinfo format for the output if
+;; @var{texinfo?} is true.
+;;-ttn-mod: don't use string comparison, consult table instead
+(define (snarf-file input output texinfo? lang)
+  (or (memq lang (map car supported-languages))
+      (error "doc-snarf: input language must be c or scheme."))
+  (write-output (snarf input lang) output
+                (if texinfo? format-texinfo format-plain)))
+
+;; fixme: this comment is required to trigger standard internal
+;; docstring snarfing...  ideally, it wouldn't be necessary.
+;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
+(define (find-std-int-doc line input-port)
+  "Unread @var{line} from @var{input-port}, then read in the entire form and
+return the standard internal docstring if found.  Return #f if not."
+  (unread-string line input-port)       ; ugh
+  (let ((form (read input-port)))
+    (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
+                (< 3 (length form))
+                (eq? 'define (car form))
+                (pair? (cadr form))
+                (symbol? (caadr form))
+                (string? (caddr form)))
+           (caddr form))
+          ((and (list? form)            ; (define VAR (lambda ARGS "DOC" ...))
+                (< 2 (length form))
+                (eq? 'define (car form))
+                (symbol? (cadr form))
+                (list? (caddr form))
+                (< 3 (length (caddr form)))
+                (eq? 'lambda (car (caddr form)))
+                (string? (caddr (caddr form))))
+           (caddr (caddr form)))
+          (else #f))))
+
+;; Split @var{string} into lines, adding @var{prefix} to each.
+;;-ttn-mod: new proc
+(define (split-prefixed string prefix)
+  (separate-fields-discarding-char
+   #\newline string
+   (lambda lines
+     (map (lambda (line)
+            (string-append prefix line))
+          lines))))
+
+;; snarf input-file output-file
+;; Extract docstrings from the input file @var{input}, presumed
+;; to be written in language @var{lang}.
+;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;-Created: 2001-02-17
+;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
+(define (snarf input-file lang)
+  (let* ((i-p (open-input-file input-file))
+         (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
+         (docstring-start  (parm-regexp 'docstring-start))
+         (docstring-end    (parm-regexp 'docstring-end))
+         (docstring-prefix (parm-regexp 'docstring-prefix))
+         (option-prefix    (parm-regexp 'option-prefix))
+         (signature-start  (parm-regexp 'signature-start))
+         (augmented-options
+          (lambda (line i-p options)
+            (let ((int-doc (and (lang-parm lang 'std-int-doc?)
+                                (let ((d (find-std-int-doc line i-p)))
+                                  (and d (split-prefixed d "internal: "))))))
+              (if int-doc
+                  (append (reverse int-doc) options)
+                  options)))))
+
+    (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
+	     (options '()) (entries '()) (lno 0))
+      (cond
+       ((eof-object? line)
+	(close-input-port i-p)
+	(reverse entries))
+
+       ;; State 'neutral: we're currently not within a docstring or
+       ;; option section
+       ((eq? state 'neutral)
+	(let ((m (regexp-exec docstring-start line)))
+	  (if m
+	    (lp (read-line i-p) 'doc-string
+		(list (match:substring m 1)) '() entries (+ lno 1))
+	    (lp (read-line i-p) state '() '() entries (+ lno 1)))))
+
+       ;; State 'doc-string: we have started reading a docstring and
+       ;; are waiting for more, for options or for a define.
+       ((eq? state 'doc-string)
+	(let ((m0 (regexp-exec docstring-prefix line))
+	      (m1 (regexp-exec option-prefix line))
+	      (m2 (regexp-exec signature-start line))
+	      (m3 (regexp-exec docstring-end line)))
+	  (cond
+	   (m0
+	    (lp (read-line i-p) 'doc-string
+		(cons (match:substring m0 1) doc-strings) '() entries
+		(+ lno 1)))
+	   (m1
+	    (lp (read-line i-p) 'options
+		doc-strings (cons (match:substring m1 1) options) entries
+		(+ lno 1)))
+	   (m2
+            (let ((options (augmented-options line i-p options))) ; ttn-mod
+              (lp (read-line i-p) 'neutral '() '()
+                  (cons (parse-entry doc-strings options line input-file lno)
+                        entries)
+                  (+ lno 1))))
+           (m3
+	    (lp (read-line i-p) 'neutral '() '()
+		(cons (parse-entry doc-strings options #f input-file lno)
+		      entries)
+		(+ lno 1)))
+	   (else
+	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
+
+       ;; State 'options: We're waiting for more options or for a
+       ;; define.
+       ((eq? state 'options)
+	(let ((m1 (regexp-exec option-prefix line))
+	      (m2 (regexp-exec signature-start line))
+	      (m3 (regexp-exec docstring-end line)))
+	  (cond
+	   (m1
+	    (lp (read-line i-p) 'options
+		doc-strings (cons (match:substring m1 1) options) entries
+		(+ lno 1)))
+	   (m2
+            (let ((options (augmented-options line i-p options))) ; ttn-mod
+              (lp (read-line i-p) 'neutral '() '()
+                  (cons (parse-entry doc-strings options line input-file lno)
+                        entries)
+                  (+ lno 1))))
+	   (m3
+	    (lp (read-line i-p) 'neutral '() '()
+		(cons (parse-entry doc-strings options #f input-file lno)
+		      entries)
+		(+ lno 1)))
+	   (else
+	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
+
+(define (make-entry symbol signature docstrings options filename line)
+  (vector 'entry symbol signature docstrings options filename line))
+(define (entry-symbol e)
+  (vector-ref e 1))
+(define (entry-signature e)
+  (vector-ref e 2))
+(define (entry-docstrings e)
+  (vector-ref e 3))
+(define (entry-options e)
+  (vector-ref e 4))
+(define (entry-filename e)
+  (vector-ref e 5))
+(define (entry-line e)
+  "This docstring will not be snarfed, unfortunately..."
+  (vector-ref e 6))
+
+;; Create a docstring entry from the docstring line list
+;; @var{doc-strings}, the option line list @var{options} and the
+;; define line @var{def-line}
+(define (parse-entry docstrings options def-line filename line-no)
+;  (write-line docstrings)
+  (cond
+   (def-line
+     (make-entry (get-symbol def-line)
+		 (make-prototype def-line) (reverse docstrings)
+		 (reverse options) filename
+		 (+ (- line-no (length docstrings) (length options)) 1)))
+   ((> (length docstrings) 0)
+    (make-entry (string->symbol (car (reverse docstrings)))
+		(car (reverse docstrings))
+		(cdr (reverse docstrings))
+		(reverse options) filename
+		(+ (- line-no (length docstrings) (length options)) 1)))
+   (else
+    (make-entry 'foo "" (reverse docstrings) (reverse options) filename
+		(+ (- line-no (length docstrings) (length options)) 1)))))
+
+;; Create a string which is a procedure prototype.  The necessary
+;; information for constructing the prototype is taken from the line
+;; @var{def-line}, which is a line starting with @code{(define...}.
+(define (make-prototype def-line)
+  (call-with-input-string
+   def-line
+   (lambda (s-p)
+     (let* ((paren (read-char s-p))
+	    (keyword (read s-p))
+	    (tmp (read s-p)))
+       (cond
+	((pair? tmp)
+	 (join-symbols tmp))
+	((symbol? tmp)
+	 (symbol->string tmp))
+	(else
+	 ""))))))
+
+(define (get-symbol def-line)
+  (call-with-input-string
+   def-line
+   (lambda (s-p)
+     (let* ((paren (read-char s-p))
+	    (keyword (read s-p))
+	    (tmp (read s-p)))
+       (cond
+	((pair? tmp)
+	 (car tmp))
+	((symbol? tmp)
+	 tmp)
+	(else
+	 'foo))))))
+
+;; Append the symbols in the string list @var{s}, separated with a
+;; space character.
+(define (join-symbols s)
+  (cond ((null? s)
+	 "")
+	((symbol? s)
+	 (string-append ". " (symbol->string s)))
+	((null? (cdr s))
+	 (symbol->string (car s)))
+	(else
+	 (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
+
+;; Write @var{entries} to @var{output-file} using @var{writer}.
+;; @var{writer} is a proc that takes one entry.
+;; If @var{output-file} is #f, write to stdout.
+;;-ttn-mod: new proc
+(define (write-output entries output-file writer)
+  (with-output-to-port (cond (output-file (open-output-file output-file))
+                             (else (current-output-port)))
+    (lambda () (for-each writer entries))))
+
+;; Write an @var{entry} using texinfo format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-texinfo entry)
+  (display "\n\f")
+  (display (entry-symbol entry))
+  (newline)
+  (display "@c snarfed from ")
+  (display (entry-filename entry))
+  (display ":")
+  (display (entry-line entry))
+  (newline)
+  (display "@deffn procedure ")
+  (display (entry-signature entry))
+  (newline)
+  (for-each (lambda (s) (write-line s))
+            (entry-docstrings entry))
+  (for-each (lambda (s) (display "@c ") (write-line s))
+            (entry-options entry))
+  (write-line "@end deffn"))
+
+;; Write an @var{entry} using plain format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-plain entry)
+  (display "Procedure: ")
+  (display (entry-signature entry))
+  (newline)
+  (for-each (lambda (s) (write-line s))
+            (entry-docstrings entry))
+  (for-each (lambda (s) (display ";; ") (write-line s))
+            (entry-options entry))
+  (display "Snarfed from ")
+  (display (entry-filename entry))
+  (display ":")
+  (display (entry-line entry))
+  (newline)
+  (write-line "\f"))
+
+;;; doc-snarf ends here
+;;; frisk --- Grok the module interfaces of a body of files
+
+;; 	Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: frisk [options] file ...
+;;
+;; Analyze FILE... module interfaces in aggregate (as a "body"),
+;; and display a summary.  Modules that are `define-module'd are
+;; considered "internal" (and those not, "external").  When module X
+;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
+;; "(an) upstream of" X.
+;;
+;; Normally, the summary displays external modules and their internal
+;; downstreams, as this is the usual question asked by a body.  There
+;; are several options that modify this output.
+;;
+;;  -u, --upstream      show upstream edges
+;;  -d, --downstream    show downstream edges (default)
+;;  -i, --internal      show internal modules
+;;  -x, --external      show external modules (default)
+;;
+;; If given both `upstream' and `downstream' options ("frisk -ud"), the
+;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
+;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
+;; MODULE-NAME ...).
+;;
+;; In all other cases, the "C MODULE" occupies its own line, and
+;; subsequent lines list the up- or downstream edges, respectively,
+;; indented by some non-zero amount of whitespace.
+;;
+;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
+;; file that do not follow a `define-module' result an edge where the
+;; downstream is the "default module", normally `(guile-user)'.  This
+;; can be set to another value by using:
+;;
+;;  -m, --default-module MOD    set MOD as the default module
+
+;; Usage from a Scheme Program: (use-modules (scripts frisk))
+;;
+;; Module export list:
+;;  (frisk . args)
+;;  (make-frisker . options)    => (lambda (files) ...) [see below]
+;;  (mod-up-ls module)          => upstream edges
+;;  (mod-down-ls module)        => downstream edges
+;;  (mod-int? module)           => is the module internal?
+;;  (edge-type edge)            => symbol: {regular,autoload,computed}
+;;  (edge-up edge)              => upstream module
+;;  (edge-down edge)            => downstream module
+;;
+;; OPTIONS is an alist.  Recognized keys are:
+;;  default-module
+;;
+;; `make-frisker' returns a procedure that takes a list of files, the
+;; FRISKER.  FRISKER returns a closure, REPORT, that takes one of the
+;; keys:
+;;  modules  -- entire list of modules
+;;  internal -- list of internal modules
+;;  external -- list of external modules
+;;  i-up     -- list of modules upstream of internal modules
+;;  x-up     -- list of modules upstream of external modules
+;;  i-down   -- list of modules downstream of internal modules
+;;  x-down   -- list of modules downstream of external modules
+;;  edges    -- list of edges
+;; Note that `x-up' should always be null, since by (lack of!)
+;; definition, we only know external modules by reference.
+;;
+;; The module and edge objects managed by REPORT can be examined in
+;; detail by using the other (self-explanatory) procedures.  Be careful
+;; not to confuse a freshly consed list of symbols, like `(a b c)' with
+;; the module `(a b c)'.  If you want to find the module by that name,
+;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
+
+;; TODO: Make "frisk -ud" output less ugly.
+;;       Consider default module as internal; add option to invert.
+;;       Support `edge-misc' data.
+
+;;; Code:
+
+(define-module (scripts frisk)
+  \:autoload (ice-9 getopt-long) (getopt-long)
+  \:use-module ((srfi srfi-1) \:select (filter remove))
+  \:export (frisk
+           make-frisker
+           mod-up-ls mod-down-ls mod-int?
+           edge-type edge-up edge-down))
+
+(define %include-in-guild-list #f)
+(define %summary "Show dependency information for a module.")
+
+(define *default-module* '(guile-user))
+
+(define (grok-proc default-module note-use!)
+  (lambda (filename)
+    (let* ((p (open-file filename "r"))
+           (next (lambda () (read p)))
+           (ferret (lambda (use)   ;;; handle "((foo bar) \:select ...)"
+                     (let ((maybe (car use)))
+                       (if (list? maybe)
+                           maybe
+                           use))))
+           (curmod #f))
+      (let loop ((form (next)))
+        (cond ((eof-object? form))
+              ((not (list? form)) (loop (next)))
+              (else (case (car form)
+                      ((define-module)
+                       (let ((module (cadr form)))
+                         (set! curmod module)
+                         (note-use! 'def module #f)
+                         (let loop ((ls form))
+                           (or (null? ls)
+                               (case (car ls)
+                                 ((#\use-module \:use-module)
+                                  (note-use! 'regular module (ferret (cadr ls)))
+                                  (loop (cddr ls)))
+                                 ((#\autoload \:autoload)
+                                  (note-use! 'autoload module (cadr ls))
+                                  (loop (cdddr ls)))
+                                 (else (loop (cdr ls))))))))
+                      ((use-modules)
+                       (for-each (lambda (use)
+                                   (note-use! 'regular
+                                              (or curmod default-module)
+                                              (ferret use)))
+                                 (cdr form)))
+                      ((load primitive-load)
+                       (note-use! 'computed
+                                  (or curmod default-module)
+                                  (let ((file (cadr form)))
+                                    (if (string? file)
+                                        file
+                                        (format #f "[computed in ~A]"
+                                                filename))))))
+                    (loop (next))))))))
+
+(define up-ls (make-object-property))   ; list
+(define dn-ls (make-object-property))   ; list
+(define int?  (make-object-property))   ; defined via `define-module'
+
+(define mod-up-ls up-ls)
+(define mod-down-ls dn-ls)
+(define mod-int? int?)
+
+(define (i-or-x module)
+  (if (int? module) 'i 'x))
+
+(define edge-type (make-object-property)) ; symbol
+
+(define (make-edge type up down)
+  (let ((new (cons up down)))
+    (set! (edge-type new) type)
+    new))
+
+(define edge-up car)
+(define edge-down cdr)
+
+(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
+(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
+
+(define (make-body alist)
+  (lambda (key)
+    (assq-ref alist key)))
+
+(define (scan default-module files)
+  (let* ((modules (list))
+         (edges (list))
+         (intern (lambda (module)
+                   (cond ((member module modules) => car)
+                         (else (set! (up-ls module) (list))
+                               (set! (dn-ls module) (list))
+                               (set! modules (cons module modules))
+                               module))))
+         (grok (grok-proc default-module
+                          (lambda (type d u)
+                            (let ((d (intern d)))
+                              (if (eq? type 'def)
+                                  (set! (int? d) #t)
+                                  (let* ((u (intern u))
+                                         (edge (make-edge type u d)))
+                                    (set! edges (cons edge edges))
+                                    (up-ls+! d edge)
+                                    (dn-ls+! u edge))))))))
+    (for-each grok files)
+    (make-body
+     `((modules  . ,modules)
+       (internal . ,(filter int? modules))
+       (external . ,(remove int? modules))
+       (i-up     . ,(filter int? (map edge-down edges)))
+       (x-up     . ,(remove int? (map edge-down edges)))
+       (i-down   . ,(filter int? (map edge-up   edges)))
+       (x-down   . ,(remove int? (map edge-up   edges)))
+       (edges    . ,edges)))))
+
+(define (make-frisker . options)
+  (let ((default-module (or (assq-ref options 'default-module)
+                            *default-module*)))
+    (lambda (files)
+      (scan default-module files))))
+
+(define (dump-updown modules)
+  (for-each (lambda (m)
+              (format #t "~A ~A --- ~A --- ~A\n"
+                      (i-or-x m) m
+                      (map (lambda (edge)
+                             (cons (edge-type edge)
+                                   (edge-up edge)))
+                           (up-ls m))
+                      (map (lambda (edge)
+                             (cons (edge-type edge)
+                                   (edge-down edge)))
+                           (dn-ls m))))
+            modules))
+
+(define (dump-up modules)
+  (for-each (lambda (m)
+              (format #t "~A ~A\n" (i-or-x m) m)
+              (for-each (lambda (edge)
+                          (format #t "\t\t\t ~A\t~A\n"
+                                  (edge-type edge) (edge-up edge)))
+                        (up-ls m)))
+            modules))
+
+(define (dump-down modules)
+  (for-each (lambda (m)
+              (format #t "~A ~A\n" (i-or-x m) m)
+              (for-each (lambda (edge)
+                          (format #t "\t\t\t ~A\t~A\n"
+                                  (edge-type edge) (edge-down edge)))
+                        (dn-ls m)))
+            modules))
+
+(define (frisk . args)
+  (let* ((parsed-opts (getopt-long
+                       (cons "frisk" args)    ;;; kludge
+                       '((upstream (single-char #\u))
+                         (downstream (single-char #\d))
+                         (internal (single-char #\i))
+                         (external (single-char #\x))
+                         (default-module
+                           (single-char #\m)
+                           (value #t)))))
+         (=u (option-ref parsed-opts 'upstream #f))
+         (=d (option-ref parsed-opts 'downstream #f))
+         (=i (option-ref parsed-opts 'internal #f))
+         (=x (option-ref parsed-opts 'external #f))
+         (files    (option-ref parsed-opts '() (list)))
+         (report   ((make-frisker
+                     `(default-module
+                        . ,(option-ref parsed-opts 'default-module
+                                       *default-module*)))
+                    files))
+         (modules  (report 'modules))
+         (internal (report 'internal))
+         (external (report 'external))
+         (edges    (report 'edges)))
+    (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
+            (length files)    "files"
+            (length modules)  "modules"
+            (length internal) "internal"
+            (length external) "external"
+            (length edges)    "edges")
+    ((cond ((and =u =d) dump-updown)
+           (=u dump-up)
+           (else dump-down))
+     (cond ((and =i =x) modules)
+           (=i internal)
+           (else external)))))
+
+(define main frisk)
+
+;;; frisk ends here
+;;; generate-autoload --- Display define-module form with autoload info
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ...
+;;
+;; The autoload form is displayed to standard output:
+;;
+;; (define-module (guile-user)
+;;   :autoload (ZAR FOO) (FOO-1 FOO-2 ...)
+;;     :
+;;     :
+;;   :autoload (ZAR BAR) (BAR-1 BAR-2 ...))
+;;
+;; For each file, a symbol triggers an autoload if it is found in one
+;; of these situations:
+;;  - in the `:export' clause of a `define-module' form
+;;  - in a top-level `export' or `export-syntax' form
+;;  - in a `define-public' form
+;;  - in a `defmacro-public' form
+;;
+;; The module name is inferred from the `define-module' form.  If either the
+;; module name or the exports list cannot be determined, no autoload entry is
+;; generated for that file.
+;;
+;; Options:
+;; --target MODULE-NAME         -- Use MODULE-NAME instead of `(guile-user)'.
+;;                                 Note that some shells may require you to
+;;                                 quote the argument to handle parentheses
+;;                                 and spaces.
+;;
+;; Usage examples from Scheme code as a module:
+;; (use-modules (scripts generate-autoload))
+;; (generate-autoload "generate-autoload")
+;; (generate-autoload "--target" "(my module)" "generate-autoload")
+;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz"))
+
+;;; Code:
+
+(define-module (scripts generate-autoload)
+  \:export (generate-autoload))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate #\autoload clauses for a module.")
+
+(define (autoload-info file)
+  (let ((p (open-input-file file)))
+    (let loop ((form (read p)) (module-name #f) (exports '()))
+      (if (eof-object? form)
+          (and module-name
+               (not (null? exports))
+               (list module-name exports)) ; ret
+          (cond ((and (list? form)
+                      (< 1 (length form))
+                      (eq? 'define-module (car form)))
+                 (loop (read p)
+                       (cadr form)
+                       (cond ((member '\:export form)
+                              => (lambda (val)
+                                   (append (cadr val) exports)))
+                             (else exports))))
+                ((and (list? form)
+                      (< 1 (length form))
+                      (memq (car form) '(export export-syntax)))
+                 (loop (read p)
+                       module-name
+                       (append (cdr form) exports)))
+                ((and (list? form)
+                      (< 2 (length form))
+                      (eq? 'define-public (car form))
+                      (list? (cadr form))
+                      (symbol? (caadr form)))
+                 (loop (read p)
+                       module-name
+                       (cons (caadr form) exports)))
+                ((and (list? form)
+                      (< 2 (length form))
+                      (eq? 'define-public (car form))
+                      (symbol? (cadr form)))
+                 (loop (read p)
+                       module-name
+                       (cons (cadr form) exports)))
+                ((and (list? form)
+                      (< 3 (length form))
+                      (eq? 'defmacro-public (car form))
+                      (symbol? (cadr form)))
+                 (loop (read p)
+                       module-name
+                       (cons (cadr form) exports)))
+                (else (loop (read p) module-name exports)))))))
+
+(define (generate-autoload . args)
+  (let* ((module-count 0)
+         (syms-count 0)
+         (target-override (cond ((member "--target" args) => cadr)
+                                (else #f)))
+         (files (if target-override (cddr args) (cdr args))))
+    (display ";;; do not edit --- generated ")
+    (display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
+    (newline)
+    (display "(define-module ")
+    (display (or target-override "(guile-user)"))
+    (for-each (lambda (file)
+                (cond ((autoload-info file)
+                       => (lambda (info)
+                            (and info
+                                 (apply (lambda (module-name exports)
+                                          (set! module-count (1+ module-count))
+                                          (set! syms-count (+ (length exports)
+                                                              syms-count))
+                                          (for-each display
+                                                    (list "\n  :autoload "
+                                                          module-name " "
+                                                          exports)))
+                                        info))))))
+              files)
+    (display ")")
+    (newline)
+    (for-each display (list "  ;;; "
+                            syms-count " symbols in "
+                            module-count " modules\n"))))
+
+(define main generate-autoload)
+
+;;; generate-autoload ends here
+;;; Help --- Show help on guild commands
+
+;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: help
+;;
+;; Show help for Guild scripts.
+
+;;; Code:
+
+(define-module (scripts help)
+  #\use-module (ice-9 format)
+  #\use-module (ice-9 documentation)
+  #\use-module ((srfi srfi-1) #\select (fold append-map))
+  #\export (show-help show-summary show-usage main))
+
+(define %summary "Show a brief help message.")
+(define %synopsis "help\nhelp --all\nhelp COMMAND")
+(define %help "
+Show help on guild commands.  With --all, show arcane incantations as
+well.  With COMMAND, show more detailed help for a particular command.
+")
+
+
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             ;; We really can't be adding e.g. ChangeLog-2008 to the set
+             ;; of runnable scripts, just because "" is a valid
+             ;; extension, by default.  So hack around that here.
+             (not (string-null? ext))
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (list-commands all?)
+  (display "\\
+Usage: guild COMMAND [ARGS]
+Run command-line scripts provided by GNU Guile and related programs.
+
+Commands:
+")
+
+  (for-each
+   (lambda (name)
+     (let* ((modname `(scripts ,(string->symbol name)))
+            (mod (resolve-module modname #\ensure #f))
+            (summary (and mod (and=> (module-variable mod '%summary)
+                                     variable-ref))))
+       (if (and mod
+                (or all?
+                    (let ((v (module-variable mod '%include-in-guild-list)))
+                      (if v (variable-ref v) #t))))
+           (if summary
+               (format #t "  ~A ~23t~a\n" name summary)
+               (format #t "  ~A\n" name)))))
+   (find-submodules '(scripts)))
+  (format #t "
+For help on a specific command, try \"guild help COMMAND\".
+
+Report guild bugs to ~a
+GNU Guile home page: <http://www.gnu.org/software/guile/>
+General help using GNU software: <http://www.gnu.org/gethelp/>
+For complete documentation, run: info guile 'Using Guile Tools'
+" %guile-bug-report-address))
+
+(define (module-commentary mod)
+  (file-commentary
+   (%search-load-path (module-filename mod))))
+
+(define (module-command-name mod)
+  (symbol->string (car (last-pair (module-name mod)))))
+
+(define* (show-usage mod #\optional (port (current-output-port)))
+  (let ((usages (string-split
+                 (let ((var (module-variable mod '%synopsis)))
+                   (if var
+                       (variable-ref var)
+                       (string-append (module-command-name mod)
+                                      " OPTION...")))
+                 #\newline)))
+    (display "Usage: guild " port)
+    (display (car usages))
+    (newline port)
+    (for-each (lambda (u)
+                (display "       guild " port)
+                (display u port)
+                (newline port))
+              (cdr usages))))
+
+(define* (show-summary mod #\optional (port (current-output-port)))
+  (let ((var (module-variable mod '%summary)))
+    (if var
+        (begin
+          (display (variable-ref var) port)
+          (newline port)))))
+
+(define* (show-help mod #\optional (port (current-output-port)))
+  (show-usage mod port)
+  (show-summary mod port)
+  (cond
+   ((module-variable mod '%help)
+    => (lambda (var)
+         (display (variable-ref var) port)
+         (newline port)))
+   ((module-commentary mod)
+    => (lambda (commentary)
+         (newline port)
+         (display commentary port)))
+   (else
+    (format #t "No documentation found for command \"~a\".\n"
+            (module-command-name mod)))))
+
+(define %mod (current-module))
+(define (main . args)
+  (cond
+   ((null? args)
+    (list-commands #f))
+   ((or (equal? args '("--all")) (equal? args '("-a")))
+    (list-commands #t))
+   ((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
+    ;; help for particular command
+    (let ((name (car args)))
+      (cond
+       ((resolve-module `(scripts ,(string->symbol name)) #\ensure #f)
+        => (lambda (mod)
+             (show-help mod)
+             (exit 0)))
+       (else
+        (format #t "No command named \"~a\".\n" name)
+        (exit 1)))))
+   (else
+    (show-help %mod (current-error-port))
+    (exit 1))))
+;;; lint --- Preemptive checks for coding errors in Guile Scheme code
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram
+
+;;; Commentary:
+
+;; Usage: lint FILE1 FILE2 ...
+;;
+;; Perform various preemptive checks for coding errors in Guile Scheme
+;; code.
+;;
+;; Right now, there is only one check available, for unresolved free
+;; variables.  The intention is that future lint-like checks will be
+;; implemented by adding to this script file.
+;;
+;; Unresolved free variables
+;; -------------------------
+;;
+;; Free variables are those whose definitions come from outside the
+;; module under investigation.  In Guile, these definitions are
+;; imported from other modules using `#\use-module' forms.
+;;
+;; This tool scans the specified files for unresolved free variables -
+;; i.e. variables for which you may have forgotten the appropriate
+;; `#\use-module', or for which the module that is supposed to export
+;; them forgot to.
+;;
+;; It isn't guaranteed that the scan will find absolutely all such
+;; errors.  Quoted (and quasiquoted) expressions are skipped, since
+;; they are most commonly used to describe constant data, not code, so
+;; code that is explicitly evaluated using `eval' will not be checked.
+;; For example, the `unresolved-var' in `(eval 'unresolved-var
+;; (current-module))' would be missed.
+;;
+;; False positives are also possible.  Firstly, the tool doesn't
+;; understand all possible forms of implicit quoting; in particular,
+;; it doesn't detect and expand uses of macros.  Secondly, it picks up
+;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
+;; Thirdly, there are occasional oddities like `next-method'.
+;; However, the number of false positives for realistic code is
+;; hopefully small enough that they can be individually considered and
+;; ignored.
+;;
+;; Example
+;; -------
+;;
+;; Note: most of the unresolved variables found in this example are
+;; false positives, as you would hope.  => scope for improvement.
+;;
+;; $ guild lint `guild`
+;; No unresolved free variables in PROGRAM
+;; No unresolved free variables in autofrisk
+;; No unresolved free variables in display-commentary
+;; Unresolved free variables in doc-snarf:
+;; 	   doc-snarf-version
+;; No unresolved free variables in frisk
+;; No unresolved free variables in generate-autoload
+;; No unresolved free variables in lint
+;; No unresolved free variables in punify
+;; No unresolved free variables in read-scheme-source
+;; Unresolved free variables in snarf-check-and-output-texi:
+;; 	   name
+;; 	   pos
+;; 	   line
+;; 	   x
+;; 	   rest
+;; 	   ...
+;; 	   do-argpos
+;; 	   do-command
+;; 	   do-args
+;; 	   type
+;; 	   num
+;; 	   file
+;; 	   do-arglist
+;; 	   req
+;; 	   opt
+;; 	   var
+;; 	   command
+;; 	   do-directive
+;; 	   s
+;; 	   ?
+;; No unresolved free variables in use2dot
+
+;;; Code:
+
+(define-module (scripts lint)
+  #\use-module (ice-9 common-list)
+  #\use-module (ice-9 format)
+  #\export (lint))
+
+(define %include-in-guild-list #f)
+(define %summary "Check for bugs and style errors in a Scheme file.")
+
+(define (lint filename)
+  (let ((module-name (scan-file-for-module-name filename))
+	(free-vars (uniq (scan-file-for-free-variables filename))))
+    (let ((module (resolve-module module-name))
+	  (all-resolved? #t))
+      (format #t "Resolved module: ~S\n" module)
+      (let loop ((free-vars free-vars))
+	(or (null? free-vars)
+	    (begin
+	      (catch #t
+		(lambda ()
+		  (eval (car free-vars) module))
+		(lambda args
+		  (if all-resolved?
+		      (format #t
+			      "Unresolved free variables in ~A:\n"
+			      filename))
+		  (write-char #\tab)
+		  (write (car free-vars))
+		  (newline)
+		  (set! all-resolved? #f)))
+	      (loop (cdr free-vars)))))
+      (if all-resolved?
+	  (format #t
+		  "No unresolved free variables in ~A\n"
+		  filename)))))
+
+(define (scan-file-for-module-name filename)
+  (with-input-from-file filename
+    (lambda ()
+      (let loop ((x (read)))
+	(cond ((eof-object? x) #f)
+	      ((and (pair? x)
+		    (eq? (car x) 'define-module))
+	       (cadr x))
+	      (else (loop (read))))))))
+
+(define (scan-file-for-free-variables filename)
+  (with-input-from-file filename
+    (lambda ()
+      (let loop ((x (read)) (fvlists '()))
+	(if (eof-object? x)
+	    (apply append fvlists)
+	    (loop (read) (cons (detect-free-variables x '()) fvlists)))))))
+
+; guile> (detect-free-variables '(let ((a 1)) a) '())
+; ()
+; guile> (detect-free-variables '(let ((a 1)) b) '())
+; (b)
+; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
+; (a)
+; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
+; ()
+; guile> (detect-free-variables '(define a 1) '())
+; ()
+; guile> (detect-free-variables '(define a b) '())
+; (b)
+; guile> (detect-free-variables '(define (a b c) b) '())
+; ()
+; guile> (detect-free-variables '(define (a b c) e) '())
+; (e)
+
+(define (detect-free-variables x locals)
+  ;; Given an expression @var{x} and a list @var{locals} of local
+  ;; variables (symbols) that are in scope for @var{x}, return a list
+  ;; of free variable symbols.
+  (cond ((symbol? x)
+	 (if (memq x locals) '() (list x)))
+
+	((pair? x)
+	 (case (car x)
+	   ((define-module define-generic quote quasiquote)
+	    ;; No code of interest in these expressions.
+	    '())
+
+	   ((let letrec)
+	    ;; Check for named let.  If there is a name, transform the
+	    ;; expression so that it looks like an unnamed let with
+	    ;; the name as one of the bindings.
+	    (if (symbol? (cadr x))
+		(set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
+				  (cdddr x))))
+	    ;; Unnamed let processing.
+	    (let ((letrec? (eq? (car x) 'letrec))
+		  (locals-for-let-body (append locals (map car (cadr x)))))
+	      (append (apply append
+			     (map (lambda (binding)
+				    (detect-free-variables (cadr binding)
+							   (if letrec?
+							       locals-for-let-body
+							       locals)))
+				  (cadr x)))
+		      (apply append
+			     (map (lambda (bodyform)
+				    (detect-free-variables bodyform
+							   locals-for-let-body))
+				  (cddr x))))))
+
+	   ((let* and-let*)
+	    ;; Handle bindings recursively.
+	    (if (null? (cadr x))
+		(apply append
+		       (map (lambda (bodyform)
+			      (detect-free-variables bodyform locals))
+			    (cddr x)))
+		(append (detect-free-variables (cadr (caadr x)) locals)
+			(detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
+					       (cons (caaadr x) locals)))))
+
+	   ((define define-public define-macro)
+	    (if (pair? (cadr x))
+		(begin
+		  (set! locals (cons (caadr x) locals))
+		  (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
+					 locals))
+		(begin
+		  (set! locals (cons (cadr x) locals))
+		  (detect-free-variables (caddr x) locals))))
+
+	   ((lambda lambda*)
+	    (let ((locals-for-lambda-body (let loop ((locals locals)
+						     (args (cadr x)))
+					    (cond ((null? args) locals)
+						  ((pair? args)
+						   (loop (cons (car args) locals)
+							 (cdr args)))
+						  (else
+						   (cons args locals))))))
+	      (apply append
+		     (map (lambda (bodyform)
+			    (detect-free-variables bodyform
+						   locals-for-lambda-body))
+			  (cddr x)))))
+
+	   ((receive)
+	    (let ((locals-for-receive-body (append locals (cadr x))))
+	      (apply append
+		     (detect-free-variables (caddr x) locals)
+		     (map (lambda (bodyform)
+			    (detect-free-variables bodyform
+						   locals-for-receive-body))
+			  (cdddr x)))))
+
+	   ((define-method define*)
+	    (let ((locals-for-method-body (let loop ((locals locals)
+						     (args (cdadr x)))
+					    (cond ((null? args) locals)
+						  ((pair? args)
+						   (loop (cons (if (pair? (car args))
+								   (caar args)
+								   (car args))
+							       locals)
+							 (cdr args)))
+						  (else
+						   (cons args locals))))))
+	      (apply append
+		     (map (lambda (bodyform)
+			    (detect-free-variables bodyform
+						   locals-for-method-body))
+			  (cddr x)))))
+
+	   ((define-class)
+	    ;; Avoid picking up slot names at the start of slot
+	    ;; definitions.
+	    (apply append
+		   (map (lambda (slot/option)
+			  (detect-free-variables-noncar (if (pair? slot/option)
+							    (cdr slot/option)
+							    slot/option)
+							locals))
+			(cdddr x))))
+
+	   ((case)
+	    (apply append
+		   (detect-free-variables (cadr x) locals)
+		   (map (lambda (case)
+			  (detect-free-variables (cdr case) locals))
+			(cddr x))))
+
+	   ((unquote unquote-splicing else =>)
+	    (detect-free-variables-noncar (cdr x) locals))
+
+	   (else (append (detect-free-variables (car x) locals)
+			 (detect-free-variables-noncar (cdr x) locals)))))
+
+	(else '())))
+
+(define (detect-free-variables-noncar x locals)
+  ;; Given an expression @var{x} and a list @var{locals} of local
+  ;; variables (symbols) that are in scope for @var{x}, return a list
+  ;; of free variable symbols.
+  (cond ((symbol? x)
+	 (if (memq x locals) '() (list x)))
+
+	((pair? x)
+	 (case (car x)
+	   ((=>)
+	    (detect-free-variables-noncar (cdr x) locals))
+
+	   (else (append (detect-free-variables (car x) locals)
+			 (detect-free-variables-noncar (cdr x) locals)))))
+
+	(else '())))
+
+(define (main . files)
+  (for-each lint files))
+
+;;; lint ends here
+;;; List --- List scripts that can be invoked by guild  -*- coding: iso-8859-1 -*-
+
+;;;; 	Copyright (C) 2009, 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
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guild.
+
+;;; Code:
+
+(define-module (scripts list)
+  #\use-module (srfi srfi-1)
+  #\export (list-scripts))
+
+(define %include-in-guild-list #f)
+(define %summary "An alias for \"help\".")
+
+
+(define (directory-files dir)
+  (if (and (file-exists? dir) (file-is-directory? dir))
+      (let ((dir-stream (opendir dir)))
+        (let loop ((new (readdir dir-stream))
+                   (acc '()))
+          (if (eof-object? new)
+              (begin
+                (closedir dir-stream)
+                acc)
+              (loop (readdir dir-stream)
+                    (if (or (string=? "."  new)             ; ignore
+                            (string=? ".." new))            ; ignore
+                        acc
+                        (cons new acc))))))
+      '()))
+
+(define (strip-extensions path)
+  (or-map (lambda (ext)
+            (and
+             (string-suffix? ext path)
+             ;; We really can't be adding e.g. ChangeLog-2008 to the set
+             ;; of runnable scripts, just because "" is a valid
+             ;; extension, by default.  So hack around that here.
+             (not (string-null? ext))
+             (substring path 0
+                        (- (string-length path) (string-length ext)))))
+          (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+  (cond ((null? l) l)
+        ((null? (cdr l)) l)
+        ((equal? (car l) (cadr l)) (unique (cdr l)))
+        (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+  (let ((shead (map symbol->string head)))
+    (unique
+     (sort
+      (append-map (lambda (path)
+                    (fold (lambda (x rest)
+                            (let ((stripped (strip-extensions x)))
+                              (if stripped (cons stripped rest) rest)))
+                          '()
+                          (directory-files
+                           (fold (lambda (x y) (in-vicinity y x)) path shead))))
+                  %load-path)
+      string<?))))
+
+(define (list-scripts . args)
+  (for-each (lambda (x)
+              ;; would be nice to show a summary.
+              (format #t "~A\n" x))
+            (find-submodules '(scripts))))
+
+(define (main . args)
+  (apply (@@ (scripts help) main) args))
+;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
+
+;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: punify FILE1 FILE2 ...
+;;
+;; Each file's forms are read and written to stdout.
+;; The effect is to remove comments and much non-essential whitespace.
+;; This is useful when installing Scheme source to space-limited media.
+;;
+;; Example:
+;; $ wc ./punify ; ./punify ./punify | wc
+;;     89     384    3031 ./punify
+;;      0      42     920
+;;
+;; TODO: Read from stdin.
+;;       Handle vectors.
+;;       Identifier punification.
+
+;;; Code:
+
+(define-module (scripts punify)
+  \:export (punify))
+
+(define %include-in-guild-list #f)
+(define %summary "Strip comments and whitespace from a Scheme file.")
+
+(define (write-punily form)
+  (cond ((and (list? form) (not (null? form)))
+         (let ((first (car form)))
+           (display "(")
+           (write-punily first)
+           (let loop ((ls (cdr form)) (last-was-list? (list? first)))
+             (if (null? ls)
+                 (display ")")
+                 (let* ((new-first (car ls))
+                        (this-is-list? (list? new-first)))
+                   (and (not last-was-list?)
+                        (not this-is-list?)
+                        (display " "))
+                   (write-punily new-first)
+                   (loop (cdr ls) this-is-list?))))))
+        ((and (symbol? form)
+              (let ((ls (string->list (symbol->string form))))
+                (and (char=? (car ls) #\:)
+                     (not (memq #\space ls))
+                     (list->string (cdr ls)))))
+         => (lambda (symbol-name-after-colon)
+              (display #\:)
+              (display symbol-name-after-colon)))
+        (else (write form))))
+
+(define (punify-one file)
+  (with-input-from-file file
+    (lambda ()
+      (let ((toke (lambda () (read (current-input-port)))))
+        (let loop ((form (toke)))
+          (or (eof-object? form)
+              (begin
+                (write-punily form)
+                (loop (toke)))))))))
+
+(define (punify . args)
+  (for-each punify-one args))
+
+(define main punify)
+
+;;; punify ends here
+;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
+
+;; 	Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-rfc822 FILE
+;;
+;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
+;; This is not very interesting, admittedly.
+;;
+;; For Scheme programming, this module exports two procs:
+;;   (read-rfc822 . args)               ; only first arg used
+;;   (read-rfc822-silently port)
+;;
+;; Parse FILE (a string) or PORT, respectively, and return a query proc that
+;; takes a symbol COMP, and returns the message component COMP.  Supported
+;; values for COMP (and the associated query return values) are:
+;;   from       -- #f (reserved for future mbox support)
+;;   headers    -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
+;;   body       -- rest of the mail message, a string
+;;   body-lines -- rest of the mail message, as a list of lines
+;; Any other query results in a "bad component" error.
+;;
+;; TODO: Add "-m" option (mbox support).
+
+;;; Code:
+
+(define-module (scripts read-rfc822)
+  \:use-module (ice-9 regex)
+  \:use-module (ice-9 rdelim)
+  \:autoload (srfi srfi-13) (string-join)
+  \:export (read-rfc822 read-rfc822-silently))
+
+(define %include-in-guild-list #f)
+(define %summary "Validate an RFC822-style file.")
+
+(define from-line-rx   (make-regexp "^From "))
+(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
+(define header-cont-rx (make-regexp "^[ \t]+"))
+
+(define option #f)                      ; for future "-m"
+
+(define (drain-message port)
+  (let loop ((line (read-line port)) (acc '()))
+    (cond ((eof-object? line)
+           (reverse acc))
+          ((and option (regexp-exec from-line-rx line))
+           (for-each (lambda (c)
+                       (unread-char c port))
+                     (cons #\newline
+                           (reverse (string->list line))))
+           (reverse acc))
+          (else
+           (loop (read-line port) (cons line acc))))))
+
+(define (parse-message port)
+  (let* ((from (and option
+                    (match:suffix (regexp-exec from-line-rx
+                                               (read-line port)))))
+         (body-lines #f)
+         (body #f)
+         (headers '())
+         (add-header! (lambda (reversed-hlines)
+                        (let* ((hlines (reverse reversed-hlines))
+                               (first (car hlines))
+                               (m (regexp-exec header-name-rx first))
+                               (name (string->symbol (match:substring m 1)))
+                               (data (string-join
+                                      (cons (substring first (match:end m))
+                                            (cdr hlines))
+                                      " ")))
+                          (set! headers (acons name data headers))))))
+    ;; "From " is only one line
+    (let loop ((line (read-line port)) (current-header #f))
+      (cond ((string-null? line)
+             (and current-header (add-header! current-header))
+             (set! body-lines (drain-message port)))
+            ((regexp-exec header-cont-rx line)
+             => (lambda (m)
+                  (loop (read-line port)
+                        (cons (match:suffix m) current-header))))
+            (else
+             (and current-header (add-header! current-header))
+             (loop (read-line port) (list line)))))
+    (set! headers (reverse headers))
+    (lambda (component)
+      (case component
+        ((from) from)
+        ((body-lines) body-lines)
+        ((headers) headers)
+        ((body) (or body
+                    (begin (set! body (string-join body-lines "\n" 'suffix))
+                           body)))
+        (else (error "bad component:" component))))))
+
+(define (read-rfc822-silently port)
+  (parse-message port))
+
+(define (display-rfc822 parse)
+  (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
+  (for-each (lambda (header)
+              (format #t "~A: ~A\n" (car header) (cdr header)))
+            (parse 'headers))
+  (format #t "\n~A" (parse 'body)))
+
+(define (read-rfc822 . args)
+  (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
+    (display-rfc822 parse))
+  #t)
+
+(define main read-rfc822)
+
+;;; read-rfc822 ends here
+;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: read-scheme-source FILE1 FILE2 ...
+;;
+;; This program parses each FILE and writes to stdout sexps that describe the
+;; top-level structures of the file: scheme forms, single-line comments, and
+;; hash-bang comments.  You can further process these (to associate comments
+;; w/ scheme forms as a kind of documentation, for example).
+;;
+;; The output sexps have one of these forms:
+;;
+;;    (quote (filename FILENAME))
+;;
+;;    (quote (comment :leading-semicolons N
+;;                    :text LINE))
+;;
+;;    (quote (whitespace :text LINE))
+;;
+;;    (quote (hash-bang-comment :line LINUM
+;;                              :line-count N
+;;                              :text-list (LINE1 LINE2 ...)))
+;;
+;;    (quote (following-form-properties :line LINUM
+;;                                      :line-count N)
+;;                                      :type TYPE
+;;                                      :signature SIGNATURE
+;;                                      :std-int-doc DOCSTRING))
+;;
+;;    SEXP
+;;
+;; The first four are straightforward (both FILENAME and LINE are strings sans
+;; newline, while LINUM and N are integers).  The last two always go together,
+;; in that order.  SEXP is scheme code processed only by `read' and then
+;; `write'.
+;;
+;; The :type field may be omitted if the form is not recognized.  Otherwise,
+;; TYPE may be one of: procedure, alias, define-module, variable.
+;;
+;; The :signature field may be omitted if the form is not a procedure.
+;; Otherwise, SIGNATURE is a list showing the procedure's signature.
+;;
+;; If the type is `procedure' and the form has a standard internal docstring
+;; (first body form a string), that is extracted in full -- including any
+;; embedded newlines -- and recorded by field :std-int-doc.
+;;
+;;
+;; Usage from a program: The output list of sexps can be retrieved by scheme
+;; programs w/o having to capture stdout, like so:
+;;
+;;    (use-modules (scripts read-scheme-source))
+;;    (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
+;;
+;; There are also two convenience procs exported for use by Scheme programs:
+;;
+;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
+;;                   have the same number of leading semicolons.
+;;
+;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
+;;                        the ":tags", and return alist of (TAG . VAL) elems.
+;;
+;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
+;;       Make `annotate!' extensible.
+
+;;; Code:
+
+(define-module (scripts read-scheme-source)
+  \:use-module (ice-9 rdelim)
+  \:export (read-scheme-source
+           read-scheme-source-silently
+           quoted?
+           clump))
+
+(define %include-in-guild-list #f)
+(define %summary "Print a parsed representation of a Scheme file.")
+
+;; Try to figure out what FORM is and its various attributes.
+;; Call proc NOTE! with key (a symbol) and value.
+;;
+(define (annotate! form note!)
+  (cond ((and (list? form)
+              (< 2 (length form))
+              (eq? 'define (car form))
+              (pair? (cadr form))
+              (symbol? (caadr form)))
+         (note! '\:type 'procedure)
+         (note! '\:signature (cadr form))
+         (and (< 3 (length form))
+              (string? (caddr form))
+              (note! '\:std-int-doc (caddr form))))
+        ((and (list? form)
+              (< 2 (length form))
+              (eq? 'define (car form))
+              (symbol? (cadr form))
+              (list? (caddr form))
+              (< 3 (length (caddr form)))
+              (eq? 'lambda (car (caddr form)))
+              (string? (caddr (caddr form))))
+         (note! '\:type 'procedure)
+         (note! '\:signature (cons (cadr form) (cadr (caddr form))))
+         (note! '\:std-int-doc (caddr (caddr form))))
+        ((and (list? form)
+              (= 3 (length form))
+              (eq? 'define (car form))
+              (symbol? (cadr form))
+              (symbol? (caddr form)))
+         (note! '\:type 'alias))
+        ((and (list? form)
+              (eq? 'define-module (car form)))
+         (note! '\:type 'define-module))
+        ;; Add other types here.
+        (else (note! '\:type 'variable))))
+
+;; Process FILE, calling NB! on parsed top-level elements.
+;; Recognized: #!-!# and regular comments in addition to normal forms.
+;;
+(define (process file nb!)
+  (nb! `'(filename ,file))
+  (let ((hash-bang-rx (make-regexp "^#!"))
+        (bang-hash-rx (make-regexp "^!#"))
+        (all-comment-rx (make-regexp "^[ \t]*(;+)"))
+        (all-whitespace-rx (make-regexp "^[ \t]*$"))
+        (p (open-input-file file)))
+    (let loop ((n (1+ (port-line p))) (line (read-line p)))
+      (or (not n)
+          (eof-object? line)
+          (begin
+            (cond ((regexp-exec hash-bang-rx line)
+                   (let loop ((line (read-line p))
+                              (text (list line)))
+                     (if (or (eof-object? line)
+                             (regexp-exec bang-hash-rx line))
+                         (nb! `'(hash-bang-comment
+                                 \:line ,n
+                                 \:line-count ,(1+ (length text))
+                                 \:text-list ,(reverse
+                                              (cons line text))))
+                         (loop (read-line p)
+                               (cons line text)))))
+                  ((regexp-exec all-whitespace-rx line)
+                   (nb! `'(whitespace \:text ,line)))
+                  ((regexp-exec all-comment-rx line)
+                   => (lambda (m)
+                        (nb! `'(comment
+                                \:leading-semicolons
+                                ,(let ((m1 (vector-ref m 1)))
+                                   (- (cdr m1) (car m1)))
+                                \:text ,line))))
+                  (else
+                   (unread-string line p)
+                   (let* ((form (read p))
+                          (count (- (port-line p) n))
+                          (props (let* ((props '())
+                                        (prop+ (lambda args
+                                                 (set! props
+                                                       (append props args)))))
+                                   (annotate! form prop+)
+                                   props)))
+                     (or (= count 1)    ; ugh
+                         (begin
+                           (read-line p)
+                           (set! count (1+ count))))
+                     (nb! `'(following-form-properties
+                             \:line ,n
+                             \:line-count ,count
+                             ,@props))
+                     (nb! form))))
+            (loop (1+ (port-line p)) (read-line p)))))))
+
+;;; entry points
+
+(define (read-scheme-source-silently . files)
+  "See commentary in module (scripts read-scheme-source)."
+  (let* ((res '()))
+    (for-each (lambda (file)
+                (process file (lambda (e) (set! res (cons e res)))))
+              files)
+    (reverse res)))
+
+(define (read-scheme-source . files)
+  "See commentary in module (scripts read-scheme-source)."
+  (for-each (lambda (file)
+              (process file (lambda (e) (write e) (newline))))
+            files))
+
+;; Recognize:          (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
+;; and return alist:   ((TAG1 . VAL1) (TAG2 . VAL2) ...)
+;; where the tags are symbols.
+;;
+(define (quoted? sym form)
+  (and (list? form)
+       (= 2 (length form))
+       (eq? 'quote (car form))
+       (let ((inside (cadr form)))
+         (and (list? inside)
+              (< 0 (length inside))
+              (eq? sym (car inside))
+              (let loop ((ls (cdr inside)) (alist '()))
+                (if (null? ls)
+                    alist               ; retval
+                    (let ((first (car ls)))
+                      (or (symbol? first)
+                          (error "bad list!"))
+                      (loop (cddr ls)
+                            (acons (string->symbol
+                                    (substring (symbol->string first) 1))
+                                   (cadr ls)
+                                   alist)))))))))
+
+;; Filter FORMS, combining contiguous comment forms that have the same number
+;; of leading semicolons.  Do not include in them whitespace lines.
+;; Whitespace lines outside of such comment groupings are ignored, as are
+;; hash-bang comments.  All other forms are passed through unchanged.
+;;
+(define (clump forms)
+  (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
+    (if (null? forms)
+        (reverse acc)                   ; retval
+        (let ((form (car forms)))
+          (cond (pass-this-one-through?
+                 (loop (cdr forms) (cons form acc) #f))
+                ((quoted? 'following-form-properties form)
+                 (loop (cdr forms) (cons form acc) #t))
+                ((quoted? 'whitespace form)             ;;; ignore
+                 (loop (cdr forms) acc #f))
+                ((quoted? 'hash-bang-comment form)      ;;; ignore for now
+                 (loop (cdr forms) acc #f))
+                ((quoted? 'comment form)
+                 => (lambda (alist)
+                      (let cloop ((inner-forms (cdr forms))
+                                  (level (assq-ref alist 'leading-semicolons))
+                                  (text (list (assq-ref alist 'text))))
+                        (let ((up (lambda ()
+                                    (loop inner-forms
+                                          (cons (cons level (reverse text))
+                                                acc)
+                                          #f))))
+                          (if (null? inner-forms)
+                              (up)
+                              (let ((inner-form (car inner-forms)))
+                                (cond ((quoted? 'comment inner-form)
+                                       => (lambda (inner-alist)
+                                            (let ((new-level
+                                                   (assq-ref
+                                                    inner-alist
+                                                    'leading-semicolons)))
+                                              (if (= new-level level)
+                                                  (cloop (cdr inner-forms)
+                                                         level
+                                                         (cons (assq-ref
+                                                                inner-alist
+                                                                'text)
+                                                               text))
+                                                  (up)))))
+                                      (else (up)))))))))
+                (else (loop (cdr forms) (cons form acc) #f)))))))
+
+;;; script entry point
+
+(define main read-scheme-source)
+
+;;; read-scheme-source ends here
+;;; read-text-outline --- Read a text outline and display it as a sexp
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-text-outline OUTLINE
+;;
+;; Scan OUTLINE file and display a list of trees, the structure of
+;; each reflecting the "levels" in OUTLINE.  The recognized outline
+;; format (used to indicate outline headings) is zero or more pairs of
+;; leading spaces followed by "-".  Something like:
+;;
+;;    - a                  0
+;;      - b                1
+;;        - c              2
+;;      - d                1
+;;    - e                  0
+;;      - f                1
+;;        - g              2
+;;      - h                1
+;;
+;; In this example the levels are shown to the right.  The output for
+;; such a file would be the single line:
+;;
+;;   (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
+;;
+;; Basically, anything at the beginning of a list is a parent, and the
+;; remaining elements of that list are its children.
+;;
+;;
+;; Usage from a Scheme program: These two procs are exported:
+;;
+;;   (read-text-outline . args)           ; only first arg is used
+;;   (read-text-outline-silently port)
+;;   (make-text-outline-reader re specs)
+;;
+;; `make-text-outline-reader' returns a proc that reads from PORT and
+;; returns a list of trees (similar to `read-text-outline-silently').
+;;
+;; RE is a regular expression (string) that is used to identify a header
+;; line of the outline (as opposed to a whitespace line or intervening
+;; text).  RE must begin w/ a sub-expression to match the "level prefix"
+;; of the line.  You can use `level-submatch-number' in SPECS (explained
+;; below) to specify a number other than 1, the default.
+;;
+;; Normally, the level of the line is taken directly as the length of
+;; its level prefix.  This often results in adjacent levels not mapping
+;; to adjacent numbers, which confuses the tree-building portion of the
+;; program, which expects top-level to be 0, first sub-level to be 1,
+;; etc.  You can use `level-substring-divisor' or `compute-level' in
+;; SPECS to specify a constant scaling factor or specify a completely
+;; alternative procedure, respectively.
+;;
+;; SPECS is an alist which may contain the following key/value pairs:
+;;
+;; - level-submatch-number NUMBER
+;; - level-substring-divisor NUMBER
+;; - compute-level PROC
+;; - body-submatch-number NUMBER
+;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
+;;
+;; The PROC value associated with key `compute-level' should take a
+;; Scheme match structure (as returned by `regexp-exec') and return a
+;; number, the normalized level for that line.  If this is specified,
+;; it takes precedence over other level-computation methods.
+;;
+;; Use `body-submatch-number' if RE specifies the whole body, or if you
+;; want to make use of the extra fields parsing.  The `extra-fields'
+;; value is a sub-alist, whose keys name additional fields that are to
+;; be recognized.  These fields along with `level' are set as object
+;; properties of the final string ("body") that is consed into the tree.
+;; If a field name ends in "?" the field value is set to be #t if there
+;; is a match and the result is not an empty string, and #f otherwise.
+;;
+;;
+;; Bugs and caveats:
+;;
+;; (1) Only the first file specified on the command line is scanned.
+;; (2) TAB characters at the beginnings of lines are not recognized.
+;; (3) Outlines that "skip" levels signal an error.  In other words,
+;;     this will fail:
+;;
+;;            - a               0
+;;              - b             1
+;;                  - c         3       <-- skipped 2 -- error!
+;;              - d             1
+;;
+;;
+;; TODO: Determine what's the right thing to do for skips.
+;;       Handle TABs.
+;;       Make line format customizable via longopts.
+
+;;; Code:
+
+(define-module (scripts read-text-outline)
+  \:export (read-text-outline
+           read-text-outline-silently
+           make-text-outline-reader)
+  \:use-module (ice-9 regex)
+  \:autoload (ice-9 rdelim) (read-line)
+  \:autoload (ice-9 getopt-long) (getopt-long))
+
+(define %include-in-guild-list #f)
+(define %summary "Convert textual outlines to s-expressions.")
+
+(define (?? symbol)
+  (let ((name (symbol->string symbol)))
+    (string=? "?" (substring name (1- (string-length name))))))
+
+(define (msub n)
+  (lambda (m)
+    (match:substring m n)))
+
+(define (??-predicates pair)
+  (cons (car pair)
+        (if (?? (car pair))
+            (lambda (m)
+              (not (string=? "" (match:substring m (cdr pair)))))
+            (msub (cdr pair)))))
+
+(define (make-line-parser re specs)
+  (let* ((rx (let ((fc (substring re 0 1)))
+               (make-regexp (if (string=? "^" fc)
+                                re
+                                (string-append "^" re)))))
+         (check (lambda (key)
+                  (assq-ref specs key)))
+         (level-substring (msub (or (check 'level-submatch-number) 1)))
+         (extract-level (cond ((check 'compute-level)
+                               => (lambda (proc)
+                                    (lambda (m)
+                                      (proc m))))
+                              ((check 'level-substring-divisor)
+                               => (lambda (n)
+                                    (lambda (m)
+                                      (/ (string-length (level-substring m))
+                                         n))))
+                              (else
+                               (lambda (m)
+                                 (string-length (level-substring m))))))
+         (extract-body (cond ((check 'body-submatch-number)
+                              => msub)
+                             (else
+                              (lambda (m) (match:suffix m)))))
+         (misc-props! (cond ((check 'extra-fields)
+                             => (lambda (alist)
+                                  (let ((new (map ??-predicates alist)))
+                                    (lambda (obj m)
+                                      (for-each
+                                       (lambda (pair)
+                                         (set-object-property!
+                                          obj (car pair)
+                                          ((cdr pair) m)))
+                                       new)))))
+                            (else
+                             (lambda (obj m) #t)))))
+    ;; retval
+    (lambda (line)
+      (cond ((regexp-exec rx line)
+             => (lambda (m)
+                  (let ((level (extract-level m))
+                        (body  (extract-body m)))
+                    (set-object-property! body 'level level)
+                    (misc-props! body m)
+                    body)))
+            (else #f)))))
+
+(define (make-text-outline-reader re specs)
+  (let ((parse-line (make-line-parser re specs)))
+    ;; retval
+    (lambda (port)
+      (let* ((all '(start))
+             (pchain (list)))           ; parents chain
+        (let loop ((line (read-line port))
+                   (prev-level -1)      ; how this relates to the first input
+                                        ; level determines whether or not we
+                                        ; start in "sibling" or "child" mode.
+                                        ; in the end, `start' is ignored and
+                                        ; it's much easier to ignore parents
+                                        ; than siblings (sometimes).  this is
+                                        ; not to encourage ignorance, however.
+                   (tp all))            ; tail pointer
+          (or (eof-object? line)
+              (cond ((parse-line line)
+                     => (lambda (w)
+                          (let* ((words (list w))
+                                 (level (object-property w 'level))
+                                 (diff (- level prev-level)))
+                            (cond
+
+                             ;; sibling
+                             ((zero? diff)
+                              ;; just extend the chain
+                              (set-cdr! tp words))
+
+                             ;; child
+                             ((positive? diff)
+                              (or (= 1 diff)
+                                  (error "unhandled diff not 1:" diff line))
+                              ;; parent may be contacted by uncle later (kids
+                              ;; these days!) so save its level
+                              (set-object-property! tp 'level prev-level)
+                              (set! pchain (cons tp pchain))
+                              ;; "push down" car into hierarchy
+                              (set-car! tp (cons (car tp) words)))
+
+                             ;; uncle
+                             ((negative? diff)
+                              ;; prune back to where levels match
+                              (do ((p pchain (cdr p)))
+                                  ((= level (object-property (car p) 'level))
+                                   (set! pchain p)))
+                              ;; resume at this level
+                              (set-cdr! (car pchain) words)
+                              (set! pchain (cdr pchain))))
+
+                            (loop (read-line port) level words))))
+                    (else (loop (read-line port) prev-level tp)))))
+        (set! all (car all))
+        (if (eq? 'start all)
+            '()                         ; wasteland
+            (cdr all))))))
+
+(define read-text-outline-silently
+  (make-text-outline-reader "(([ ][ ])*)- *"
+                            '((level-substring-divisor . 2))))
+
+(define (read-text-outline . args)
+  (write (read-text-outline-silently (open-file (car args) "r")))
+  (newline)
+  #t)                                   ; exit val
+
+(define main read-text-outline)
+
+;;; read-text-outline ends here
+;;; scan-api --- Scan and group interpreter and libguile interface elements
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
+;;
+;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
+;; shared-object library, to determine available interface elements, and
+;; display them to stdout as an alist:
+;;
+;;   ((meta ...) (interface ...))
+;;
+;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
+;; `libguileinterface', `sofile' and `groups'.  The interface elements are in
+;; turn sub-alists w/ keys `groups' and `scan-data'.  Interface elements
+;; initially belong in one of two groups `Scheme' or `C' (but not both --
+;; signal error if that happens).
+;;
+;; Optional GROUPINGS ... are files each containing a single "grouping
+;; definition" alist with each entry of the form:
+;;
+;;   (NAME (description "DESCRIPTION") (members SYM...))
+;;
+;; All of the SYM... should be proper subsets of the interface.  In addition
+;; to `description' and `members' forms, the entry may optionally include:
+;;
+;;   (grok USE-MODULES (lambda (x) CODE))
+;;
+;; where CODE implements a group-membership predicate to be applied to `x', a
+;; symbol.  [When evaluated, CODE can assume (use-modules MODULE) has been
+;; executed where MODULE is an element of USE-MODULES, a list.  [NOT YET
+;; IMPLEMENTED!]]
+;;
+;; Currently, there are two convenience predicates that operate on `x':
+;;   (in-group? x GROUP)
+;;   (name-prefix? x PREFIX)
+;;
+;; TODO: Allow for concurrent Scheme/C membership.
+;;       Completely separate reporting.
+
+;;; Code:
+
+(define-module (scripts scan-api)
+  \:use-module (ice-9 popen)
+  \:use-module (ice-9 rdelim)
+  \:use-module (ice-9 regex)
+  \:export (scan-api))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate an API description for a Guile extension.")
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (add-props object . args)
+  (let loop ((args args))
+    (if (null? args)
+        object                          ; retval
+        (let ((key (car args))
+              (value (cadr args)))
+          (put object key value)
+          (loop (cddr args))))))
+
+(define (scan re command match)
+  (let ((rx (make-regexp re))
+        (port (open-pipe command OPEN_READ)))
+    (let loop ((line (read-line port)))
+      (or (eof-object? line)
+          (begin
+            (cond ((regexp-exec rx line) => match))
+            (loop (read-line port)))))))
+
+(define (scan-Scheme! ht guile)
+  (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
+        (format #f "~A -c '~S ~S'"
+                guile
+                '(use-modules (ice-9 session))
+                '(apropos "."))
+        (lambda (m)
+          (let ((x (string->symbol (match:substring m 1))))
+            (put x 'Scheme (or (match:substring m 3)
+                               ""))
+            (hashq-set! ht x #t)))))
+
+(define (scan-C! ht sofile)
+  (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
+        (format #f "nm ~A" sofile)
+        (lambda (m)
+          (let ((x (string->symbol (match:substring m 2))))
+            (put x 'C (string->symbol (match:substring m 1)))
+            (and (hashq-get-handle ht x)
+                 (error "both Scheme and C:" x))
+            (hashq-set! ht x #t)))))
+
+(define THIS-MODULE (current-module))
+
+(define (in-group? x group)
+  (memq group (get x 'groups)))
+
+(define (name-prefix? x prefix)
+  (string-match (string-append "^" prefix) (symbol->string x)))
+
+(define (add-group-name! x name)
+  (put x 'groups (cons name (get x 'groups))))
+
+(define (make-grok-proc name form)
+  (let* ((predicate? (eval form THIS-MODULE))
+         (p (lambda (x)
+              (and (predicate? x)
+                   (add-group-name! x name)))))
+    (put p 'name name)
+    p))
+
+(define (make-members-proc name members)
+  (let ((p (lambda (x)
+             (and (memq x members)
+                  (add-group-name! x name)))))
+    (put p 'name name)
+    p))
+
+(define (make-grouper files)            ; \/^^^o/ . o
+  (let ((hook (make-hook 1)))           ; /\____\
+    (for-each
+     (lambda (file)
+       (for-each
+        (lambda (gdef)
+          (let ((name (car gdef))
+                (members (assq-ref gdef 'members))
+                (grok (assq-ref gdef 'grok)))
+            (or members grok
+                (error "bad grouping, must have `members' or `grok'"))
+            (add-hook! hook
+                       (if grok
+                           (add-props (make-grok-proc name (cadr grok))
+                                      'description
+                                      (assq-ref gdef 'description))
+                           (make-members-proc name members))
+                       #t)))            ; append
+        (read (open-file file OPEN_READ))))
+     files)
+    hook))
+
+(define (scan-api . args)
+  (let ((guile (list-ref args 0))
+        (sofile (list-ref args 1))
+        (grouper (false-if-exception (make-grouper (cddr args))))
+        (ht (make-hash-table 3331)))
+    (scan-Scheme! ht guile)
+    (scan-C!      ht sofile)
+    (let ((all (sort (hash-fold (lambda (key value prior-result)
+                                  (add-props
+                                   key
+                                   'string (symbol->string key)
+                                   'scan-data (or (get key 'Scheme)
+                                                  (get key 'C))
+                                   'groups (if (get key 'Scheme)
+                                               '(Scheme)
+                                               '(C)))
+                                  (and grouper (run-hook grouper key))
+                                  (cons key prior-result))
+                                '()
+                                ht)
+                     (lambda (a b)
+                       (string<? (get a 'string)
+                                 (get b 'string))))))
+      (format #t ";;; generated by scan-api -- do not edit!\n\n")
+      (format #t "(\n")
+      (format #t "(meta\n")
+      (format #t "  (GUILE_LOAD_PATH . ~S)\n"
+              (or (getenv "GUILE_LOAD_PATH") ""))
+      (format #t "  (LTDL_LIBRARY_PATH . ~S)\n"
+              (or (getenv "LTDL_LIBRARY_PATH") ""))
+      (format #t "  (guile . ~S)\n" guile)
+      (format #t "  (libguileinterface . ~S)\n"
+              (let ((i #f))
+                (scan "(.+)"
+                      (format #f "~A -c '(display ~A)'"
+                              guile
+                              '(assq-ref %guile-build-info
+                                         'libguileinterface))
+                      (lambda (m) (set! i (match:substring m 1))))
+                i))
+      (format #t "  (sofile . ~S)\n" sofile)
+      (format #t "  ~A\n"
+              (cons 'groups (append (if grouper
+                                        (map (lambda (p) (get p 'name))
+                                             (hook->list grouper))
+                                        '())
+                                    '(Scheme C))))
+      (format #t ") ;; end of meta\n")
+      (format #t "(interface\n")
+      (for-each (lambda (x)
+                  (format #t "(~A ~A (scan-data ~S))\n"
+                          x
+                          (cons 'groups (get x 'groups))
+                          (get x 'scan-data)))
+                all)
+      (format #t ") ;; end of interface\n")
+      (format #t ") ;; eof\n")))
+  #t)
+
+(define main scan-api)
+
+;;; scan-api ends here
+;;; snarf-check-and-output-texi --- called by the doc snarfer.
+
+;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Michael Livshin
+
+;;; Code:
+
+(define-module (scripts snarf-check-and-output-texi)
+    \:use-module (ice-9 streams)
+    \:use-module (ice-9 match)
+    \:export (snarf-check-and-output-texi))
+
+(define %include-in-guild-list #f)
+(define %summary "Transform snarfed .doc files into texinfo documentation.")
+
+;;; why aren't these in some module?
+
+(define-macro (when cond . body)
+  `(if ,cond (begin ,@body)))
+
+(define-macro (unless cond . body)
+  `(if (not ,cond) (begin ,@body)))
+
+(define *manual-flag* #f)
+
+(define (snarf-check-and-output-texi . flags)
+  (if (member "--manual" flags)
+      (set! *manual-flag* #t))
+  (process-stream (current-input-port)))
+
+(define (process-stream port)
+  (let loop ((input (stream-map (match-lambda
+                                 (('id . s)
+                                  (cons 'id (string->symbol s)))
+                                 (('int_dec . s)
+                                  (cons 'int (string->number s)))
+                                 (('int_oct . s)
+                                  (cons 'int (string->number s 8)))
+                                 (('int_hex . s)
+                                  (cons 'int (string->number s 16)))
+                                 ((and x (? symbol?))
+                                  (cons x x))
+                                 ((and x (? string?))
+                                  (cons 'string x))
+                                 (x x))
+                                (make-stream (lambda (s)
+                                               (let loop ((s s))
+                                                 (cond
+                                                   ((stream-null? s) #t)
+                                                   ((memq (stream-car s) '(eol hash))
+                                                    (loop (stream-cdr s)))
+                                                   (else (cons (stream-car s) (stream-cdr s))))))
+                                             (port->stream port read)))))
+
+    (unless (stream-null? input)
+      (let ((token (stream-car input)))
+        (if (eq? (car token) 'snarf_cookie)
+          (dispatch-top-cookie (stream-cdr input)
+                               loop)
+          (loop (stream-cdr input)))))))
+
+(define (dispatch-top-cookie input cont)
+
+  (when (stream-null? input)
+    (error 'syntax "premature end of file"))
+
+  (let ((token (stream-car input)))
+    (cond
+      ((eq? (car token) 'brace_open)
+       (consume-multiline (stream-cdr input)
+                          cont))
+      (else
+       (consume-upto-cookie process-singleline
+                            input
+                            cont)))))
+
+(define (consume-upto-cookie process input cont)
+  (let loop ((acc '()) (input input))
+
+    (when (stream-null? input)
+      (error 'syntax "premature end of file in directive context"))
+
+    (let ((token (stream-car input)))
+      (cond
+        ((eq? (car token) 'snarf_cookie)
+         (process (reverse! acc))
+         (cont (stream-cdr input)))
+
+        (else (loop (cons token acc) (stream-cdr input)))))))
+
+(define (consume-multiline input cont)
+  (begin-multiline)
+
+  (let loop ((input input))
+
+    (when (stream-null? input)
+      (error 'syntax "premature end of file in multiline context"))
+
+    (let ((token (stream-car input)))
+      (cond
+        ((eq? (car token) 'brace_close)
+         (end-multiline)
+         (cont (stream-cdr input)))
+
+        (else (consume-upto-cookie process-multiline-directive
+                                   input
+                                   loop))))))
+
+(define *file* #f)
+(define *line* #f)
+(define *c-function-name* #f)
+(define *function-name* #f)
+(define *snarf-type* #f)
+(define *args* #f)
+(define *sig* #f)
+(define *docstring* #f)
+
+(define (begin-multiline)
+  (set! *file* #f)
+  (set! *line* #f)
+  (set! *c-function-name* #f)
+  (set! *function-name* #f)
+  (set! *snarf-type* #f)
+  (set! *args* #f)
+  (set! *sig* #f)
+  (set! *docstring* #f))
+
+(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
+(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
+
+(define (end-multiline)
+  (let* ((req (car *sig*))
+         (opt (cadr *sig*))
+         (var (caddr *sig*))
+         (all (+ req opt var)))
+    (if (and (not (eqv? *snarf-type* 'register))
+             (not (= (length *args*) all)))
+      (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
+             *file* *line* *function-name* (length *args*) all)))
+    (let ((nice-sig
+            (if (eq? *snarf-type* 'register)
+              *function-name*
+              (with-output-to-string
+                (lambda ()
+                  (format #t "~A" *function-name*)
+                  (let loop-req ((args *args*) (r 0))
+                    (if (< r req)
+                      (begin
+                       (format #t " ~A" (car args))
+                       (loop-req (cdr args) (+ 1 r)))
+                      (let loop-opt ((o 0) (args args) (tail '()))
+                       (if (< o opt)
+                         (begin
+                          (format #t " [~A" (car args))
+                          (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
+                         (begin
+                          (if (> var 0)
+                            (format #t " . ~A"
+                                    (car args)))
+                          (let loop-tail ((tail tail))
+                               (if (not (null? tail))
+                                 (begin
+                                  (format #t "~A" (car tail))
+                                  (loop-tail (cdr tail))))))))))))))
+	  (scm-deffnx
+	    (if (and *manual-flag* (eq? *snarf-type* 'primitive))
+		(with-output-to-string
+		  (lambda ()
+                    (format #t "@deffnx {C Function} ~A (" *c-function-name*)
+		    (unless (null? *args*)
+		      (format #t "~A" (car *args*))
+		      (let loop ((args (cdr *args*)))
+			(unless (null? args)
+			  (format #t ", ~A" (car args))
+			  (loop (cdr args)))))
+		    (format #t ")\n")))
+		#f)))
+      (format #t "\n~A\n" *function-name*)
+      (format #t "@c snarfed from ~A:~A\n" *file* *line*)
+      (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
+      (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
+	(cond ((null? strings))
+	      ((or (not scm-deffnx)
+		   (and (>= (string-length (car strings))
+			    *primitive-deffnx-sig-length*)
+			(string=? (substring (car strings)
+					     0 *primitive-deffnx-sig-length*)
+				  *primitive-deffnx-signature*)))
+	       (display (car strings))
+	       (loop (cdr strings) scm-deffnx))
+	      (else (display scm-deffnx)
+		    (loop strings #f))))
+      (display "\n")
+      (display "@end deffn\n"))))
+
+(define (texi-quote s)
+  (let rec ((i 0))
+    (if (= i (string-length s))
+      ""
+      (string-append (let ((ss (substring s i (+ i 1))))
+                       (if (string=? ss "@")
+                         "@@"
+                         ss))
+                     (rec (+ i 1))))))
+
+(define (process-multiline-directive l)
+
+  (define do-args
+    (match-lambda
+
+     (('(paren_close . paren_close))
+      '())
+
+     (('(comma . comma) rest ...)
+      (do-args rest))
+
+     (('(id . SCM) ('id . name) rest ...)
+      (cons name (do-args rest)))
+
+     (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
+
+  (define do-arglist
+    (match-lambda
+
+     (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
+      '())
+
+     (('(paren_open . paren_open) rest ...)
+      (do-args rest))
+
+     (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
+
+  (define do-command
+    (match-lambda
+
+     (('cname ('id . name))
+      (set! *c-function-name* (texi-quote (symbol->string name))))
+
+     (('fname ('string . name) ...)
+      (set! *function-name* (texi-quote (apply string-append name))))
+
+     (('type ('id . type))
+      (set! *snarf-type* type))
+
+     (('type ('int . num))
+      (set! *snarf-type* num))
+
+     (('location ('string . file) ('int . line))
+      (set! *file* file)
+      (set! *line* line))
+
+     (('arglist rest ...)
+      (set! *args* (do-arglist rest)))
+
+     (('argsig ('int . req) ('int . opt) ('int . var))
+      (set! *sig* (list req opt var)))
+
+     (x (error (format #f "unknown doc attribute: ~A" x)))))
+
+  (define do-directive
+    (match-lambda
+
+     ((('id . command) rest ...)
+      (do-command (cons command rest)))
+
+     ((('string . string) ...)
+      (set! *docstring* string))
+
+     (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
+
+  (do-directive l))
+
+(define (process-singleline l)
+
+  (define do-argpos
+    (match-lambda
+     ((('id . name) ('int . pos) ('int . line))
+      (let ((idx (list-index *args* name)))
+        (when idx
+          (unless (= (+ idx 1) pos)
+            (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
+                             *file* line name pos (+ idx 1))
+                     (current-error-port))))))
+     (x #f)))
+
+  (define do-command
+    (match-lambda
+     (('(id . argpos) rest ...)
+      (do-argpos rest))
+     (x (error (format #f "unknown check: ~A" x)))))
+
+  (when *function-name*
+    (do-command l)))
+
+(define main snarf-check-and-output-texi)
+;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
+
+;; 	Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: snarf-guile-m4-docs FILE
+;;
+;; Grep FILE for comments preceding macro definitions, massage
+;; them into valid texi, and display to stdout.  For each comment,
+;; lines preceding "^# Usage:" are discarded.
+;;
+;; TODO: Generalize.
+
+;;; Code:
+
+(define-module (scripts snarf-guile-m4-docs)
+  \:use-module (ice-9 rdelim)
+  \:export (snarf-guile-m4-docs))
+
+(define %include-in-guild-list #f)
+(define %summary "Snarf out texinfo documentation from .m4 files.")
+
+(define (display-texi lines)
+  (display "@deffn {Autoconf Macro}")
+  (for-each (lambda (line)
+              (display (cond ((and (>= (string-length line) 2)
+				   (string=? "# " (substring line 0 2)))
+			      (substring line 2))
+			     ((string=? "#" (substring line 0 1))
+			      (substring line 1))
+			     (else line)))
+              (newline))
+            lines)
+  (display "@end deffn")
+  (newline) (newline))
+
+(define (prefix? line sub)
+  (false-if-exception
+   (string=? sub (substring line 0 (string-length sub)))))
+
+(define (massage-usage line)
+  (let loop ((line (string->list line)) (acc '()))
+    (if (null? line)
+        (list (list->string (reverse acc)))
+        (loop (cdr line)
+              (cons (case (car line)
+                      ((#\( #\) #\,) #\space)
+                      (else (car line)))
+                    acc)))))
+
+(define (snarf-guile-m4-docs . args)
+  (let* ((p (open-file (car args) "r"))
+         (next (lambda () (read-line p))))
+    (let loop ((line (next)) (acc #f))
+      (or (eof-object? line)
+          (cond ((prefix? line "# Usage:")
+                 (loop (next) (massage-usage (substring line 8))))
+                ((prefix? line "AC_DEFUN")
+                 (display-texi (reverse acc))
+                 (loop (next) #f))
+                ((and acc (prefix? line "#"))
+                 (loop (next) (cons line acc)))
+                (else
+                 (loop (next) #f)))))))
+
+(define main snarf-guile-m4-docs)
+
+;;; snarf-guile-m4-docs ends here
+;;; summarize-guile-TODO --- Display Guile TODO list in various ways
+
+;; 	Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: summarize-guile-TODO TODOFILE
+;;
+;; The TODOFILE is typically Guile's (see workbook/tasks/README)
+;; presumed to serve as our signal to ourselves (lest we want real
+;; bosses hassling us) wrt to the overt message "items to do" as well as
+;; the messages that can be inferred from its structure.
+;;
+;; This program reads TODOFILE and displays interpretations on its
+;; structure, including registered markers and ownership, in various
+;; ways.
+;;
+;; A primary interest in any task is its parent task.  The output
+;; summarization by default lists every item and its parent chain.
+;; Top-level parents are not items.  You can use these command-line
+;; options to modify the selection and display (selection criteria
+;; are ANDed together):
+;;
+;; -i, --involved USER  -- select USER-involved items
+;; -p, --personal USER  -- select USER-responsible items
+;; -t, --todo           -- select unfinished items (status "-")
+;; -d, --done           -- select finished items (status "+")
+;; -r, --review         -- select review items (marker "R")
+;;
+;; -w, --who            -- also show who is associated w/ the item
+;; -n, --no-parent      -- do not show parent chain
+;;
+;;
+;; Usage from a Scheme program:
+;;   (summarize-guile-TODO . args)      ; uses first arg only
+;;
+;;
+;; Bugs: (1) Markers are scanned in sequence: D R X N%.  This means "XD"
+;;           and the like are completely dropped.  However, such strings
+;;           are unlikely to be used if the markers are chosen to be
+;;           somewhat exclusive, which is currently the case for D R X.
+;;           N% used w/ these needs to be something like: "D25%" (this
+;;           means discussion accounts for 1/4 of the task).
+;;
+;; TODO: Implement more various ways. (Patches welcome.)
+;;       Add support for ORing criteria.
+
+;;; Code:
+(debug-enable 'backtrace)
+
+(define-module (scripts summarize-guile-TODO)
+  \:use-module (scripts read-text-outline)
+  \:use-module (ice-9 getopt-long)
+  \:autoload (srfi srfi-13) (string-tokenize) ; string library
+  \:autoload (srfi srfi-14) (char-set) ; string library
+  \:autoload (ice-9 common-list) (remove-if-not)
+  \:export (summarize-guile-TODO))
+
+(define %include-in-guild-list #f)
+(define %summary "A quaint relic of the past.")
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (as-leaf x)
+  (cond ((get x 'who)
+         => (lambda (who)
+              (put x 'who
+                   (map string->symbol
+                        (string-tokenize who (char-set #\:)))))))
+  (cond ((get x 'pct-done)
+         => (lambda (pct-done)
+              (put x 'pct-done (string->number pct-done)))))
+  x)
+
+(define (hang-by-the-leaves trees)
+  (let ((leaves '()))
+    (letrec ((hang (lambda (tree parent)
+                     (if (list? tree)
+                         (begin
+                           (put (car tree) 'parent parent)
+                           (for-each (lambda (child)
+                                       (hang child (car tree)))
+                                     (cdr tree)))
+                         (begin
+                           (put tree 'parent parent)
+                           (set! leaves (cons (as-leaf tree) leaves)))))))
+      (for-each (lambda (tree)
+                  (hang tree #f))
+                trees))
+    leaves))
+
+(define (read-TODO file)
+  (hang-by-the-leaves
+   ((make-text-outline-reader
+     "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
+     '((level-substring-divisor . 2)
+       (body-submatch-number . 9)
+       (extra-fields . ((status . 3)
+                        (design? . 4)
+                        (review? . 5)
+                        (extblock? . 6)
+                        (pct-done . 8)
+                        (who . 11)))))
+    (open-file file "r"))))
+
+(define (select-items p items)
+  (let ((sub '()))
+    (cond ((option-ref p 'involved #f)
+           => (lambda (u)
+                (let ((u (string->symbol u)))
+                  (set! sub (cons
+                             (lambda (x)
+                               (and (get x 'who)
+                                    (memq u (get x 'who))))
+                             sub))))))
+    (cond ((option-ref p 'personal #f)
+           => (lambda (u)
+                (let ((u (string->symbol u)))
+                  (set! sub (cons
+                             (lambda (x)
+                               (cond ((get x 'who)
+                                      => (lambda (ls)
+                                           (eq? (car (reverse ls))
+                                                u)))
+                                     (else #f)))
+                             sub))))))
+    (for-each (lambda (pair)
+                (cond ((option-ref p (car pair) #f)
+                       (set! sub (cons (cdr pair) sub)))))
+              `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
+                (done . ,(lambda (x) (string=? (get x 'status) "+")))
+                (review . ,(lambda (x) (get x 'review?)))))
+    (let loop ((sub (reverse sub)) (items items))
+      (if (null? sub)
+          (reverse items)
+          (loop (cdr sub) (remove-if-not (car sub) items))))))
+
+(define (make-display-item show-who? show-parent?)
+  (let ((show-who
+         (if show-who?
+             (lambda (item)
+               (cond ((get item 'who)
+                      => (lambda (who) (format #f " ~A" who)))
+                     (else "")))
+             (lambda (item) "")))
+        (show-parents
+         (if show-parent?
+             (lambda (item)
+               (let loop ((parent (get item 'parent)) (indent 2))
+                 (and parent
+                      (begin
+                        (format #t "under : ~A~A\n"
+                                (make-string indent #\space)
+                                parent)
+                        (loop (get parent 'parent) (+ 2 indent))))))
+             (lambda (item) #t))))
+    (lambda (item)
+      (format #t "status: ~A~A~A~A~A~A\nitem  : ~A\n"
+              (get item 'status)
+              (if (get item 'design?) "D" "")
+              (if (get item 'review?) "R" "")
+              (if (get item 'extblock?) "X" "")
+              (cond ((get item 'pct-done)
+                     => (lambda (pct-done)
+                          (format #f " ~A%" pct-done)))
+                    (else ""))
+              (show-who item)
+              item)
+      (show-parents item))))
+
+(define (display-items p items)
+  (let ((display-item (make-display-item (option-ref p 'who #f)
+                                         (not (option-ref p 'no-parent #f))
+                                         )))
+    (for-each display-item items)))
+
+(define (summarize-guile-TODO . args)
+  (let ((p (getopt-long (cons "summarize-guile-TODO" args)
+                        '((who (single-char #\w))
+                          (no-parent (single-char #\n))
+                          (involved (single-char #\i)
+                                    (value #t))
+                          (personal (single-char #\p)
+                                    (value #t))
+                          (todo (single-char #\t))
+                          (done (single-char #\d))
+                          (review (single-char #\r))
+                          ;; Add options here.
+                          ))))
+    (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
+  #t)                                   ; exit val
+
+(define main summarize-guile-TODO)
+
+;;; summarize-guile-TODO ends here
+;;; use2dot --- Display module dependencies as a DOT specification
+
+;; 	Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: use2dot [OPTIONS] [FILE ...]
+;; Display to stdout a DOT specification that describes module dependencies
+;; in FILEs.
+;;
+;; A top-level `use-modules' form or a `:use-module' `define-module'-component
+;; results in a "solid" style edge.
+;;
+;; An `:autoload' `define-module'-component results in a "dotted" style edge
+;; with label "N" indicating that N names are responsible for triggering the
+;; autoload.  [The "N" label is not implemented.]
+;;
+;; A top-level `load' or `primitive-load' form results in a a "bold" style
+;; edge to a node named with either the file name if the `load' argument is a
+;; string, or "[computed in FILE]" otherwise.
+;;
+;; Options:
+;;  -m, --default-module MOD -- Set MOD as the default module (for top-level
+;;                              `use-modules' forms that do not follow some
+;;                              `define-module' form in a file).  MOD should be
+;;                              be a list or `#f', in which case such top-level
+;;                              `use-modules' forms are effectively ignored.
+;;                              Default value: `(guile-user)'.
+
+;;; Code:
+
+(define-module (scripts use2dot)
+  \:autoload (ice-9 getopt-long) (getopt-long)
+  \:use-module ((srfi srfi-13) \:select (string-join))
+  \:use-module ((scripts frisk)
+               \:select (make-frisker edge-type edge-up edge-down))
+  \:export (use2dot))
+
+(define %summary "Print a module's dependencies in graphviz format.")
+
+(define *default-module* '(guile-user))
+
+(define (q s)                           ; quote
+  (format #f "~S" s))
+
+(define (vv pairs)                      ; => ("var=val" ...)
+  (map (lambda (pair)
+         (format #f "~A=~A" (car pair) (cdr pair)))
+       pairs))
+
+(define (>>header)
+  (format #t "digraph use2dot {\n")
+  (for-each (lambda (s) (format #t "  ~A;\n" s))
+            (vv `((label . ,(q "Guile Module Dependencies"))
+                  ;;(rankdir . LR)
+                  ;;(size . ,(q "7.5,10"))
+                  (ratio . fill)
+                  ;;(nodesep . ,(q "0.05"))
+                  ))))
+
+(define (>>body edges)
+  (for-each
+   (lambda (edge)
+     (format #t "  \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge))
+     (cond ((case (edge-type edge)
+              ((autoload) '((style . dotted) (fontsize . 5)))
+              ((computed) '((style . bold)))
+              (else #f))
+            => (lambda (etc)
+                 (format #t " [~A]" (string-join (vv etc) ",")))))
+     (format #t ";\n"))
+   edges))
+
+(define (>>footer)
+  (format #t "}"))
+
+(define (>> edges)
+  (>>header)
+  (>>body edges)
+  (>>footer))
+
+(define (use2dot . args)
+  (let* ((parsed-args (getopt-long (cons "use2dot" args)    ;;; kludge
+                                   '((default-module
+                                       (single-char #\m) (value #t)))))
+         (=m (option-ref parsed-args 'default-module *default-module*))
+         (scan (make-frisker `(default-module . ,=m)))
+         (files (option-ref parsed-args '() '())))
+    (>> (reverse ((scan files) 'edges)))))
+
+(define main use2dot)
+
+;;; use2dot ends here
+;;; srfi-1.scm --- List Library
+
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Some parts from the reference implementation, which is
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use.
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;; Date: 2001-06-06
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-1 (List Library).
+;;
+;; All procedures defined in SRFI-1, which are not already defined in
+;; the Guile core library, are exported.  The procedures in this
+;; implementation work, but they have not been tuned for speed or
+;; memory usage.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-1)
+  \:export (
+;;; Constructors
+ ;; cons				<= in the core
+ ;; list				<= in the core
+ xcons
+ ;; cons*				<= in the core
+ ;; make-list				<= in the core
+ list-tabulate
+ list-copy
+ circular-list
+ ;; iota				; Extended.
+
+;;; Predicates
+ proper-list?
+ circular-list?
+ dotted-list?
+ ;; pair?				<= in the core
+ ;; null?				<= in the core
+ null-list?
+ not-pair?
+ list=
+
+;;; Selectors
+ ;; car					<= in the core
+ ;; cdr					<= in the core
+ ;; caar				<= in the core
+ ;; cadr				<= in the core
+ ;; cdar				<= in the core
+ ;; cddr				<= in the core
+ ;; caaar				<= in the core
+ ;; caadr				<= in the core
+ ;; cadar				<= in the core
+ ;; caddr				<= in the core
+ ;; cdaar				<= in the core
+ ;; cdadr				<= in the core
+ ;; cddar				<= in the core
+ ;; cdddr				<= in the core
+ ;; caaaar				<= in the core
+ ;; caaadr				<= in the core
+ ;; caadar				<= in the core
+ ;; caaddr				<= in the core
+ ;; cadaar				<= in the core
+ ;; cadadr				<= in the core
+ ;; caddar				<= in the core
+ ;; cadddr				<= in the core
+ ;; cdaaar				<= in the core
+ ;; cdaadr				<= in the core
+ ;; cdadar				<= in the core
+ ;; cdaddr				<= in the core
+ ;; cddaar				<= in the core
+ ;; cddadr				<= in the core
+ ;; cdddar				<= in the core
+ ;; cddddr				<= in the core
+ ;; list-ref				<= in the core
+ first
+ second
+ third
+ fourth
+ fifth
+ sixth
+ seventh
+ eighth
+ ninth
+ tenth
+ car+cdr
+ take
+ drop
+ take-right
+ drop-right
+ take!
+ drop-right!
+ split-at
+ split-at!
+ last
+ ;; last-pair				<= in the core
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+ ;; length				<= in the core
+ length+
+ ;; append				<= in the core
+ ;; append!				<= in the core
+ concatenate
+ concatenate!
+ ;; reverse				<= in the core
+ ;; reverse!				<= in the core
+ append-reverse
+ append-reverse!
+ zip
+ unzip1
+ unzip2
+ unzip3
+ unzip4
+ unzip5
+ count
+
+;;; Fold, unfold & map
+ fold
+ fold-right
+ pair-fold
+ pair-fold-right
+ reduce
+ reduce-right
+ unfold
+ unfold-right
+ ;; map					; Extended.
+ ;; for-each				; Extended.
+ append-map
+ append-map!
+ map!
+ ;; map-in-order			; Extended.
+ pair-for-each
+ filter-map
+
+;;; Filtering & partitioning
+ ;; filter				<= in the core
+ partition
+ remove
+ ;; filter!				<= in the core
+ partition!
+ remove!
+
+;;; Searching
+ find
+ find-tail
+ take-while
+ take-while!
+ drop-while
+ span
+ span!
+ break
+ break!
+ any
+ every
+ ;; list-index				; Extended.
+ ;; member				; Extended.
+ ;; memq				<= in the core
+ ;; memv				<= in the core
+
+;;; Deletion
+ ;; delete				; Extended.
+ ;; delete!				; Extended.
+ delete-duplicates
+ delete-duplicates!
+
+;;; Association lists
+ ;; assoc				; Extended.
+ ;; assq				<= in the core
+ ;; assv				<= in the core
+ alist-cons
+ alist-copy
+ alist-delete
+ alist-delete!
+
+;;; Set operations on lists
+ lset<=
+ lset=
+ lset-adjoin
+ lset-union
+ lset-intersection
+ lset-difference
+ lset-xor
+ lset-diff+intersection
+ lset-union!
+ lset-intersection!
+ lset-difference!
+ lset-xor!
+ lset-diff+intersection!
+
+;;; Primitive side-effects
+ ;; set-car!				<= in the core
+ ;; set-cdr!				<= in the core
+ )
+  \:re-export (cons list cons* make-list pair? null?
+	      car cdr caar cadr cdar cddr
+	      caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	      caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	      cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+	      list-ref last-pair length append append! reverse reverse!
+	      filter filter! memq memv assq assv set-car! set-cdr!)
+  \:replace (iota map for-each map-in-order list-copy list-index member
+	    delete delete! assoc)
+  )
+
+(cond-expand-provide (current-module) '(srfi-1))
+
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_srfi_1")
+
+
+;;; Constructors
+
+(define (xcons d a)
+  "Like `cons', but with interchanged arguments.  Useful mostly when passed to
+higher-order procedures."
+  (cons a d))
+
+(define (wrong-type-arg caller arg)
+  (scm-error 'wrong-type-arg (symbol->string caller)
+             "Wrong type argument: ~S" (list arg) '()))
+
+(define-syntax-rule (check-arg pred arg caller)
+  (if (not (pred arg))
+      (wrong-type-arg 'caller arg)))
+
+(define (out-of-range proc arg)
+  (scm-error 'out-of-range proc
+             "Value out of range: ~A" (list arg) (list arg)))
+
+;; the srfi spec doesn't seem to forbid inexact integers.
+(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
+
+(define (list-tabulate n init-proc)
+  "Return an N-element list, where each list element is produced by applying the
+procedure INIT-PROC to the corresponding list index.  The order in which
+INIT-PROC is applied to the indices is not specified."
+  (check-arg non-negative-integer? n list-tabulate)
+  (let lp ((n n) (acc '()))
+    (if (<= n 0)
+        acc
+        (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+
+(define (circular-list elt1 . elts)
+  (set! elts (cons elt1 elts))
+  (set-cdr! (last-pair elts) elts)
+  elts)
+
+(define* (iota count #\optional (start 0) (step 1))
+  (check-arg non-negative-integer? count iota)
+  (let lp ((n 0) (acc '()))
+    (if (= n count)
+	(reverse! acc)
+	(lp (+ n 1) (cons (+ start (* n step)) acc)))))
+
+;;; Predicates
+
+(define (proper-list? x)
+  (list? x))
+
+(define (circular-list? x)
+  (if (not-pair? x)
+    #f
+    (let lp ((hare (cdr x)) (tortoise x))
+      (if (not-pair? hare)
+	#f
+	(let ((hare (cdr hare)))
+	  (if (not-pair? hare)
+	    #f
+	    (if (eq? hare tortoise)
+	      #t
+	      (lp (cdr hare) (cdr tortoise)))))))))
+
+(define (dotted-list? x)
+  (cond
+    ((null? x) #f)
+    ((not-pair? x) #t)
+    (else
+     (let lp ((hare (cdr x)) (tortoise x))
+       (cond
+	 ((null? hare) #f)
+	 ((not-pair? hare) #t)
+	 (else
+	  (let ((hare (cdr hare)))
+	    (cond
+	      ((null? hare) #f)
+	      ((not-pair? hare) #t)
+	      ((eq? hare tortoise) #f)
+	      (else
+	       (lp (cdr hare) (cdr tortoise)))))))))))
+
+(define (null-list? x)
+  (cond
+    ((proper-list? x)
+     (null? x))
+    ((circular-list? x)
+     #f)
+    (else
+     (error "not a proper list in null-list?"))))
+
+(define (not-pair? x)
+  "Return #t if X is not a pair, #f otherwise.
+
+This is shorthand notation `(not (pair? X))' and is supposed to be used for
+end-of-list checking in contexts where dotted lists are allowed."
+  (not (pair? x)))
+
+(define (list= elt= . rest)
+  (define (lists-equal a b)
+    (let lp ((a a) (b b))
+      (cond ((null? a)
+	     (null? b))
+	    ((null? b)
+	     #f)
+	    (else
+	     (and (elt= (car a) (car b))
+		  (lp (cdr a) (cdr b)))))))
+
+  (check-arg procedure? elt= list=)
+  (or (null? rest)
+      (let lp ((lists rest))
+	(or (null? (cdr lists))
+	    (and (lists-equal (car lists) (cadr lists))
+		 (lp (cdr lists)))))))
+
+;;; Selectors
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr x)
+  "Return two values, the `car' and the `cdr' of PAIR."
+  (values (car x) (cdr x)))
+
+(define take list-head)
+(define drop list-tail)
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.  Note that they diverge for circular lists.
+
+(define (take-right lis k)
+  (let lp ((lag lis)  (lead (drop lis k)))
+    (if (pair? lead)
+	(lp (cdr lag) (cdr lead))
+	lag)))
+
+(define (drop-right lis k)
+  (let lp ((lag lis) (lead (drop lis k)) (result '()))
+    (if (pair? lead)
+	(lp (cdr lag) (cdr lead) (cons (car lag) result))
+	(reverse result))))
+
+(define (take! lst i)
+  "Linear-update variant of `take'."
+  (if (= i 0)
+      '()
+      (let ((tail (drop lst (- i 1))))
+        (set-cdr! tail '())
+        lst)))
+
+(define (drop-right! lst i)
+  "Linear-update variant of `drop-right'."
+  (let ((tail (drop lst i)))
+    (if (null? tail)
+        '()
+        (let loop ((prev lst)
+                   (tail (cdr tail)))
+          (if (null? tail)
+              (if (pair? prev)
+                  (begin
+                    (set-cdr! prev '())
+                    lst)
+                  lst)
+              (loop (cdr prev)
+                    (cdr tail)))))))
+
+(define (split-at lst i)
+  "Return two values, a list of the elements before index I in LST, and
+a list of those after."
+  (if (< i 0)
+      (out-of-range 'split-at i)
+      (let lp ((l lst) (n i) (acc '()))
+        (if (<= n 0)
+            (values (reverse! acc) l)
+            (lp (cdr l) (- n 1) (cons (car l) acc))))))
+
+(define (split-at! lst i)
+  "Linear-update variant of `split-at'."
+  (cond ((< i 0)
+         (out-of-range 'split-at! i))
+        ((= i 0)
+         (values '() lst))
+        (else
+         (let lp ((l lst) (n (- i 1)))
+           (if (<= n 0)
+               (let ((tmp (cdr l)))
+                 (set-cdr! l '())
+                 (values lst tmp))
+               (lp (cdr l) (- n 1)))))))
+
+(define (last pair)
+  "Return the last element of the non-empty, finite list PAIR."
+  (car (last-pair pair)))
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+
+(define (zip clist1 . rest)
+  (let lp ((l (cons clist1 rest)) (acc '()))
+    (if (any null? l)
+      (reverse! acc)
+      (lp (map cdr l) (cons (map car l) acc)))))
+
+
+(define (unzip1 l)
+  (map first l))
+(define (unzip2 l)
+  (values (map first l) (map second l)))
+(define (unzip3 l)
+  (values (map first l) (map second l) (map third l)))
+(define (unzip4 l)
+  (values (map first l) (map second l) (map third l) (map fourth l)))
+(define (unzip5 l)
+  (values (map first l) (map second l) (map third l) (map fourth l)
+	  (map fifth l)))
+
+;;; Fold, unfold & map
+
+(define (fold kons knil list1 . rest)
+  "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+that result.  See the manual for details."
+  (check-arg procedure? kons fold)
+  (if (null? rest)
+      (let f ((knil knil) (list1 list1))
+	(if (null? list1)
+	    knil
+	    (f (kons (car list1) knil) (cdr list1))))
+      (let f ((knil knil) (lists (cons list1 rest)))
+	(if (any null? lists)
+	    knil
+	    (let ((cars (map car lists))
+		  (cdrs (map cdr lists)))
+	      (f (apply kons (append! cars (list knil))) cdrs))))))
+
+(define (fold-right kons knil clist1 . rest)
+  (check-arg procedure? kons fold-right)
+  (if (null? rest)
+      (let loop ((lst    (reverse clist1))
+                 (result knil))
+        (if (null? lst)
+            result
+            (loop (cdr lst)
+                  (kons (car lst) result))))
+      (let loop ((lists  (map reverse (cons clist1 rest)))
+                 (result knil))
+        (if (any1 null? lists)
+            result
+            (loop (map cdr lists)
+                  (apply kons (append! (map car lists) (list result))))))))
+
+(define (pair-fold kons knil clist1 . rest)
+  (check-arg procedure? kons pair-fold)
+  (if (null? rest)
+      (let f ((knil knil) (list1 clist1))
+	(if (null? list1)
+	    knil
+	    (let ((tail (cdr list1)))
+	    (f (kons list1 knil) tail))))
+      (let f ((knil knil) (lists (cons clist1 rest)))
+	(if (any null? lists)
+	    knil
+	    (let ((tails (map cdr lists)))
+	      (f (apply kons (append! lists (list knil))) tails))))))
+
+
+(define (pair-fold-right kons knil clist1 . rest)
+  (check-arg procedure? kons pair-fold-right)
+  (if (null? rest)
+    (let f ((list1 clist1))
+      (if (null? list1)
+	knil
+	(kons list1 (f (cdr list1)))))
+    (let f ((lists (cons clist1 rest)))
+      (if (any null? lists)
+	knil
+	(apply kons (append! lists (list (f (map cdr lists)))))))))
+
+(define* (unfold p f g seed #\optional (tail-gen (lambda (x) '())))
+  (define (reverse+tail lst seed)
+    (let loop ((lst    lst)
+               (result (tail-gen seed)))
+      (if (null? lst)
+          result
+          (loop (cdr lst)
+                (cons (car lst) result)))))
+
+  (check-arg procedure? p unfold)
+  (check-arg procedure? f unfold)
+  (check-arg procedure? g unfold)
+  (check-arg procedure? tail-gen unfold)
+  (let loop ((seed   seed)
+             (result '()))
+    (if (p seed)
+        (reverse+tail result seed)
+        (loop (g seed)
+              (cons (f seed) result)))))
+
+(define* (unfold-right p f g seed #\optional (tail '()))
+  (check-arg procedure? p unfold-right)
+  (check-arg procedure? f unfold-right)
+  (check-arg procedure? g unfold-right)
+  (let uf ((seed seed) (lis tail))
+    (if (p seed)
+        lis
+        (uf (g seed) (cons (f seed) lis)))))
+
+(define (reduce f ridentity lst)
+  "`reduce' is a variant of `fold', where the first call to F is on two
+elements from LST, rather than one element and a given initial value.
+If LST is empty, RIDENTITY is returned.  If LST has just one element
+then that's the return value."
+  (check-arg procedure? f reduce)
+  (if (null? lst)
+      ridentity
+      (fold f (car lst) (cdr lst))))
+
+(define (reduce-right f ridentity lst)
+  "`reduce-right' is a variant of `fold-right', where the first call to
+F is on two elements from LST, rather than one element and a given
+initial value.  If LST is empty, RIDENTITY is returned.  If LST
+has just one element then that's the return value."
+  (reduce f ridentity (reverse lst)))
+
+(define map
+  (case-lambda
+    ((f l)
+     (check-arg procedure? f map)
+     (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+       (if (pair? hare)
+           (if move?
+               (if (eq? tortoise hare)
+                   (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                              (list l) #f)
+                   (map1 (cdr hare) (cdr tortoise) #f
+                       (cons (f (car hare)) out)))
+               (map1 (cdr hare) tortoise #t
+                     (cons (f (car hare)) out)))
+           (if (null? hare)
+               (reverse! out)
+               (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                          (list l) #f)))))
+    
+    ((f l1 . rest)
+     (check-arg procedure? f map)
+     (let ((len (fold (lambda (ls len)
+                        (let ((ls-len (length+ ls)))
+                          (if len
+                              (if ls-len (min ls-len len) len)
+                              ls-len)))
+                      (length+ l1)
+                      rest)))
+       (if (not len)
+           (scm-error 'wrong-type-arg "map"
+                      "Args do not contain a proper (finite) list: ~S"
+                      (list (cons l1 rest)) #f))
+       (let mapn ((l1 l1) (rest rest) (len len) (out '()))
+         (if (zero? len)
+             (reverse! out)
+             (mapn (cdr l1) (map cdr rest) (1- len)
+                   (cons (apply f (car l1) (map car rest)) out))))))))
+
+(define map-in-order map)
+
+(define for-each
+  (case-lambda
+    ((f l)
+     (check-arg procedure? f for-each)
+     (let for-each1 ((hare l) (tortoise l) (move? #f))
+       (if (pair? hare)
+           (if move?
+               (if (eq? tortoise hare)
+                   (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                              (list l) #f)
+                   (begin
+                     (f (car hare))
+                     (for-each1 (cdr hare) (cdr tortoise) #f)))
+               (begin
+                 (f (car hare))
+                 (for-each1 (cdr hare) tortoise #t)))
+           
+           (if (not (null? hare))
+               (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+                          (list l) #f)))))
+    
+    ((f l1 . rest)
+     (check-arg procedure? f for-each)
+     (let ((len (fold (lambda (ls len)
+                        (let ((ls-len (length+ ls)))
+                          (if len
+                              (if ls-len (min ls-len len) len)
+                              ls-len)))
+                      (length+ l1)
+                      rest)))
+       (if (not len)
+           (scm-error 'wrong-type-arg "for-each"
+                      "Args do not contain a proper (finite) list: ~S"
+                      (list (cons l1 rest)) #f))
+       (let for-eachn ((l1 l1) (rest rest) (len len))
+         (if (> len 0)
+             (begin
+               (apply f (car l1) (map car rest))
+               (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
+
+(define (append-map f clist1 . rest)
+  (concatenate (apply map f clist1 rest)))
+  
+(define (append-map! f clist1 . rest)
+  (concatenate! (apply map f clist1 rest)))
+
+;; OPTIMIZE-ME: Re-use cons cells of list1
+(define map! map)
+
+(define (filter-map proc list1 . rest)
+  "Apply PROC to the elements of LIST1... and return a list of the
+results as per SRFI-1 `map', except that any #f results are omitted from
+the list returned."
+  (check-arg procedure? proc filter-map)
+  (if (null? rest)
+      (let lp ((l list1)
+               (rl '()))
+        (if (null? l)
+            (reverse! rl)
+            (let ((res (proc (car l))))
+              (if res
+                  (lp (cdr l) (cons res rl))
+                  (lp (cdr l) rl)))))
+      (let lp ((l (cons list1 rest))
+               (rl '()))
+        (if (any1 null? l)
+            (reverse! rl)
+            (let ((res (apply proc (map car l))))
+              (if res
+                  (lp (map cdr l) (cons res rl))
+                  (lp (map cdr l) rl)))))))
+
+(define (pair-for-each f clist1 . rest)
+  (check-arg procedure? f pair-for-each)
+  (if (null? rest)
+    (let lp ((l clist1))
+      (if (null? l)
+	(if #f #f)
+	(begin
+	  (f l)
+	  (lp (cdr l)))))
+    (let lp ((l (cons clist1 rest)))
+      (if (any1 null? l)
+	(if #f #f)
+	(begin
+	  (apply f l)
+	  (lp (map cdr l)))))))
+
+
+;;; Searching
+
+(define (take-while pred ls)
+  "Return a new list which is the longest initial prefix of LS whose
+elements all satisfy the predicate PRED."
+  (check-arg procedure? pred take-while)
+  (cond ((null? ls) '())
+        ((not (pred (car ls))) '())
+        (else
+         (let ((result (list (car ls))))
+           (let lp ((ls (cdr ls)) (p result))
+             (cond ((null? ls) result)
+                   ((not (pred (car ls))) result)
+                   (else
+                    (set-cdr! p (list (car ls)))
+                    (lp (cdr ls) (cdr p)))))))))
+
+(define (take-while! pred lst)
+  "Linear-update variant of `take-while'."
+  (check-arg procedure? pred take-while!)
+  (let loop ((prev #f)
+             (rest lst))
+    (cond ((null? rest)
+           lst)
+          ((pred (car rest))
+           (loop rest (cdr rest)))
+          (else
+           (if (pair? prev)
+               (begin
+                 (set-cdr! prev '())
+                 lst)
+               '())))))
+
+(define (drop-while pred lst)
+  "Drop the longest initial prefix of LST whose elements all satisfy the
+predicate PRED."
+  (check-arg procedure? pred drop-while)
+  (let loop ((lst lst))
+    (cond ((null? lst)
+           '())
+          ((pred (car lst))
+           (loop (cdr lst)))
+          (else lst))))
+
+(define (span pred lst)
+  "Return two values, the longest initial prefix of LST whose elements
+all satisfy the predicate PRED, and the remainder of LST."
+  (check-arg procedure? pred span)
+  (let lp ((lst lst) (rl '()))
+    (if (and (not (null? lst))
+             (pred (car lst)))
+        (lp (cdr lst) (cons (car lst) rl))
+        (values (reverse! rl) lst))))
+
+(define (span! pred list)
+  "Linear-update variant of `span'."
+  (check-arg procedure? pred span!)
+  (let loop ((prev #f)
+             (rest list))
+    (cond ((null? rest)
+           (values list '()))
+          ((pred (car rest))
+           (loop rest (cdr rest)))
+          (else
+           (if (pair? prev)
+               (begin
+                 (set-cdr! prev '())
+                 (values list rest))
+               (values '() list))))))
+
+(define (break pred clist)
+  "Return two values, the longest initial prefix of LST whose elements
+all fail the predicate PRED, and the remainder of LST."
+  (check-arg procedure? pred break)
+  (let lp ((clist clist) (rl '()))
+    (if (or (null? clist)
+	    (pred (car clist)))
+	(values (reverse! rl) clist)
+	(lp (cdr clist) (cons (car clist) rl)))))
+
+(define (break! pred list)
+  "Linear-update variant of `break'."
+  (check-arg procedure? pred break!)
+  (let loop ((l    list)
+             (prev #f))
+    (cond ((null? l)
+           (values list '()))
+          ((pred (car l))
+           (if (pair? prev)
+               (begin
+                 (set-cdr! prev '())
+                 (values list l))
+               (values '() list)))
+          (else
+           (loop (cdr l) l)))))
+
+(define (any pred ls . lists)
+  (check-arg procedure? pred any)
+  (if (null? lists)
+      (any1 pred ls)
+      (let lp ((lists (cons ls lists)))
+	(cond ((any1 null? lists)
+	       #f)
+	      ((any1 null? (map cdr lists))
+	       (apply pred (map car lists)))
+	      (else
+	       (or (apply pred (map car lists)) (lp (map cdr lists))))))))
+
+(define (any1 pred ls)
+  (let lp ((ls ls))
+    (cond ((null? ls)
+	   #f)
+	  ((null? (cdr ls))
+	   (pred (car ls)))
+	  (else
+	   (or (pred (car ls)) (lp (cdr ls)))))))
+
+(define (every pred ls . lists)
+  (check-arg procedure? pred every)
+  (if (null? lists)
+      (every1 pred ls)
+      (let lp ((lists (cons ls lists)))
+	(cond ((any1 null? lists)
+	       #t)
+	      ((any1 null? (map cdr lists))
+	       (apply pred (map car lists)))
+	      (else
+	       (and (apply pred (map car lists)) (lp (map cdr lists))))))))
+
+(define (every1 pred ls)
+  (let lp ((ls ls))
+    (cond ((null? ls)
+	   #t)
+	  ((null? (cdr ls))
+	   (pred (car ls)))
+	  (else
+	   (and (pred (car ls)) (lp (cdr ls)))))))
+
+(define (list-index pred clist1 . rest)
+  "Return the index of the first set of elements, one from each of
+CLIST1 ... CLISTN, that satisfies PRED."
+  (check-arg procedure? pred list-index)
+  (if (null? rest)
+    (let lp ((l clist1) (i 0))
+      (if (null? l)
+	#f
+	(if (pred (car l))
+	  i
+	  (lp (cdr l) (+ i 1)))))
+    (let lp ((lists (cons clist1 rest)) (i 0))
+      (cond ((any1 null? lists)
+	     #f)
+	    ((apply pred (map car lists)) i)
+	    (else
+	     (lp (map cdr lists) (+ i 1)))))))
+
+;;; Association lists
+
+(define alist-cons acons)
+
+(define (alist-copy alist)
+  "Return a copy of ALIST, copying both the pairs comprising the list
+and those making the associations."
+  (let lp ((a  alist)
+           (rl '()))
+    (if (null? a)
+        (reverse! rl)
+        (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
+
+(define* (alist-delete key alist #\optional (k= equal?))
+  (check-arg procedure? k= alist-delete)
+  (let lp ((a alist) (rl '()))
+    (if (null? a)
+	(reverse! rl)
+	(if (k= key (caar a))
+            (lp (cdr a) rl)
+            (lp (cdr a) (cons (car a) rl))))))
+
+(define* (alist-delete! key alist #\optional (k= equal?))
+  (alist-delete key alist k=))	; XXX:optimize
+
+;;; Delete / assoc / member
+
+(define* (member x ls #\optional (= equal?))
+  (cond
+   ;; This might be performance-sensitive, so punt on the check here,
+   ;; relying on memq/memv to check that = is a procedure.
+   ((eq? = eq?) (memq x ls))
+   ((eq? = eqv?) (memv x ls))
+   (else 
+    (check-arg procedure? = member)
+    (find-tail (lambda (y) (= x y)) ls))))
+
+;;; Set operations on lists
+
+(define (lset<= = . rest)
+  (check-arg procedure? = lset<=)
+  (if (null? rest)
+      #t
+      (let lp ((f (car rest)) (r (cdr rest)))
+        (or (null? r)
+            (and (every (lambda (el) (member el (car r) =)) f)
+                 (lp (car r) (cdr r)))))))
+
+(define (lset= = . rest)
+  (check-arg procedure? = lset<=)
+  (if (null? rest)
+    #t
+    (let lp ((f (car rest)) (r (cdr rest)))
+      (or (null? r)
+	  (and (every (lambda (el) (member el (car r) =)) f)
+	       (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
+	       (lp (car r) (cdr r)))))))
+
+;; It's not quite clear if duplicates among the `rest' elements are meant to
+;; be cast out.  The spec says `=' is called as (= lstelem restelem),
+;; suggesting perhaps not, but the reference implementation shows the "list"
+;; at each stage as including those elements already added.  The latter
+;; corresponds to what's described for lset-union, so that's what's done.
+;;
+(define (lset-adjoin = list . rest)
+  "Add to LIST any of the elements of REST not already in the list.
+These elements are `cons'ed onto the start of LIST (so the return shares
+a common tail with LIST), but the order they're added is unspecified.
+
+The given `=' procedure is used for comparing elements, called
+as `(@var{=} listelem elem)', i.e., the second argument is one of the
+given REST parameters."
+  ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
+  ;; first, so we can pass the raw procedure through to `member',
+  ;; allowing `memq' / `memv' to be selected.
+  (define pred
+    (if (or (eq? = eq?) (eq? = eqv?))
+        =
+        (begin
+          (check-arg procedure? = lset-adjoin)
+          (lambda (x y) (= y x)))))
+  
+  (let lp ((ans list) (rest rest))
+    (if (null? rest)
+        ans
+        (lp (if (member (car rest) ans pred)
+                ans
+                (cons (car rest) ans))
+            (cdr rest)))))
+
+(define (lset-union = . rest)
+  ;; Likewise, allow memq / memv to be used if possible.
+  (define pred
+    (if (or (eq? = eq?) (eq? = eqv?))
+        =
+        (begin
+          (check-arg procedure? = lset-union)
+          (lambda (x y) (= y x)))))
+  
+  (fold (lambda (lis ans)		; Compute ANS + LIS.
+          (cond ((null? lis) ans)	; Don't copy any lists
+                ((null? ans) lis) 	; if we don't have to.
+                ((eq? lis ans) ans)
+                (else
+                 (fold (lambda (elt ans)
+                         (if (member elt ans pred)
+                             ans
+                             (cons elt ans)))
+                       ans lis))))
+        '()
+        rest))
+
+(define (lset-intersection = list1 . rest)
+  (check-arg procedure? = lset-intersection)
+  (let lp ((l list1) (acc '()))
+    (if (null? l)
+      (reverse! acc)
+      (if (every (lambda (ll) (member (car l) ll =)) rest)
+	(lp (cdr l) (cons (car l) acc))
+	(lp (cdr l) acc)))))
+
+(define (lset-difference = list1 . rest)
+  (check-arg procedure? = lset-difference)
+  (if (null? rest)
+    list1
+    (let lp ((l list1) (acc '()))
+      (if (null? l)
+	(reverse! acc)
+	(if (any (lambda (ll) (member (car l) ll =)) rest)
+	  (lp (cdr l) acc)
+	  (lp (cdr l) (cons (car l) acc)))))))
+
+;(define (fold kons knil list1 . rest)
+
+(define (lset-xor = . rest)
+  (check-arg procedure? = lset-xor)
+  (fold (lambda (lst res)
+	  (let lp ((l lst) (acc '()))
+	    (if (null? l)
+	      (let lp0 ((r res) (acc acc))
+		(if (null? r)
+		  (reverse! acc)
+		  (if (member (car r) lst =)
+		    (lp0 (cdr r) acc)
+		    (lp0 (cdr r) (cons (car r) acc)))))
+	      (if (member (car l) res =)
+		(lp (cdr l) acc)
+		(lp (cdr l) (cons (car l) acc))))))
+	'()
+	rest))
+
+(define (lset-diff+intersection = list1 . rest)
+  (check-arg procedure? = lset-diff+intersection)
+  (let lp ((l list1) (accd '()) (acci '()))
+    (if (null? l)
+      (values (reverse! accd) (reverse! acci))
+      (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
+	(if appears
+	  (lp (cdr l) accd (cons (car l) acci))
+	  (lp (cdr l) (cons (car l) accd) acci))))))
+
+
+(define (lset-union! = . rest)
+  (check-arg procedure? = lset-union!)
+  (apply lset-union = rest))		; XXX:optimize
+
+(define (lset-intersection! = list1 . rest)
+  (check-arg procedure? = lset-intersection!)
+  (apply lset-intersection = list1 rest)) ; XXX:optimize
+
+(define (lset-xor! = . rest)
+  (check-arg procedure? = lset-xor!)
+  (apply lset-xor = rest))		; XXX:optimize
+
+(define (lset-diff+intersection! = list1 . rest)
+  (check-arg procedure? = lset-diff+intersection!)
+  (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
+
+;;; srfi-1.scm ends here
+;;; srfi-10.scm --- Hash-Comma Reader Extension
+
+;; 	Copyright (C) 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 implements the syntax extension #,(), also called
+;; hash-comma, which is defined in SRFI-10.
+;;
+;; The support for SRFI-10 consists of the procedure
+;; `define-reader-ctor' for defining new reader constructors and the
+;; read syntax form
+;;
+;; #,(<ctor> <datum> ...)
+;;
+;; where <ctor> must be a symbol for which a read constructor was
+;; defined previously.
+;;
+;; Example:
+;;
+;; (define-reader-ctor 'file open-input-file)
+;; (define f '#,(file "/etc/passwd"))
+;; (read-line f)
+;; =>
+;; "root:x:0:0:root:/root:/bin/bash"
+;;
+;; Please note the quote before the #,(file ...) expression.  This is
+;; necessary because ports are not self-evaluating in Guile.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-10)
+  \:use-module (ice-9 rdelim)
+  \:export (define-reader-ctor))
+
+(cond-expand-provide (current-module) '(srfi-10))
+
+;; This hash table stores the association between comma-hash tags and
+;; the corresponding constructor procedures.
+;;
+(define reader-ctors (make-hash-table 31))
+
+;; This procedure installs the procedure @var{proc} as the constructor
+;; for the comma-hash tag @var{symbol}.
+;;
+(define (define-reader-ctor symbol proc)
+  (hashq-set! reader-ctors symbol proc)
+  (if #f #f))				; Return unspecified value.
+
+;; Retrieve the constructor procedure for the tag @var{symbol} or
+;; throw an error if no such tag is defined.
+;;
+(define (lookup symbol)
+  (let ((p (hashq-ref reader-ctors symbol #f)))
+    (if (procedure? p)
+	p
+	(error "unknown hash-comma tag " symbol))))
+
+;; This is the actual reader extension.
+;;
+(define (hash-comma char port)
+  (let* ((obj (read port)))
+    (if (and (list? obj) (positive? (length obj)) (symbol? (car obj)))
+	(let ((p (lookup (car obj))))
+	  (let ((res (apply p (cdr obj))))
+	    res))
+	(error "syntax error in hash-comma expression"))))
+
+;; Install the hash extension.
+;;
+(read-hash-extend #\, hash-comma)
+
+;;; srfi-10.scm ends here
+;;; srfi-11.scm --- let-values and let*-values
+
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 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
+
+;;; Commentary:
+
+;; This module exports two syntax forms: let-values and let*-values.
+;;
+;; Sample usage:
+;;
+;;   (let-values (((x y . z) (foo a b))
+;;                ((p q) (bar c)))
+;;     (baz x y z p q))
+;;
+;; This binds `x' and `y' to the first to values returned by `foo',
+;; `z' to the rest of the values from `foo', and `p' and `q' to the
+;; values returned by `bar'.  All of these are available to `baz'.
+;;
+;; let*-values : let-values :: let* : let
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-11)
+  \:export-syntax (let-values let*-values))
+
+(cond-expand-provide (current-module) '(srfi-11))
+
+;;;;;;;;;;;;;;
+;; let-values
+;;
+;; Current approach is to translate
+;;
+;;   (let-values (((x y . z) (foo a b))
+;;                ((p q) (bar c)))
+;;     (baz x y z p q))
+;;
+;; into
+;;
+;;   (call-with-values (lambda () (foo a b))
+;;     (lambda (<tmp-x> <tmp-y> . <tmp-z>)
+;;       (call-with-values (lambda () (bar c))
+;;         (lambda (<tmp-p> <tmp-q>)
+;;           (let ((x <tmp-x>)
+;;                 (y <tmp-y>)
+;;                 (z <tmp-z>)
+;;                 (p <tmp-p>)
+;;                 (q <tmp-q>))
+;;             (baz x y z p q))))))
+
+;; We could really use quasisyntax here...
+(define-syntax let-values
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((binds exp)) b0 b1 ...)
+       (syntax (call-with-values (lambda () exp)
+                 (lambda binds b0 b1 ...))))
+      ((_ (clause ...) b0 b1 ...)
+       (let lp ((clauses (syntax (clause ...)))
+                (ids '())
+                (tmps '()))
+         (if (null? clauses)
+             (with-syntax (((id ...) ids)
+                           ((tmp ...) tmps))
+               (syntax (let ((id tmp) ...)
+                         b0 b1 ...)))
+             (syntax-case (car clauses) ()
+               (((var ...) exp)
+                (with-syntax (((new-tmp ...) (generate-temporaries 
+                                              (syntax (var ...))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (var ... id ...))
+                                           (syntax (new-tmp ... tmp ...)))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda (new-tmp ...) inner))))))
+               ((vars exp)
+                (with-syntax ((((new-tmp . new-var) ...)
+                               (let lp ((vars (syntax vars)))
+                                 (syntax-case vars ()
+                                   ((id . rest)
+                                    (acons (syntax id)
+                                           (car
+                                            (generate-temporaries (syntax (id))))
+                                           (lp (syntax rest))))
+                                   (id (acons (syntax id)
+                                              (car
+                                               (generate-temporaries (syntax (id))))
+                                              '())))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (new-var ... id ...))
+                                           (syntax (new-tmp ... tmp ...))))
+                                (args (let lp ((tmps (syntax (new-tmp ...))))
+                                        (syntax-case tmps ()
+                                          ((id) (syntax id))
+                                          ((id . rest) (cons (syntax id)
+                                                             (lp (syntax rest))))))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda args inner)))))))))))))
+
+;;;;;;;;;;;;;;
+;; let*-values
+;;
+;; Current approach is to translate
+;;
+;;   (let*-values (((x y z) (foo a b))
+;;                ((p q) (bar c)))
+;;     (baz x y z p q))
+;;
+;; into
+;;
+;;   (call-with-values (lambda () (foo a b))
+;;     (lambda (x y z)
+;;       (call-with-values (lambda (bar c))
+;;         (lambda (p q)
+;;           (baz x y z p q)))))
+
+(define-syntax let*-values
+  (syntax-rules ()
+    ((let*-values () body ...)
+     (let () body ...))
+    ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
+     (call-with-values (lambda () binding-1)
+       (lambda vars-1
+         (let*-values ((vars-2 binding-2) ...)
+           body ...))))))
+
+;;; srfi-11.scm ends here
+;;; srfi-111.scm -- SRFI 111 Boxes
+
+;;      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, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-111)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\export (box box? unbox set-box!))
+
+(cond-expand-provide (current-module) '(srfi-111))
+
+(define-record-type <box>
+  (box value)
+  box?
+  (value unbox set-box!))
+
+(set-record-type-printer! <box>
+  (lambda (box port)
+    (display "#<box " port)
+    (display (number->string (object-address box) 16) port)
+    (display " value: ")
+    (write (unbox box) port)
+    (display ">" port)))
+;;; srfi-13.scm --- String Library
+
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 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.
+;;
+;; All procedures are in the core and are simply reexported here.
+
+;;; Code:
+
+(define-module (srfi srfi-13))
+
+(re-export
+;;; Predicates
+ string?
+ string-null?
+ string-any
+ string-every
+
+;;; Constructors
+ make-string
+ string
+ string-tabulate
+
+;;; List/string conversion
+ string->list
+ list->string
+ reverse-list->string
+ string-join
+
+;;; Selection
+ string-length
+ string-ref
+ string-copy
+ substring/shared
+ string-copy!
+ string-take string-take-right
+ string-drop string-drop-right
+ string-pad string-pad-right
+ string-trim string-trim-right
+ string-trim-both
+
+;;; Modification
+ string-set!
+ string-fill!
+
+;;; Comparison
+ string-compare
+ string-compare-ci
+ string= string<>
+ string< string>
+ string<= string>=
+ string-ci= string-ci<>
+ string-ci< string-ci>
+ string-ci<= string-ci>=
+ string-hash string-hash-ci
+
+;;; Prefixes/Suffixes
+ string-prefix-length
+ string-prefix-length-ci
+ string-suffix-length
+ string-suffix-length-ci
+ string-prefix?
+ string-prefix-ci?
+ string-suffix?
+ string-suffix-ci?
+
+;;; Searching
+ string-index
+ string-index-right
+ string-skip string-skip-right
+ string-count
+ string-contains string-contains-ci
+
+;;; Alphabetic case mapping
+ string-upcase
+ string-upcase!
+ string-downcase
+ string-downcase!
+ string-titlecase
+ string-titlecase!
+
+;;; Reverse/Append
+ string-reverse
+ string-reverse!
+ string-append
+ string-append/shared
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate/shared
+ string-concatenate-reverse/shared
+
+;;; Fold/Unfold/Map
+ string-map string-map!
+ string-fold
+ string-fold-right
+ string-unfold
+ string-unfold-right
+ string-for-each
+ string-for-each-index
+
+;;; Replicate/Rotate
+ xsubstring
+ string-xcopy!
+
+;;; Miscellaneous
+ string-replace
+ string-tokenize
+
+;;; Filtering/Deleting
+ string-filter
+ string-delete)
+
+(cond-expand-provide (current-module) '(srfi-13))
+
+;;; srfi-13.scm ends here
+;;; srfi-14.scm --- Character-set Library
+
+;; 	Copyright (C) 2001, 2002, 2004, 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-14))
+
+(re-export
+;;; General procedures
+ char-set?
+ char-set=
+ char-set<=
+ char-set-hash
+
+;;; Iterating over character sets
+ char-set-cursor
+ char-set-ref
+ char-set-cursor-next
+ end-of-char-set?
+ char-set-fold
+ char-set-unfold char-set-unfold!
+ char-set-for-each
+ char-set-map
+
+;;; Creating character sets
+ char-set-copy
+ char-set
+ list->char-set list->char-set!
+ string->char-set string->char-set!
+ char-set-filter char-set-filter!
+ ucs-range->char-set ucs-range->char-set!
+ ->char-set
+
+;;; Querying character sets
+ char-set-size
+ char-set-count
+ char-set->list
+ char-set->string
+ char-set-contains?
+ char-set-every
+ char-set-any
+
+;;; Character set algebra
+ char-set-adjoin char-set-adjoin!
+ char-set-delete char-set-delete!
+ char-set-complement
+ char-set-union
+ char-set-intersection
+ char-set-difference
+ char-set-xor
+ char-set-diff+intersection
+ char-set-complement!
+ char-set-union!
+ char-set-intersection!
+ char-set-difference!
+ char-set-xor!
+ char-set-diff+intersection!
+
+;;; Standard character sets
+ char-set:lower-case
+ char-set:upper-case
+ char-set:title-case
+ char-set:letter
+ char-set:digit
+ char-set:letter+digit
+ char-set:graphic
+ char-set:printing
+ char-set:whitespace
+ char-set:iso-control
+ char-set:punctuation
+ char-set:symbol
+ char-set:hex-digit
+ char-set:blank
+ char-set:ascii
+ char-set:empty
+ char-set:full)
+
+(cond-expand-provide (current-module) '(srfi-14))
+
+;;; srfi-14.scm ends here
+;;; srfi-16.scm --- case-lambda
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 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
+
+;;; Commentary:
+
+;; Implementation of SRFI-16.  `case-lambda' is a syntactic form
+;; which permits writing functions acting different according to the
+;; number of arguments passed.
+;;
+;; The syntax of the `case-lambda' form is defined in the following
+;; EBNF grammar.
+;;
+;; <case-lambda>
+;;    --> (case-lambda <case-lambda-clause>)
+;; <case-lambda-clause>
+;;    --> (<signature> <definition-or-command>*)
+;; <signature>
+;;    --> (<identifier>*)
+;;      | (<identifier>* . <identifier>)
+;;      | <identifier>
+;;
+;; The value returned by a `case-lambda' form is a procedure which
+;; matches the number of actual arguments against the signatures in
+;; the various clauses, in order.  The first matching clause is
+;; selected, the corresponding values from the actual parameter list
+;; are bound to the variable names in the clauses and the body of the
+;; clause is evaluated.
+
+;;; Code:
+
+(define-module (srfi srfi-16)
+  #\re-export (case-lambda))
+
+;; Case-lambda is now provided by core psyntax.
+;;; srfi-17.scm --- Generalized set!
+
+;; Copyright (C) 2001, 2002, 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
+
+;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-17: Generalized set!
+;;
+;; It exports the Guile procedure `make-procedure-with-setter' under
+;; the SRFI name `getter-with-setter' and exports the standard
+;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
+;; `vector-ref' as procedures with setters, as required by the SRFI.
+;;
+;; SRFI-17 was heavily criticized during its discussion period but it
+;; was finalized anyway.  One issue was its concept of globally
+;; associating setter "properties" with (procedure) values, which is
+;; non-Schemy.  For this reason, this implementation chooses not to
+;; provide a way to set the setter of a procedure.  In fact, (set!
+;; (setter PROC) SETTER) signals an error.  The only way to attach a
+;; setter to a procedure is to create a new object (a "procedure with
+;; setter") via the `getter-with-setter' procedure. This procedure is
+;; also specified in the SRFI.  Using it avoids the described
+;; problems.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-17)
+  \:export (getter-with-setter)
+  \:replace (;; redefined standard procedures
+	    setter
+	    car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
+	    cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
+	    caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
+	    cdddar cddddr string-ref vector-ref))
+
+(cond-expand-provide (current-module) '(srfi-17))
+
+;;; Procedures
+
+(define getter-with-setter make-procedure-with-setter)
+
+(define setter
+  (getter-with-setter
+   (@ (guile) setter)
+   (lambda args
+     (error "Setting setters is not supported for a good reason."))))
+
+;;; Redefine R5RS procedures to appropriate procedures with setters
+
+(define (compose-setter setter location)
+  (lambda (obj value)
+    (setter (location obj) value)))
+
+(define car
+  (getter-with-setter (@ (guile) car)
+                      set-car!))
+(define cdr
+  (getter-with-setter (@ (guile) cdr)
+                      set-cdr!))
+
+(define caar
+  (getter-with-setter (@ (guile) caar)
+                      (compose-setter set-car! (@ (guile) car))))
+(define cadr
+  (getter-with-setter (@ (guile) cadr)
+                      (compose-setter set-car! (@ (guile) cdr))))
+(define cdar
+  (getter-with-setter (@ (guile) cdar)
+                      (compose-setter set-cdr! (@ (guile) car))))
+(define cddr
+  (getter-with-setter (@ (guile) cddr)
+                      (compose-setter set-cdr! (@ (guile) cdr))))
+
+(define caaar
+  (getter-with-setter (@ (guile) caaar)
+                      (compose-setter set-car! (@ (guile) caar))))
+(define caadr
+  (getter-with-setter (@ (guile) caadr)
+                      (compose-setter set-car! (@ (guile) cadr))))
+(define cadar
+  (getter-with-setter (@ (guile) cadar)
+                      (compose-setter set-car! (@ (guile) cdar))))
+(define caddr
+  (getter-with-setter (@ (guile) caddr)
+                      (compose-setter set-car! (@ (guile) cddr))))
+(define cdaar
+  (getter-with-setter (@ (guile) cdaar)
+                      (compose-setter set-cdr! (@ (guile) caar))))
+(define cdadr
+  (getter-with-setter (@ (guile) cdadr)
+                      (compose-setter set-cdr! (@ (guile) cadr))))
+(define cddar
+  (getter-with-setter (@ (guile) cddar)
+                      (compose-setter set-cdr! (@ (guile) cdar))))
+(define cdddr
+  (getter-with-setter (@ (guile) cdddr)
+                      (compose-setter set-cdr! (@ (guile) cddr))))
+
+(define caaaar
+  (getter-with-setter (@ (guile) caaaar)
+                      (compose-setter set-car! (@ (guile) caaar))))
+(define caaadr
+  (getter-with-setter (@ (guile) caaadr)
+                      (compose-setter set-car! (@ (guile) caadr))))
+(define caadar
+  (getter-with-setter (@ (guile) caadar)
+                      (compose-setter set-car! (@ (guile) cadar))))
+(define caaddr
+  (getter-with-setter (@ (guile) caaddr)
+                      (compose-setter set-car! (@ (guile) caddr))))
+(define cadaar
+  (getter-with-setter (@ (guile) cadaar)
+                      (compose-setter set-car! (@ (guile) cdaar))))
+(define cadadr
+  (getter-with-setter (@ (guile) cadadr)
+                      (compose-setter set-car! (@ (guile) cdadr))))
+(define caddar
+  (getter-with-setter (@ (guile) caddar)
+                      (compose-setter set-car! (@ (guile) cddar))))
+(define cadddr
+  (getter-with-setter (@ (guile) cadddr)
+                      (compose-setter set-car! (@ (guile) cdddr))))
+(define cdaaar
+  (getter-with-setter (@ (guile) cdaaar)
+                      (compose-setter set-cdr! (@ (guile) caaar))))
+(define cdaadr
+  (getter-with-setter (@ (guile) cdaadr)
+                      (compose-setter set-cdr! (@ (guile) caadr))))
+(define cdadar
+  (getter-with-setter (@ (guile) cdadar)
+                      (compose-setter set-cdr! (@ (guile) cadar))))
+(define cdaddr
+  (getter-with-setter (@ (guile) cdaddr)
+                      (compose-setter set-cdr! (@ (guile) caddr))))
+(define cddaar
+  (getter-with-setter (@ (guile) cddaar)
+                      (compose-setter set-cdr! (@ (guile) cdaar))))
+(define cddadr
+  (getter-with-setter (@ (guile) cddadr)
+                      (compose-setter set-cdr! (@ (guile) cdadr))))
+(define cdddar
+  (getter-with-setter (@ (guile) cdddar)
+                      (compose-setter set-cdr! (@ (guile) cddar))))
+(define cddddr
+  (getter-with-setter (@ (guile) cddddr)
+                      (compose-setter set-cdr! (@ (guile) cdddr))))
+
+(define string-ref
+  (getter-with-setter (@ (guile) string-ref)
+                      string-set!))
+
+(define vector-ref
+  (getter-with-setter (@ (guile) vector-ref)
+                      vector-set!))
+
+;;; srfi-17.scm ends here
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008, 2009, 2010, 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: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2008-04-11
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-18 (Multithreading support).
+;;
+;; All procedures defined in SRFI-18, which are not already defined in
+;; the Guile core library, are exported.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-18)
+  \:use-module (srfi srfi-34)
+  \:export (
+
+;;; Threads
+ ;; current-thread			<= in the core
+ ;; thread?				<= in the core
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+ thread-sleep!
+ thread-terminate!
+ thread-join!
+
+;;; Mutexes
+ ;; mutex?				<= in the core
+ make-mutex
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-lock!
+ mutex-unlock!
+
+;;; Condition variables
+ ;; condition-variable?			<= in the core
+ make-condition-variable
+ condition-variable-name
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable-signal!
+ condition-variable-broadcast!
+ condition-variable-wait!
+
+;;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
+ 
+ current-exception-handler
+ with-exception-handler
+ raise
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason
+ )
+  \:re-export (current-thread thread? mutex? condition-variable?)
+  \:replace (current-time 
+	    make-thread 
+	    make-mutex 
+	    make-condition-variable
+	    raise))
+
+(if (not (provided? 'threads))
+    (error "SRFI-18 requires Guile with threads support"))
+
+(cond-expand-provide (current-module) '(srfi-18))
+
+(define (check-arg-type pred arg caller)
+  (if (pred arg)
+      arg
+      (scm-error 'wrong-type-arg caller
+		 "Wrong type argument: ~S" (list arg) '())))
+
+(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
+(define join-timeout-exception (list 'join-timeout-exception))
+(define terminated-thread-exception (list 'terminated-thread-exception))
+(define uncaught-exception (list 'uncaught-exception))
+
+(define object-names (make-weak-key-hash-table))
+(define object-specifics (make-weak-key-hash-table))
+(define thread-start-conds (make-weak-key-hash-table))
+(define thread-exception-handlers (make-weak-key-hash-table))
+
+;; EXCEPTIONS
+
+(define raise (@ (srfi srfi-34) raise))
+(define (initial-handler obj) 
+  (srfi-18-exception-preserver (cons uncaught-exception obj)))
+
+(define thread->exception (make-object-property))
+
+(define (srfi-18-exception-preserver obj)
+  (if (or (terminated-thread-exception? obj)
+          (uncaught-exception? obj))
+      (set! (thread->exception (current-thread)) obj)))
+
+(define (srfi-18-exception-handler key . args)
+
+  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
+  ;; if one is caught at this level, it has already been taken care of by
+  ;; `initial-handler'.
+
+  (and (not (eq? key 'srfi-34))
+       (srfi-18-exception-preserver (if (null? args) 
+					(cons uncaught-exception key)
+					(cons* uncaught-exception key args)))))
+
+(define (current-handler-stack)
+  (let ((ct (current-thread)))
+    (or (hashq-ref thread-exception-handlers ct)
+	(hashq-set! thread-exception-handlers ct (list initial-handler)))))
+
+(define (with-exception-handler handler thunk)
+  (let ((ct (current-thread))
+        (hl (current-handler-stack)))
+    (check-arg-type procedure? handler "with-exception-handler") 
+    (check-arg-type thunk? thunk "with-exception-handler")
+    (hashq-set! thread-exception-handlers ct (cons handler hl))
+    (apply (@ (srfi srfi-34) with-exception-handler) 
+           (list (lambda (obj)
+                   (hashq-set! thread-exception-handlers ct hl) 
+                   (handler obj))
+                 (lambda () 
+                   (call-with-values thunk
+                     (lambda res
+                       (hashq-set! thread-exception-handlers ct hl)
+                       (apply values res))))))))
+
+(define (current-exception-handler)
+  (car (current-handler-stack)))
+
+(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
+(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
+(define (uncaught-exception? obj) 
+  (and (pair? obj) (eq? (car obj) uncaught-exception)))
+(define (uncaught-exception-reason exc)
+  (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
+(define (terminated-thread-exception? obj) 
+  (eq? obj terminated-thread-exception))
+
+;; THREADS
+
+;; Create a new thread and prevent it from starting using a condition variable.
+;; Once started, install a top-level exception handler that rethrows any 
+;; exceptions wrapped in an uncaught-exception wrapper. 
+
+(define make-thread 
+  (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
+			     (lambda () 
+			       (lock-mutex lmutex)
+			       (signal-condition-variable lcond)
+			       (lock-mutex smutex)
+			       (unlock-mutex lmutex)
+			       (wait-condition-variable scond smutex)
+			       (unlock-mutex smutex)
+			       (with-exception-handler initial-handler 
+						       thunk)))))
+    (lambda (thunk . name)
+      (let ((n (and (pair? name) (car name)))
+
+	    (lm (make-mutex 'launch-mutex))
+	    (lc (make-condition-variable 'launch-condition-variable))
+	    (sm (make-mutex 'start-mutex))
+	    (sc (make-condition-variable 'start-condition-variable)))
+	
+	(lock-mutex lm)
+	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
+				       srfi-18-exception-handler)))
+	  (hashq-set! thread-start-conds t (cons sm sc))
+	  (and n (hashq-set! object-names t n))
+	  (wait-condition-variable lc lm)
+	  (unlock-mutex lm)
+	  t)))))
+
+(define (thread-name thread)
+  (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+
+(define (thread-specific thread)
+  (hashq-ref object-specifics 
+	     (check-arg-type thread? thread "thread-specific")))
+
+(define (thread-specific-set! thread obj)
+  (hashq-set! object-specifics
+	      (check-arg-type thread? thread "thread-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (thread-start! thread)
+  (let ((x (hashq-ref thread-start-conds
+		      (check-arg-type thread? thread "thread-start!"))))
+    (and x (let ((smutex (car x))
+		 (scond (cdr x)))
+	     (hashq-remove! thread-start-conds thread)
+	     (lock-mutex smutex)
+	     (signal-condition-variable scond)
+	     (unlock-mutex smutex)))
+    thread))
+
+(define (thread-yield!) (yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+  (let* ((ct (time->seconds (current-time)))
+	 (t (cond ((time? timeout) (- (time->seconds timeout) ct))
+		  ((number? timeout) (- timeout ct))
+		  (else (scm-error 'wrong-type-arg "thread-sleep!"
+				   "Wrong type argument: ~S" 
+				   (list timeout) 
+				   '()))))
+	 (secs (inexact->exact (truncate t)))
+	 (usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
+    (and (> secs 0) (sleep secs))
+    (and (> usecs 0) (usleep usecs))
+    *unspecified*))
+
+;; A convenience function for installing exception handlers on SRFI-18 
+;; primitives that resume the calling continuation after the handler is 
+;; invoked -- this resolves a behavioral incompatibility with Guile's
+;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
+;; exceptions.  (SRFI-18, "Primitives and exceptions")
+
+(define (wrap thunk)
+  (lambda (continuation)
+    (with-exception-handler (lambda (obj)
+			      ((current-exception-handler) obj)
+			      (continuation))
+			    thunk)))
+
+;; A pass-thru to cancel-thread that first installs a handler that throws
+;; terminated-thread exception, as per SRFI-18, 
+
+(define (thread-terminate! thread)
+  (define (thread-terminate-inner!)
+    (let ((current-handler (thread-cleanup thread)))
+      (if (thunk? current-handler)
+	  (set-thread-cleanup! thread 
+			       (lambda ()
+				 (with-exception-handler initial-handler
+							 current-handler) 
+				 (srfi-18-exception-preserver
+				  terminated-thread-exception)))
+	  (set-thread-cleanup! thread
+			       (lambda () (srfi-18-exception-preserver
+					   terminated-thread-exception))))
+      (cancel-thread thread)
+      *unspecified*))
+  (thread-terminate-inner!))
+
+(define (thread-join! thread . args) 
+  (define thread-join-inner!
+    (wrap (lambda ()
+	    (let ((v (apply join-thread (cons thread args)))
+		  (e (thread->exception thread)))
+	      (if (and (= (length args) 1) (not v))
+		  (raise join-timeout-exception))
+	      (if e (raise e))
+	      v))))
+  (call/cc thread-join-inner!))
+
+;; MUTEXES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-mutex
+  (lambda name
+    (let ((n (and (pair? name) (car name)))
+	  (m ((@ (guile) make-mutex) 
+	      'unchecked-unlock 
+	      'allow-external-unlock 
+	      'recursive)))
+      (and n (hashq-set! object-names m n)) m)))
+
+(define (mutex-name mutex)
+  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+
+(define (mutex-specific mutex)
+  (hashq-ref object-specifics 
+	     (check-arg-type mutex? mutex "mutex-specific")))
+
+(define (mutex-specific-set! mutex obj)
+  (hashq-set! object-specifics
+	      (check-arg-type mutex? mutex "mutex-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (mutex-state mutex)
+  (let ((owner (mutex-owner mutex)))
+    (if owner
+	(if (thread-exited? owner) 'abandoned owner)
+	(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
+
+(define (mutex-lock! mutex . args) 
+  (define mutex-lock-inner!
+    (wrap (lambda ()
+	    (catch 'abandoned-mutex-error
+		   (lambda () (apply lock-mutex (cons mutex args)))
+		   (lambda (key . args) (raise abandoned-mutex-exception))))))
+  (call/cc mutex-lock-inner!))
+
+(define (mutex-unlock! mutex . args) 
+  (apply unlock-mutex (cons mutex args)))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-condition-variable
+  (lambda name
+    (let ((n (and (pair? name) (car name)))
+	  (m ((@ (guile) make-condition-variable))))
+      (and n (hashq-set! object-names m n)) m)))
+
+(define (condition-variable-name condition-variable)
+  (hashq-ref object-names (check-arg-type condition-variable? 
+					  condition-variable
+					  "condition-variable-name")))
+
+(define (condition-variable-specific condition-variable)
+  (hashq-ref object-specifics (check-arg-type condition-variable? 
+					      condition-variable 
+					      "condition-variable-specific")))
+
+(define (condition-variable-specific-set! condition-variable obj)
+  (hashq-set! object-specifics
+	      (check-arg-type condition-variable? 
+			      condition-variable 
+			      "condition-variable-specific-set!")
+	      obj)
+  *unspecified*)
+
+(define (condition-variable-signal! cond) 
+  (signal-condition-variable cond) 
+  *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+  (broadcast-condition-variable cond)
+  *unspecified*)
+
+;; TIME
+
+(define current-time gettimeofday)
+(define (time? obj)
+  (and (pair? obj)
+       (let ((co (car obj))) (and (integer? co) (>= co 0)))
+       (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
+
+(define (time->seconds time) 
+  (and (check-arg-type time? time "time->seconds")
+       (+ (car time) (/ (cdr time) 1000000))))
+
+(define (seconds->time x)
+  (and (check-arg-type number? x "seconds->time")
+       (let ((fx (truncate x)))
+	 (cons (inexact->exact fx)
+	       (inexact->exact (truncate (* (- x fx) 1000000)))))))
+
+;; srfi-18.scm ends here
+;;; srfi-19.scm --- Time/Date Library
+
+;; Copyright (C) 2001-2003, 2005-2011, 2014, 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
+
+;;; Author: Rob Browning <rlb@cs.utexas.edu>
+;;;         Originally from SRFI reference implementation by Will Fitzgerald.
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+;; FIXME: I haven't checked a decent amount of this code for potential
+;; performance improvements, but I suspect that there may be some
+;; substantial ones to be realized, esp. in the later "parsing" half
+;; of the file, by rewriting the code with use of more Guile native
+;; functions that do more work in a "chunk".
+;;
+;; FIXME: mkoeppe: Time zones are treated a little simplistic in
+;; SRFI-19; they are only a numeric offset.  Thus, printing time zones
+;; (LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly.  The
+;; functions taking an optional TZ-OFFSET should be extended to take a
+;; symbolic time-zone (like "CET"); this string should be stored in
+;; the DATE structure.
+
+(define-module (srfi srfi-19)
+  \:use-module (srfi srfi-6)
+  \:use-module (srfi srfi-8)
+  \:use-module (srfi srfi-9)
+  \:autoload   (ice-9 rdelim) (read-line)
+  \:use-module (ice-9 i18n)
+  \:replace (current-time)
+  \:export (;; Constants
+           time-duration
+           time-monotonic
+           time-process
+           time-tai
+           time-thread
+           time-utc
+           ;; Current time and clock resolution
+           current-date
+           current-julian-day
+           current-modified-julian-day
+           time-resolution
+           ;; Time object and accessors
+           make-time
+           time?
+           time-type
+           time-nanosecond
+           time-second
+           set-time-type!
+           set-time-nanosecond!
+           set-time-second!
+           copy-time
+           ;; Time comparison procedures
+           time<=?
+           time<?
+           time=?
+           time>=?
+           time>?
+           ;; Time arithmetic procedures
+           time-difference
+           time-difference!
+           add-duration
+           add-duration!
+           subtract-duration
+           subtract-duration!
+           ;; Date object and accessors
+           make-date
+           date?
+           date-nanosecond
+           date-second
+           date-minute
+           date-hour
+           date-day
+           date-month
+           date-year
+           date-zone-offset
+           date-year-day
+           date-week-day
+           date-week-number
+           ;; Time/Date/Julian Day/Modified Julian Day converters
+           date->julian-day
+           date->modified-julian-day
+           date->time-monotonic
+           date->time-tai
+           date->time-utc
+           julian-day->date
+           julian-day->time-monotonic
+           julian-day->time-tai
+           julian-day->time-utc
+           modified-julian-day->date
+           modified-julian-day->time-monotonic
+           modified-julian-day->time-tai
+           modified-julian-day->time-utc
+           time-monotonic->date
+           time-monotonic->julian-day
+           time-monotonic->modified-julian-day
+           time-monotonic->time-tai
+           time-monotonic->time-tai!
+           time-monotonic->time-utc
+           time-monotonic->time-utc!
+           time-tai->date
+           time-tai->julian-day
+           time-tai->modified-julian-day
+           time-tai->time-monotonic
+           time-tai->time-monotonic!
+           time-tai->time-utc
+           time-tai->time-utc!
+           time-utc->date
+           time-utc->julian-day
+           time-utc->modified-julian-day
+           time-utc->time-monotonic
+           time-utc->time-monotonic!
+           time-utc->time-tai
+           time-utc->time-tai!
+           ;; Date to string/string to date converters.
+           date->string
+           string->date))
+
+(cond-expand-provide (current-module) '(srfi-19))
+
+(define time-tai 'time-tai)
+(define time-utc 'time-utc)
+(define time-monotonic 'time-monotonic)
+(define time-thread 'time-thread)
+(define time-process 'time-process)
+(define time-duration 'time-duration)
+
+;; FIXME: do we want to add gc time?
+;; (define time-gc 'time-gc)
+
+;;-- LOCALE dependent constants
+
+;; See date->string
+(define locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
+(define locale-short-date-format "~m/~d/~y")
+(define locale-time-format "~H:~M:~S")
+(define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
+
+;;-- Miscellaneous Constants.
+;;-- only the tai-epoch-in-jd might need changing if
+;;   a different epoch is used.
+
+(define nano 1000000000)           ; nanoseconds in a second
+(define sid  86400)                ; seconds in a day
+(define sihd 43200)                ; seconds in a half day
+(define tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+
+;; FIXME: should this be something other than misc-error?
+(define (time-error caller type value)
+  (if value
+      (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
+      (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
+
+;; A table of leap seconds
+;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
+;; and update as necessary.
+;; this procedures reads the file in the above
+;; format and creates the leap second table
+;; it also calls the almost standard, but not R5 procedures read-line
+;; & open-input-string
+;; ie (set! leap-second-table (read-tai-utc-date "tai-utc.dat"))
+
+(define (read-tai-utc-data filename)
+  (define (convert-jd jd)
+    (* (- (inexact->exact jd) tai-epoch-in-jd) sid))
+  (define (convert-sec sec)
+    (inexact->exact sec))
+  (let ((port (open-input-file filename))
+        (table '()))
+    (let loop ((line (read-line port)))
+      (if (not (eof-object? line))
+          (begin
+            (let* ((data (read (open-input-string
+                                (string-append "(" line ")"))))
+                   (year (car data))
+                   (jd   (cadddr (cdr data)))
+                   (secs (cadddr (cdddr data))))
+              (if (>= year 1972)
+                  (set! table (cons
+                               (cons (convert-jd jd) (convert-sec secs))
+                               table)))
+              (loop (read-line port))))))
+    table))
+
+;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
+;; note they go higher to lower, and end in 1972.
+(define leap-second-table
+  '((1435708800 . 36)
+    (1341100800 . 35)
+    (1230768000 . 34)
+    (1136073600 . 33)
+    (915148800 . 32)
+    (867715200 . 31)
+    (820454400 . 30)
+    (773020800 . 29)
+    (741484800 . 28)
+    (709948800 . 27)
+    (662688000 . 26)
+    (631152000 . 25)
+    (567993600 . 24)
+    (489024000 . 23)
+    (425865600 . 22)
+    (394329600 . 21)
+    (362793600 . 20)
+    (315532800 . 19)
+    (283996800 . 18)
+    (252460800 . 17)
+    (220924800 . 16)
+    (189302400 . 15)
+    (157766400 . 14)
+    (126230400 . 13)
+    (94694400  . 12)
+    (78796800  . 11)
+    (63072000  . 10)))
+
+(define (read-leap-second-table filename)
+  (set! leap-second-table (read-tai-utc-data filename)))
+
+
+(define (leap-second-delta utc-seconds)
+  (letrec ((lsd (lambda (table)
+                  (cond ((>= utc-seconds (caar table))
+                         (cdar table))
+                        (else (lsd (cdr table)))))))
+    (if (< utc-seconds  (* (- 1972 1970) 365 sid)) 0
+        (lsd  leap-second-table))))
+
+
+;;; the TIME structure; creates the accessors, too.
+
+(define-record-type time
+  (make-time-unnormalized type nanosecond second)
+  time?
+  (type time-type set-time-type!)
+  (nanosecond time-nanosecond set-time-nanosecond!)
+  (second time-second set-time-second!))
+
+(define (copy-time time)
+  (make-time (time-type time) (time-nanosecond time) (time-second time)))
+
+(define (split-real r)
+  (if (integer? r)
+      (values (inexact->exact r) 0)
+      (let ((l (truncate r)))
+        (values (inexact->exact l) (- r l)))))
+
+(define (time-normalize! t)
+  (if (>= (abs (time-nanosecond t)) 1000000000)
+      (receive (int frac)
+	  (split-real (time-nanosecond t))
+	(set-time-second! t (+ (time-second t)
+			       (quotient int 1000000000)))
+	(set-time-nanosecond! t (+ (remainder int 1000000000)
+				   frac))))
+  (if (and (positive? (time-second t))
+           (negative? (time-nanosecond t)))
+      (begin
+        (set-time-second! t (- (time-second t) 1))
+        (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
+      (if (and (negative? (time-second t))
+               (positive? (time-nanosecond t)))
+          (begin
+            (set-time-second! t (+ (time-second t) 1))
+            (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
+  t)
+
+(define (make-time type nanosecond second)
+  (time-normalize! (make-time-unnormalized type nanosecond second)))
+
+;; Helpers
+;; FIXME: finish this and publish it?
+(define (date->broken-down-time date)
+  (let ((result (mktime 0)))
+    ;; FIXME: What should we do about leap-seconds which may overflow
+    ;; set-tm:sec?
+    (set-tm:sec result (date-second date))
+    (set-tm:min result (date-minute date))
+    (set-tm:hour result (date-hour date))
+    ;; FIXME: SRFI day ranges from 0-31.  (not compatible with set-tm:mday).
+    (set-tm:mday result (date-day date))
+    (set-tm:mon result (- (date-month date) 1))
+    ;; FIXME: need to signal error on range violation.
+    (set-tm:year result (+ 1900 (date-year date)))
+    (set-tm:isdst result -1)
+    (set-tm:gmtoff result (- (date-zone-offset date)))
+    result))
+
+;;; current-time
+
+;;; specific time getters.
+
+(define (current-time-utc)
+  ;; Resolution is microseconds.
+  (let ((tod (gettimeofday)))
+    (make-time time-utc (* (cdr tod) 1000) (car tod))))
+
+(define (current-time-tai)
+  ;; Resolution is microseconds.
+  (let* ((tod (gettimeofday))
+         (sec (car tod))
+         (usec (cdr tod)))
+    (make-time time-tai
+               (* usec 1000)
+               (+ (car tod) (leap-second-delta sec)))))
+
+;;(define (current-time-ms-time time-type proc)
+;;  (let ((current-ms (proc)))
+;;    (make-time time-type
+;;               (quotient current-ms 10000)
+;;       (* (remainder current-ms 1000) 10000))))
+
+;; -- we define it to be the same as TAI.
+;;    A different implemation of current-time-montonic
+;;    will require rewriting all of the time-monotonic converters,
+;;    of course.
+
+(define (current-time-monotonic)
+  ;; Resolution is microseconds.
+  (current-time-tai))
+
+(define (current-time-thread)
+  (time-error 'current-time 'unsupported-clock-type 'time-thread))
+
+(define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
+
+(define (current-time-process)
+  (let ((run-time (get-internal-run-time)))
+    (make-time
+     time-process
+     (* (remainder run-time internal-time-units-per-second)
+        ns-per-guile-tick)
+     (quotient run-time internal-time-units-per-second))))
+
+;;(define (current-time-gc)
+;;  (current-time-ms-time time-gc current-gc-milliseconds))
+
+(define (current-time . clock-type)
+  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+    (cond
+     ((eq? clock-type time-tai) (current-time-tai))
+     ((eq? clock-type time-utc) (current-time-utc))
+     ((eq? clock-type time-monotonic) (current-time-monotonic))
+     ((eq? clock-type time-thread) (current-time-thread))
+     ((eq? clock-type time-process) (current-time-process))
+     ;;     ((eq? clock-type time-gc) (current-time-gc))
+     (else (time-error 'current-time 'invalid-clock-type clock-type)))))
+
+;; -- Time Resolution
+;; This is the resolution of the clock in nanoseconds.
+;; This will be implementation specific.
+
+(define (time-resolution . clock-type)
+  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+    (case clock-type
+      ((time-tai) 1000)
+      ((time-utc) 1000)
+      ((time-monotonic) 1000)
+      ((time-process) ns-per-guile-tick)
+      ;;     ((eq? clock-type time-thread) 1000)
+      ;;     ((eq? clock-type time-gc) 10000)
+      (else (time-error 'time-resolution 'invalid-clock-type clock-type)))))
+
+;; -- Time comparisons
+
+(define (time=? t1 t2)
+  ;; Arrange tests for speed and presume that t1 and t2 are actually times.
+  ;; also presume it will be rare to check two times of different types.
+  (and (= (time-second t1) (time-second t2))
+       (= (time-nanosecond t1) (time-nanosecond t2))
+       (eq? (time-type t1) (time-type t2))))
+
+(define (time>? t1 t2)
+  (or (> (time-second t1) (time-second t2))
+      (and (= (time-second t1) (time-second t2))
+           (> (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<? t1 t2)
+  (or (< (time-second t1) (time-second t2))
+      (and (= (time-second t1) (time-second t2))
+           (< (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time>=? t1 t2)
+  (or (> (time-second t1) (time-second t2))
+      (and (= (time-second t1) (time-second t2))
+           (>= (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<=? t1 t2)
+  (or (< (time-second t1) (time-second t2))
+      (and (= (time-second t1) (time-second t2))
+           (<= (time-nanosecond t1) (time-nanosecond t2)))))
+
+;; -- Time arithmetic
+
+(define (time-difference! time1 time2)
+  (let ((sec-diff (- (time-second time1) (time-second time2)))
+        (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
+    (set-time-type! time1 time-duration)
+    (set-time-second! time1 sec-diff)
+    (set-time-nanosecond! time1 nsec-diff)
+    (time-normalize! time1)))
+
+(define (time-difference time1 time2)
+  (let ((result (copy-time time1)))
+    (time-difference! result time2)))
+
+(define (add-duration! t duration)
+  (if (not (eq? (time-type duration) time-duration))
+      (time-error 'add-duration 'not-duration duration)
+      (let ((sec-plus (+ (time-second t) (time-second duration)))
+            (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
+        (set-time-second! t sec-plus)
+        (set-time-nanosecond! t nsec-plus)
+        (time-normalize! t))))
+
+(define (add-duration t duration)
+  (let ((result (copy-time t)))
+    (add-duration! result duration)))
+
+(define (subtract-duration! t duration)
+  (if (not (eq? (time-type duration) time-duration))
+      (time-error 'add-duration 'not-duration duration)
+      (let ((sec-minus  (- (time-second t) (time-second duration)))
+            (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
+        (set-time-second! t sec-minus)
+        (set-time-nanosecond! t nsec-minus)
+        (time-normalize! t))))
+
+(define (subtract-duration time1 duration)
+  (let ((result (copy-time time1)))
+    (subtract-duration! result duration)))
+
+;; -- Converters between types.
+
+(define (priv:time-tai->time-utc! time-in time-out caller)
+  (if (not (eq? (time-type time-in) time-tai))
+      (time-error caller 'incompatible-time-types time-in))
+  (set-time-type! time-out time-utc)
+  (set-time-nanosecond! time-out (time-nanosecond time-in))
+  (set-time-second!     time-out (- (time-second time-in)
+                                    (leap-second-delta
+                                     (time-second time-in))))
+  time-out)
+
+(define (time-tai->time-utc time-in)
+  (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
+
+
+(define (time-tai->time-utc! time-in)
+  (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
+
+(define (priv:time-utc->time-tai! time-in time-out caller)
+  (if (not (eq? (time-type time-in) time-utc))
+      (time-error caller 'incompatible-time-types time-in))
+  (set-time-type! time-out time-tai)
+  (set-time-nanosecond! time-out (time-nanosecond time-in))
+  (set-time-second!     time-out (+ (time-second time-in)
+                                    (leap-second-delta
+                                     (time-second time-in))))
+  time-out)
+
+(define (time-utc->time-tai time-in)
+  (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
+
+(define (time-utc->time-tai! time-in)
+  (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
+
+;; -- these depend on time-monotonic having the same definition as time-tai!
+(define (time-monotonic->time-utc time-in)
+  (if (not (eq? (time-type time-in) time-monotonic))
+      (time-error 'time-monotonic->time-utc
+                       'incompatible-time-types time-in))
+  (let ((ntime (copy-time time-in)))
+    (set-time-type! ntime time-tai)
+    (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
+
+(define (time-monotonic->time-utc! time-in)
+  (if (not (eq? (time-type time-in) time-monotonic))
+      (time-error 'time-monotonic->time-utc!
+                       'incompatible-time-types time-in))
+  (set-time-type! time-in time-tai)
+  (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
+
+(define (time-monotonic->time-tai time-in)
+  (if (not (eq? (time-type time-in) time-monotonic))
+      (time-error 'time-monotonic->time-tai
+                       'incompatible-time-types time-in))
+  (let ((ntime (copy-time time-in)))
+    (set-time-type! ntime time-tai)
+    ntime))
+
+(define (time-monotonic->time-tai! time-in)
+  (if (not (eq? (time-type time-in) time-monotonic))
+      (time-error 'time-monotonic->time-tai!
+                       'incompatible-time-types time-in))
+  (set-time-type! time-in time-tai)
+  time-in)
+
+(define (time-utc->time-monotonic time-in)
+  (if (not (eq? (time-type time-in) time-utc))
+      (time-error 'time-utc->time-monotonic
+                       'incompatible-time-types time-in))
+  (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
+                                         'time-utc->time-monotonic)))
+    (set-time-type! ntime time-monotonic)
+    ntime))
+
+(define (time-utc->time-monotonic! time-in)
+  (if (not (eq? (time-type time-in) time-utc))
+      (time-error 'time-utc->time-monotonic!
+                       'incompatible-time-types time-in))
+  (let ((ntime (priv:time-utc->time-tai! time-in time-in
+                                         'time-utc->time-monotonic!)))
+    (set-time-type! ntime time-monotonic)
+    ntime))
+
+(define (time-tai->time-monotonic time-in)
+  (if (not (eq? (time-type time-in) time-tai))
+      (time-error 'time-tai->time-monotonic
+                       'incompatible-time-types time-in))
+  (let ((ntime (copy-time time-in)))
+    (set-time-type! ntime time-monotonic)
+    ntime))
+
+(define (time-tai->time-monotonic! time-in)
+  (if (not (eq? (time-type time-in) time-tai))
+      (time-error 'time-tai->time-monotonic!
+                       'incompatible-time-types time-in))
+  (set-time-type! time-in time-monotonic)
+  time-in)
+
+;; -- Date Structures
+
+;; FIXME: to be really safe, perhaps we should normalize the
+;; seconds/nanoseconds/minutes coming in to make-date...
+
+(define-record-type date
+  (make-date nanosecond second minute
+             hour day month
+             year
+             zone-offset)
+  date?
+  (nanosecond date-nanosecond set-date-nanosecond!)
+  (second date-second set-date-second!)
+  (minute date-minute set-date-minute!)
+  (hour date-hour set-date-hour!)
+  (day date-day set-date-day!)
+  (month date-month set-date-month!)
+  (year date-year set-date-year!)
+  (zone-offset date-zone-offset set-date-zone-offset!))
+
+;; gives the julian day which starts at noon.
+(define (encode-julian-day-number day month year)
+  (let* ((a (quotient (- 14 month) 12))
+         (y (- (+ year 4800) a (if (negative? year) -1  0)))
+         (m (- (+ month (* 12 a)) 3)))
+    (+ day
+       (quotient (+ (* 153 m) 2) 5)
+       (* 365 y)
+       (quotient y 4)
+       (- (quotient y 100))
+       (quotient y 400)
+       -32045)))
+
+;; gives the seconds/date/month/year
+(define (decode-julian-day-number jdn)
+  (let* ((days (inexact->exact (truncate jdn)))
+         (a (+ days 32044))
+         (b (quotient (+ (* 4 a) 3) 146097))
+         (c (- a (quotient (* 146097 b) 4)))
+         (d (quotient (+ (* 4 c) 3) 1461))
+         (e (- c (quotient (* 1461 d) 4)))
+         (m (quotient (+ (* 5 e) 2) 153))
+         (y (+ (* 100 b) d -4800 (quotient m 10))))
+    (values ; seconds date month year
+     (* (- jdn days) sid)
+     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
+     (+ m 3 (* -12 (quotient m 10)))
+     (if (>= 0 y) (- y 1) y))))
+
+;; relies on the fact that we named our time zone accessor
+;; differently from MzScheme's....
+;; This should be written to be OS specific.
+
+(define (local-tz-offset utc-time)
+  ;; SRFI uses seconds West, but guile (and libc) use seconds East.
+  (- (tm:gmtoff (localtime (time-second utc-time)))))
+
+;; special thing -- ignores nanos
+(define (time->julian-day-number seconds tz-offset)
+  (+ (/ (+ seconds tz-offset sihd)
+        sid)
+     tai-epoch-in-jd))
+
+(define (leap-second? second)
+  (and (assoc second leap-second-table) #t))
+
+(define (time-utc->date time . tz-offset)
+  (if (not (eq? (time-type time) time-utc))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (let* ((offset (if (null? tz-offset)
+		     (local-tz-offset time)
+		     (car tz-offset)))
+         (leap-second? (leap-second? (+ offset (time-second time))))
+         (jdn (time->julian-day-number (if leap-second?
+                                                (- (time-second time) 1)
+                                                (time-second time))
+                                            offset)))
+
+    (call-with-values (lambda () (decode-julian-day-number jdn))
+      (lambda (secs date month year)
+	;; secs is a real because jdn is a real in Guile;
+	;; but it is conceptionally an integer.
+        (let* ((int-secs (inexact->exact (round secs)))
+               (hours    (quotient int-secs (* 60 60)))
+               (rem      (remainder int-secs (* 60 60)))
+               (minutes  (quotient rem 60))
+               (seconds  (remainder rem 60)))
+          (make-date (time-nanosecond time)
+                     (if leap-second? (+ seconds 1) seconds)
+                     minutes
+                     hours
+                     date
+                     month
+                     year
+                     offset))))))
+
+(define (time-tai->date time  . tz-offset)
+  (if (not (eq? (time-type time) time-tai))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (let* ((offset (if (null? tz-offset)
+		     (local-tz-offset (time-tai->time-utc time))
+		     (car tz-offset)))
+         (seconds (- (time-second time)
+                     (leap-second-delta (time-second time))))
+         (leap-second? (leap-second? (+ offset seconds)))
+         (jdn (time->julian-day-number (if leap-second?
+                                                (- seconds 1)
+                                                seconds)
+                                            offset)))
+    (call-with-values (lambda () (decode-julian-day-number jdn))
+      (lambda (secs date month year)
+	;; secs is a real because jdn is a real in Guile;
+	;; but it is conceptionally an integer.
+        ;; adjust for leap seconds if necessary ...
+        (let* ((int-secs (inexact->exact (round secs)))
+	       (hours    (quotient int-secs (* 60 60)))
+               (rem      (remainder int-secs (* 60 60)))
+               (minutes  (quotient rem 60))
+               (seconds  (remainder rem 60)))
+          (make-date (time-nanosecond time)
+                     (if leap-second? (+ seconds 1) seconds)
+                     minutes
+                     hours
+                     date
+                     month
+                     year
+                     offset))))))
+
+;; this is the same as time-tai->date.
+(define (time-monotonic->date time . tz-offset)
+  (if (not (eq? (time-type time) time-monotonic))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (let* ((offset (if (null? tz-offset)
+		     (local-tz-offset (time-monotonic->time-utc time))
+		     (car tz-offset)))
+         (seconds (- (time-second time)
+                     (leap-second-delta (time-second time))))
+         (leap-second? (leap-second? (+ offset seconds)))
+         (jdn (time->julian-day-number (if leap-second?
+                                                (- seconds 1)
+                                                seconds)
+                                            offset)))
+    (call-with-values (lambda () (decode-julian-day-number jdn))
+      (lambda (secs date month year)
+	;; secs is a real because jdn is a real in Guile;
+	;; but it is conceptionally an integer.
+        ;; adjust for leap seconds if necessary ...
+        (let* ((int-secs (inexact->exact (round secs)))
+	       (hours    (quotient int-secs (* 60 60)))
+               (rem      (remainder int-secs (* 60 60)))
+               (minutes  (quotient rem 60))
+               (seconds  (remainder rem 60)))
+          (make-date (time-nanosecond time)
+                     (if leap-second? (+ seconds 1) seconds)
+                     minutes
+                     hours
+                     date
+                     month
+                     year
+                     offset))))))
+
+(define (date->time-utc date)
+  (let* ((jdays (- (encode-julian-day-number (date-day date)
+                                                 (date-month date)
+                                                 (date-year date))
+		   tai-epoch-in-jd))
+	 ;; jdays is an integer plus 1/2,
+	 (jdays-1/2 (inexact->exact (- jdays 1/2))))
+    (make-time
+     time-utc
+     (date-nanosecond date)
+     (+ (* jdays-1/2 24 60 60)
+        (* (date-hour date) 60 60)
+        (* (date-minute date) 60)
+        (date-second date)
+	(- (date-zone-offset date))))))
+
+(define (date->time-tai date)
+  (time-utc->time-tai! (date->time-utc date)))
+
+(define (date->time-monotonic date)
+  (time-utc->time-monotonic! (date->time-utc date)))
+
+(define (leap-year? year)
+  (or (= (modulo year 400) 0)
+      (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+
+;; Map 1-based month number M to number of days in the year before the
+;; start of month M (in a non-leap year).
+(define month-assoc '((1 . 0)   (2 . 31)   (3 . 59)   (4 . 90)
+			   (5 . 120) (6 . 151)  (7 . 181)  (8 . 212)
+			   (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
+
+(define (year-day day month year)
+  (let ((days-pr (assoc month month-assoc)))
+    (if (not days-pr)
+        (time-error 'date-year-day 'invalid-month-specification month))
+    (if (and (leap-year? year) (> month 2))
+        (+ day (cdr days-pr) 1)
+        (+ day (cdr days-pr)))))
+
+(define (date-year-day date)
+  (year-day (date-day date) (date-month date) (date-year date)))
+
+;; from calendar faq
+(define (week-day day month year)
+  (let* ((a (quotient (- 14 month) 12))
+         (y (- year a))
+         (m (+ month (* 12 a) -2)))
+    (modulo (+ day
+               y
+               (quotient y 4)
+               (- (quotient y 100))
+               (quotient y 400)
+               (quotient (* 31 m) 12))
+            7)))
+
+(define (date-week-day date)
+  (week-day (date-day date) (date-month date) (date-year date)))
+
+(define (days-before-first-week date day-of-week-starting-week)
+  (let* ((first-day (make-date 0 0 0 0
+                               1
+                               1
+                               (date-year date)
+                               #f))
+         (fdweek-day (date-week-day first-day)))
+    (modulo (- day-of-week-starting-week fdweek-day)
+            7)))
+
+;; The "-1" here is a fix for the reference implementation, to make a new
+;; week start on the given day-of-week-starting-week.  date-year-day returns
+;; a day starting from 1 for 1st Jan.
+;;
+(define (date-week-number date day-of-week-starting-week)
+  (quotient (- (date-year-day date)
+	       1
+               (days-before-first-week  date day-of-week-starting-week))
+            7))
+
+(define (current-date . tz-offset)
+  (let ((time (current-time time-utc)))
+    (time-utc->date
+     time
+     (if (null? tz-offset)
+	 (local-tz-offset time)
+	 (car tz-offset)))))
+
+;; given a 'two digit' number, find the year within 50 years +/-
+(define (natural-year n)
+  (let* ((current-year (date-year (current-date)))
+         (current-century (* (quotient current-year 100) 100)))
+    (cond
+     ((>= n 100) n)
+     ((<  n 0) n)
+     ((<=  (- (+ current-century n) current-year) 50) (+ current-century n))
+     (else (+ (- current-century 100) n)))))
+
+(define (date->julian-day date)
+  (let ((nanosecond (date-nanosecond date))
+        (second (date-second date))
+        (minute (date-minute date))
+        (hour (date-hour date))
+        (day (date-day date))
+        (month (date-month date))
+        (year (date-year date))
+        (offset (date-zone-offset date)))
+    (+ (encode-julian-day-number day month year)
+       (- 1/2)
+       (+ (/ (+ (- offset)
+                (* hour 60 60)
+                (* minute 60)
+                second
+                (/ nanosecond nano))
+             sid)))))
+
+(define (date->modified-julian-day date)
+  (- (date->julian-day date)
+     4800001/2))
+
+(define (time-utc->julian-day time)
+  (if (not (eq? (time-type time) time-utc))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano))
+        sid)
+     tai-epoch-in-jd))
+
+(define (time-utc->modified-julian-day time)
+  (- (time-utc->julian-day time)
+     4800001/2))
+
+(define (time-tai->julian-day time)
+  (if (not (eq? (time-type time) time-tai))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (+ (/ (+ (- (time-second time)
+              (leap-second-delta (time-second time)))
+           (/ (time-nanosecond time) nano))
+        sid)
+     tai-epoch-in-jd))
+
+(define (time-tai->modified-julian-day time)
+  (- (time-tai->julian-day time)
+     4800001/2))
+
+;; this is the same as time-tai->julian-day
+(define (time-monotonic->julian-day time)
+  (if (not (eq? (time-type time) time-monotonic))
+      (time-error 'time->date 'incompatible-time-types  time))
+  (+ (/ (+ (- (time-second time)
+              (leap-second-delta (time-second time)))
+           (/ (time-nanosecond time) nano))
+        sid)
+     tai-epoch-in-jd))
+
+(define (time-monotonic->modified-julian-day time)
+  (- (time-monotonic->julian-day time)
+     4800001/2))
+
+(define (julian-day->time-utc jdn)
+  (let ((secs (* sid (- jdn tai-epoch-in-jd))))
+    (receive (seconds parts)
+	(split-real secs)
+      (make-time time-utc
+		 (* parts nano)
+		 seconds))))
+
+(define (julian-day->time-tai jdn)
+  (time-utc->time-tai! (julian-day->time-utc jdn)))
+
+(define (julian-day->time-monotonic jdn)
+  (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define (julian-day->date jdn . tz-offset)
+  (let* ((time (julian-day->time-utc jdn))
+	 (offset (if (null? tz-offset)
+		     (local-tz-offset time)
+		     (car tz-offset))))
+    (time-utc->date time offset)))
+
+(define (modified-julian-day->date jdn . tz-offset)
+  (apply julian-day->date (+ jdn 4800001/2)
+	 tz-offset))
+
+(define (modified-julian-day->time-utc jdn)
+  (julian-day->time-utc (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-tai jdn)
+  (julian-day->time-tai (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-monotonic jdn)
+  (julian-day->time-monotonic (+ jdn 4800001/2)))
+
+(define (current-julian-day)
+  (time-utc->julian-day (current-time time-utc)))
+
+(define (current-modified-julian-day)
+  (time-utc->modified-julian-day (current-time time-utc)))
+
+;; returns a string rep. of number N, of minimum LENGTH, padded with
+;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
+;; as if number->string was used.  if string is longer than or equal
+;; in length to LENGTH, it's as if number->string was used.
+
+(define (padding n pad-with length)
+  (let* ((str (number->string n))
+         (str-len (string-length str)))
+    (if (or (>= str-len length)
+            (not pad-with))
+        str
+        (string-append (make-string (- length str-len) pad-with) str))))
+
+(define (last-n-digits i n)
+  (abs (remainder i (expt 10 n))))
+
+(define (locale-abbr-weekday n) (locale-day-short (+ 1 n)))
+(define (locale-long-weekday n) (locale-day (+ 1 n)))
+(define locale-abbr-month       locale-month-short)
+(define locale-long-month       locale-month)
+
+(define (date-reverse-lookup needle haystack-ref haystack-len
+                                  same?)
+  ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure
+  ;; that returns a string corresponding to the given index) by passing it
+  ;; indices lower than HAYSTACK-LEN.
+  (let loop ((index 1))
+    (cond ((> index haystack-len) #f)
+          ((same? needle (haystack-ref index))
+           index)
+          (else (loop (+ index 1))))))
+
+(define (locale-abbr-weekday->index string)
+  (date-reverse-lookup string locale-day-short 7 string=?))
+
+(define (locale-long-weekday->index string)
+  (date-reverse-lookup string locale-day 7 string=?))
+
+(define (locale-abbr-month->index string)
+  (date-reverse-lookup string locale-abbr-month  12 string=?))
+
+(define (locale-long-month->index string)
+  (date-reverse-lookup string locale-long-month  12 string=?))
+
+
+;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
+;; Print it here instead of the numerical offset if available.
+(define (locale-print-time-zone date port)
+  (tz-printer (date-zone-offset date) port))
+
+(define (locale-am-string/pm hr)
+  (if (> hr 11) (locale-pm-string) (locale-am-string)))
+
+(define (tz-printer offset port)
+  (cond
+   ((= offset 0) (display "Z" port))
+   ((negative? offset) (display "-" port))
+   (else (display "+" port)))
+  (if (not (= offset 0))
+      (let ((hours   (abs (quotient offset (* 60 60))))
+            (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
+        (display (padding hours #\0 2) port)
+        (display (padding minutes #\0 2) port))))
+
+;; A table of output formatting directives.
+;; the first time is the format char.
+;; the second is a procedure that takes the date, a padding character
+;; (which might be #f), and the output port.
+;;
+(define directives
+  (list
+   (cons #\~ (lambda (date pad-with port)
+               (display #\~ port)))
+   (cons #\a (lambda (date pad-with port)
+               (display (locale-abbr-weekday (date-week-day date))
+                        port)))
+   (cons #\A (lambda (date pad-with port)
+               (display (locale-long-weekday (date-week-day date))
+                        port)))
+   (cons #\b (lambda (date pad-with port)
+               (display (locale-abbr-month (date-month date))
+                        port)))
+   (cons #\B (lambda (date pad-with port)
+               (display (locale-long-month (date-month date))
+                        port)))
+   (cons #\c (lambda (date pad-with port)
+               (display (date->string date locale-date-time-format) port)))
+   (cons #\d (lambda (date pad-with port)
+               (display (padding (date-day date)
+                                      #\0 2)
+                        port)))
+   (cons #\D (lambda (date pad-with port)
+               (display (date->string date "~m/~d/~y") port)))
+   (cons #\e (lambda (date pad-with port)
+               (display (padding (date-day date)
+                                      #\Space 2)
+                        port)))
+   (cons #\f (lambda (date pad-with port)
+               (if (> (date-nanosecond date)
+                      nano)
+                   (display (padding (+ (date-second date) 1)
+                                          pad-with 2)
+                            port)
+                   (display (padding (date-second date)
+                                          pad-with 2)
+                            port))
+               (receive (i f)
+                        (split-real (/
+                                          (date-nanosecond date)
+                                          nano 1.0))
+                        (let* ((ns (number->string f))
+                               (le (string-length ns)))
+                          (if (> le 2)
+                              (begin
+                                (display (locale-decimal-point) port)
+                                (display (substring ns 2 le) port)))))))
+   (cons #\h (lambda (date pad-with port)
+               (display (date->string date "~b") port)))
+   (cons #\H (lambda (date pad-with port)
+               (display (padding (date-hour date)
+                                      pad-with 2)
+                        port)))
+   (cons #\I (lambda (date pad-with port)
+               (let ((hr (date-hour date)))
+                 (if (> hr 12)
+                     (display (padding (- hr 12)
+                                            pad-with 2)
+                              port)
+                     (display (padding hr
+                                            pad-with 2)
+                              port)))))
+   (cons #\j (lambda (date pad-with port)
+               (display (padding (date-year-day date)
+                                      pad-with 3)
+                        port)))
+   (cons #\k (lambda (date pad-with port)
+               (display (padding (date-hour date)
+                                      #\Space 2)
+                        port)))
+   (cons #\l (lambda (date pad-with port)
+               (let ((hr (if (> (date-hour date) 12)
+                             (- (date-hour date) 12) (date-hour date))))
+                 (display (padding hr  #\Space 2)
+                          port))))
+   (cons #\m (lambda (date pad-with port)
+               (display (padding (date-month date)
+                                      pad-with 2)
+                        port)))
+   (cons #\M (lambda (date pad-with port)
+               (display (padding (date-minute date)
+                                      pad-with 2)
+                        port)))
+   (cons #\n (lambda (date pad-with port)
+               (newline port)))
+   (cons #\N (lambda (date pad-with port)
+               (display (padding (date-nanosecond date)
+                                      pad-with 7)
+                        port)))
+   (cons #\p (lambda (date pad-with port)
+               (display (locale-am-string/pm (date-hour date)) port)))
+   (cons #\r (lambda (date pad-with port)
+               (display (date->string date "~I:~M:~S ~p") port)))
+   (cons #\s (lambda (date pad-with port)
+               (display (time-second (date->time-utc date)) port)))
+   (cons #\S (lambda (date pad-with port)
+               (if (> (date-nanosecond date)
+                      nano)
+                   (display (padding (+ (date-second date) 1)
+                                          pad-with 2)
+                            port)
+                   (display (padding (date-second date)
+                                          pad-with 2)
+                            port))))
+   (cons #\t (lambda (date pad-with port)
+               (display #\Tab port)))
+   (cons #\T (lambda (date pad-with port)
+               (display (date->string date "~H:~M:~S") port)))
+   (cons #\U (lambda (date pad-with port)
+               (if (> (days-before-first-week date 0) 0)
+                   (display (padding (+ (date-week-number date 0) 1)
+                                          #\0 2) port)
+                   (display (padding (date-week-number date 0)
+                                          #\0 2) port))))
+   (cons #\V (lambda (date pad-with port)
+               (display (padding (date-week-number date 1)
+                                      #\0 2) port)))
+   (cons #\w (lambda (date pad-with port)
+               (display (date-week-day date) port)))
+   (cons #\x (lambda (date pad-with port)
+               (display (date->string date locale-short-date-format) port)))
+   (cons #\X (lambda (date pad-with port)
+               (display (date->string date locale-time-format) port)))
+   (cons #\W (lambda (date pad-with port)
+               (if (> (days-before-first-week date 1) 0)
+                   (display (padding (+ (date-week-number date 1) 1)
+                                          #\0 2) port)
+                   (display (padding (date-week-number date 1)
+                                          #\0 2) port))))
+   (cons #\y (lambda (date pad-with port)
+               (display (padding (last-n-digits
+                                       (date-year date) 2)
+                                      pad-with
+                                      2)
+                        port)))
+   (cons #\Y (lambda (date pad-with port)
+               (display (date-year date) port)))
+   (cons #\z (lambda (date pad-with port)
+               (tz-printer (date-zone-offset date) port)))
+   (cons #\Z (lambda (date pad-with port)
+               (locale-print-time-zone date port)))
+   (cons #\1 (lambda (date pad-with port)
+               (display (date->string date "~Y-~m-~d") port)))
+   (cons #\2 (lambda (date pad-with port)
+               (display (date->string date "~H:~M:~S~z") port)))
+   (cons #\3 (lambda (date pad-with port)
+               (display (date->string date "~H:~M:~S") port)))
+   (cons #\4 (lambda (date pad-with port)
+               (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
+   (cons #\5 (lambda (date pad-with port)
+               (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
+
+
+(define (get-formatter char)
+  (let ((associated (assoc char directives)))
+    (if associated (cdr associated) #f)))
+
+(define (date-printer date index format-string str-len port)
+  (if (< index str-len)
+      (let ((current-char (string-ref format-string index)))
+        (if (not (char=? current-char #\~))
+            (begin
+              (display current-char port)
+              (date-printer date (+ index 1) format-string str-len port))
+            (if (= (+ index 1) str-len) ; bad format string.
+                (time-error 'date-printer 'bad-date-format-string
+                                 format-string)
+                (let ((pad-char? (string-ref format-string (+ index 1))))
+                  (cond
+                   ((char=? pad-char? #\-)
+                    (if (= (+ index 2) str-len) ; bad format string.
+                        (time-error 'date-printer
+                                         'bad-date-format-string
+                                         format-string)
+                        (let ((formatter (get-formatter
+                                          (string-ref format-string
+                                                      (+ index 2)))))
+                          (if (not formatter)
+                              (time-error 'date-printer
+                                               'bad-date-format-string
+                                               format-string)
+                              (begin
+                                (formatter date #f port)
+                                (date-printer date
+                                                   (+ index 3)
+                                                   format-string
+                                                   str-len
+                                                   port))))))
+
+                   ((char=? pad-char? #\_)
+                    (if (= (+ index 2) str-len) ; bad format string.
+                        (time-error 'date-printer
+                                         'bad-date-format-string
+                                         format-string)
+                        (let ((formatter (get-formatter
+                                          (string-ref format-string
+                                                      (+ index 2)))))
+                          (if (not formatter)
+                              (time-error 'date-printer
+                                               'bad-date-format-string
+                                               format-string)
+                              (begin
+                                (formatter date #\Space port)
+                                (date-printer date
+                                                   (+ index 3)
+                                                   format-string
+                                                   str-len
+                                                   port))))))
+                   (else
+                    (let ((formatter (get-formatter
+                                      (string-ref format-string
+                                                  (+ index 1)))))
+                      (if (not formatter)
+                          (time-error 'date-printer
+                                           'bad-date-format-string
+                                           format-string)
+                          (begin
+                            (formatter date #\0 port)
+                            (date-printer date
+                                               (+ index 2)
+                                               format-string
+                                               str-len
+                                               port))))))))))))
+
+
+(define (date->string date .  format-string)
+  (let ((str-port (open-output-string))
+        (fmt-str (if (null? format-string) "~c" (car format-string))))
+    (date-printer date 0 fmt-str (string-length fmt-str) str-port)
+    (get-output-string str-port)))
+
+(define (char->int ch)
+  (case ch
+   ((#\0) 0)
+   ((#\1) 1)
+   ((#\2) 2)
+   ((#\3) 3)
+   ((#\4) 4)
+   ((#\5) 5)
+   ((#\6) 6)
+   ((#\7) 7)
+   ((#\8) 8)
+   ((#\9) 9)
+   (else (time-error 'char->int 'bad-date-template-string
+                          (list "Non-integer character" ch)))))
+
+;; read an integer upto n characters long on port; upto -> #f is any length
+(define (integer-reader upto port)
+  (let loop ((accum 0) (nchars 0))
+    (let ((ch (peek-char port)))
+      (if (or (eof-object? ch)
+              (not (char-numeric? ch))
+              (and upto (>= nchars  upto)))
+          accum
+          (loop (+ (* accum 10) (char->int (read-char port)))
+                (+ nchars 1))))))
+
+(define (make-integer-reader upto)
+  (lambda (port)
+    (integer-reader upto port)))
+
+;; read *exactly* n characters and convert to integer; could be padded
+(define (integer-reader-exact n port)
+  (let ((padding-ok #t))
+    (define (accum-int port accum nchars)
+      (let ((ch (peek-char port)))
+	(cond
+	 ((>= nchars n) accum)
+	 ((eof-object? ch)
+	  (time-error 'string->date 'bad-date-template-string
+                           "Premature ending to integer read."))
+	 ((char-numeric? ch)
+	  (set! padding-ok #f)
+	  (accum-int port
+                     (+ (* accum 10) (char->int (read-char port)))
+		     (+ nchars 1)))
+	 (padding-ok
+	  (read-char port) ; consume padding
+	  (accum-int port accum (+ nchars 1)))
+	 (else ; padding where it shouldn't be
+	  (time-error 'string->date 'bad-date-template-string
+                           "Non-numeric characters in integer read.")))))
+    (accum-int port 0 0)))
+
+
+(define (make-integer-exact-reader n)
+  (lambda (port)
+    (integer-reader-exact n port)))
+
+(define (zone-reader port)
+  (let ((offset 0)
+        (positive? #f))
+    (let ((ch (read-char port)))
+      (if (eof-object? ch)
+          (time-error 'string->date 'bad-date-template-string
+                           (list "Invalid time zone +/-" ch)))
+      (if (or (char=? ch #\Z) (char=? ch #\z))
+          0
+          (begin
+            (cond
+             ((char=? ch #\+) (set! positive? #t))
+             ((char=? ch #\-) (set! positive? #f))
+             (else
+              (time-error 'string->date 'bad-date-template-string
+                               (list "Invalid time zone +/-" ch))))
+            (let ((ch (read-char port)))
+              (if (eof-object? ch)
+                  (time-error 'string->date 'bad-date-template-string
+                                   (list "Invalid time zone number" ch)))
+              (set! offset (* (char->int ch)
+                              10 60 60)))
+            (let ((ch (read-char port)))
+              (if (eof-object? ch)
+                  (time-error 'string->date 'bad-date-template-string
+                                   (list "Invalid time zone number" ch)))
+              (set! offset (+ offset (* (char->int ch)
+                                        60 60))))
+            (let ((ch (read-char port)))
+              (if (eof-object? ch)
+                  (time-error 'string->date 'bad-date-template-string
+                                   (list "Invalid time zone number" ch)))
+              (set! offset (+ offset (* (char->int ch)
+                                        10 60))))
+            (let ((ch (read-char port)))
+              (if (eof-object? ch)
+                  (time-error 'string->date 'bad-date-template-string
+                                   (list "Invalid time zone number" ch)))
+              (set! offset (+ offset (* (char->int ch)
+                                        60))))
+            (if positive? offset (- offset)))))))
+
+;; looking at a char, read the char string, run thru indexer, return index
+(define (locale-reader port indexer)
+
+  (define (read-char-string result)
+    (let ((ch (peek-char port)))
+      (if (char-alphabetic? ch)
+          (read-char-string (cons (read-char port) result))
+          (list->string (reverse! result)))))
+
+  (let* ((str (read-char-string '()))
+         (index (indexer str)))
+    (if index index (time-error 'string->date
+                                     'bad-date-template-string
+                                     (list "Invalid string for " indexer)))))
+
+(define (make-locale-reader indexer)
+  (lambda (port)
+    (locale-reader port indexer)))
+
+(define (make-char-id-reader char)
+  (lambda (port)
+    (if (char=? char (read-char port))
+        char
+        (time-error 'string->date
+                         'bad-date-template-string
+                         "Invalid character match."))))
+
+;; A List of formatted read directives.
+;; Each entry is a list.
+;; 1. the character directive;
+;; a procedure, which takes a character as input & returns
+;; 2. #t as soon as a character on the input port is acceptable
+;; for input,
+;; 3. a port reader procedure that knows how to read the current port
+;; for a value. Its one parameter is the port.
+;; 4. an optional action procedure, that takes the value (from 3.) and
+;; some object (here, always the date) and (probably) side-effects it.
+;; If no action is required, as with ~A, this element may be #f.
+
+(define read-directives
+  (let ((ireader4 (make-integer-reader 4))
+        (ireader2 (make-integer-reader 2))
+        (eireader2 (make-integer-exact-reader 2))
+        (locale-reader-abbr-weekday (make-locale-reader
+                                     locale-abbr-weekday->index))
+        (locale-reader-long-weekday (make-locale-reader
+                                     locale-long-weekday->index))
+        (locale-reader-abbr-month   (make-locale-reader
+                                     locale-abbr-month->index))
+        (locale-reader-long-month   (make-locale-reader
+                                     locale-long-month->index))
+        (char-fail (lambda (ch) #t)))
+
+    (list
+     (list #\~ char-fail (make-char-id-reader #\~) #f)
+     (list #\a char-alphabetic? locale-reader-abbr-weekday #f)
+     (list #\A char-alphabetic? locale-reader-long-weekday #f)
+     (list #\b char-alphabetic? locale-reader-abbr-month
+           (lambda (val object)
+             (set-date-month! object val)))
+     (list #\B char-alphabetic? locale-reader-long-month
+           (lambda (val object)
+             (set-date-month! object val)))
+     (list #\d char-numeric? ireader2 (lambda (val object)
+                                        (set-date-day!
+                                         object val)))
+     (list #\e char-fail eireader2 (lambda (val object)
+                                     (set-date-day! object val)))
+     (list #\h char-alphabetic? locale-reader-abbr-month
+           (lambda (val object)
+             (set-date-month! object val)))
+     (list #\H char-numeric? ireader2 (lambda (val object)
+                                        (set-date-hour! object val)))
+     (list #\k char-fail eireader2 (lambda (val object)
+                                     (set-date-hour! object val)))
+     (list #\m char-numeric? ireader2 (lambda (val object)
+                                        (set-date-month! object val)))
+     (list #\M char-numeric? ireader2 (lambda (val object)
+                                        (set-date-minute!
+                                         object val)))
+     (list #\S char-numeric? ireader2 (lambda (val object)
+                                        (set-date-second! object val)))
+     (list #\y char-fail eireader2
+           (lambda (val object)
+             (set-date-year! object (natural-year val))))
+     (list #\Y char-numeric? ireader4 (lambda (val object)
+                                        (set-date-year! object val)))
+     (list #\z (lambda (c)
+                 (or (char=? c #\Z)
+                     (char=? c #\z)
+                     (char=? c #\+)
+                     (char=? c #\-)))
+           zone-reader (lambda (val object)
+                              (set-date-zone-offset! object val))))))
+
+(define (priv:string->date date index format-string str-len port template-string)
+  (define (skip-until port skipper)
+    (let ((ch (peek-char port)))
+      (if (eof-object? ch)
+          (time-error 'string->date 'bad-date-format-string template-string)
+          (if (not (skipper ch))
+              (begin (read-char port) (skip-until port skipper))))))
+  (if (< index str-len)
+      (let ((current-char (string-ref format-string index)))
+        (if (not (char=? current-char #\~))
+            (let ((port-char (read-char port)))
+              (if (or (eof-object? port-char)
+                      (not (char=? current-char port-char)))
+                  (time-error 'string->date
+                                   'bad-date-format-string template-string))
+              (priv:string->date date
+                                 (+ index 1)
+                                 format-string
+                                 str-len
+                                 port
+                                 template-string))
+            ;; otherwise, it's an escape, we hope
+            (if (> (+ index 1) str-len)
+                (time-error 'string->date
+                                 'bad-date-format-string template-string)
+                (let* ((format-char (string-ref format-string (+ index 1)))
+                       (format-info (assoc format-char read-directives)))
+                  (if (not format-info)
+                      (time-error 'string->date
+                                       'bad-date-format-string template-string)
+                      (begin
+                        (let ((skipper (cadr format-info))
+                              (reader  (caddr format-info))
+                              (actor   (cadddr format-info)))
+                          (skip-until port skipper)
+                          (let ((val (reader port)))
+                            (if (eof-object? val)
+                                (time-error 'string->date
+                                                 'bad-date-format-string
+                                                 template-string)
+                                (if actor (actor val date))))
+                          (priv:string->date date
+                                             (+ index 2)
+                                             format-string
+                                             str-len
+                                             port
+                                             template-string))))))))))
+
+(define (string->date input-string template-string)
+  (define (date-ok? date)
+    (and (date-nanosecond date)
+         (date-second date)
+         (date-minute date)
+         (date-hour date)
+         (date-day date)
+         (date-month date)
+         (date-year date)
+         (date-zone-offset date)))
+  (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
+    (priv:string->date newdate
+                       0
+                       template-string
+                       (string-length template-string)
+                       (open-input-string input-string)
+                       template-string)
+    (if (not (date-zone-offset newdate))
+	(begin
+	  ;; this is necessary to get DST right -- as far as we can
+	  ;; get it right (think of the double/missing hour in the
+	  ;; night when we are switching between normal time and DST).
+	  (set-date-zone-offset! newdate
+				 (local-tz-offset
+				  (make-time time-utc 0 0)))
+	  (set-date-zone-offset! newdate
+				 (local-tz-offset
+				  (date->time-utc newdate)))))
+    (if (date-ok? newdate)
+        newdate
+        (time-error
+         'string->date
+         'bad-date-format-string
+         (list "Incomplete date read. " newdate template-string)))))
+
+;;; srfi-19.scm ends here
+;;; srfi-2.scm --- and-let*
+
+;; 	Copyright (C) 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-2)
+  \:use-module (ice-9 and-let-star)
+  \:re-export-syntax (and-let*))
+
+(cond-expand-provide (current-module) '(srfi-2))
+
+;;; srfi-2.scm ends here
+;;; srfi-26.scm --- specializing parameters without currying.
+
+;; Copyright (C) 2002, 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 (srfi srfi-26)
+  \:export (cut cute))
+
+(cond-expand-provide (current-module) '(srfi-26))
+
+(define-syntax cut
+  (lambda (stx)
+    (syntax-case stx ()
+      ((cut slot0 slot1+ ...)
+       (let loop ((slots	#'(slot0 slot1+ ...))
+                  (params	'())
+                  (args	'()))
+         (if (null? slots)
+             #`(lambda #,(reverse params) #,(reverse args))
+             (let ((s	  (car slots))
+                   (rest (cdr slots)))
+               (with-syntax (((var) (generate-temporaries '(var))))
+                 (syntax-case s (<> <___>)
+                   (<>
+                    (loop rest (cons #'var params) (cons #'var args)))
+                   (<___>
+                    (if (pair? rest)
+                        (error "<___> not on the end of cut expression"))
+                    #`(lambda #,(append (reverse params) #'var)
+                        (apply #,@(reverse (cons #'var args)))))
+                   (else
+                    (loop rest params (cons s args))))))))))))
+
+(define-syntax cute
+  (lambda (stx)
+    (syntax-case stx ()
+      ((cute slots ...)
+       (let loop ((slots #'(slots ...))
+                  (bindings '())
+                  (arguments '()))
+         (define (process-hole)
+           (loop (cdr slots) bindings (cons (car slots) arguments)))
+         (if (null? slots)
+             #`(let #,bindings
+                 (cut #,@(reverse arguments)))
+             (syntax-case (car slots) (<> <___>)
+               (<> (process-hole))
+               (<___> (process-hole))
+               (expr
+                (with-syntax (((t) (generate-temporaries '(t))))
+                  (loop (cdr slots)
+                        (cons #'(t expr) bindings)
+                        (cons #'t arguments)))))))))))
+;;; srfi-27.scm --- Sources of Random Bits
+
+;; Copyright (C) 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, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-27)
+  #\export (random-integer
+            random-real
+            default-random-source
+            make-random-source
+            random-source?
+            random-source-state-ref
+            random-source-state-set!
+            random-source-randomize!
+            random-source-pseudo-randomize!
+            random-source-make-integers
+            random-source-make-reals)
+  #\use-module (srfi srfi-9))
+
+(cond-expand-provide (current-module) '(srfi-27))
+
+(define-record-type \:random-source
+  (%make-random-source state)
+  random-source?
+  (state random-source-state set-random-source-state!))
+
+(define (make-random-source)
+  (%make-random-source (seed->random-state 0)))
+
+(define (random-source-state-ref s)
+  (random-state->datum (random-source-state s)))
+
+(define (random-source-state-set! s state)
+  (set-random-source-state! s (datum->random-state state)))
+
+(define (random-source-randomize! s)
+  (let ((time (gettimeofday)))
+    (set-random-source-state! s (seed->random-state
+                                 (+ (* (car time) 1e6) (cdr time))))))
+
+(define (random-source-pseudo-randomize! s i j)
+  (set-random-source-state! s (seed->random-state (i+j->seed i j))))
+
+(define (i+j->seed i j)
+  (logior (ash (spread i 2) 1)
+          (spread j 2)))
+
+(define (spread n amount)
+  (let loop ((result 0) (n n) (shift 0))
+    (if (zero? n)
+        result
+        (loop (logior result
+                      (ash (logand n 1) shift))
+              (ash n -1)
+              (+ shift amount)))))
+
+(define (random-source-make-integers s)
+  (lambda (n)
+    (random n (random-source-state s))))
+
+(define random-source-make-reals
+  (case-lambda
+    ((s)
+     (lambda ()
+       (let loop ()
+         (let ((x (random:uniform (random-source-state s))))
+           (if (zero? x)
+               (loop)
+               x)))))
+    ((s unit)
+     (or (and (real? unit) (< 0 unit 1))
+         (error "unit must be real between 0 and 1" unit))
+     (random-source-make-reals s))))
+
+(define default-random-source (make-random-source))
+(define random-integer (random-source-make-integers default-random-source))
+(define random-real (random-source-make-reals default-random-source))
+;;; srfi-28.scm --- Basic Format Strings
+
+;; 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, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module provides a wrapper for simple-format that always outputs
+;; to a string.
+;;
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-28)
+  #\replace (format))
+
+(define (format message . args)
+  (apply simple-format #f message args))
+
+(cond-expand-provide (current-module) '(srfi-28))
+;;; srfi-31.scm --- special form for recursive evaluation
+
+;; 	Copyright (C) 2004, 2006, 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
+
+;;; Original author: Rob Browning <rlb@defaultvalue.org>
+
+(define-module (srfi srfi-31)
+  #\export (rec))
+
+(cond-expand-provide (current-module) '(srfi-31))
+
+(define-syntax rec
+  (syntax-rules ()
+    "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+    ((_ (name . formals) body ...)                ; procedure
+     (letrec ((name (lambda formals body ...)))
+       name))
+    ((_ name expr)                                ; arbitrary object
+     (letrec ((name expr))
+       name))))
+;;; srfi-34.scm --- Exception handling for programs
+
+;; Copyright (C) 2003, 2006, 2008, 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram <neil@ossau.uklinux.net>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-34: Exception Handling for
+;; Programs.  For documentation please see the SRFI-34 document; this
+;; module is not yet documented at all in the Guile manual.
+
+;;; Code:
+
+(define-module (srfi srfi-34)
+  #\export (with-exception-handler)
+  #\replace (raise)
+  #\export-syntax (guard))
+
+(cond-expand-provide (current-module) '(srfi-34))
+
+(define throw-key 'srfi-34)
+
+(define (with-exception-handler handler thunk)
+  "Returns the result(s) of invoking THUNK. HANDLER must be a
+procedure that accepts one argument.  It is installed as the current
+exception handler for the dynamic extent (as determined by
+dynamic-wind) of the invocation of THUNK."
+  (with-throw-handler throw-key
+	      thunk
+	      (lambda (key obj)
+		(handler obj))))
+
+(define (raise obj)
+  "Invokes the current exception handler on OBJ.  The handler is
+called in the dynamic environment of the call to raise, except that
+the current exception handler is that in place for the call to
+with-exception-handler that installed the handler being called.  The
+handler's continuation is otherwise unspecified."
+  (throw throw-key obj))
+
+(define-syntax guard
+  (syntax-rules (else)
+    "Syntax: (guard (<var> <clause1> <clause2> ...) <body>)
+Each <clause> should have the same form as a `cond' clause.
+
+Semantics: Evaluating a guard form evaluates <body> with an exception
+handler that binds the raised object to <var> and within the scope of
+that binding evaluates the clauses as if they were the clauses of a
+cond expression.  That implicit cond expression is evaluated with the
+continuation and dynamic environment of the guard expression.  If
+every <clause>'s <test> evaluates to false and there is no else
+clause, then raise is re-invoked on the raised object within the
+dynamic environment of the original call to raise except that the
+current exception handler is that of the guard expression."
+    ((guard (var clause ... (else e e* ...)) body body* ...)
+     (catch throw-key
+       (lambda () body body* ...)
+       (lambda (key var)
+         (cond clause ...
+               (else e e* ...)))))
+    ((guard (var clause clause* ...) body body* ...)
+     (catch throw-key
+       (lambda () body body* ...)
+       (lambda (key var)
+         (cond clause clause* ...
+               (else (throw key var))))))))
+
+
+;;; (srfi srfi-34) ends here.
+;;; srfi-35.scm --- Conditions                 -*- coding: utf-8 -*-
+
+;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-35, "Conditions".  Conditions are a
+;; means to convey information about exceptional conditions between parts of
+;; a program.
+
+;;; Code:
+
+(define-module (srfi srfi-35)
+  #\use-module (srfi srfi-1)
+  #\export (make-condition-type condition-type?
+            make-condition condition? condition-has-type? condition-ref
+            make-compound-condition extract-condition
+            define-condition-type condition
+            &condition
+            &message message-condition? condition-message
+            &serious serious-condition?
+            &error error?))
+
+(cond-expand-provide (current-module) '(srfi-35))
+
+
+;;;
+;;; Condition types.
+;;;
+
+(define %condition-type-vtable
+  ;; The vtable of all condition types.
+  ;;   vtable fields: vtable, self, printer
+  ;;   user fields:   id, parent, all-field-names
+  (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+                        (lambda (ct port)
+                          (format port "#<condition-type ~a ~a>"
+                                  (condition-type-id ct)
+                                  (number->string (object-address ct)
+                                                  16))))))
+    (set-struct-vtable-name! s 'condition-type)
+    s))
+
+(define (%make-condition-type layout id parent all-fields)
+  (let ((struct (make-struct %condition-type-vtable 0
+                             (make-struct-layout layout) ;; layout
+                             print-condition             ;; printer
+                             id parent all-fields)))
+
+    ;; Hack to associate STRUCT with a name, providing a better name for
+    ;; GOOPS classes as returned by `class-of' et al.
+    (set-struct-vtable-name! struct (cond ((symbol? id) id)
+                                          ((string? id) (string->symbol id))
+                                          (else         (string->symbol ""))))
+    struct))
+
+(define (condition-type? obj)
+  "Return true if OBJ is a condition type."
+  (and (struct? obj)
+       (eq? (struct-vtable obj)
+	    %condition-type-vtable)))
+
+(define (condition-type-id ct)
+  (and (condition-type? ct)
+       (struct-ref ct (+ vtable-offset-user 0))))
+
+(define (condition-type-parent ct)
+  (and (condition-type? ct)
+       (struct-ref ct (+ vtable-offset-user 1))))
+
+(define (condition-type-all-fields ct)
+  (and (condition-type? ct)
+       (struct-ref ct (+ vtable-offset-user 2))))
+
+
+(define (struct-layout-for-condition field-names)
+  ;; Return a string denoting the layout required to hold the fields listed
+  ;; in FIELD-NAMES.
+  (let loop ((field-names field-names)
+	     (layout      '("pr")))
+    (if (null? field-names)
+	(string-concatenate/shared layout)
+	(loop (cdr field-names)
+	      (cons "pr" layout)))))
+
+(define (print-condition c port)
+  ;; Print condition C to PORT in a way similar to how records print:
+  ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
+  (define (field-values)
+    (let* ((type    (struct-vtable c))
+           (strings (fold (lambda (field result)
+                            (cons (format #f "~A: ~S" field
+                                          (condition-ref c field))
+                                  result))
+                          '()
+                          (condition-type-all-fields type))))
+      (string-join (reverse strings) " ")))
+
+  (format port "#<condition ~a [~a] ~a>"
+          (condition-type-id (condition-type c))
+          (field-values)
+          (number->string (object-address c) 16)))
+
+(define (make-condition-type id parent field-names)
+  "Return a new condition type named ID, inheriting from PARENT, and with the
+fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
+symbols and must not contain names already used by PARENT or one of its
+supertypes."
+  (if (symbol? id)
+      (if (condition-type? parent)
+	  (let ((parent-fields (condition-type-all-fields parent)))
+	    (if (and (every symbol? field-names)
+		     (null? (lset-intersection eq?
+					       field-names parent-fields)))
+		(let* ((all-fields (append parent-fields field-names))
+		       (layout     (struct-layout-for-condition all-fields)))
+		  (%make-condition-type layout
+                                        id parent all-fields))
+		(error "invalid condition type field names"
+		       field-names)))
+	  (error "parent is not a condition type" parent))
+      (error "condition type identifier is not a symbol" id)))
+
+(define (make-compound-condition-type id parents)
+  ;; Return a compound condition type made of the types listed in PARENTS.
+  ;; All fields from PARENTS are kept, even same-named ones, since they are
+  ;; needed by `extract-condition'.
+  (cond ((null? parents)
+         (error "`make-compound-condition-type' passed empty parent list"
+                id))
+        ((null? (cdr parents))
+         (car parents))
+        (else
+         (let* ((all-fields (append-map condition-type-all-fields
+                                        parents))
+                (layout     (struct-layout-for-condition all-fields)))
+           (%make-condition-type layout
+                                 id
+                                 parents         ;; list of parents!
+                                 all-fields)))))
+
+
+;;;
+;;; Conditions.
+;;;
+
+(define (condition? c)
+  "Return true if C is a condition."
+  (and (struct? c)
+       (condition-type? (struct-vtable c))))
+
+(define (condition-type c)
+  (and (struct? c)
+       (let ((vtable (struct-vtable c)))
+	 (if (condition-type? vtable)
+	     vtable
+	     #f))))
+
+(define (condition-has-type? c type)
+  "Return true if condition C has type TYPE."
+  (if (and (condition? c) (condition-type? type))
+      (let loop ((ct (condition-type c)))
+        (or (eq? ct type)
+            (and ct
+                 (let ((parent (condition-type-parent ct)))
+                   (if (list? parent)
+                       (any loop parent) ;; compound condition
+                       (loop (condition-type-parent ct)))))))
+      (throw 'wrong-type-arg "condition-has-type?"
+             "Wrong type argument")))
+
+(define (condition-ref c field-name)
+  "Return the value of the field named FIELD-NAME from condition C."
+  (if (condition? c)
+      (if (symbol? field-name)
+	  (let* ((type   (condition-type c))
+		 (fields (condition-type-all-fields type))
+		 (index  (list-index (lambda (name)
+				       (eq? name field-name))
+				     fields)))
+	    (if index
+		(struct-ref c index)
+		(error "invalid field name" field-name)))
+	  (error "field name is not a symbol" field-name))
+      (throw 'wrong-type-arg "condition-ref"
+             "Wrong type argument: ~S" c)))
+
+(define (make-condition-from-values type values)
+  (apply make-struct type 0 values))
+
+(define (make-condition type . field+value)
+  "Return a new condition of type TYPE with fields initialized as specified
+by FIELD+VALUE, a sequence of field names (symbols) and values."
+  (if (condition-type? type)
+      (let* ((all-fields (condition-type-all-fields type))
+	     (inits      (fold-right (lambda (field inits)
+				       (let ((v (memq field field+value)))
+					 (if (pair? v)
+					     (cons (cadr v) inits)
+					     (error "field not specified"
+						    field))))
+				     '()
+				     all-fields)))
+	(make-condition-from-values type inits))
+      (throw 'wrong-type-arg "make-condition"
+             "Wrong type argument: ~S" type)))
+
+(define (make-compound-condition . conditions)
+  "Return a new compound condition composed of CONDITIONS."
+  (let* ((types  (map condition-type conditions))
+	 (ct     (make-compound-condition-type 'compound types))
+	 (inits  (append-map (lambda (c)
+			       (let ((ct (condition-type c)))
+				 (map (lambda (f)
+					(condition-ref c f))
+				      (condition-type-all-fields ct))))
+			     conditions)))
+    (make-condition-from-values ct inits)))
+
+(define (extract-condition c type)
+  "Return a condition of condition type TYPE with the field values specified
+by C."
+
+  (define (first-field-index parents)
+    ;; Return the index of the first field of TYPE within C.
+    (let loop ((parents parents)
+	       (index   0))
+      (let ((parent (car parents)))
+	(cond ((null? parents)
+	       #f)
+	      ((eq? parent type)
+	       index)
+	      ((pair? parent)
+	       (or (loop parent index)
+		   (loop (cdr parents)
+			 (+ index
+			    (apply + (map condition-type-all-fields
+					  parent))))))
+	      (else
+	       (let ((shift (length (condition-type-all-fields parent))))
+		 (loop (cdr parents)
+		       (+ index shift))))))))
+
+  (define (list-fields start-index field-names)
+    ;; Return a list of the form `(FIELD-NAME VALUE...)'.
+    (let loop ((index       start-index)
+	       (field-names field-names)
+	       (result      '()))
+      (if (null? field-names)
+	  (reverse! result)
+	  (loop (+ 1 index)
+		(cdr field-names)
+		(cons* (struct-ref c index)
+		       (car field-names)
+		       result)))))
+
+  (if (and (condition? c) (condition-type? type))
+      (let* ((ct     (condition-type c))
+             (parent (condition-type-parent ct)))
+        (cond ((eq? type ct)
+               c)
+              ((pair? parent)
+               ;; C is a compound condition.
+               (let ((field-index (first-field-index parent)))
+                 ;;(format #t "field-index: ~a ~a~%" field-index
+                 ;;        (list-fields field-index
+                 ;;                     (condition-type-all-fields type)))
+                 (apply make-condition type
+                        (list-fields field-index
+                                     (condition-type-all-fields type)))))
+              (else
+               ;; C does not have type TYPE.
+               #f)))
+      (throw 'wrong-type-arg "extract-condition"
+             "Wrong type argument")))
+
+
+;;;
+;;; Syntax.
+;;;
+
+(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
+  (begin
+    (define name
+      (make-condition-type 'name parent '(field-name ...)))
+    (define (pred c)
+      (condition-has-type? c name))
+    (define (field-accessor c)
+      (condition-ref c 'field-name))
+    ...))
+
+(define-syntax-rule (compound-condition (type ...) (field ...))
+  ;; Create a compound condition using `make-compound-condition-type'.
+  (condition ((make-compound-condition-type '%compound `(,type ...))
+              field ...)))
+
+(define-syntax condition-instantiation
+  ;; Build the `(make-condition type ...)' call.
+  (syntax-rules ()
+    ((_ type (out ...))
+     (make-condition type out ...))
+    ((_ type (out ...) (field-name field-value) rest ...)
+     (condition-instantiation type (out ... 'field-name field-value) rest ...))))
+
+(define-syntax condition
+  (syntax-rules ()
+    ((_ (type field ...))
+     (condition-instantiation type () field ...))
+    ((_ (type field ...) ...)
+     (compound-condition (type ...) (field ... ...)))))
+
+
+;;;
+;;; Standard condition types.
+;;;
+
+(define &condition
+  ;; The root condition type.
+  (make-struct %condition-type-vtable 0
+	       (make-struct-layout "")
+	       (lambda (c port)
+		 (display "<&condition>"))
+	       '&condition #f '() '()))
+
+(define-condition-type &message &condition
+  message-condition?
+  (message condition-message))
+
+(define-condition-type &serious &condition
+  serious-condition?)
+
+(define-condition-type &error &serious
+  error?)
+
+;;; srfi-35.scm ends here
+;;; 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 (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
+;; 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)))))))
+;;; 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)))))
+;;; 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)
+;;; 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)
+;;; srfi-41.scm -- SRFI 41 streams
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; 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-41)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-8)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (srfi srfi-26)
+  #\use-module (ice-9 match)
+  #\export (stream-null stream-cons stream? stream-null? stream-pair?
+            stream-car stream-cdr stream-lambda define-stream
+            list->stream port->stream stream stream->list stream-append
+            stream-concat stream-constant stream-drop stream-drop-while
+            stream-filter stream-fold stream-for-each stream-from
+            stream-iterate stream-length stream-let stream-map
+            stream-match stream-of stream-range stream-ref stream-reverse
+            stream-scan stream-take stream-take-while stream-unfold
+            stream-unfolds stream-zip))
+
+(cond-expand-provide (current-module) '(srfi-41))
+
+;;; Private supporting functions and macros.
+
+(define-syntax-rule (must pred obj func msg args ...)
+  (let ((item obj))
+    (unless (pred item)
+      (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-not pred obj func msg args ...)
+  (let ((item obj))
+    (when (pred item)
+      (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-every pred objs func msg args ...)
+  (let ((flunk (remove pred objs)))
+    (unless (null? flunk)
+      (throw 'wrong-type-arg func msg (list args ...) flunk))))
+
+(define-syntax-rule (first-value expr)
+  (receive (first . _) expr
+    first))
+
+(define-syntax-rule (second-value expr)
+  (receive (first second . _) expr
+    second))
+
+(define-syntax-rule (third-value expr)
+  (receive (first second third . _) expr
+    third))
+
+(define-syntax define-syntax*
+  (syntax-rules ()
+    ((_ (name . args) body ...)
+     (define-syntax name (lambda* args body ...)))
+    ((_ name syntax)
+     (define-syntax name syntax))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Here we include a copy of the code of srfi-45.scm (but with renamed
+;; identifiers), in order to create a new promise type that's disjoint
+;; from the promises created by srfi-45.  Ideally this should be done
+;; using a 'make-promise-type' macro that instantiates a copy of this
+;; code, but a psyntax bug in Guile 2.0 prevents this from working
+;; properly: <http://bugs.gnu.org/13995>.  So for now, we duplicate the
+;; code.
+
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; 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-record-type stream-promise (make-stream-promise val) stream-promise?
+  (val stream-promise-val stream-promise-val-set!))
+
+(define-record-type stream-value (make-stream-value tag proc) stream-value?
+  (tag stream-value-tag stream-value-tag-set!)
+  (proc stream-value-proc stream-value-proc-set!))
+
+(define-syntax-rule (stream-lazy exp)
+  (make-stream-promise (make-stream-value 'lazy (lambda () exp))))
+
+(define (stream-eager x)
+  (make-stream-promise (make-stream-value 'eager x)))
+
+(define-syntax-rule (stream-delay exp)
+  (stream-lazy (stream-eager exp)))
+
+(define (stream-force promise)
+  (let ((content (stream-promise-val promise)))
+    (case (stream-value-tag content)
+      ((eager) (stream-value-proc content))
+      ((lazy)  (let* ((promise* ((stream-value-proc content)))
+                      (content  (stream-promise-val promise)))
+                 (if (not (eqv? (stream-value-tag content) 'eager))
+                     (begin (stream-value-tag-set! content
+                                                   (stream-value-tag (stream-promise-val promise*)))
+                            (stream-value-proc-set! content
+                                                    (stream-value-proc (stream-promise-val promise*)))
+                            (stream-promise-val-set! promise* content)))
+                 (stream-force promise))))))
+
+;;
+;; End of the copy of the code from srfi-45.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Primitive stream functions and macros: (streams primitive)
+
+(define stream? stream-promise?)
+
+(define %stream-null (cons 'stream 'null))
+(define stream-null (stream-eager %stream-null))
+
+(define (stream-null? obj)
+  (and (stream-promise? obj)
+       (eqv? (stream-force obj) %stream-null)))
+
+(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
+  (kar stream-kar)
+  (kdr stream-kdr))
+
+(define (stream-pair? obj)
+  (and (stream-promise? obj) (stream-pare? (stream-force obj))))
+
+(define-syntax-rule (stream-cons obj strm)
+  (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
+
+(define (stream-car strm)
+  (must stream? strm 'stream-car "non-stream")
+  (let ((pare (stream-force strm)))
+    (must stream-pare? pare 'stream-car "null stream")
+    (stream-force (stream-kar pare))))
+
+(define (stream-cdr strm)
+  (must stream? strm 'stream-cdr "non-stream")
+  (let ((pare (stream-force strm)))
+    (must stream-pare? pare 'stream-cdr "null stream")
+    (stream-kdr pare)))
+
+(define-syntax-rule (stream-lambda formals body0 body1 ...)
+  (lambda formals (stream-lazy (begin body0 body1 ...))))
+
+(define* (stream-promise-visit promise #\key on-eager on-lazy)
+  (define content (stream-promise-val promise))
+  (case (stream-value-tag content)
+    ((eager) (on-eager (stream-value-proc content)))
+    ((lazy)  (on-lazy (stream-value-proc content)))))
+
+(set-record-type-printer! stream-promise
+  (lambda (strm port)
+    (display "#<stream" port)
+    (let loop ((strm strm))
+      (stream-promise-visit strm
+        #\on-eager (lambda (pare)
+                     (cond ((eq? pare %stream-null)
+                            (write-char #\> port))
+                           (else
+                            (write-char #\space port)
+                            (stream-promise-visit (stream-kar pare)
+                              #\on-eager (cut write <> port)
+                              #\on-lazy  (lambda (_) (write-char #\? port)))
+                            (loop (stream-kdr pare)))))
+        #\on-lazy (lambda (_) (display " ...>" port))))))
+
+;;; Derived stream functions and macros: (streams derived)
+
+(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
+  (define name (stream-lambda formal body0 body1 ...)))
+
+(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
+  ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
+
+(define (list->stream objs)
+  (define (list? x)
+    (or (proper-list? x) (circular-list? x)))
+  (must list? objs 'list->stream "non-list argument")
+  (stream-let recur ((objs objs))
+    (if (null? objs) stream-null
+        (stream-cons (car objs) (recur (cdr objs))))))
+
+(define* (port->stream #\optional (port (current-input-port)))
+  (must input-port? port 'port->stream "non-input-port argument")
+  (stream-let recur ()
+    (let ((c (read-char port)))
+      (if (eof-object? c) stream-null
+          (stream-cons c (recur))))))
+
+(define-syntax stream
+  (syntax-rules ()
+    ((_) stream-null)
+    ((_ x y ...) (stream-cons x (stream y ...)))))
+
+;; Common helper for the various eager-folding functions, such as
+;; stream-fold, stream-drop, stream->list, stream-length, etc.
+(define-inlinable (stream-fold-aux proc base strm limit)
+  (do ((val base (and proc (proc val (stream-car strm))))
+       (strm strm (stream-cdr strm))
+       (limit limit (and limit (1- limit))))
+      ((or (and limit (zero? limit)) (stream-null? strm))
+       (values val strm limit))))
+
+(define stream->list
+  (case-lambda
+   ((strm) (stream->list #f strm))
+   ((n strm)
+    (must stream? strm 'stream->list "non-stream argument")
+    (when n
+      (must integer? n 'stream->list "non-integer count")
+      (must exact? n 'stream->list "inexact count")
+      (must-not negative? n 'stream->list "negative count"))
+    (reverse! (first-value (stream-fold-aux xcons '() strm n))))))
+
+(define (stream-append . strms)
+  (must-every stream? strms 'stream-append "non-stream argument")
+  (stream-let recur ((strms strms))
+    (if (null? strms) stream-null
+        (let ((strm (car strms)))
+          (if (stream-null? strm) (recur (cdr strms))
+              (stream-cons (stream-car strm)
+                           (recur (cons (stream-cdr strm) (cdr strms)))))))))
+
+(define (stream-concat strms)
+  (must stream? strms 'stream-concat "non-stream argument")
+  (stream-let recur ((strms strms))
+    (if (stream-null? strms) stream-null
+        (let ((strm (stream-car strms)))
+          (must stream? strm 'stream-concat "non-stream object in input stream")
+          (if (stream-null? strm) (recur (stream-cdr strms))
+              (stream-cons (stream-car strm)
+                           (recur (stream-cons (stream-cdr strm)
+                                               (stream-cdr strms)))))))))
+
+(define stream-constant
+  (case-lambda
+   (() stream-null)
+   (objs (list->stream (apply circular-list objs)))))
+
+(define-syntax* (stream-do x)
+  (define (end x)
+    (syntax-case x ()
+      (() #'(if #f #f))
+      ((result) #'result)
+      ((result ...) #'(begin result ...))))
+  (define (var-step v s)
+    (syntax-case s ()
+      (() v)
+      ((e) #'e)
+      (_ (syntax-violation 'stream-do "bad step expression" x s))))
+
+  (syntax-case x ()
+    ((_ ((var init . step) ...)
+        (test result ...)
+        expr ...)
+     (with-syntax ((result (end #'(result ...)))
+                   ((step ...) (map var-step #'(var ...) #'(step ...))))
+       #'(stream-let loop ((var init) ...)
+           (if test result
+               (begin
+                 expr ...
+                 (loop step ...))))))))
+
+(define (stream-drop n strm)
+  (must integer? n 'stream-drop "non-integer argument")
+  (must exact? n 'stream-drop "inexact argument")
+  (must-not negative? n 'stream-drop "negative argument")
+  (must stream? strm 'stream-drop "non-stream argument")
+  (second-value (stream-fold-aux #f #f strm n)))
+
+(define (stream-drop-while pred? strm)
+  (must procedure? pred? 'stream-drop-while "non-procedural argument")
+  (must stream? strm 'stream-drop-while "non-stream argument")
+  (stream-do ((strm strm (stream-cdr strm)))
+             ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
+
+(define (stream-filter pred? strm)
+  (must procedure? pred? 'stream-filter "non-procedural argument")
+  (must stream? strm 'stream-filter "non-stream argument")
+  (stream-let recur ((strm strm))
+    (cond ((stream-null? strm) stream-null)
+          ((pred? (stream-car strm))
+           (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+          (else (recur (stream-cdr strm))))))
+
+(define (stream-fold proc base strm)
+  (must procedure? proc 'stream-fold "non-procedural argument")
+  (must stream? strm 'stream-fold "non-stream argument")
+  (first-value (stream-fold-aux proc base strm #f)))
+
+(define stream-for-each
+  (case-lambda
+   ((proc strm)
+    (must procedure? proc 'stream-for-each "non-procedural argument")
+    (must stream? strm 'stream-for-each "non-stream argument")
+    (do ((strm strm (stream-cdr strm)))
+        ((stream-null? strm))
+      (proc (stream-car strm))))
+   ((proc strm . rest)
+    (let ((strms (cons strm rest)))
+      (must procedure? proc 'stream-for-each "non-procedural argument")
+      (must-every stream? strms 'stream-for-each "non-stream argument")
+      (do ((strms strms (map stream-cdr strms)))
+          ((any stream-null? strms))
+        (apply proc (map stream-car strms)))))))
+
+(define* (stream-from first #\optional (step 1))
+  (must number? first 'stream-from "non-numeric starting number")
+  (must number? step 'stream-from "non-numeric step size")
+  (stream-let recur ((first first))
+    (stream-cons first (recur (+ first step)))))
+
+(define (stream-iterate proc base)
+  (must procedure? proc 'stream-iterate "non-procedural argument")
+  (stream-let recur ((base base))
+    (stream-cons base (recur (proc base)))))
+
+(define (stream-length strm)
+  (must stream? strm 'stream-length "non-stream argument")
+  (- -1 (third-value (stream-fold-aux #f #f strm -1))))
+
+(define stream-map
+  (case-lambda
+   ((proc strm)
+    (must procedure? proc 'stream-map "non-procedural argument")
+    (must stream? strm 'stream-map "non-stream argument")
+    (stream-let recur ((strm strm))
+      (if (stream-null? strm) stream-null
+          (stream-cons (proc (stream-car strm))
+                       (recur (stream-cdr strm))))))
+   ((proc strm . rest)
+    (let ((strms (cons strm rest)))
+      (must procedure? proc 'stream-map "non-procedural argument")
+      (must-every stream? strms 'stream-map "non-stream argument")
+      (stream-let recur ((strms strms))
+        (if (any stream-null? strms) stream-null
+            (stream-cons (apply proc (map stream-car strms))
+                         (recur (map stream-cdr strms)))))))))
+
+(define-syntax* (stream-match x)
+  (define (make-matcher x)
+    (syntax-case x ()
+      (() #'(? stream-null?))
+      (rest (identifier? #'rest) #'rest)
+      ((var . rest) (identifier? #'var)
+       (with-syntax ((next (make-matcher #'rest)))
+         #'(? (negate stream-null?)
+              (= stream-car var)
+              (= stream-cdr next))))))
+  (define (make-guarded x fail)
+    (syntax-case (list x fail) ()
+      (((expr) _) #'expr)
+      (((guard expr) fail) #'(if guard expr (fail)))))
+
+  (syntax-case x ()
+    ((_ strm-expr (pat . expr) ...)
+     (with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
+       (with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
+                     ((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
+         #'(let ((strm strm-expr))
+             (must stream? strm 'stream-match "non-stream argument")
+             (match strm (matcher (=> fail) expr) ...)))))))
+
+(define-syntax-rule (stream-of expr rest ...)
+  (stream-of-aux expr stream-null rest ...))
+
+(define-syntax stream-of-aux
+  (syntax-rules (in is)
+    ((_ expr base)
+     (stream-cons expr base))
+    ((_ expr base (var in stream) rest ...)
+     (stream-let recur ((strm stream))
+       (if (stream-null? strm) base
+           (let ((var (stream-car strm)))
+             (stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
+    ((_ expr base (var is exp) rest ...)
+     (let ((var exp)) (stream-of-aux expr base rest ...)))
+    ((_ expr base pred? rest ...)
+     (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define* (stream-range first past #\optional step)
+  (must number? first 'stream-range "non-numeric starting number")
+  (must number? past 'stream-range "non-numeric ending number")
+  (when step
+    (must number? step 'stream-range "non-numeric step size"))
+  (let* ((step (or step (if (< first past) 1 -1)))
+         (lt? (if (< 0 step) < >)))
+    (stream-let recur ((first first))
+      (if (lt? first past)
+          (stream-cons first (recur (+ first step)))
+          stream-null))))
+
+(define (stream-ref strm n)
+  (must stream? strm 'stream-ref "non-stream argument")
+  (must integer? n 'stream-ref "non-integer argument")
+  (must exact? n 'stream-ref "inexact argument")
+  (must-not negative? n 'stream-ref "negative argument")
+  (let ((res (stream-drop n strm)))
+    (must-not stream-null? res 'stream-ref "beyond end of stream")
+    (stream-car res)))
+
+(define (stream-reverse strm)
+  (must stream? strm 'stream-reverse "non-stream argument")
+  (stream-do ((strm strm (stream-cdr strm))
+              (rev stream-null (stream-cons (stream-car strm) rev)))
+             ((stream-null? strm) rev)))
+
+(define (stream-scan proc base strm)
+  (must procedure? proc 'stream-scan "non-procedural argument")
+  (must stream? strm 'stream-scan "non-stream argument")
+  (stream-let recur ((base base) (strm strm))
+    (if (stream-null? strm) (stream base)
+        (stream-cons base (recur (proc base (stream-car strm))
+                                 (stream-cdr strm))))))
+
+(define (stream-take n strm)
+  (must stream? strm 'stream-take "non-stream argument")
+  (must integer? n 'stream-take "non-integer argument")
+  (must exact? n 'stream-take "inexact argument")
+  (must-not negative? n 'stream-take "negative argument")
+  (stream-let recur ((n n) (strm strm))
+    (if (or (zero? n) (stream-null? strm)) stream-null
+        (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
+
+(define (stream-take-while pred? strm)
+  (must procedure? pred? 'stream-take-while "non-procedural argument")
+  (must stream? strm 'stream-take-while "non-stream argument")
+  (stream-let recur ((strm strm))
+    (cond ((stream-null? strm) stream-null)
+          ((pred? (stream-car strm))
+           (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+          (else stream-null))))
+
+(define (stream-unfold mapper pred? generator base)
+  (must procedure? mapper 'stream-unfold "non-procedural mapper")
+  (must procedure? pred? 'stream-unfold "non-procedural pred?")
+  (must procedure? generator 'stream-unfold "non-procedural generator")
+  (stream-let recur ((base base))
+    (if (pred? base)
+        (stream-cons (mapper base) (recur (generator base)))
+        stream-null)))
+
+(define (stream-unfolds gen seed)
+  (define-stream (generator-stream seed)
+    (receive (next . items) (gen seed)
+      (stream-cons (list->vector items) (generator-stream next))))
+  (define-stream (make-result-stream genstrm index)
+    (define head (vector-ref (stream-car genstrm) index))
+    (define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
+    (match head
+      (() stream-null)
+      (#f (tail))
+      ((item) (stream-cons item (tail)))
+      ((? list? items) (stream-append (list->stream items) (tail)))))
+
+  (must procedure? gen 'stream-unfolds "non-procedural argument")
+  (let ((genstrm (generator-stream seed)))
+    (apply values (list-tabulate (vector-length (stream-car genstrm))
+                                 (cut make-result-stream genstrm <>)))))
+
+(define (stream-zip strm . rest)
+  (let ((strms (cons strm rest)))
+    (must-every stream? strms 'stream-zip "non-stream argument")
+    (stream-let recur ((strms strms))
+      (if (any stream-null? strms) stream-null
+          (stream-cons (map stream-car strms) (recur (map stream-cdr strms)))))))
+;;; srfi-42.scm --- Eager comprehensions
+
+;; Copyright (C) 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, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-42)
+  #\export (\:
+            \:-dispatch-ref
+            \:-dispatch-set!
+            \:char-range
+            \:dispatched
+            \:do
+            \:generator-proc
+            \:integers
+            \:let
+            \:list
+            \:parallel
+            \:port
+            \:range
+            \:real-range
+            \:string
+            \:until
+            \:vector
+            \:while
+            any?-ec
+            append-ec
+            dispatch-union
+            do-ec
+            every?-ec
+            first-ec
+            fold-ec
+            fold3-ec
+            last-ec
+            list-ec
+            make-initial-\:-dispatch
+            max-ec
+            min-ec
+            product-ec
+            string-append-ec
+            string-ec
+            sum-ec
+            vector-ec
+            vector-of-length-ec))
+
+(cond-expand-provide (current-module) '(srfi-42))
+
+(include-from-path "srfi/srfi-42/ec.scm")
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+; 
+; Loading the implementation into Scheme48 0.57:
+;   ,open srfi-23
+;   ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+;   ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+;   (require 'macro) (require 'record) 
+;   (load "ec.scm")
+;
+; Implementation comments:
+;   * All local (not exported) identifiers are named ec-<something>.
+;   * This implementation focuses on portability, performance, 
+;     readability, and simplicity roughly in this order. Design
+;     decisions related to performance are taken for Scheme48.
+;   * Alternative implementations, Comments and Warnings are 
+;     mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do. 
+;
+; We use the following short names for syntactic variables
+;   q    - qualifier
+;   cc   - current continuation, thing to call at the end;
+;          the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+;   cmd  - an expression being evaluated for its side-effects
+;   expr - an expression
+;   gen  - a generator of an eager comprehension
+;   ob   - outer binding
+;   oc   - outer command
+;   lb   - loop binding
+;   ne1? - not-end1? (before the payload)
+;   ib   - inner binding
+;   ic   - inner command
+;   ne2? - not-end2? (after the payload)
+;   ls   - loop step
+;   etc  - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+;   handles nested, if/not/and/or, begin, :let, and calls generator 
+;   macros in CPS to transform them into fully decorated :do.
+;   The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+  (syntax-rules (nested if not and or begin \:do let)
+
+    ; explicit nesting -> implicit nesting
+    ((do-ec (nested q ...) etc ...)
+     (do-ec q ... etc ...) )
+
+    ; implicit nesting -> fold do-ec
+    ((do-ec q1 q2 etc1 etc ...)
+     (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+    ; no qualifiers at all -> evaluate cmd once
+    ((do-ec cmd)
+     (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+    ; filter -> make conditional
+    ((do-ec (if test) cmd)
+     (if test (do-ec cmd)) )
+    ((do-ec (not test) cmd)
+     (if (not test) (do-ec cmd)) )
+    ((do-ec (and test ...) cmd)
+     (if (and test ...) (do-ec cmd)) )
+    ((do-ec (or test ...) cmd)
+     (if (or test ...) (do-ec cmd)) )
+
+    ; begin -> make a sequence
+    ((do-ec (begin etc ...) cmd)
+     (begin etc ... (do-ec cmd)) )
+
+    ; fully decorated :do-generator -> delegate to do-ec:do
+    ((do-ec (#\:do olet lbs ne1? ilet ne2? lss) cmd)
+     (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+    ((do-ec (g arg1 arg ...) cmd)
+     (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (#\:do olet lbs ne1? ilet ne2? lss))
+;   generates code for a single fully decorated :do-generator
+;   with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+  (syntax-rules (#\:do let)
+
+    ; reentry point (*) -> generate code
+    ((do-ec:do cmd 
+               (#\:do (let obs oc ...) 
+                    lbs 
+                    ne1? 
+                    (let ibs ic ...) 
+                    ne2? 
+                    (ls ...) ))
+     (ec-simplify
+       (let obs
+         oc ...
+         (let loop lbs
+           (ec-simplify
+             (if ne1?
+                 (ec-simplify
+                   (let ibs
+                      ic ...
+                      cmd
+                      (ec-simplify
+                        (if ne2?
+                            (loop ls ...) )))))))))) ))
+
+    
+; (ec-simplify <expression>)
+;   generates potentially more efficient code for <expression>.
+;   The macro handles if, (begin <command>*), and (let () <command>*)
+;   and takes care of special cases.
+
+(define-syntax ec-simplify
+  (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+    ; literal <test>
+    ((ec-simplify (if #t consequent))
+     consequent )
+    ((ec-simplify (if #f consequent))
+     (if #f #f) )
+    ((ec-simplify (if #t consequent alternate))
+     consequent )
+    ((ec-simplify (if #f consequent alternate))
+     alternate )
+
+    ; (not (not <test>))
+    ((ec-simplify (if (not (not test)) consequent))
+     (ec-simplify (if test consequent)) )
+    ((ec-simplify (if (not (not test)) consequent alternate))
+     (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*) 
+
+    ; empty <binding spec>*
+    ((ec-simplify (let () command ...))
+     (ec-simplify (begin command ...)) )
+
+; begin 
+
+    ; flatten use helper (ec-simplify 1 done to-do)
+    ((ec-simplify (begin command ...))
+     (ec-simplify 1 () (command ...)) )
+    ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+     (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+    ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+     (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+    ; exit helper
+    ((ec-simplify 1 () ())
+     (if #f #f) )
+    ((ec-simplify 1 (command) ())
+     command )
+    ((ec-simplify 1 (command1 command ...) ())
+     (begin command1 command ...) )
+
+; anything else
+
+    ((ec-simplify expression)
+     expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax \:do
+  (syntax-rules ()
+
+    ; full decorated -> continue with cc, reentry at (*)
+    ((#\:do (cc ...) olet lbs ne1? ilet ne2? lss)
+     (cc ... (#\:do olet lbs ne1? ilet ne2? lss)) )
+
+    ; short form -> fill in default values
+    ((#\:do cc lbs ne1? lss)
+     (#\:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+    
+
+(define-syntax \:let
+  (syntax-rules (index)
+    ((\:let cc var (index i) expression)
+     (#\:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+    ((\:let cc var expression)
+     (#\:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax \:parallel
+  (syntax-rules (#\:do)
+    ((\:parallel cc)
+     cc )
+    ((\:parallel cc (g arg1 arg ...) gen ...)
+     (g (\:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (\:parallel-1 cc (to-do ...) result [ next ] )
+;    iterates over to-do by converting the first generator into 
+;    the :do-generator next and merging next into result.
+
+(define-syntax \:parallel-1  ; used as 
+  (syntax-rules (#\:do let)
+
+    ; process next element of to-do, reentry at (**)
+    ((\:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+     (g (\:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+    ; reentry point (**) -> merge next into result
+    ((\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ...) oc1 ...) 
+            (lb1 ...) 
+            ne1?1 
+            (let (ib1 ...) ic1 ...) 
+            ne2?1 
+            (ls1 ...) )
+       (#\:do (let (ob2 ...) oc2 ...) 
+            (lb2 ...) 
+            ne1?2 
+            (let (ib2 ...) ic2 ...) 
+            ne2?2 
+            (ls2 ...) ))
+     (\:parallel-1 
+       cc 
+       gens 
+       (#\:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) 
+            (lb1 ... lb2 ...) 
+            (and ne1?1 ne1?2) 
+            (let (ib1 ... ib2 ...) ic1 ... ic2 ...) 
+            (and ne2?1 ne2?2) 
+            (ls1 ... ls2 ...) )))
+
+    ; no more gens -> continue with cc, reentry at (*)
+    ((\:parallel-1 (cc ...) () result)
+     (cc ... result) )))
+
+(define-syntax \:while
+  (syntax-rules ()
+    ((\:while cc (g arg1 arg ...) test)
+     (g (\:while-1 cc test) arg1 arg ...) )))
+
+; (\:while-1 cc test (#\:do ...))
+;    modifies the fully decorated :do-generator such that it
+;    runs while test is a true value. 
+;       The original implementation just replaced ne1? by
+;    (and ne1? test) as follows:
+;
+;      (define-syntax \:while-1
+;        (syntax-rules (#\:do)
+;          ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+;           (#\:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+;    Unfortunately, this code is wrong because ne1? may depend
+;    in the inner bindings introduced in ilet, but ne1? is evaluated
+;    outside of the inner bindings. (Refer to the specification of
+;    :do to see the structure.) 
+;       The problem manifests itself (as sunnan@handgranat.org 
+;    observed, 25-Apr-2005) when the :list-generator is modified:
+; 
+;      (do-ec (\:while (\:list x '(1 2)) (= x 1)) (display x)).
+;
+;    In order to generate proper code, we introduce temporary
+;    variables saving the values of the inner bindings. The inner
+;    bindings are executed in a new ne1?, which also evaluates ne1?
+;    outside the scope of the inner bindings, then the inner commands
+;    are executed (possibly changing the variables), and then the
+;    values of the inner bindings are saved and (and ne1? test) is
+;    returned. In the new ilet, the inner variables are bound and
+;    initialized and their values are restored. So we construct:
+;
+;     (let (ob .. (ib-tmp #f) ...)
+;       oc ...
+;       (let loop (lb ...)
+;         (if (let (ne1?-value ne1?)
+;               (let ((ib-var ib-rhs) ...)
+;                 ic ...
+;                 (set! ib-tmp ib-var) ...)
+;               (and ne1?-value test))
+;             (let ((ib-var ib-tmp) ...)
+;               /payload/
+;               (if ne2?
+;                   (loop ls ...) )))))
+; 
+; Bug #2:
+;    Unfortunately, the above expansion is still incorrect (as Jens-Axel 
+;    Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+;    if ne1?-value is #f, indicating that the loop has ended.
+;       The problem manifests itself in the following example:
+;
+;      (do-ec (\:while (\:list x '(1)) #t) (display x))
+;
+;    Which iterates :list beyond exhausting the list '(1).
+;
+;    For the fix, we follow Jens-Axel's approach of guarding the evaluation
+;    of ib-rhs with a check on ne1?-value.
+
+(define-syntax \:while-1
+  (syntax-rules (#\:do let)
+    ((\:while-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (\:while-2 cc test () () () (#\:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax \:while-2
+  (syntax-rules (#\:do let)
+    ((\:while-2 cc 
+               test 
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let ((ib-var ib-rhs) ib ...) ic ...)
+                    ne2? 
+                    lss))
+     (\:while-2 cc 
+               test 
+               (ib-let     ... (ib-tmp #f))
+               (ib-save    ... (ib-var ib-rhs))
+               (ib-restore ... (ib-var ib-tmp))
+               (#\:do olet 
+                    lbs 
+                    ne1? 
+                    (let (ib ...) ic ... (set! ib-tmp ib-var)) 
+                    ne2? 
+                    lss)))
+    ((\:while-2 cc
+               test
+               (ib-let     ...)
+               (ib-save    ...)
+               (ib-restore ...)
+               (#\:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+     (#\:do cc
+          (let (ob ... ib-let ...) oc ...)
+          lbs
+          (let ((ne1?-value ne1?))
+	    (and ne1?-value
+		 (let (ib-save ...)
+		   ic ...
+		   test)))
+          (let (ib-restore ...))
+          ne2?
+          lss))))
+
+
+(define-syntax \:until
+  (syntax-rules ()
+    ((\:until cc (g arg1 arg ...) test)
+     (g (\:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax \:until-1
+  (syntax-rules (#\:do)
+    ((\:until-1 cc test (#\:do olet lbs ne1? ilet ne2? lss))
+     (#\:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax \:list
+  (syntax-rules (index)
+    ((\:list cc var (index i) arg ...)
+     (\:parallel cc (\:list var arg ...) (\:integers i)) )
+    ((\:list cc var arg1 arg2 arg ...)
+     (\:list cc var (append arg1 arg2 arg ...)) )
+    ((\:list cc var arg)
+     (#\:do cc
+          (let ())
+          ((t arg))
+          (not (null? t))
+          (let ((var (car t))))
+          #t
+          ((cdr t)) ))))
+
+
+(define-syntax \:string
+  (syntax-rules (index)
+    ((\:string cc var (index i) arg)
+     (#\:do cc
+          (let ((str arg) (len 0)) 
+            (set! len (string-length str)))
+          ((i 0))
+          (< i len)
+          (let ((var (string-ref str i))))
+          #t
+          ((+ i 1)) ))
+    ((\:string cc var (index i) arg1 arg2 arg ...)
+     (\:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+    ((\:string cc var arg1 arg ...)
+     (\:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+;   be used for :string. However, it is less interesting as the
+;   overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax \:vector
+  (syntax-rules (index)
+    ((\:vector cc var arg)
+     (\:vector cc var (index i) arg) )
+    ((\:vector cc var (index i) arg)
+     (#\:do cc
+          (let ((vec arg) (len 0)) 
+            (set! len (vector-length vec)))
+          ((i 0))
+          (< i len)
+          (let ((var (vector-ref vec i))))
+          #t
+          ((+ i 1)) ))
+
+    ((\:vector cc var (index i) arg1 arg2 arg ...)
+     (\:parallel cc (\:vector cc var arg1 arg2 arg ...) (\:integers i)) )
+    ((\:vector cc var arg1 arg2 arg ...)
+     (#\:do cc
+          (let ((vec #f)
+                (len 0)
+                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+          ((k 0))
+          (if (< k len)
+              #t
+              (if (null? vecs)
+                  #f
+                  (begin (set! vec (car vecs))
+                         (set! vecs (cdr vecs))
+                         (set! len (vector-length vec))
+                         (set! k 0)
+                         #t )))
+          (let ((var (vector-ref vec k))))
+          #t
+          ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+  (if (null? vecs)
+      '()
+      (if (zero? (vector-length (car vecs)))
+          (ec-:vector-filter (cdr vecs))
+          (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+;   append and :list in the multi-argument case. Please refer to the
+;   'design.scm' for more details.
+
+
+(define-syntax \:integers
+  (syntax-rules (index)
+    ((\:integers cc var (index i))
+     (#\:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+    ((\:integers cc var)
+     (#\:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax \:range
+  (syntax-rules (index)
+
+    ; handle index variable and add optional args
+    ((\:range cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:range var arg1 arg ...) (\:integers i)) )
+    ((\:range cc var arg1)
+     (\:range cc var 0 arg1 1) )
+    ((\:range cc var arg1 arg2)
+     (\:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+    ((\:range cc var 0 arg2 1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var 0 arg2 -1)
+     (#\:do cc
+          (let ((b arg2))
+            (if (not (and (integer? b) (exact? b)))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" 0 b 1 )))
+          ((var 0))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+    ((\:range cc var arg1 arg2 1)
+     (#\:do cc
+          (let ((a arg1) (b arg2))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b 1 )) )
+          ((var a))
+          (< var b)
+          (let ())
+          #t
+          ((+ var 1)) ))
+
+    ((\:range cc var arg1 arg2 -1)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s -1) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b -1 )) )
+          ((var a))
+          (> var b)
+          (let ())
+          #t
+          ((- var 1)) ))
+
+; the general case
+
+    ((\:range cc var arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (stop 0))
+            (if (not (and (integer? a) (exact? a)
+                          (integer? b) (exact? b)
+                          (integer? s) (exact? s) ))
+                (error 
+                   "arguments of :range are not exact integer "
+                   "(use :real-range?)" a b s ))
+            (if (zero? s)
+                (error "step size must not be zero in :range") )
+            (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+          ((var a))
+          (not (= var stop))
+          (let ())
+          #t
+          ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+;   are exact integers. This overhead has proven very helpful for 
+;   saving users from themselves.
+
+
+(define-syntax \:real-range
+  (syntax-rules (index)
+
+    ; add optional args and index variable
+    ((\:real-range cc var arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var (index i) arg1)
+     (\:real-range cc var (index i) 0 arg1 1) )
+    ((\:real-range cc var arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var (index i) arg1 arg2)
+     (\:real-range cc var (index i) arg1 arg2 1) )
+    ((\:real-range cc var arg1 arg2 arg3)
+     (\:real-range cc var (index i) arg1 arg2 arg3) )
+
+    ; the fully qualified case
+    ((\:real-range cc var (index i) arg1 arg2 arg3)
+     (#\:do cc
+          (let ((a arg1) (b arg2) (s arg3) (istop 0))
+            (if (not (and (real? a) (real? b) (real? s)))
+                (error "arguments of :real-range are not real" a b s) )
+            (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+                (set! a (exact->inexact a)) )
+            (set! istop (/ (- b a) s)) )
+          ((i 0))
+          (< i istop)
+          (let ((var (+ a (* s i)))))
+          #t
+          ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+;   value in case any of the other values is inexact. This is a
+;   precaution to avoid (list-ec (\: x 0 3.0) x) => '(0 1.0 2.0).
+
+    
+(define-syntax \:char-range
+  (syntax-rules (index)
+    ((\:char-range cc var (index i) arg1 arg2)
+     (\:parallel cc (\:char-range var arg1 arg2) (\:integers i)) )
+    ((\:char-range cc var arg1 arg2)
+     (#\:do cc
+          (let ((imax (char->integer arg2))))
+          ((i (char->integer arg1)))
+          (<= i imax)
+          (let ((var (integer->char i))))
+          #t
+          ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator 
+;   because the integers obtained by char->integer are not necessarily 
+;   consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax \:port
+  (syntax-rules (index)
+    ((\:port cc var (index i) arg1 arg ...)
+     (\:parallel cc (\:port var arg1 arg ...) (\:integers i)) )
+    ((\:port cc var arg)
+     (\:port cc var arg read) )
+    ((\:port cc var arg1 arg2)
+     (#\:do cc
+          (let ((port arg1) (read-proc arg2)))
+          ((var (read-proc port)))
+          (not (eof-object? var))
+          (let ())
+          #t
+          ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax \:dispatched
+  (syntax-rules (index)
+    ((\:dispatched cc var (index i) dispatch arg1 arg ...)
+     (\:parallel cc 
+                (\:integers i)
+                (\:dispatched var dispatch arg1 arg ...) ))
+    ((\:dispatched cc var dispatch arg1 arg ...)
+     (#\:do cc
+          (let ((d dispatch) 
+                (args (list arg1 arg ...)) 
+                (g #f) 
+                (empty (list #f)) )
+            (set! g (d args))
+            (if (not (procedure? g))
+                (error "unrecognized arguments in dispatching" 
+                       args 
+                       (d '()) )))
+          ((var (g empty)))
+          (not (eq? var empty))
+          (let ())
+          #t
+          ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+;   non-empty list. It is compared using eq? which distinguishes
+;   the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax \:generator-proc
+  (syntax-rules (#\:do let)
+
+    ; call g with a variable, reentry at (**)
+    ((\:generator-proc (g arg ...))
+     (g (\:generator-proc var) var arg ...) )
+
+    ; reentry point (**) -> make the code from a single :do
+    ((\:generator-proc
+       var 
+       (#\:do (let obs oc ...) 
+            ((lv li) ...) 
+            ne1? 
+            (let ((i v) ...) ic ...) 
+            ne2? 
+            (ls ...)) )
+     (ec-simplify 
+      (let obs
+          oc ...
+          (let ((lv li) ... (ne2 #t))
+            (ec-simplify
+             (let ((i #f) ...) ; v not yet valid
+               (lambda (empty)
+                 (if (and ne1? ne2)
+                     (ec-simplify
+                      (begin 
+                        (set! i v) ...
+                        ic ...
+                        (let ((value var))
+                          (ec-simplify
+                           (if ne2?
+                               (ec-simplify 
+                                (begin (set! lv ls) ...) )
+                               (set! ne2 #f) ))
+                          value )))
+                     empty ))))))))
+
+    ; silence warnings of some macro expanders
+    ((\:generator-proc var)
+     (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+  (lambda (args)
+    (let ((g1 (d1 args)) (g2 (d2 args)))
+      (if g1
+          (if g2 
+              (if (null? args)
+                  (append (if (list? g1) g1 (list g1)) 
+                          (if (list? g2) g2 (list g2)) )
+                  (error "dispatching conflict" args (d1 '()) (d2 '())) )
+              g1 )
+          (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-\:-dispatch)
+  (lambda (args)
+    (case (length args)
+      ((0) 'SRFI42)
+      ((1) (let ((a1 (car args)))
+             (cond
+              ((list? a1)
+               (\:generator-proc (\:list a1)) )
+              ((string? a1)
+               (\:generator-proc (\:string a1)) )
+              ((vector? a1)
+               (\:generator-proc (\:vector a1)) )
+              ((and (integer? a1) (exact? a1))
+               (\:generator-proc (\:range a1)) )
+              ((real? a1)
+               (\:generator-proc (\:real-range a1)) )
+              ((input-port? a1)
+               (\:generator-proc (\:port a1)) )
+              (else
+               #f ))))
+      ((2) (let ((a1 (car args)) (a2 (cadr args)))
+             (cond
+              ((and (list? a1) (list? a2))
+               (\:generator-proc (\:list a1 a2)) )
+              ((and (string? a1) (string? a1))
+               (\:generator-proc (\:string a1 a2)) )
+              ((and (vector? a1) (vector? a2))
+               (\:generator-proc (\:vector a1 a2)) )
+              ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+               (\:generator-proc (\:range a1 a2)) )
+              ((and (real? a1) (real? a2))
+               (\:generator-proc (\:real-range a1 a2)) )
+              ((and (char? a1) (char? a2))
+               (\:generator-proc (\:char-range a1 a2)) )
+              ((and (input-port? a1) (procedure? a2))
+               (\:generator-proc (\:port a1 a2)) )
+              (else
+               #f ))))
+      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+             (cond
+              ((and (list? a1) (list? a2) (list? a3))
+               (\:generator-proc (\:list a1 a2 a3)) )
+              ((and (string? a1) (string? a1) (string? a3))
+               (\:generator-proc (\:string a1 a2 a3)) )
+              ((and (vector? a1) (vector? a2) (vector? a3))
+               (\:generator-proc (\:vector a1 a2 a3)) )
+              ((and (integer? a1) (exact? a1) 
+                    (integer? a2) (exact? a2)
+                    (integer? a3) (exact? a3))
+               (\:generator-proc (\:range a1 a2 a3)) )
+              ((and (real? a1) (real? a2) (real? a3))
+               (\:generator-proc (\:real-range a1 a2 a3)) )
+              (else
+               #f ))))
+      (else
+       (letrec ((every? 
+                 (lambda (pred args)
+                   (if (null? args)
+                       #t
+                       (and (pred (car args))
+                            (every? pred (cdr args)) )))))
+         (cond
+          ((every? list? args)
+           (\:generator-proc (\:list (apply append args))) )
+          ((every? string? args)
+           (\:generator-proc (\:string (apply string-append args))) )
+          ((every? vector? args)
+           (\:generator-proc (\:list (apply append (map vector->list args)))) )
+          (else
+           #f )))))))
+
+(define \\:-dispatch
+  (make-initial-\:-dispatch) )
+
+(define (\\:-dispatch-ref)
+  \:-dispatch )
+
+(define (\\:-dispatch-set! dispatch)
+  (if (not (procedure? dispatch))
+      (error "not a procedure" dispatch) )
+  (set! \:-dispatch dispatch) )
+
+(define-syntax \:
+  (syntax-rules (index)
+    ((\: cc var (index i) arg1 arg ...)
+     (\:dispatched cc var (index i) \:-dispatch arg1 arg ...) )
+    ((\: cc var arg1 arg ...)
+     (\:dispatched cc var \:-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+  (syntax-rules (nested)
+    ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+     (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+    ((fold3-ec x0 expression f1 f2)
+     (fold3-ec x0 (nested) expression f1 f2) )
+
+    ((fold3-ec x0 qualifier expression f1 f2)
+     (let ((result #f) (empty #t))
+       (do-ec qualifier
+              (let ((value expression)) ; don't duplicate
+                (if empty
+                    (begin (set! result (f1 value))
+                           (set! empty #f) )
+                    (set! result (f2 value result)) )))
+       (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+  (syntax-rules (nested)
+    ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+    ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+     (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+    ((fold-ec x0 expression f2)
+     (fold-ec x0 (nested) expression f2) )
+
+    ((fold-ec x0 qualifier expression f2)
+     (let ((result x0))
+       (do-ec qualifier (set! result (f2 expression result)))
+       result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+  (syntax-rules ()
+    ((list-ec etc1 etc ...)
+     (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+;   using set-cdr! to add at the tail. This removes the overhead of copying
+;   at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+  (syntax-rules ()
+    ((append-ec etc1 etc ...)
+     (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+  (syntax-rules ()
+    ((string-ec etc1 etc ...)
+     (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+;   problem. A more space-aware implementation collect the characters 
+;   in an intermediate list and when this list becomes too large it is
+;   converted into an intermediate string. At the end, the intermediate
+;   strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+  (syntax-rules ()
+    ((string-append-ec etc1 etc ...)
+     (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+  (syntax-rules ()
+    ((vector-ec etc1 etc ...)
+     (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+;   However, the space overhead for the intermediate list is much lower
+;   than for string-ec and as there is no vector-append, the intermediate
+;   vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+  (syntax-rules (nested)
+    ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+     (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+    ((vector-of-length-ec k q1 q2             etc1 etc ...)
+     (vector-of-length-ec k (nested q1 q2)    etc1 etc ...) )
+    ((vector-of-length-ec k expression)
+     (vector-of-length-ec k (nested) expression) )
+
+    ((vector-of-length-ec k qualifier expression)
+     (let ((len k))
+       (let ((vec (make-vector len))
+             (i 0) )
+         (do-ec qualifier
+                (if (< i len)
+                    (begin (vector-set! vec i expression)
+                           (set! i (+ i 1)) )
+                    (error "vector is too short for the comprehension") ))
+         (if (= i len)
+             vec
+             (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+  (syntax-rules ()
+    ((sum-ec etc1 etc ...)
+     (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+  (syntax-rules ()
+    ((product-ec etc1 etc ...)
+     (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+  (syntax-rules ()
+    ((min-ec etc1 etc ...)
+     (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+  (syntax-rules ()
+    ((max-ec etc1 etc ...)
+     (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+  (syntax-rules (nested)
+    ((last-ec default (nested q1 ...) q etc1 etc ...)
+     (last-ec default (nested q1 ... q) etc1 etc ...) )
+    ((last-ec default q1 q2             etc1 etc ...)
+     (last-ec default (nested q1 q2)    etc1 etc ...) )
+    ((last-ec default expression)
+     (last-ec default (nested) expression) )
+
+    ((last-ec default qualifier expression)
+     (let ((result default))
+       (do-ec qualifier (set! result expression))
+       result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+  (syntax-rules (nested)
+    ((first-ec default (nested q1 ...) q etc1 etc ...)
+     (first-ec default (nested q1 ... q) etc1 etc ...) )
+    ((first-ec default q1 q2             etc1 etc ...)
+     (first-ec default (nested q1 q2)    etc1 etc ...) )
+    ((first-ec default expression)
+     (first-ec default (nested) expression) )
+
+    ((first-ec default qualifier expression)
+     (let ((result default) (stop #f))
+       (ec-guarded-do-ec 
+         stop 
+         (nested qualifier)
+         (begin (set! result expression)
+                (set! stop #t) ))
+       result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+;   constructs (do-ec q ... cmd) where the generators gen in q ... are
+;   replaced by (\:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+  (syntax-rules (nested if not and or begin)
+
+    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+    ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+     (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+     (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+     (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+    ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+     (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+     (do-ec 
+       (\:until gen stop) 
+       (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+    ((ec-guarded-do-ec stop (nested) cmd)
+     (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+;   possible to use call-with-current-continuation:
+;
+;   (define-synatx first-ec 
+;     ...same as above...
+;     ((first-ec default qualifier expression)
+;      (call-with-current-continuation 
+;       (lambda (cc)
+;        (do-ec qualifier (cc expression))
+;        default ))) ))
+;
+;   This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+  (syntax-rules (nested)
+    ((any?-ec (nested q1 ...) q etc1 etc ...)
+     (any?-ec (nested q1 ... q) etc1 etc ...) )
+    ((any?-ec q1 q2             etc1 etc ...)
+     (any?-ec (nested q1 q2)    etc1 etc ...) )
+    ((any?-ec expression)
+     (any?-ec (nested) expression) )
+
+    ((any?-ec qualifier expression)
+     (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+  (syntax-rules (nested)
+    ((every?-ec (nested q1 ...) q etc1 etc ...)
+     (every?-ec (nested q1 ... q) etc1 etc ...) )
+    ((every?-ec q1 q2             etc1 etc ...)
+     (every?-ec (nested q1 q2)    etc1 etc ...) )
+    ((every?-ec expression)
+     (every?-ec (nested) expression) )
+
+    ((every?-ec qualifier expression)
+     (first-ec #t qualifier (if (not expression)) #f) )))
+
+;;; srfi-43.scm -- SRFI 43 Vector library
+
+;;      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, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Mark H Weaver <mhw@netris.org>
+
+(define-module (srfi srfi-43)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-8)
+  #\re-export (make-vector vector vector? vector-ref vector-set!
+                           vector-length)
+  #\replace (vector-copy vector-fill! list->vector vector->list)
+  #\export (vector-empty? vector= vector-unfold vector-unfold-right
+                          vector-reverse-copy
+                          vector-append vector-concatenate
+                          vector-fold vector-fold-right
+                          vector-map vector-map!
+                          vector-for-each vector-count
+                          vector-index vector-index-right
+                          vector-skip vector-skip-right
+                          vector-binary-search
+                          vector-any vector-every
+                          vector-swap! vector-reverse!
+                          vector-copy! vector-reverse-copy!
+                          reverse-vector->list
+                          reverse-list->vector))
+
+(cond-expand-provide (current-module) '(srfi-43))
+
+(define (error-from who msg . args)
+  (apply error
+         (string-append (symbol->string who) ": " msg)
+         args))
+
+(define-syntax-rule (assert-nonneg-exact-integer k who)
+  (unless (and (exact-integer? k)
+               (not (negative? k)))
+    (error-from who "expected non-negative exact integer, got" k)))
+
+(define-syntax-rule (assert-procedure f who)
+  (unless (procedure? f)
+    (error-from who "expected procedure, got" f)))
+
+(define-syntax-rule (assert-vector v who)
+  (unless (vector? v)
+    (error-from who "expected vector, got" v)))
+
+(define-syntax-rule (assert-valid-index i len who)
+  (unless (and (exact-integer? i)
+               (<= 0 i len))
+    (error-from who "invalid index" i)))
+
+(define-syntax-rule (assert-valid-start start len who)
+  (unless (and (exact-integer? start)
+               (<= 0 start len))
+    (error-from who "invalid start index" start)))
+
+(define-syntax-rule (assert-valid-range start end len who)
+  (unless (and (exact-integer? start)
+               (exact-integer? end)
+               (<= 0 start end len))
+    (error-from who "invalid index range" start end)))
+
+(define-syntax-rule (assert-vectors vs who)
+  (let loop ((vs vs))
+    (unless (null? vs)
+      (assert-vector (car vs) who)
+      (loop (cdr vs)))))
+
+;; Return the length of the shortest vector in VS.
+;; VS must have at least one element.
+(define (min-length vs)
+  (let loop ((vs (cdr vs))
+             (result (vector-length (car vs))))
+    (if (null? vs)
+        result
+        (loop (cdr vs) (min result (vector-length (car vs)))))))
+
+;; Return a list of the Ith elements of the vectors in VS.
+(define (vectors-ref vs i)
+  (let loop ((vs vs) (xs '()))
+    (if (null? vs)
+        (reverse! xs)
+        (loop (cdr vs) (cons (vector-ref (car vs) i)
+                             xs)))))
+
+(define vector-unfold
+  (case-lambda
+    "(vector-unfold f length initial-seed ...) -> vector
+
+The fundamental vector constructor.  Create a vector whose length is
+LENGTH and iterates across each index k from 0 up to LENGTH - 1,
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration.  It is an
+error for the number of seeds to vary between iterations."
+    ((f len)
+     (assert-procedure f 'vector-unfold)
+     (assert-nonneg-exact-integer len 'vector-unfold)
+     (let ((v (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! v i (f i))
+           (loop (+ i 1))))
+       v))
+    ((f len seed)
+     (assert-procedure f 'vector-unfold)
+     (assert-nonneg-exact-integer len 'vector-unfold)
+     (let ((v (make-vector len)))
+       (let loop ((i 0) (seed seed))
+         (unless (= i len)
+           (receive (x seed) (f i seed)
+             (vector-set! v i x)
+             (loop (+ i 1) seed))))
+       v))
+    ((f len seed1 seed2)
+     (assert-procedure f 'vector-unfold)
+     (assert-nonneg-exact-integer len 'vector-unfold)
+     (let ((v (make-vector len)))
+       (let loop ((i 0) (seed1 seed1) (seed2 seed2))
+         (unless (= i len)
+           (receive (x seed1 seed2) (f i seed1 seed2)
+             (vector-set! v i x)
+             (loop (+ i 1) seed1 seed2))))
+       v))
+    ((f len . seeds)
+     (assert-procedure f 'vector-unfold)
+     (assert-nonneg-exact-integer len 'vector-unfold)
+     (let ((v (make-vector len)))
+       (let loop ((i 0) (seeds seeds))
+         (unless (= i len)
+           (receive (x . seeds) (apply f i seeds)
+             (vector-set! v i x)
+             (loop (+ i 1) seeds))))
+       v))))
+
+(define vector-unfold-right
+  (case-lambda
+    "(vector-unfold-right f length initial-seed ...) -> vector
+
+The fundamental vector constructor.  Create a vector whose length is
+LENGTH and iterates across each index k from LENGTH - 1 down to 0,
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration.  It is an
+error for the number of seeds to vary between iterations."
+    ((f len)
+     (assert-procedure f 'vector-unfold-right)
+     (assert-nonneg-exact-integer len 'vector-unfold-right)
+     (let ((v (make-vector len)))
+       (let loop ((i (- len 1)))
+         (unless (negative? i)
+           (vector-set! v i (f i))
+           (loop (- i 1))))
+       v))
+    ((f len seed)
+     (assert-procedure f 'vector-unfold-right)
+     (assert-nonneg-exact-integer len 'vector-unfold-right)
+     (let ((v (make-vector len)))
+       (let loop ((i (- len 1)) (seed seed))
+         (unless (negative? i)
+           (receive (x seed) (f i seed)
+             (vector-set! v i x)
+             (loop (- i 1) seed))))
+       v))
+    ((f len seed1 seed2)
+     (assert-procedure f 'vector-unfold-right)
+     (assert-nonneg-exact-integer len 'vector-unfold-right)
+     (let ((v (make-vector len)))
+       (let loop ((i (- len 1)) (seed1 seed1) (seed2 seed2))
+         (unless (negative? i)
+           (receive (x seed1 seed2) (f i seed1 seed2)
+             (vector-set! v i x)
+             (loop (- i 1) seed1 seed2))))
+       v))
+    ((f len . seeds)
+     (assert-procedure f 'vector-unfold-right)
+     (assert-nonneg-exact-integer len 'vector-unfold-right)
+     (let ((v (make-vector len)))
+       (let loop ((i (- len 1)) (seeds seeds))
+         (unless (negative? i)
+           (receive (x . seeds) (apply f i seeds)
+             (vector-set! v i x)
+             (loop (- i 1) seeds))))
+       v))))
+
+(define guile-vector-copy (@ (guile) vector-copy))
+
+;; TODO: Enhance Guile core 'vector-copy' to do this.
+(define vector-copy
+  (case-lambda*
+   "(vector-copy vec [start [end [fill]]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec starting at index START
+and stopping at index END.  START defaults to 0 and END defaults to
+the value of (vector-length VEC).  If END extends beyond the length of
+VEC, the slots in the new vector that obviously cannot be filled by
+elements from VEC are filled with FILL, whose default value is
+unspecified."
+   ((v) (guile-vector-copy v))
+   ((v start)
+    (assert-vector v 'vector-copy)
+    (let ((len (vector-length v)))
+      (assert-valid-start start len 'vector-copy)
+      (let ((result (make-vector (- len start))))
+        (vector-move-left! v start len result 0)
+        result)))
+   ((v start end #\optional (fill *unspecified*))
+    (assert-vector v 'vector-copy)
+    (let ((len (vector-length v)))
+      (unless (and (exact-integer? start)
+                   (exact-integer? end)
+                   (<= 0 start end))
+        (error-from 'vector-copy "invalid index range" start end))
+      (let ((result (make-vector (- end start) fill)))
+        (vector-move-left! v start (min end len) result 0)
+        result)))))
+
+(define vector-reverse-copy
+  (let ()
+    (define (%vector-reverse-copy vec start end)
+      (let* ((len (- end start))
+             (result (make-vector len)))
+        (let loop ((i 0) (j (- end 1)))
+          (unless (= i len)
+            (vector-set! result i (vector-ref vec j))
+            (loop (+ i 1) (- j 1))))
+        result))
+    (case-lambda
+      "(vector-reverse-copy vec [start [end]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec in reverse order starting
+at index START and stopping at index END.  START defaults to 0 and END
+defaults to the value of (vector-length VEC)."
+      ((vec)
+       (assert-vector vec 'vector-reverse-copy)
+       (%vector-reverse-copy vec 0 (vector-length vec)))
+      ((vec start)
+       (assert-vector vec 'vector-reverse-copy)
+       (let ((len (vector-length vec)))
+         (assert-valid-start start len 'vector-reverse-copy)
+         (%vector-reverse-copy vec start len)))
+      ((vec start end)
+       (assert-vector vec 'vector-reverse-copy)
+       (let ((len (vector-length vec)))
+         (assert-valid-range start end len 'vector-reverse-copy)
+         (%vector-reverse-copy vec start end))))))
+
+(define (%vector-concatenate vs)
+  (let* ((result-len (let loop ((vs vs) (len 0))
+                       (if (null? vs)
+                           len
+                           (loop (cdr vs) (+ len (vector-length (car vs)))))))
+         (result (make-vector result-len)))
+    (let loop ((vs vs) (pos 0))
+      (unless (null? vs)
+        (let* ((v (car vs))
+               (len (vector-length v)))
+          (vector-move-left! v 0 len result pos)
+          (loop (cdr vs) (+ pos len)))))
+    result))
+
+(define vector-append
+  (case-lambda
+    "(vector-append vec ...) -> vector
+
+Return a newly allocated vector that contains all elements in order
+from the subsequent locations in VEC ..."
+    (() (vector))
+    ((v)
+     (assert-vector v 'vector-append)
+     (guile-vector-copy v))
+    ((v1 v2)
+     (assert-vector v1 'vector-append)
+     (assert-vector v2 'vector-append)
+     (let ((len1 (vector-length v1))
+           (len2 (vector-length v2)))
+       (let ((result (make-vector (+ len1 len2))))
+         (vector-move-left! v1 0 len1 result 0)
+         (vector-move-left! v2 0 len2 result len1)
+         result)))
+    (vs
+     (assert-vectors vs 'vector-append)
+     (%vector-concatenate vs))))
+
+(define (vector-concatenate vs)
+  "(vector-concatenate list-of-vectors) -> vector
+
+Append each vector in LIST-OF-VECTORS.  Equivalent to:
+  (apply vector-append LIST-OF-VECTORS)"
+  (assert-vectors vs 'vector-concatenate)
+  (%vector-concatenate vs))
+
+(define (vector-empty? vec)
+  "(vector-empty? vec) -> boolean
+
+Return true if VEC is empty, i.e. its length is 0, and false if not."
+  (assert-vector vec 'vector-empty?)
+  (zero? (vector-length vec)))
+
+(define vector=
+  (let ()
+    (define (all-of-length? len vs)
+      (or (null? vs)
+          (and (= len (vector-length (car vs)))
+               (all-of-length? len (cdr vs)))))
+    (define (=up-to? i elt=? v1 v2)
+      (or (negative? i)
+          (let ((x1 (vector-ref v1 i))
+                (x2 (vector-ref v2 i)))
+            (and (or (eq? x1 x2) (elt=? x1 x2))
+                 (=up-to? (- i 1) elt=? v1 v2)))))
+    (case-lambda
+      "(vector= elt=? vec ...) -> boolean
+
+Return true if the vectors VEC ... have equal lengths and equal
+elements according to ELT=?.  ELT=? is always applied to two
+arguments.  Element comparison must be consistent with eq?, in the
+following sense: if (eq? a b) returns true, then (elt=? a b) must also
+return true.  The order in which comparisons are performed is
+unspecified."
+      ((elt=?)
+       (assert-procedure elt=? 'vector=)
+       #t)
+      ((elt=? v)
+       (assert-procedure elt=? 'vector=)
+       (assert-vector v 'vector=)
+       #t)
+      ((elt=? v1 v2)
+       (assert-procedure elt=? 'vector=)
+       (assert-vector v1 'vector=)
+       (assert-vector v2 'vector=)
+       (let ((len (vector-length v1)))
+         (and (= len (vector-length v2))
+              (=up-to? (- len 1) elt=? v1 v2))))
+      ((elt=? v1 . vs)
+       (assert-procedure elt=? 'vector=)
+       (assert-vector  v1 'vector=)
+       (assert-vectors vs 'vector=)
+       (let ((len (vector-length v1)))
+         (and (all-of-length? len vs)
+              (let loop ((vs vs))
+                (or (null? vs)
+                    (and (=up-to? (- len 1) elt=? v1 (car vs))
+                         (loop (cdr vs)))))))))))
+
+(define vector-fold
+  (case-lambda
+    "(vector-fold kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator.  KONS is iterated over each index in
+all of the vectors, stopping at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration.  The iteration is strictly
+left-to-right."
+    ((kcons knil v)
+     (assert-procedure kcons 'vector-fold)
+     (assert-vector v 'vector-fold)
+     (let ((len (vector-length v)))
+       (let loop ((i 0) (state knil))
+         (if (= i len)
+             state
+             (loop (+ i 1) (kcons i state (vector-ref v i)))))))
+    ((kcons knil v1 v2)
+     (assert-procedure kcons 'vector-fold)
+     (assert-vector v1 'vector-fold)
+     (assert-vector v2 'vector-fold)
+     (let ((len (min (vector-length v1) (vector-length v2))))
+       (let loop ((i 0) (state knil))
+         (if (= i len)
+             state
+             (loop (+ i 1)
+                   (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+    ((kcons knil . vs)
+     (assert-procedure kcons 'vector-fold)
+     (assert-vectors vs 'vector-fold)
+     (let ((len (min-length vs)))
+       (let loop ((i 0) (state knil))
+         (if (= i len)
+             state
+             (loop (+ i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-fold-right
+  (case-lambda
+    "(vector-fold-right kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator.  KONS is iterated over each index in
+all of the vectors, starting at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration.  The iteration is strictly
+right-to-left."
+    ((kcons knil v)
+     (assert-procedure kcons 'vector-fold-right)
+     (assert-vector v 'vector-fold-right)
+     (let ((len (vector-length v)))
+       (let loop ((i (- len 1)) (state knil))
+         (if (negative? i)
+             state
+             (loop (- i 1) (kcons i state (vector-ref v i)))))))
+    ((kcons knil v1 v2)
+     (assert-procedure kcons 'vector-fold-right)
+     (assert-vector v1 'vector-fold-right)
+     (assert-vector v2 'vector-fold-right)
+     (let ((len (min (vector-length v1) (vector-length v2))))
+       (let loop ((i (- len 1)) (state knil))
+         (if (negative? i)
+             state
+             (loop (- i 1)
+                   (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+    ((kcons knil . vs)
+     (assert-procedure kcons 'vector-fold-right)
+     (assert-vectors vs 'vector-fold-right)
+     (let ((len (min-length vs)))
+       (let loop ((i (- len 1)) (state knil))
+         (if (negative? i)
+             state
+             (loop (- i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-map
+  (case-lambda
+    "(vector-map f vec2 vec2 ...) -> vector
+
+Return a new vector of the shortest size of the vector arguments.
+Each element at index i of the new vector is mapped from the old
+vectors by (F i (vector-ref VEC1 i) (vector-ref VEC2 i) ...).  The
+dynamic order of application of F is unspecified."
+    ((f v)
+     (assert-procedure f 'vector-map)
+     (assert-vector v 'vector-map)
+     (let* ((len (vector-length v))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result i (f i (vector-ref v i)))
+           (loop (+ i 1))))
+       result))
+    ((f v1 v2)
+     (assert-procedure f 'vector-map)
+     (assert-vector v1 'vector-map)
+     (assert-vector v2 'vector-map)
+     (let* ((len (min (vector-length v1) (vector-length v2)))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i)))
+           (loop (+ i 1))))
+       result))
+    ((f . vs)
+     (assert-procedure f 'vector-map)
+     (assert-vectors vs 'vector-map)
+     (let* ((len (min-length vs))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result i (apply f i (vectors-ref vs i)))
+           (loop (+ i 1))))
+       result))))
+
+(define vector-map!
+  (case-lambda
+    "(vector-map! f vec2 vec2 ...) -> unspecified
+
+Similar to vector-map, but rather than mapping the new elements into a
+new vector, the new mapped elements are destructively inserted into
+VEC1.  The dynamic order of application of F is unspecified."
+    ((f v)
+     (assert-procedure f 'vector-map!)
+     (assert-vector v 'vector-map!)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! v i (f i (vector-ref v i)))
+           (loop (+ i 1))))))
+    ((f v1 v2)
+     (assert-procedure f 'vector-map!)
+     (assert-vector v1 'vector-map!)
+     (assert-vector v2 'vector-map!)
+     (let ((len (min (vector-length v1) (vector-length v2))))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i)))
+           (loop (+ i 1))))))
+    ((f . vs)
+     (assert-procedure f 'vector-map!)
+     (assert-vectors vs 'vector-map!)
+     (let ((len (min-length vs))
+           (v1 (car vs)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! v1 i (apply f i (vectors-ref vs i)))
+           (loop (+ i 1))))))))
+
+(define vector-for-each
+  (case-lambda
+    "(vector-for-each f vec1 vec2 ...) -> unspecified
+
+Call (F i VEC1[i] VEC2[i] ...) for each index i less than the length
+of the shortest vector passed.  The iteration is strictly
+left-to-right."
+    ((f v)
+     (assert-procedure f 'vector-for-each)
+     (assert-vector v 'vector-for-each)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f i (vector-ref v i))
+           (loop (+ i 1))))))
+    ((f v1 v2)
+     (assert-procedure f 'vector-for-each)
+     (assert-vector v1 'vector-for-each)
+     (assert-vector v2 'vector-for-each)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f i (vector-ref v1 i) (vector-ref v2 i))
+           (loop (+ i 1))))))
+    ((f . vs)
+     (assert-procedure f 'vector-for-each)
+     (assert-vectors vs 'vector-for-each)
+     (let ((len (min-length vs)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (apply f i (vectors-ref vs i))
+           (loop (+ i 1))))))))
+
+(define vector-count
+  (case-lambda
+    "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer
+
+Count the number of indices i for which (PRED? VEC1[i] VEC2[i] ...)
+returns true, where i is less than the length of the shortest vector
+passed."
+    ((pred? v)
+     (assert-procedure pred? 'vector-count)
+     (assert-vector v 'vector-count)
+     (let ((len (vector-length v)))
+       (let loop ((i 0) (count 0))
+         (cond ((= i len) count)
+               ((pred? i (vector-ref v i))
+                (loop (+ i 1) (+ count 1)))
+               (else
+                (loop (+ i 1) count))))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-count)
+     (assert-vector v1 'vector-count)
+     (assert-vector v2 'vector-count)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i 0) (count 0))
+         (cond ((= i len) count)
+               ((pred? i (vector-ref v1 i) (vector-ref v2 i))
+                (loop (+ i 1) (+ count 1)))
+               (else
+                (loop (+ i 1) count))))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-count)
+     (assert-vectors vs 'vector-count)
+     (let ((len (min-length vs)))
+       (let loop ((i 0) (count 0))
+         (cond ((= i len) count)
+               ((apply pred? i (vectors-ref vs i))
+                (loop (+ i 1) (+ count 1)))
+               (else
+                (loop (+ i 1) count))))))))
+
+(define vector-index
+  (case-lambda
+    "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+satisfy PRED?.  If no matching element is found by the end of the
+shortest vector, return #f."
+    ((pred? v)
+     (assert-procedure pred? 'vector-index)
+     (assert-vector v 'vector-index)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (pred? (vector-ref v i))
+                  i
+                  (loop (+ i 1)))))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-index)
+     (assert-vector v1 'vector-index)
+     (assert-vector v2 'vector-index)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (pred? (vector-ref v1 i)
+                         (vector-ref v2 i))
+                  i
+                  (loop (+ i 1)))))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-index)
+     (assert-vectors vs 'vector-index)
+     (let ((len (min-length vs)))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (apply pred? (vectors-ref vs i))
+                  i
+                  (loop (+ i 1)))))))))
+
+(define vector-index-right
+  (case-lambda
+    "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+satisfy PRED?, searching from right-to-left.  If no matching element
+is found before the end of the shortest vector, return #f."
+    ((pred? v)
+     (assert-procedure pred? 'vector-index-right)
+     (assert-vector v 'vector-index-right)
+     (let ((len (vector-length v)))
+       (let loop ((i (- len 1)))
+         (and (>= i 0)
+              (if (pred? (vector-ref v i))
+                  i
+                  (loop (- i 1)))))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-index-right)
+     (assert-vector v1 'vector-index-right)
+     (assert-vector v2 'vector-index-right)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i (- len 1)))
+         (and (>= i 0)
+              (if (pred? (vector-ref v1 i)
+                         (vector-ref v2 i))
+                  i
+                  (loop (- i 1)))))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-index-right)
+     (assert-vectors vs 'vector-index-right)
+     (let ((len (min-length vs)))
+       (let loop ((i (- len 1)))
+         (and (>= i 0)
+              (if (apply pred? (vectors-ref vs i))
+                  i
+                  (loop (- i 1)))))))))
+
+(define vector-skip
+  (case-lambda
+    "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+do not satisfy PRED?.  If no matching element is found by the end of
+the shortest vector, return #f."
+    ((pred? v)
+     (assert-procedure pred? 'vector-skip)
+     (assert-vector v 'vector-skip)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (pred? (vector-ref v i))
+                  (loop (+ i 1))
+                  i)))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-skip)
+     (assert-vector v1 'vector-skip)
+     (assert-vector v2 'vector-skip)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (pred? (vector-ref v1 i)
+                         (vector-ref v2 i))
+                  (loop (+ i 1))
+                  i)))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-skip)
+     (assert-vectors vs 'vector-skip)
+     (let ((len (min-length vs)))
+       (let loop ((i 0))
+         (and (< i len)
+              (if (apply pred? (vectors-ref vs i))
+                  (loop (+ i 1))
+                  i)))))))
+
+(define vector-skip-right
+  (case-lambda
+    "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+do not satisfy PRED?, searching from right-to-left.  If no matching
+element is found before the end of the shortest vector, return #f."
+    ((pred? v)
+     (assert-procedure pred? 'vector-skip-right)
+     (assert-vector v 'vector-skip-right)
+     (let ((len (vector-length v)))
+       (let loop ((i (- len 1)))
+         (and (not (negative? i))
+              (if (pred? (vector-ref v i))
+                  (loop (- i 1))
+                  i)))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-skip-right)
+     (assert-vector v1 'vector-skip-right)
+     (assert-vector v2 'vector-skip-right)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i (- len 1)))
+         (and (not (negative? i))
+              (if (pred? (vector-ref v1 i)
+                         (vector-ref v2 i))
+                  (loop (- i 1))
+                  i)))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-skip-right)
+     (assert-vectors vs 'vector-skip-right)
+     (let ((len (min-length vs)))
+       (let loop ((i (- len 1)))
+         (and (not (negative? i))
+              (if (apply pred? (vectors-ref vs i))
+                  (loop (- i 1))
+                  i)))))))
+
+(define vector-binary-search
+  (let ()
+    (define (%vector-binary-search vec value cmp start end)
+      (let loop ((lo start) (hi end))
+        (and (< lo hi)
+             (let* ((i (quotient (+ lo hi) 2))
+                    (x (vector-ref vec i))
+                    (c (cmp x value)))
+               (cond ((zero? c) i)
+                     ((positive? c) (loop lo i))
+                     ((negative? c) (loop (+ i 1) hi)))))))
+    (case-lambda
+      "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative integer or #f
+
+Find and return an index of VEC between START and END whose value is
+VALUE using a binary search.  If no matching element is found, return
+#f.  The default START is 0 and the default END is the length of VEC.
+CMP must be a procedure of two arguments such that (CMP A B) returns
+a negative integer if A < B, a positive integer if A > B, or zero if
+A = B.  The elements of VEC must be sorted in non-decreasing order
+according to CMP."
+      ((vec value cmp)
+       (assert-vector vec 'vector-binary-search)
+       (assert-procedure cmp 'vector-binary-search)
+       (%vector-binary-search vec value cmp 0 (vector-length vec)))
+
+      ((vec value cmp start)
+       (assert-vector vec 'vector-binary-search)
+       (let ((len (vector-length vec)))
+         (assert-valid-start start len 'vector-binary-search)
+         (%vector-binary-search vec value cmp start len)))
+
+      ((vec value cmp start end)
+       (assert-vector vec 'vector-binary-search)
+       (let ((len (vector-length vec)))
+         (assert-valid-range start end len 'vector-binary-search)
+         (%vector-binary-search vec value cmp start end))))))
+
+(define vector-any
+  (case-lambda
+    "(vector-any pred? vec1 vec2 ...) -> value or #f
+
+Find the first parallel set of elements from VEC1 VEC2 ... for which
+PRED? returns a true value.  If such a parallel set of elements
+exists, vector-any returns the value that PRED? returned for that set
+of elements.  The iteration is strictly left-to-right."
+    ((pred? v)
+     (assert-procedure pred? 'vector-any)
+     (assert-vector v 'vector-any)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (and (< i len)
+              (or (pred? (vector-ref v i))
+                  (loop (+ i 1)))))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-any)
+     (assert-vector v1 'vector-any)
+     (assert-vector v2 'vector-any)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (let loop ((i 0))
+         (and (< i len)
+              (or (pred? (vector-ref v1 i)
+                         (vector-ref v2 i))
+                  (loop (+ i 1)))))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-any)
+     (assert-vectors vs 'vector-any)
+     (let ((len (min-length vs)))
+       (let loop ((i 0))
+         (and (< i len)
+              (or (apply pred? (vectors-ref vs i))
+                  (loop (+ i 1)))))))))
+
+(define vector-every
+  (case-lambda
+    "(vector-every pred? vec1 vec2 ...) -> value or #f
+
+If, for every index i less than the length of the shortest vector
+argument, the set of elements VEC1[i] VEC2[i] ... satisfies PRED?,
+vector-every returns the value that PRED? returned for the last set of
+elements, at the last index of the shortest vector.  The iteration is
+strictly left-to-right."
+    ((pred? v)
+     (assert-procedure pred? 'vector-every)
+     (assert-vector v 'vector-every)
+     (let ((len (vector-length v)))
+       (or (zero? len)
+           (let loop ((i 0))
+             (let ((val (pred? (vector-ref v i)))
+                   (next-i (+ i 1)))
+               (if (or (not val) (= next-i len))
+                   val
+                   (loop next-i)))))))
+    ((pred? v1 v2)
+     (assert-procedure pred? 'vector-every)
+     (assert-vector v1 'vector-every)
+     (assert-vector v2 'vector-every)
+     (let ((len (min (vector-length v1)
+                     (vector-length v2))))
+       (or (zero? len)
+           (let loop ((i 0))
+             (let ((val (pred? (vector-ref v1 i)
+                               (vector-ref v2 i)))
+                   (next-i (+ i 1)))
+               (if (or (not val) (= next-i len))
+                   val
+                   (loop next-i)))))))
+    ((pred? . vs)
+     (assert-procedure pred? 'vector-every)
+     (assert-vectors vs 'vector-every)
+     (let ((len (min-length vs)))
+       (or (zero? len)
+           (let loop ((i 0))
+             (let ((val (apply pred? (vectors-ref vs i)))
+                   (next-i (+ i 1)))
+               (if (or (not val) (= next-i len))
+                   val
+                   (loop next-i)))))))))
+
+(define (vector-swap! vec i j)
+  "(vector-swap! vec i j) -> unspecified
+
+Swap the values of the locations in VEC at I and J."
+  (assert-vector vec 'vector-swap!)
+  (let ((len (vector-length vec)))
+    (assert-valid-index i len 'vector-swap!)
+    (assert-valid-index j len 'vector-swap!)
+    (let ((tmp (vector-ref vec i)))
+      (vector-set! vec i (vector-ref vec j))
+      (vector-set! vec j tmp))))
+
+;; TODO: Enhance Guile core 'vector-fill!' to do this.
+(define vector-fill!
+  (let ()
+    (define guile-vector-fill!
+      (@ (guile) vector-fill!))
+    (define (%vector-fill! vec fill start end)
+      (let loop ((i start))
+        (when (< i end)
+          (vector-set! vec i fill)
+          (loop (+ i 1)))))
+    (case-lambda
+      "(vector-fill! vec fill [start [end]]) -> unspecified
+
+Assign the value of every location in VEC between START and END to
+FILL.  START defaults to 0 and END defaults to the length of VEC."
+      ((vec fill)
+       (guile-vector-fill! vec fill))
+      ((vec fill start)
+       (assert-vector vec 'vector-fill!)
+       (let ((len (vector-length vec)))
+         (assert-valid-start start len 'vector-fill!)
+         (%vector-fill! vec fill start len)))
+      ((vec fill start end)
+       (assert-vector vec 'vector-fill!)
+       (let ((len (vector-length vec)))
+         (assert-valid-range start end len 'vector-fill!)
+         (%vector-fill! vec fill start end))))))
+
+(define (%vector-reverse! vec start end)
+  (let loop ((i start) (j (- end 1)))
+    (when (< i j)
+      (let ((tmp (vector-ref vec i)))
+        (vector-set! vec i (vector-ref vec j))
+        (vector-set! vec j tmp)
+        (loop (+ i 1) (- j 1))))))
+
+(define vector-reverse!
+  (case-lambda
+    "(vector-reverse! vec [start [end]]) -> unspecified
+
+Destructively reverse the contents of VEC between START and END.
+START defaults to 0 and END defaults to the length of VEC."
+    ((vec)
+     (assert-vector vec 'vector-reverse!)
+     (%vector-reverse! vec 0 (vector-length vec)))
+    ((vec start)
+     (assert-vector vec 'vector-reverse!)
+     (let ((len (vector-length vec)))
+       (assert-valid-start start len 'vector-reverse!)
+       (%vector-reverse! vec start len)))
+    ((vec start end)
+     (assert-vector vec 'vector-reverse!)
+     (let ((len (vector-length vec)))
+       (assert-valid-range start end len 'vector-reverse!)
+       (%vector-reverse! vec start end)))))
+
+(define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
+  (define copy!
+    (let ((%copy! inner-proc))
+      (case-lambda
+        docstring
+        ((target tstart source)
+         (assert-vector target 'copy!)
+         (assert-vector source 'copy!)
+         (let ((tlen (vector-length target))
+               (slen (vector-length source)))
+           (assert-valid-start tstart tlen 'copy!)
+           (unless (>= tlen (+ tstart slen))
+             (error-from 'copy! "would write past end of target"))
+           (%copy! target tstart source 0 slen)))
+
+        ((target tstart source sstart)
+         (assert-vector target 'copy!)
+         (assert-vector source 'copy!)
+         (let ((tlen (vector-length target))
+               (slen (vector-length source)))
+           (assert-valid-start tstart tlen 'copy!)
+           (assert-valid-start sstart slen 'copy!)
+           (unless (>= tlen (+ tstart (- slen sstart)))
+             (error-from 'copy! "would write past end of target"))
+           (%copy! target tstart source sstart slen)))
+
+        ((target tstart source sstart send)
+         (assert-vector target 'copy!)
+         (assert-vector source 'copy!)
+         (let ((tlen (vector-length target))
+               (slen (vector-length source)))
+           (assert-valid-start tstart tlen 'copy!)
+           (assert-valid-range sstart send slen 'copy!)
+           (unless (>= tlen (+ tstart (- send sstart)))
+             (error-from 'copy! "would write past end of target"))
+           (%copy! target tstart source sstart send)))))))
+
+(define-vector-copier! vector-copy!
+  "(vector-copy! target tstart source [sstart [send]]) -> unspecified
+
+Copy a block of elements from SOURCE to TARGET, both of which must be
+vectors, starting in TARGET at TSTART and starting in SOURCE at
+SSTART, ending when SEND - SSTART elements have been copied.  It is an
+error for TARGET to have a length less than TSTART + (SEND - SSTART).
+SSTART defaults to 0 and SEND defaults to the length of SOURCE."
+  (lambda (target tstart source sstart send)
+    (if (< tstart sstart)
+        (vector-move-left!  source sstart send target tstart)
+        (vector-move-right! source sstart send target tstart))))
+
+(define-vector-copier! vector-reverse-copy!
+  "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
+
+Like vector-copy!, but copy the elements in the reverse order.  It is
+an error if TARGET and SOURCE are identical vectors and the TARGET and
+SOURCE ranges overlap; however, if TSTART = SSTART,
+vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND)
+would."
+  (lambda (target tstart source sstart send)
+    (if (and (eq? target source) (= tstart sstart))
+        (%vector-reverse! target sstart send)
+        (let loop ((i tstart) (j (- send 1)))
+          (when (>= j sstart)
+            (vector-set! target i (vector-ref source j))
+            (loop (+ i 1) (- j 1)))))))
+
+(define vector->list
+  (let ()
+    (define (%vector->list vec start end)
+      (let loop ((i (- end 1))
+                 (result '()))
+        (if (< i start)
+            result
+            (loop (- i 1) (cons (vector-ref vec i) result)))))
+    (case-lambda
+      "(vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END.  START defaults to 0 and END defaults to the length of
+VEC."
+      ((vec)
+       (assert-vector vec 'vector->list)
+       (%vector->list vec 0 (vector-length vec)))
+      ((vec start)
+       (assert-vector vec 'vector->list)
+       (let ((len (vector-length vec)))
+         (assert-valid-start start len 'vector->list)
+         (%vector->list vec start len)))
+      ((vec start end)
+       (assert-vector vec 'vector->list)
+       (let ((len (vector-length vec)))
+         (assert-valid-range start end len 'vector->list)
+         (%vector->list vec start end))))))
+
+(define reverse-vector->list
+  (let ()
+    (define (%reverse-vector->list vec start end)
+      (let loop ((i start)
+                 (result '()))
+        (if (>= i end)
+            result
+            (loop (+ i 1) (cons (vector-ref vec i) result)))))
+    (case-lambda
+      "(reverse-vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END in reverse order.  START defaults to 0 and END defaults
+to the length of VEC."
+      ((vec)
+       (assert-vector vec 'reverse-vector->list)
+       (%reverse-vector->list vec 0 (vector-length vec)))
+      ((vec start)
+       (assert-vector vec 'reverse-vector->list)
+       (let ((len (vector-length vec)))
+         (assert-valid-start start len 'reverse-vector->list)
+         (%reverse-vector->list vec start len)))
+      ((vec start end)
+       (assert-vector vec 'reverse-vector->list)
+       (let ((len (vector-length vec)))
+         (assert-valid-range start end len 'reverse-vector->list)
+         (%reverse-vector->list vec start end))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (list->vector lst #\optional (start 0) (end (length lst)))
+  "(list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END.  START defaults to 0 and END defaults
+to the length of PROPER-LIST."
+  (let* ((len (- end start))
+         (result (make-vector len)))
+    (let loop ((i 0) (lst (drop lst start)))
+      (if (= i len)
+          result
+          (begin (vector-set! result i (car lst))
+                 (loop (+ i 1) (cdr lst)))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (reverse-list->vector lst #\optional (start 0) (end (length lst)))
+  "(reverse-list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END, in reverse order.  START defaults to 0
+and END defaults to the length of PROPER-LIST."
+  (let* ((len (- end start))
+         (result (make-vector len)))
+    (let loop ((i (- len 1)) (lst (drop lst start)))
+      (if (negative? i)
+          result
+          (begin (vector-set! result i (car lst))
+                 (loop (- i 1) (cdr lst)))))))
+;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
+
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; 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.
+
+;;; Commentary:
+
+;; This is the code of the reference implementation of SRFI-45, modified
+;; to use SRFI-9 and to add 'promise?' to the list of exports.
+
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-45)
+  #\export (delay
+             lazy
+             force
+             eager
+             promise?)
+  #\replace (delay force promise?)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu))
+
+(cond-expand-provide (current-module) '(srfi-45))
+
+(define-record-type promise (make-promise val) promise?
+  (val promise-val promise-val-set!))
+
+(define-record-type value (make-value tag proc) value?
+  (tag value-tag value-tag-set!)
+  (proc value-proc value-proc-set!))
+
+(define-syntax-rule (lazy exp)
+  (make-promise (make-value 'lazy (lambda () exp))))
+
+(define (eager x)
+  (make-promise (make-value 'eager x)))
+
+(define-syntax-rule (delay exp)
+  (lazy (eager exp)))
+
+(define (force promise)
+  (let ((content (promise-val promise)))
+    (case (value-tag content)
+      ((eager) (value-proc content))
+      ((lazy)  (let* ((promise* ((value-proc content)))
+                      (content  (promise-val promise)))        ; *
+                 (if (not (eqv? (value-tag content) 'eager))   ; *
+                     (begin (value-tag-set! content
+                                            (value-tag (promise-val promise*)))
+                            (value-proc-set! content
+                                             (value-proc (promise-val promise*)))
+                            (promise-val-set! promise* content)))
+                 (force promise))))))
+
+;; (*) These two lines re-fetch and check the original promise in case
+;;     the first line of the let* caused it to be forced.  For an example
+;;     where this happens, see reentrancy test 3 below.
+
+(define* (promise-visit promise #\key on-eager on-lazy)
+  (define content (promise-val promise))
+  (case (value-tag content)
+    ((eager) (on-eager (value-proc content)))
+    ((lazy)  (on-lazy (value-proc content)))))
+
+(set-record-type-printer! promise
+  (lambda (promise port)
+    (promise-visit promise
+      #\on-eager (lambda (value)
+                   (format port "#<promise = ~s>" value))
+      #\on-lazy  (lambda (proc)
+                   (format port "#<promise => ~s>" proc)))))
+;;; srfi-6.scm --- Basic String Ports
+
+;; 	Copyright (C) 2001, 2002, 2003, 2006, 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:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-6)
+  #\replace (open-input-string open-output-string)
+  #\re-export (get-output-string))
+
+;; SRFI-6 says nothing about encodings, and assumes that any character
+;; or string can be written to a string port.  Thus, make all SRFI-6
+;; string ports Unicode capable.  See <http://bugs.gnu.org/11197>.
+
+(define (open-input-string s)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-input-string) s)))
+
+(define (open-output-string)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-output-string))))
+
+(cond-expand-provide (current-module) '(srfi-6))
+
+;;; srfi-6.scm ends here
+;;; srfi-60.scm --- Integers as Bits
+
+;; Copyright (C) 2005, 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 (srfi srfi-60)
+  #\export (bitwise-and
+	    bitwise-ior
+	    bitwise-xor
+	    bitwise-not
+	    any-bits-set?
+	    bitwise-if bitwise-merge
+	    log2-binary-factors first-set-bit
+	    bit-set?
+	    copy-bit
+	    bit-field
+	    copy-bit-field
+	    arithmetic-shift
+	    rotate-bit-field
+	    reverse-bit-field
+	    integer->list
+	    list->integer
+	    booleans->integer)
+  #\replace (bit-count)
+  #\re-export (logand
+	       logior
+	       logxor
+	       integer-length
+	       logtest
+	       logcount
+	       logbit?
+	       ash))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_srfi_60")
+
+(define bitwise-and logand)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-not lognot)
+(define any-bits-set? logtest)
+(define bit-count logcount)
+
+(define (bitwise-if mask n0 n1)
+  (logior (logand mask n0)
+          (logand (lognot mask) n1)))
+(define bitwise-merge bitwise-if)
+
+(define first-set-bit log2-binary-factors)
+(define bit-set? logbit?)
+(define bit-field bit-extract)
+
+(define (copy-bit-field n newbits start end)
+  (logxor n (ash (logxor (bit-extract n start end)              ;; cancel old
+			 (bit-extract newbits 0 (- end start))) ;; insert new
+		 start)))
+
+(define arithmetic-shift ash)
+
+(cond-expand-provide (current-module) '(srfi-60))
+;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
+
+;;      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, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-64)
+  #\export
+  (test-begin
+   test-end test-assert test-eqv test-eq test-equal
+   test-approximate test-assert test-error test-apply test-with-runner
+   test-match-nth test-match-all test-match-any test-match-name
+   test-skip test-expect-fail test-read-eval-string
+   test-runner-group-path test-group test-group-with-cleanup
+   test-result-ref test-result-set! test-result-clear test-result-remove
+   test-result-kind test-passed?
+   test-log-to-file
+   test-runner? test-runner-reset test-runner-null
+   test-runner-simple test-runner-current test-runner-factory test-runner-get
+   test-runner-create test-runner-test-name
+   test-runner-pass-count test-runner-pass-count!
+   test-runner-fail-count test-runner-fail-count!
+   test-runner-xpass-count test-runner-xpass-count!
+   test-runner-xfail-count test-runner-xfail-count!
+   test-runner-skip-count test-runner-skip-count!
+   test-runner-group-stack test-runner-group-stack!
+   test-runner-on-test-begin test-runner-on-test-begin!
+   test-runner-on-test-end test-runner-on-test-end!
+   test-runner-on-group-begin test-runner-on-group-begin!
+   test-runner-on-group-end test-runner-on-group-end!
+   test-runner-on-final test-runner-on-final!
+   test-runner-on-bad-count test-runner-on-bad-count!
+   test-runner-on-bad-end-name test-runner-on-bad-end-name!
+   test-result-alist test-result-alist!
+   test-runner-aux-value test-runner-aux-value!
+   test-on-group-begin-simple test-on-group-end-simple
+   test-on-bad-count-simple test-on-bad-end-name-simple
+   test-on-final-simple test-on-test-end-simple
+   test-on-final-simple))
+
+(cond-expand-provide (current-module) '(srfi-64))
+
+(include-from-path "srfi/srfi-64/testing.scm")
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;;
+;; 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.
+
+(cond-expand
+ (chicken
+  (require-extension syntax-case))
+ (guile-2
+  (use-modules (srfi srfi-9)
+               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
+               ;; with either Guile's native exceptions or R6RS exceptions.
+               ;;(srfi srfi-34) (srfi srfi-35)
+               (srfi srfi-39)))
+ (guile
+  (use-modules (ice-9 syncase) (srfi srfi-9)
+	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
+	       (srfi srfi-39)))
+ (sisc
+  (require-extension (srfi 9 34 35 39)))
+ (kawa
+  (module-compile-options warn-undefined-variable\: #t
+			  warn-invoke-unknown-method\: #t)
+  (provide 'srfi-64)
+  (provide 'testing)
+  (require 'srfi-34)
+  (require 'srfi-35))
+ (else ()
+  ))
+
+(cond-expand
+ (kawa
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export test-begin . other-names)
+       (module-export %test-begin . other-names)))))
+ (else
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export . names) (if #f #f))))))
+
+;; List of exported names
+(%test-export
+ test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
+ test-end test-assert test-eqv test-eq test-equal
+ test-approximate test-assert test-error test-apply test-with-runner
+ test-match-nth test-match-all test-match-any test-match-name
+ test-skip test-expect-fail test-read-eval-string
+ test-runner-group-path test-group test-group-with-cleanup
+ test-result-ref test-result-set! test-result-clear test-result-remove
+ test-result-kind test-passed?
+ test-log-to-file
+ ; Misc test-runner functions
+ test-runner? test-runner-reset test-runner-null
+ test-runner-simple test-runner-current test-runner-factory test-runner-get
+ test-runner-create test-runner-test-name
+ ;; test-runner field setter and getter functions - see %test-record-define:
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+ test-result-alist test-result-alist!
+ test-runner-aux-value test-runner-aux-value!
+ ;; default/simple call-back functions, used in default test-runner,
+ ;; but can be called to construct more complex ones.
+ test-on-group-begin-simple test-on-group-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ test-on-final-simple test-on-test-end-simple
+ test-on-final-simple)
+
+(cond-expand
+ (srfi-9
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index setter getter) ...)
+       (define-record-type test-runner
+	 (alloc)
+	 runner?
+	 (name setter getter) ...)))))
+ (else
+  (define %test-runner-cookie (list "test-runner"))
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index getter setter) ...)
+       (begin
+	 (define (runner? obj)
+	   (and (vector? obj)
+		(> (vector-length obj) 1)
+		(eq (vector-ref obj 0) %test-runner-cookie)))
+	 (define (alloc)
+	   (let ((runner (make-vector 23)))
+	     (vector-set! runner 0 %test-runner-cookie)
+	     runner))
+	 (begin
+	   (define (getter runner)
+	     (vector-ref runner index)) ...)
+	 (begin
+	   (define (setter runner value)
+	     (vector-set! runner index value)) ...)))))))
+
+(%test-record-define
+ %test-runner-alloc test-runner?
+ ;; Cumulate count of all tests that have passed and were expected to.
+ (pass-count 1 test-runner-pass-count test-runner-pass-count!)
+ (fail-count 2 test-runner-fail-count test-runner-fail-count!)
+ (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count 5 test-runner-skip-count test-runner-skip-count!)
+ (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
+ ;; Normally #t, except when in a test-apply.
+ (run-list 8 %test-runner-run-list %test-runner-run-list!)
+ (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
+ (group-stack 11 test-runner-group-stack test-runner-group-stack!)
+ (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
+ ;; Call-back when entering a group. Takes (runner suite-name count).
+ (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
+ ;; Call-back when leaving a group.
+ (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
+ ;; Call-back when leaving the outermost group.
+ (on-final 16 test-runner-on-final test-runner-on-final!)
+ ;; Call-back when expected number of tests was wrong.
+ (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
+ ;; Call-back when name in test=end doesn't match test-begin.
+ (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ ;; Cumulate count of all tests that have been done.
+ (total-count 19 %test-runner-total-count %test-runner-total-count!)
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list 20 %test-runner-count-list %test-runner-count-list!)
+ (result-alist 21 test-result-alist test-result-alist!)
+ ;; Field can be used by test-runner for any purpose.
+ ;; test-runner-simple uses it for a log file.
+ (aux-value 22 test-runner-aux-value test-runner-aux-value!)
+)
+
+(define (test-runner-reset runner)
+  (test-result-alist! runner '())
+  (test-runner-pass-count! runner 0)
+  (test-runner-fail-count! runner 0)
+  (test-runner-xpass-count! runner 0)
+  (test-runner-xfail-count! runner 0)
+  (test-runner-skip-count! runner 0)
+  (%test-runner-total-count! runner 0)
+  (%test-runner-count-list! runner '())
+  (%test-runner-run-list! runner #t)
+  (%test-runner-skip-list! runner '())
+  (%test-runner-fail-list! runner '())
+  (%test-runner-skip-save! runner '())
+  (%test-runner-fail-save! runner '())
+  (test-runner-group-stack! runner '()))
+
+(define (test-runner-group-path runner)
+  (reverse (test-runner-group-stack runner)))
+
+(define (%test-null-callback runner) #f)
+
+(define (test-runner-null)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
+    (test-runner-on-group-end! runner %test-null-callback)
+    (test-runner-on-final! runner %test-null-callback)
+    (test-runner-on-test-begin! runner %test-null-callback)
+    (test-runner-on-test-end! runner %test-null-callback)
+    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
+    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
+    runner))
+
+;; Not part of the specification.  FIXME
+;; Controls whether a log file is generated.
+(define test-log-to-file #t)
+
+(define (test-runner-simple)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner test-on-group-begin-simple)
+    (test-runner-on-group-end! runner test-on-group-end-simple)
+    (test-runner-on-final! runner test-on-final-simple)
+    (test-runner-on-test-begin! runner test-on-test-begin-simple)
+    (test-runner-on-test-end! runner test-on-test-end-simple)
+    (test-runner-on-bad-count! runner test-on-bad-count-simple)
+    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+    runner))
+
+(cond-expand
+ (srfi-39
+  (define test-runner-current (make-parameter #f))
+  (define test-runner-factory (make-parameter test-runner-simple)))
+ (else
+  (define %test-runner-current #f)
+  (define-syntax test-runner-current
+    (syntax-rules ()
+      ((test-runner-current)
+       %test-runner-current)
+      ((test-runner-current runner)
+       (set! %test-runner-current runner))))
+  (define %test-runner-factory test-runner-simple)
+  (define-syntax test-runner-factory
+    (syntax-rules ()
+      ((test-runner-factory)
+       %test-runner-factory)
+      ((test-runner-factory runner)
+       (set! %test-runner-factory runner))))))
+
+;; A safer wrapper to test-runner-current.
+(define (test-runner-get)
+  (let ((r (test-runner-current)))
+    (if (not r)
+	(cond-expand
+	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
+	 (else #t)))
+    r))
+
+(define (%test-specifier-matches spec runner)
+  (spec runner))
+
+(define (test-runner-create)
+  ((test-runner-factory)))
+
+(define (%test-any-specifier-matches list runner)
+  (let ((result #f))
+    (let loop ((l list))
+      (cond ((null? l) result)
+	    (else
+	     (if (%test-specifier-matches (car l) runner)
+		 (set! result #t))
+	     (loop (cdr l)))))))
+
+;; Returns #f, #t, or 'xfail.
+(define (%test-should-execute runner)
+  (let ((run (%test-runner-run-list runner)))
+    (cond ((or
+	    (not (or (eqv? run #t)
+		     (%test-any-specifier-matches run runner)))
+	    (%test-any-specifier-matches
+	     (%test-runner-skip-list runner)
+	     runner))
+	    (test-result-set! runner 'result-kind 'skip)
+	    #f)
+	  ((%test-any-specifier-matches
+	    (%test-runner-fail-list runner)
+	    runner)
+	   (test-result-set! runner 'result-kind 'xfail)
+	   'xfail)
+	  (else #t))))
+
+(define (%test-begin suite-name count)
+  (if (not (test-runner-current))
+      (test-runner-current (test-runner-create)))
+  (let ((runner (test-runner-current)))
+    ((test-runner-on-group-begin runner) runner suite-name count)
+    (%test-runner-skip-save! runner
+			       (cons (%test-runner-skip-list runner)
+				     (%test-runner-skip-save runner)))
+    (%test-runner-fail-save! runner
+			       (cons (%test-runner-fail-list runner)
+				     (%test-runner-fail-save runner)))
+    (%test-runner-count-list! runner
+			     (cons (cons (%test-runner-total-count runner)
+					 count)
+				   (%test-runner-count-list runner)))
+    (test-runner-group-stack! runner (cons suite-name
+					(test-runner-group-stack runner)))))
+(cond-expand
+ (kawa
+  ;; Kawa has test-begin built in, implemented as:
+  ;; (begin
+  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
+  ;;   (%test-begin suite-name [count]))
+  ;; This puts test-begin but only test-begin in the default environment.,
+  ;; which makes normal test suites loadable without non-portable commands.
+  )
+ (else
+  (define-syntax test-begin
+    (syntax-rules ()
+      ((test-begin suite-name)
+       (%test-begin suite-name #f))
+      ((test-begin suite-name count)
+       (%test-begin suite-name count))))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+  (if (null? (test-runner-group-stack runner))
+      (begin
+	(display "%%%% Starting test ")
+	(display suite-name)
+	(if test-log-to-file
+	    (let* ((log-file-name
+		    (if (string? test-log-to-file) test-log-to-file
+			(string-append suite-name ".log")))
+		   (log-file
+		    (cond-expand (mzscheme
+				  (open-output-file log-file-name 'truncate/replace))
+				 (else (open-output-file log-file-name)))))
+	      (display "%%%% Starting test " log-file)
+	      (display suite-name log-file)
+	      (newline log-file)
+	      (test-runner-aux-value! runner log-file)
+	      (display "  (Writing full log to \"")
+	      (display log-file-name)
+	      (display "\")")))
+	(newline)))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group begin: " log)
+	  (display suite-name log)
+	  (newline log))))
+  #f)
+
+(define (test-on-group-end-simple runner)
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group end: " log)
+	  (display (car (test-runner-group-stack runner)) log)
+	  (newline log))))
+  #f)
+
+(define (%test-on-bad-count-write runner count expected-count port)
+  (display "*** Total number of tests was " port)
+  (display count port)
+  (display " but should be " port)
+  (display expected-count port)
+  (display ". ***" port)
+  (newline port)
+  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
+  (newline port))
+
+(define (test-on-bad-count-simple runner count expected-count)
+  (%test-on-bad-count-write runner count expected-count (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-on-bad-count-write runner count expected-count log))))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
+			    " does not match test-begin " end-name)))
+    (cond-expand
+     (srfi-23 (error msg))
+     (else (display msg) (newline)))))
+  
+
+(define (%test-final-report1 value label port)
+  (if (> value 0)
+      (begin
+	(display label port)
+	(display value port)
+	(newline port))))
+
+(define (%test-final-report-simple runner port)
+  (%test-final-report1 (test-runner-pass-count runner)
+		      "# of expected passes      " port)
+  (%test-final-report1 (test-runner-xfail-count runner)
+		      "# of expected failures    " port)
+  (%test-final-report1 (test-runner-xpass-count runner)
+		      "# of unexpected successes " port)
+  (%test-final-report1 (test-runner-fail-count runner)
+		      "# of unexpected failures  " port)
+  (%test-final-report1 (test-runner-skip-count runner)
+		      "# of skipped tests        " port))
+
+(define (test-on-final-simple runner)
+  (%test-final-report-simple runner (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-final-report-simple runner log))))
+
+(define (%test-format-line runner)
+   (let* ((line-info (test-result-alist runner))
+	  (source-file (assq 'source-file line-info))
+	  (source-line (assq 'source-line line-info))
+	  (file (if source-file (cdr source-file) "")))
+     (if source-line
+	 (string-append file ":"
+			(number->string (cdr source-line)) ": ")
+	 "")))
+
+(define (%test-end suite-name line-info)
+  (let* ((r (test-runner-get))
+	 (groups (test-runner-group-stack r))
+	 (line (%test-format-line r)))
+    (test-result-alist! r line-info)
+    (if (null? groups)
+	(let ((msg (string-append line "test-end not in a group")))
+	  (cond-expand
+	   (srfi-23 (error msg))
+	   (else (display msg) (newline)))))
+    (if (and suite-name (not (equal? suite-name (car groups))))
+	((test-runner-on-bad-end-name r) r suite-name (car groups)))
+    (let* ((count-list (%test-runner-count-list r))
+	   (expected-count (cdar count-list))
+	   (saved-count (caar count-list))
+	   (group-count (- (%test-runner-total-count r) saved-count)))
+      (if (and expected-count
+	       (not (= expected-count group-count)))
+	  ((test-runner-on-bad-count r) r group-count expected-count))
+      ((test-runner-on-group-end r) r)
+      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+      (%test-runner-count-list! r (cdr count-list))
+      (if (null? (test-runner-group-stack r))
+	  ((test-runner-on-final r) r)))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((test-group suite-name . body)
+     (let ((r (test-runner-current)))
+       ;; Ideally should also set line-number, if available.
+       (test-result-alist! r (list (cons 'test-name suite-name)))
+       (if (%test-should-execute r)
+	   (dynamic-wind
+	       (lambda () (test-begin suite-name))
+	       (lambda () . body)
+	       (lambda () (test-end  suite-name))))))))
+
+(define-syntax test-group-with-cleanup
+  (syntax-rules ()
+    ((test-group-with-cleanup suite-name form cleanup-form)
+     (test-group suite-name
+		    (dynamic-wind
+			(lambda () #f)
+			(lambda () form)
+			(lambda () cleanup-form))))
+    ((test-group-with-cleanup suite-name cleanup-form)
+     (test-group-with-cleanup suite-name #f cleanup-form))
+    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
+     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
+
+(define (test-on-test-begin-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (source-form (assq 'source-form results))
+	       (test-name (assq 'test-name results)))
+	  (display "Test begin:" log)
+	  (newline log)
+	  (if test-name (%test-write-result1 test-name log))
+	  (if source-file (%test-write-result1 source-file log))
+	  (if source-line (%test-write-result1 source-line log))
+	  (if source-form (%test-write-result1 source-form log))))))
+
+(define-syntax test-result-ref
+  (syntax-rules ()
+    ((test-result-ref runner pname)
+     (test-result-ref runner pname #f))
+    ((test-result-ref runner pname default)
+     (let ((p (assq pname (test-result-alist runner))))
+       (if p (cdr p) default)))))
+
+(define (test-on-test-end-simple runner)
+  (let ((log (test-runner-aux-value runner))
+	(kind (test-result-ref runner 'result-kind)))
+    (if (memq kind '(fail xpass))
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (test-name (assq 'test-name results)))
+	  (if (or source-file source-line)
+	      (begin
+		(if source-file (display (cdr source-file)))
+		(display ":")
+		(if source-line (display (cdr source-line)))
+		(display ": ")))
+	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
+	  (if test-name
+	      (begin
+		(display " ")
+		(display (cdr test-name))))
+	  (newline)))
+    (if (output-port? log)
+	(begin
+	  (display "Test end:" log)
+	  (newline log)
+	  (let loop ((list (test-result-alist runner)))
+	    (if (pair? list)
+		(let ((pair (car list)))
+		  ;; Write out properties not written out by on-test-begin.
+		  (if (not (memq (car pair)
+				 '(test-name source-file source-line source-form)))
+		      (%test-write-result1 pair log))
+		  (loop (cdr list)))))))))
+
+(define (%test-write-result1 pair port)
+  (display "  " port)
+  (display (car pair) port)
+  (display ": " port)
+  (write (cdr pair) port)
+  (newline port))
+
+(define (test-result-set! runner pname value)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(set-cdr! p value)
+	(test-result-alist! runner (cons (cons pname value) alist)))))
+
+(define (test-result-clear runner)
+  (test-result-alist! runner '()))
+
+(define (test-result-remove runner pname)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(test-result-alist! runner
+				   (let loop ((r alist))
+				     (if (eq? r p) (cdr r)
+					 (cons (car r) (loop (cdr r)))))))))
+
+(define (test-result-kind . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
+    (test-result-ref runner 'result-kind)))
+
+(define (test-passed? . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
+    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
+
+(define (%test-report-result)
+  (let* ((r (test-runner-get))
+	 (result-kind (test-result-kind r)))
+    (case result-kind
+      ((pass)
+       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
+      ((fail)
+       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
+      ((xpass)
+       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
+      ((xfail)
+       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
+      (else
+       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
+    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
+    ((test-runner-on-test-end r) r)))
+
+(cond-expand
+ (guile
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (catch #t
+         (lambda () test-expression)
+         (lambda (key . args)
+           (test-result-set! (test-runner-current) 'actual-error
+                             (cons key args))
+           #f))))))
+ (kawa
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (try-catch test-expression
+		  (ex <java.lang.Throwable>
+		      (test-result-set! (test-runner-current) 'actual-error ex)
+		      #f))))))
+ (srfi-34
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (guard (err (else #f)) test-expression)))))
+ (chicken
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (condition-case test-expression (ex () #f))))))
+ (else
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       test-expression)))))
+	    
+(cond-expand
+ ((or kawa mzscheme)
+  (cond-expand
+   (mzscheme
+    (define-for-syntax (%test-syntax-file form)
+      (let ((source (syntax-source form)))
+	(cond ((string? source) file)
+				((path? source) (path->string source))
+				(else #f)))))
+   (kawa
+    (define (%test-syntax-file form)
+      (syntax-source form))))
+  (define (%test-source-line2 form)
+    (let* ((line (syntax-line form))
+	   (file (%test-syntax-file form))
+	   (line-pair (if line (list (cons 'source-line line)) '())))
+      (cons (cons 'source-form (syntax-object->datum form))
+	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
+ (guile-2
+  (define (%test-source-line2 form)
+    (let* ((src-props (syntax-source form))
+           (file (and src-props (assq-ref src-props 'filename)))
+           (line (and src-props (assq-ref src-props 'line)))
+           (file-alist (if file
+                           `((source-file . ,file))
+                           '()))
+           (line-alist (if line
+                           `((source-line . ,(+ line 1)))
+                           '())))
+      (datum->syntax (syntax here)
+                     `((source-form . ,(syntax->datum form))
+                       ,@file-alist
+                       ,@line-alist)))))
+ (else
+  (define (%test-source-line2 form)
+    '())))
+
+(define (%test-on-test-begin r)
+  (%test-should-execute r)
+  ((test-runner-on-test-begin r) r)
+  (not (eq? 'skip (test-result-ref r 'result-kind))))
+
+(define (%test-on-test-end r result)
+    (test-result-set! r 'result-kind
+		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
+			  (if result 'xpass 'xfail)
+			  (if result 'pass 'fail))))
+
+(define (test-runner-test-name runner)
+  (test-result-ref runner 'test-name ""))
+
+(define-syntax %test-comp2body
+  (syntax-rules ()
+		((%test-comp2body r comp expected expr)
+		 (let ()
+		   (if (%test-on-test-begin r)
+		       (let ((exp expected))
+			 (test-result-set! r 'expected-value exp)
+			 (let ((res (%test-evaluate-with-catch expr)))
+			   (test-result-set! r 'actual-value res)
+			   (%test-on-test-end r (comp exp res)))))
+		   (%test-report-result)))))
+
+(define (%test-approximate= error)
+  (lambda (value expected)
+    (let ((rval (real-part value))
+          (ival (imag-part value))
+          (rexp (real-part expected))
+          (iexp (imag-part expected)))
+      (and (>= rval (- rexp error))
+           (>= ival (- iexp error))
+           (<= rval (+ rexp error))
+           (<= ival (+ iexp error))))))
+
+(define-syntax %test-comp1body
+  (syntax-rules ()
+    ((%test-comp1body r expr)
+     (let ()
+       (if (%test-on-test-begin r)
+	   (let ()
+	     (let ((res (%test-evaluate-with-catch expr)))
+	       (test-result-set! r 'actual-value res)
+	       (%test-on-test-end r res))))
+       (%test-report-result)))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+  ;; Should be made to work for any Scheme with syntax-case
+  ;; However, I haven't gotten the quoting working.  FIXME.
+  (define-syntax test-end
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac suite-name) line)
+	 (syntax
+	  (%test-end suite-name line)))
+	(((mac) line)
+	 (syntax
+	  (%test-end #f line))))))
+  (define-syntax test-assert
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac tname expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get))
+		 (name tname))
+	    (test-result-alist! r (cons (cons 'test-name tname) line))
+	    (%test-comp1body r expr))))
+	(((mac expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-comp1body r expr)))))))
+  (define (%test-comp2 comp x)
+    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
+      (((mac tname expected expr) line comp)
+       (syntax
+	(let* ((r (test-runner-get))
+	       (name tname))
+	  (test-result-alist! r (cons (cons 'test-name tname) line))
+	  (%test-comp2body r comp expected expr))))
+      (((mac expected expr) line comp)
+       (syntax
+	(let* ((r (test-runner-get)))
+	  (test-result-alist! r line)
+	  (%test-comp2body r comp expected expr))))))
+  (define-syntax test-eqv
+    (lambda (x) (%test-comp2 (syntax eqv?) x)))
+  (define-syntax test-eq
+    (lambda (x) (%test-comp2 (syntax eq?) x)))
+  (define-syntax test-equal
+    (lambda (x) (%test-comp2 (syntax equal?) x)))
+  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+      (((mac tname expected expr error) line)
+       (syntax
+	(let* ((r (test-runner-get))
+	       (name tname))
+	  (test-result-alist! r (cons (cons 'test-name tname) line))
+	  (%test-comp2body r (%test-approximate= error) expected expr))))
+      (((mac expected expr error) line)
+       (syntax
+	(let* ((r (test-runner-get)))
+	  (test-result-alist! r line)
+	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
+ (else
+  (define-syntax test-end
+    (syntax-rules ()
+      ((test-end)
+       (%test-end #f '()))
+      ((test-end suite-name)
+       (%test-end suite-name '()))))
+  (define-syntax test-assert
+    (syntax-rules ()
+      ((test-assert tname test-expression)
+       (let* ((r (test-runner-get))
+	      (name tname))
+	 (test-result-alist! r '((test-name . tname)))
+	 (%test-comp1body r test-expression)))
+      ((test-assert test-expression)
+       (let* ((r (test-runner-get)))
+	 (test-result-alist! r '())
+	 (%test-comp1body r test-expression)))))
+  (define-syntax %test-comp2
+    (syntax-rules ()
+      ((%test-comp2 comp tname expected expr)
+       (let* ((r (test-runner-get))
+	      (name tname))
+	 (test-result-alist! r (list (cons 'test-name tname)))
+	 (%test-comp2body r comp expected expr)))
+      ((%test-comp2 comp expected expr)
+       (let* ((r (test-runner-get)))
+	 (test-result-alist! r '())
+	 (%test-comp2body r comp expected expr)))))
+  (define-syntax test-equal
+    (syntax-rules ()
+      ((test-equal . rest)
+       (%test-comp2 equal? . rest))))
+  (define-syntax test-eqv
+    (syntax-rules ()
+      ((test-eqv . rest)
+       (%test-comp2 eqv? . rest))))
+  (define-syntax test-eq
+    (syntax-rules ()
+      ((test-eq . rest)
+       (%test-comp2 eq? . rest))))
+  (define-syntax test-approximate
+    (syntax-rules ()
+      ((test-approximate tname expected expr error)
+       (%test-comp2 (%test-approximate= error) tname expected expr))
+      ((test-approximate expected expr error)
+       (%test-comp2 (%test-approximate= error) expected expr))))))
+
+(cond-expand
+ (guile
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (cond ((%test-on-test-begin r)
+              (let ((et etype))
+                (test-result-set! r 'expected-error et)
+                (%test-on-test-end r
+                                   (catch #t
+                                     (lambda ()
+                                       (test-result-set! r 'actual-value expr)
+                                       #f)
+                                     (lambda (key . args)
+                                       ;; TODO: decide how to specify expected
+                                       ;; error types for Guile.
+                                       (test-result-set! r 'actual-error
+                                                         (cons key args))
+                                       #t)))
+                (%test-report-result))))))))
+ (mzscheme
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
+					 (let ()
+					   (test-result-set! r 'actual-value expr)
+					   #f)))))))
+ (chicken
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+        (%test-comp1body r (condition-case expr (ex () #t)))))))
+ (kawa
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r #t expr)
+       (cond ((%test-on-test-begin r)
+	      (test-result-set! r 'expected-error #t)
+	      (%test-on-test-end r
+				 (try-catch
+				  (let ()
+				    (test-result-set! r 'actual-value expr)
+				    #f)
+				  (ex <java.lang.Throwable>
+				      (test-result-set! r 'actual-error ex)
+				      #t)))
+	      (%test-report-result))))
+      ((%test-error r etype expr)
+       (if (%test-on-test-begin r)
+	   (let ((et etype))
+	     (test-result-set! r 'expected-error et)
+	     (%test-on-test-end r
+				(try-catch
+				 (let ()
+				   (test-result-set! r 'actual-value expr)
+				   #f)
+				 (ex <java.lang.Throwable>
+				     (test-result-set! r 'actual-error ex)
+				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
+						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
+					    (instance? ex et))
+					   (else #t)))))
+	     (%test-report-result)))))))
+ ((and srfi-34 srfi-35)
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (guard (ex ((condition-type? etype)
+		   (and (condition? ex) (condition-has-type? ex etype)))
+		  ((procedure? etype)
+		   (etype ex))
+		  ((equal? etype #t)
+		   #t)
+		  (else #t))
+	      expr #f))))))
+ (srfi-34
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
+ (else
+  (define-syntax %test-error
+    (syntax-rules ()
+      ((%test-error r etype expr)
+       (begin
+	 ((test-runner-on-test-begin r) r)
+	 (test-result-set! r 'result-kind 'skip)
+	 (%test-report-result)))))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+
+  (define-syntax test-error
+    (lambda (x)
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+	(((mac tname etype expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get))
+		 (name tname))
+	    (test-result-alist! r (cons (cons 'test-name tname) line))
+	    (%test-error r etype expr))))
+	(((mac etype expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-error r etype expr))))
+	(((mac expr) line)
+	 (syntax
+	  (let* ((r (test-runner-get)))
+	    (test-result-alist! r line)
+	    (%test-error r #t expr))))))))
+ (else
+  (define-syntax test-error
+    (syntax-rules ()
+      ((test-error name etype expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r `((test-name . ,name)))
+         (%test-error r etype expr)))
+      ((test-error etype expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r etype expr)))
+      ((test-error expr)
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r #t expr)))))))
+
+(define (test-apply first . rest)
+  (if (test-runner? first)
+      (test-with-runner first (apply test-apply rest))
+      (let ((r (test-runner-current)))
+	(if r
+	    (let ((run-list (%test-runner-run-list r)))
+	      (cond ((null? rest)
+		     (%test-runner-run-list! r (reverse run-list))
+		     (first)) ;; actually apply procedure thunk
+		    (else
+		     (%test-runner-run-list!
+		      r
+		      (if (eq? run-list #t) (list first) (cons first run-list)))
+		     (apply test-apply rest)
+		     (%test-runner-run-list! r run-list))))
+	    (let ((r (test-runner-create)))
+	      (test-with-runner r (apply test-apply first rest))
+	      ((test-runner-on-final r) r))))))
+
+(define-syntax test-with-runner
+  (syntax-rules ()
+    ((test-with-runner runner form ...)
+     (let ((saved-runner (test-runner-current)))
+       (dynamic-wind
+           (lambda () (test-runner-current runner))
+           (lambda () form ...)
+           (lambda () (test-runner-current saved-runner)))))))
+
+;;; Predicates
+
+(define (%test-match-nth n count)
+  (let ((i 0))
+    (lambda (runner)
+      (set! i (+ i 1))
+      (and (>= i n) (< i (+ n count))))))
+
+(define-syntax test-match-nth
+  (syntax-rules ()
+    ((test-match-nth n)
+     (test-match-nth n 1))
+    ((test-match-nth n count)
+     (%test-match-nth n count))))
+
+(define (%test-match-all . pred-list)
+  (lambda (runner)
+    (let ((result #t))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if (not ((car l) runner))
+		  (set! result #f))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-all
+  (syntax-rules ()
+    ((test-match-all pred ...)
+     (%test-match-all (%test-as-specifier pred) ...))))
+
+(define (%test-match-any . pred-list)
+  (lambda (runner)
+    (let ((result #f))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if ((car l) runner)
+		  (set! result #t))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-any
+  (syntax-rules ()
+    ((test-match-any pred ...)
+     (%test-match-any (%test-as-specifier pred) ...))))
+
+;; Coerce to a predicate function:
+(define (%test-as-specifier specifier)
+  (cond ((procedure? specifier) specifier)
+	((integer? specifier) (test-match-nth 1 specifier))
+	((string? specifier) (test-match-name specifier))
+	(else
+	 (error "not a valid test specifier"))))
+
+(define-syntax test-skip
+  (syntax-rules ()
+    ((test-skip pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-skip-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-skip-list runner)))))))
+
+(define-syntax test-expect-fail
+  (syntax-rules ()
+    ((test-expect-fail pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-fail-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-fail-list runner)))))))
+
+(define (test-match-name name)
+  (lambda (runner)
+    (equal? name (test-runner-test-name runner))))
+
+(define (test-read-eval-string string)
+  (let* ((port (open-input-string string))
+	 (form (read port)))
+    (if (eof-object? (read-char port))
+	(cond-expand
+	 (guile (eval form (current-module)))
+	 (else (eval form)))
+	(cond-expand
+	 (srfi-23 (error "(not at eof)"))
+	 (else "error")))))
+
+;;; srfi-67.scm --- Compare Procedures
+
+;; Copyright (C) 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, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-67)
+  #\export (</<=?
+            </<?
+            <=/<=?
+            <=/<?
+            <=?
+            <?
+            =?
+            >/>=?
+            >/>?
+            >=/>=?
+            >=/>?
+            >=?
+            >?
+            boolean-compare
+            chain<=?
+            chain<?
+            chain=?
+            chain>=?
+            chain>?
+            char-compare
+            char-compare-ci
+            compare-by<
+            compare-by<=
+            compare-by=/<
+            compare-by=/>
+            compare-by>
+            compare-by>=
+            complex-compare
+            cond-compare
+            debug-compare
+            default-compare
+            if-not=?
+            if3
+            if<=?
+            if<?
+            if=?
+            if>=?
+            if>?
+            integer-compare
+            kth-largest
+            list-compare
+            list-compare-as-vector
+            max-compare
+            min-compare
+            not=?
+            number-compare
+            pair-compare
+            pair-compare-car
+            pair-compare-cdr
+            pairwise-not=?
+            rational-compare
+            real-compare
+            refine-compare
+            select-compare
+            symbol-compare
+            vector-compare
+            vector-compare-as-list)
+  #\replace (string-compare string-compare-ci)
+  #\use-module (srfi srfi-27))
+
+(cond-expand-provide (current-module) '(srfi-67))
+
+(include-from-path "srfi/srfi-67/compare.scm")
+; Copyright (c) 2011 Free Software Foundation, Inc.
+; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
+; 
+; 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.
+; 
+; -----------------------------------------------------------------------
+; 
+; Compare procedures SRFI (reference implementation)
+; Sebastian.Egner@philips.com, Jensaxel@soegaard.net
+; history of this file:
+;   SE, 14-Oct-2004: first version
+;   SE, 18-Oct-2004: 1st redesign: axioms for 'compare function'
+;   SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite
+;   SE,  2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's
+;   SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare
+;   SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added
+;   SE, 12-Jan-2005: pair-compare-cdr
+;   SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=?
+;   SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc.
+;   JS, 24-Feb-2005: selection-compare added
+;   SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc.
+;   JS, 28-Feb-2005: kth-largest modified - is "stable" now
+;   SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged
+;   SE, 07-Apr-2005: compare-based type checks made explicit
+;   SE, 18-Apr-2005: added (rel? compare) and eq?-test
+;   SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y
+
+; =============================================================================
+
+; Reference Implementation
+; ========================
+;
+; in R5RS (including hygienic macros)
+;  + SRFI-16 (case-lambda) 
+;  + SRFI-23 (error) 
+;  + SRFI-27 (random-integer)
+
+; Implementation remarks:
+;   * In general, the emphasis of this implementation is on correctness
+;     and portability, not on efficiency.
+;   * Variable arity procedures are expressed in terms of case-lambda
+;     in the hope that this will produce efficient code for the case
+;     where the arity is statically known at the call site.
+;   * In procedures that are required to type-check their arguments,
+;     we use (compare x x) for executing extra checks. This relies on
+;     the assumption that eq? is used to catch this case quickly.
+;   * Care has been taken to reference comparison procedures of R5RS
+;     only at the time the operations here are being defined. This
+;     makes it possible to redefine these operations, if need be.
+;   * For the sake of efficiency, some inlining has been done by hand.
+;     This is mainly expressed by macros producing defines.
+;   * Identifiers of the form compare:<something> are private.
+;
+; Hints for low-level implementation:
+;   * The basis of this SRFI are the atomic compare procedures, 
+;     i.e. boolean-compare, char-compare, etc. and the conditionals
+;     if3, if=?, if<? etc., and default-compare. These should make
+;     optimal use of the available type information.
+;   * For the sake of speed, the reference implementation does not
+;     use a LET to save the comparison value c for the ERROR call.
+;     This can be fixed in a low-level implementation at no cost.
+;   * Type-checks based on (compare x x) are made explicit by the
+;     expression (compare:check result compare x ...).
+;   * Eq? should  can used to speed up built-in compare procedures,
+;     but it can only be used after type-checking at least one of
+;     the arguments.
+
+(define (compare:checked result compare . args)
+  (for-each (lambda (x) (compare x x)) args)
+  result)
+
+
+; 3-sided conditional
+
+(define-syntax-rule (if3 c less equal greater)
+  (case c
+    ((-1) less)
+    (( 0) equal)
+    (( 1) greater)
+    (else (error "comparison value not in {-1,0,1}"))))
+
+
+; 2-sided conditionals for comparisons
+
+(define-syntax compare:if-rel?
+  (syntax-rules ()
+    ((compare:if-rel? c-cases a-cases c consequence)
+     (compare:if-rel? c-cases a-cases c consequence (if #f #f)))
+    ((compare:if-rel? c-cases a-cases c consequence alternate)
+     (case c
+       (c-cases consequence)
+       (a-cases alternate)
+       (else    (error "comparison value not in {-1,0,1}"))))))
+
+(define-syntax-rule (if=? arg ...)
+  (compare:if-rel? (0) (-1 1) arg ...))
+
+(define-syntax-rule (if<? arg ...)
+  (compare:if-rel? (-1) (0 1) arg ...))
+
+(define-syntax-rule (if>? arg ...)
+  (compare:if-rel? (1) (-1 0) arg ...))
+
+(define-syntax-rule (if<=? arg ...)
+  (compare:if-rel? (-1 0) (1) arg ...))
+
+(define-syntax-rule (if>=? arg ...)
+  (compare:if-rel? (0 1) (-1) arg ...))
+
+(define-syntax-rule (if-not=? arg ...)
+  (compare:if-rel? (-1 1) (0) arg ...))
+
+
+; predicates from compare procedures
+
+(define-syntax-rule (compare:define-rel? rel? if-rel?)
+  (define rel?
+    (case-lambda
+      (()        (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+      ((compare) (lambda (x y) (if-rel? (compare         x y) #t #f)))
+      ((x y)                   (if-rel? (default-compare x y) #t #f))
+      ((compare x y)
+       (if (procedure? compare)
+           (if-rel? (compare x y) #t #f)
+           (error "not a procedure (Did you mean rel/rel??): " compare))))))
+
+(compare:define-rel? =?    if=?)
+(compare:define-rel? <?    if<?)
+(compare:define-rel? >?    if>?)
+(compare:define-rel? <=?   if<=?)
+(compare:define-rel? >=?   if>=?)
+(compare:define-rel? not=? if-not=?)
+
+
+; chains of length 3
+
+(define-syntax-rule (compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
+  (define rel1/rel2?
+    (case-lambda
+      (()
+       (lambda (x y z)
+         (if-rel1? (default-compare x y)
+                   (if-rel2? (default-compare y z) #t #f)
+                   (compare:checked #f default-compare z))))
+      ((compare)
+       (lambda (x y z)
+         (if-rel1? (compare x y)
+                   (if-rel2? (compare y z) #t #f)
+                   (compare:checked #f compare z))))
+      ((x y z)
+       (if-rel1? (default-compare x y)
+                 (if-rel2? (default-compare y z) #t #f)
+                 (compare:checked #f default-compare z)))
+      ((compare x y z)
+       (if-rel1? (compare x y)
+                 (if-rel2? (compare y z) #t #f)
+                 (compare:checked #f compare z))))))
+
+(compare:define-rel1/rel2? </<?   if<?  if<?)
+(compare:define-rel1/rel2? </<=?  if<?  if<=?)
+(compare:define-rel1/rel2? <=/<?  if<=? if<?)
+(compare:define-rel1/rel2? <=/<=? if<=? if<=?)
+(compare:define-rel1/rel2? >/>?   if>?  if>?)
+(compare:define-rel1/rel2? >/>=?  if>?  if>=?)
+(compare:define-rel1/rel2? >=/>?  if>=? if>?)
+(compare:define-rel1/rel2? >=/>=? if>=? if>=?)
+
+
+; chains of arbitrary length
+
+(define-syntax-rule (compare:define-chain-rel? chain-rel? if-rel?)
+  (define chain-rel?
+    (case-lambda
+      ((compare)
+       #t)
+      ((compare x1)
+       (compare:checked #t compare x1))
+      ((compare x1 x2)
+       (if-rel? (compare x1 x2) #t #f))
+      ((compare x1 x2 x3)
+       (if-rel? (compare x1 x2)
+                (if-rel? (compare x2 x3) #t #f)
+                (compare:checked #f compare x3)))
+      ((compare x1 x2 . x3+)
+       (if-rel? (compare x1 x2)
+                (let chain? ((head x2) (tail x3+))
+                  (if (null? tail)
+                      #t
+                      (if-rel? (compare head (car tail))
+                               (chain? (car tail) (cdr tail))
+                               (apply compare:checked #f 
+                                      compare (cdr tail)))))
+                (apply compare:checked #f compare x3+))))))
+
+(compare:define-chain-rel? chain=?  if=?)
+(compare:define-chain-rel? chain<?  if<?)
+(compare:define-chain-rel? chain>?  if>?)
+(compare:define-chain-rel? chain<=? if<=?)
+(compare:define-chain-rel? chain>=? if>=?)
+
+
+; pairwise inequality
+
+(define pairwise-not=?
+  (let ((= =) (<= <=))
+    (case-lambda
+      ((compare)
+       #t)
+      ((compare x1)
+       (compare:checked #t compare x1))
+      ((compare x1 x2)
+       (if-not=? (compare x1 x2) #t #f))
+      ((compare x1 x2 x3)
+       (if-not=? (compare x1 x2)
+                 (if-not=? (compare x2 x3)
+                           (if-not=? (compare x1 x3) #t #f)
+                           #f)
+		 (compare:checked #f compare x3)))
+      ((compare . x1+)
+       (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t))
+         (if (< n 2)
+	     (if (and unchecked? (= n 1))
+		 (compare:checked #t compare (car x))
+		 #t)
+             (let* ((i-pivot (random-integer n))
+                    (x-pivot (list-ref x i-pivot)))
+               (let split ((i 0) (x x) (x< '()) (x> '()))
+                 (if (null? x)
+                     (and (unequal? x< (length x<) #f)
+                          (unequal? x> (length x>) #f))
+                     (if (= i i-pivot)
+                         (split (+ i 1) (cdr x) x< x>)
+                         (if3 (compare (car x) x-pivot)
+                              (split (+ i 1) (cdr x) (cons (car x) x<) x>)
+			      (if unchecked?
+				  (apply compare:checked #f compare (cdr x))
+				  #f)
+                              (split (+ i 1) (cdr x) x< (cons (car x) x>)))))))))))))
+
+
+; min/max
+
+(define min-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if<=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3) x1 x3)
+            (if<=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3)
+                   (if<=? (compare x1 x4) x1 x4)
+                   (if<=? (compare x3 x4) x3 x4))
+            (if<=? (compare x2 x3)
+                   (if<=? (compare x2 x4) x2 x4)
+                   (if<=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmin
+           (min (if<=? (compare xmin (car xs)) xmin (car xs))
+                (cdr xs)))))))
+
+(define max-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if>=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3) x1 x3)
+            (if>=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3)
+                   (if>=? (compare x1 x4) x1 x4)
+                   (if>=? (compare x3 x4) x3 x4))
+            (if>=? (compare x2 x3)
+                   (if>=? (compare x2 x4) x2 x4)
+                   (if>=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmax
+           (max (if>=? (compare xmax (car xs)) xmax (car xs))
+                (cdr xs)))))))
+
+
+; kth-largest
+
+(define kth-largest
+  (let ((= =) (< <))
+    (case-lambda
+      ((compare k x0)
+       (case (modulo k 1)
+         ((0)  (compare:checked x0 compare x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1)
+       (case (modulo k 2)
+         ((0) (if<=? (compare x0 x1) x0 x1))
+         ((1) (if<=? (compare x0 x1) x1 x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1 x2)
+       (case (modulo k 3)
+         ((0) (if<=? (compare x0 x1)
+                     (if<=? (compare x0 x2) x0 x2)
+                     (if<=? (compare x1 x2) x1 x2)))
+         ((1) (if3 (compare x0 x1)
+                   (if<=? (compare x1 x2)
+                          x1
+                          (if<=? (compare x0 x2) x2 x0))
+                   (if<=? (compare x0 x2) x1 x0)
+                   (if<=? (compare x0 x2)
+                          x0
+                          (if<=? (compare x1 x2) x2 x1))))
+         ((2) (if<=? (compare x0 x1)
+                     (if<=? (compare x1 x2) x2 x1)
+                     (if<=? (compare x0 x2) x2 x0)))
+         (else (error "bad index" k))))
+      ((compare k x0 . x1+) ; |x1+| >= 1
+       (if (not (and (integer? k) (exact? k)))
+           (error "bad index" k))
+       (let ((n (+ 1 (length x1+))))
+         (let kth ((k   (modulo k n))
+                   (n   n)  ; = |x|
+                   (rev #t) ; are x<, x=, x> reversed?
+                   (x   (cons x0 x1+)))
+           (let ((pivot (list-ref x (random-integer n))))
+             (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0))
+               (if (null? x)
+                   (cond
+                     ((< k n<)
+                      (kth k n< (not rev) x<))
+                     ((< k (+ n< n=))
+                      (if rev
+                          (list-ref x= (- (- n= 1) (- k n<)))
+                          (list-ref x= (- k n<))))
+                     (else
+                      (kth (- k (+ n< n=)) n> (not rev) x>)))
+                   (if3 (compare (car x) pivot)
+                        (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>)
+                        (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>)
+                        (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1))))))))))))
+
+
+; compare functions from predicates
+
+(define compare-by<
+  (case-lambda
+   ((lt)     (lambda (x y) (if (lt x y) -1 (if (lt y x)  1 0))))
+   ((lt x y)               (if (lt x y) -1 (if (lt y x)  1 0)))))
+
+(define compare-by>
+  (case-lambda
+   ((gt)     (lambda (x y) (if (gt x y) 1 (if (gt y x)  -1 0))))
+   ((gt x y)               (if (gt x y) 1 (if (gt y x)  -1 0)))))
+
+(define compare-by<=
+  (case-lambda
+   ((le)     (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1)))
+   ((le x y)               (if (le x y) (if (le y x) 0 -1) 1))))
+
+(define compare-by>=
+  (case-lambda
+   ((ge)     (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1)))
+   ((ge x y)               (if (ge x y) (if (ge y x) 0 1) -1))))
+
+(define compare-by=/<
+  (case-lambda
+   ((eq lt)     (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1))))
+   ((eq lt x y)               (if (eq x y) 0 (if (lt x y) -1 1)))))
+
+(define compare-by=/>
+  (case-lambda
+   ((eq gt)     (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1))))
+   ((eq gt x y)               (if (eq x y) 0 (if (gt x y) 1 -1)))))
+
+; refine and extend construction
+
+(define-syntax refine-compare
+  (syntax-rules ()
+    ((refine-compare)
+     0)
+    ((refine-compare c1)
+     c1)
+    ((refine-compare c1 c2 cs ...)
+     (if3 c1 -1 (refine-compare c2 cs ...) 1))))
+
+(define-syntax select-compare
+  (syntax-rules (else)
+    ((select-compare x y clause ...)
+     (let ((x-val x) (y-val y))
+       (select-compare (x-val y-val clause ...))))
+    ; used internally: (select-compare (x y clause ...))
+    ((select-compare (x y))
+     0)
+    ((select-compare (x y (else c ...)))
+     (refine-compare c ...))
+    ((select-compare (x y (t? c ...) clause ...))
+     (let ((t?-val t?))
+       (let ((tx (t?-val x)) (ty (t?-val y)))
+         (if tx
+             (if ty (refine-compare c ...) -1)
+             (if ty 1 (select-compare (x y clause ...)))))))))
+
+(define-syntax cond-compare
+  (syntax-rules (else)
+    ((cond-compare)
+     0)
+    ((cond-compare (else cs ...))
+     (refine-compare cs ...))
+    ((cond-compare ((tx ty) cs ...) clause ...)
+     (let ((tx-val tx) (ty-val ty))
+       (if tx-val
+           (if ty-val (refine-compare cs ...) -1)
+           (if ty-val 1 (cond-compare clause ...)))))))
+
+
+; R5RS atomic types
+
+(define-syntax compare:type-check
+  (syntax-rules ()
+    ((compare:type-check type? type-name x)
+     (if (not (type? x))
+         (error (string-append "not " type-name ":") x)))
+    ((compare:type-check type? type-name x y)
+     (begin (compare:type-check type? type-name x)
+            (compare:type-check type? type-name y)))))
+
+(define-syntax-rule (compare:define-by=/< compare = < type? type-name)
+  (define compare
+    (let ((= =) (< <))
+      (lambda (x y)
+        (if (type? x)
+            (if (eq? x y)
+                0
+                (if (type? y)
+                    (if (= x y) 0 (if (< x y) -1 1))
+                    (error (string-append "not " type-name ":") y)))
+            (error (string-append "not " type-name ":") x))))))
+
+(define (boolean-compare x y)
+  (compare:type-check boolean? "boolean" x y)
+  (if x (if y 0 1) (if y -1 0)))
+
+(compare:define-by=/< char-compare char=? char<? char? "char")
+
+(compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char")
+
+(compare:define-by=/< string-compare string=? string<? string? "string")
+
+(compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string")
+
+(define (symbol-compare x y)
+  (compare:type-check symbol? "symbol" x y)
+  (string-compare (symbol->string x) (symbol->string y)))
+
+(compare:define-by=/< integer-compare = < integer? "integer")
+
+(compare:define-by=/< rational-compare = < rational? "rational")
+
+(compare:define-by=/< real-compare = < real? "real")
+
+(define (complex-compare x y)
+  (compare:type-check complex? "complex" x y)
+  (if (and (real? x) (real? y))
+      (real-compare x y)
+      (refine-compare (real-compare (real-part x) (real-part y))
+                      (real-compare (imag-part x) (imag-part y)))))
+
+(define (number-compare x y)
+  (compare:type-check number? "number" x y)
+  (complex-compare x y))
+
+
+; R5RS compound data structures: dotted pair, list, vector
+
+(define (pair-compare-car compare)
+  (lambda (x y)
+    (compare (car x) (car y))))
+
+(define (pair-compare-cdr compare)
+  (lambda (x y)
+    (compare (cdr x) (cdr y))))
+
+(define pair-compare
+  (case-lambda
+    
+    ; dotted pair
+    ((pair-compare-car pair-compare-cdr x y)
+     (refine-compare (pair-compare-car (car x) (car y))
+                     (pair-compare-cdr (cdr x) (cdr y))))
+    
+    ; possibly improper lists
+    ((compare x y)
+     (cond-compare 
+      (((null? x) (null? y)) 0)
+      (((pair? x) (pair? y)) (compare              (car x) (car y))
+                             (pair-compare compare (cdr x) (cdr y)))
+      (else                  (compare x y))))
+    
+    ; for convenience
+    ((x y)
+     (pair-compare default-compare x y))))
+
+(define list-compare
+  (case-lambda
+    ((compare x y empty? head tail)
+     (cond-compare
+      (((empty? x) (empty? y)) 0)
+      (else (compare              (head x) (head y))
+            (list-compare compare (tail x) (tail y) empty? head tail))))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare compare         x y null? car   cdr))
+    ((        x y              )
+     (list-compare default-compare x y null? car   cdr))))
+
+(define list-compare-as-vector
+  (case-lambda
+    ((compare x y empty? head tail)
+     (refine-compare
+      (let compare-length ((x x) (y y))
+        (cond-compare
+         (((empty? x) (empty? y)) 0)
+         (else (compare-length (tail x) (tail y)))))
+      (list-compare compare x y empty? head tail)))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare-as-vector default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare-as-vector compare         x y null?  car  cdr))
+    ((        x y              )
+     (list-compare-as-vector default-compare x y null?  car  cdr))))
+
+(define vector-compare
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((n (size x)) (m (size y)))
+         (refine-compare 
+          (integer-compare n m)
+          (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+            (if (= i n)
+                0
+                (refine-compare (compare (ref x i) (ref y i))
+                                (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare default-compare x y vector-length vector-ref)))))
+
+(define vector-compare-as-list
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((nx (size x)) (ny (size y)))
+         (let ((n (min nx ny)))
+           (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+             (if (= i n)
+                 (integer-compare nx ny)
+                 (refine-compare (compare (ref x i) (ref y i))
+                                 (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare-as-list default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare-as-list compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare-as-list default-compare x y vector-length vector-ref)))))
+
+
+; default compare
+
+(define (default-compare x y)
+  (select-compare 
+   x y
+   (null?    0)
+   (pair?    (default-compare (car x) (car y))
+	     (default-compare (cdr x) (cdr y)))
+   (boolean? (boolean-compare x y))
+   (char?    (char-compare    x y))
+   (string?  (string-compare  x y))
+   (symbol?  (symbol-compare  x y))
+   (number?  (number-compare  x y))
+   (vector?  (vector-compare default-compare x y))
+   (else (error "unrecognized type in default-compare" x y))))
+
+; Note that we pass default-compare to compare-{pair,vector} explictly.
+; This makes sure recursion proceeds with this default-compare, which 
+; need not be the one in the lexical scope of compare-{pair,vector}.
+
+
+; debug compare
+
+(define (debug-compare c)
+  
+  (define (checked-value c x y)
+    (let ((c-xy (c x y)))
+      (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1))
+          c-xy
+          (error "compare value not in {-1,0,1}" c-xy (list c x y)))))
+  
+  (define (random-boolean)
+    (zero? (random-integer 2)))
+  
+  (define q ; (u v w) such that u <= v, v <= w, and not u <= w
+    '#(
+       ;x < y   x = y   x > y   [x < z]
+       0       0       0    ; y < z
+               0    (z y x) (z y x) ; y = z
+               0    (z y x) (z y x) ; y > z
+               
+               ;x < y   x = y   x > y   [x = z]
+               (y z x) (z x y)    0    ; y < z
+               (y z x)    0    (x z y) ; y = z
+               0    (y x z) (x z y) ; y > z
+               
+               ;x < y   x = y   x > y   [x > z]
+               (x y z) (x y z)    0    ; y < z
+               (x y z) (x y z)    0    ; y = z
+               0       0       0    ; y > z
+               ))
+  
+  (let ((z? #f) (z #f)) ; stored element from previous call
+    (lambda (x y)
+      (let ((c-xx (checked-value c x x))
+	    (c-yy (checked-value c y y))
+	    (c-xy (checked-value c x y))
+	    (c-yx (checked-value c y x)))
+	(if (not (zero? c-xx))
+	    (error "compare error: not reflexive" c x))
+	(if (not (zero? c-yy))
+	    (error "compare error: not reflexive" c y))
+	(if (not (zero? (+ c-xy c-yx)))
+	    (error "compare error: not anti-symmetric" c x y))
+	(if z?
+	    (let ((c-xz (checked-value c x z))
+		  (c-zx (checked-value c z x))
+		  (c-yz (checked-value c y z))
+		  (c-zy (checked-value c z y)))
+	      (if (not (zero? (+ c-xz c-zx)))
+		  (error "compare error: not anti-symmetric" c x z))
+	      (if (not (zero? (+ c-yz c-zy)))
+		  (error "compare error: not anti-symmetric" c y z))
+	      (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13))))
+		(if (list? ijk)
+		    (apply error
+			   "compare error: not transitive"
+			   c 
+			   (map (lambda (i) (case i ((x) x) ((y) y) ((z) z)))
+				ijk)))))
+	    (set! z? #t))
+	(set! z (if (random-boolean) x y)) ; randomized testing
+	c-xy))))
+;;; srfi-69.scm --- Basic hash tables
+
+;; 	Copyright (C) 2007 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:
+
+;; My `hash' is compatible with core `hash', so I replace it.
+;; However, my `hash-table?' and `make-hash-table' are different, so
+;; importing this module will warn about them.  If you don't rename my
+;; imports, you shouldn't use both my hash tables and Guile's hash
+;; tables in the same module.
+;;
+;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
+;; are compatible with my `string-hash' and `string-ci-hash', and are
+;; furthermore primitive in Guile, so I use them as my own.
+;;
+;; I also have the extension of allowing hash functions that require a
+;; second argument to be used as the `hash-table-hash-function', and use
+;; these in defaults to avoid an indirection in the hashx functions.  The
+;; only deviation this causes is:
+;;
+;;  ((hash-table-hash-function (make-hash-table)) obj)
+;;  error> Wrong number of arguments to #<primitive-procedure hash>
+;;
+;; I don't think that SRFI 69 actually specifies that I *can't* do this,
+;; because it only implies the signature of a hash function by way of the
+;; named, exported hash functions.  However, if this matters enough I can
+;; add a private derivation of hash-function to the srfi-69:hash-table
+;; record type, like associator is to equivalence-function.
+;;
+;; Also, outside of the issue of how weak keys and values are referenced
+;; outside the table, I always interpret key equivalence to be that of
+;; the `hash-table-equivalence-function'.  For example, given the
+;; requirement that `alist->hash-table' give earlier associations
+;; priority, what should these answer?
+;;
+;;  (hash-table-keys
+;;   (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
+;;
+;;  (let ((ht (make-hash-table string-ci=?)))
+;;    (hash-table-set! ht "xY" 2)
+;;    (hash-table-set! ht "Xy" 1)
+;;    (hash-table-keys ht))
+;;
+;; My interpretation is that they can answer either ("Xy") or ("xY"),
+;; where `hash-table-values' will of course always answer (1), because
+;; the keys are the same according to the equivalence function.  In this
+;; implementation, both answer ("xY").  However, I don't guarantee that
+;; this won't change in the future.
+
+;;; Code:
+
+;;;; Module definition & exports
+
+(define-module (srfi srfi-69)
+  #\use-module (srfi srfi-1)	;alist-cons,second&c,assoc
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-13)	;string-hash,string-hash-ci
+  #\use-module (ice-9 optargs)
+  #\export (;; Type constructors & predicate
+	    make-hash-table hash-table? alist->hash-table
+	    ;; Reflective queries
+	    hash-table-equivalence-function hash-table-hash-function
+	    ;; Dealing with single elements
+	    hash-table-ref hash-table-ref/default hash-table-set!
+	    hash-table-delete! hash-table-exists? hash-table-update!
+	    hash-table-update!/default
+	    ;; Dealing with the whole contents
+	    hash-table-size hash-table-keys hash-table-values
+	    hash-table-walk hash-table-fold hash-table->alist
+	    hash-table-copy hash-table-merge!
+	    ;; Hashing
+	    string-ci-hash hash-by-identity)
+  #\re-export (string-hash)
+  #\replace (hash make-hash-table hash-table?))
+
+(cond-expand-provide (current-module) '(srfi-69))
+
+;;;; Internal helper macros
+
+;; Define these first, so the compiler will pick them up.
+
+;; I am a macro only for efficiency, to avoid varargs/apply.
+(define-macro (hashx-invoke hashx-proc ht-var . args)
+  "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
+assoc-function, and the hash-table as first args."
+  `(,hashx-proc (hash-table-hash-function ,ht-var)
+		(ht-associator ,ht-var)
+		(ht-real-table ,ht-var)
+		. ,args))
+
+(define-macro (with-hashx-values bindings ht-var . body-forms)
+  "Bind BINDINGS to the hash-function, associator, and real-table of
+HT-VAR, while evaluating BODY-FORMS."
+  `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
+	 (,(second bindings) (ht-associator ,ht-var))
+	 (,(third bindings) (ht-real-table ,ht-var)))
+     . ,body-forms))
+
+
+;;;; Hashing
+
+;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
+;;; though not documented anywhere but libguile/numbers.c.
+
+(define (caller-with-default-size hash-fn)
+  "Answer a function that makes `most-positive-fixnum' the default
+second argument to HASH-FN, a 2-arg procedure."
+  (lambda* (obj #\optional (size most-positive-fixnum))
+    (hash-fn obj size)))
+
+(define hash (caller-with-default-size (@ (guile) hash)))
+
+(define string-ci-hash string-hash-ci)
+
+(define hash-by-identity (caller-with-default-size hashq))
+
+;;;; Reflective queries, construction, predicate
+
+(define-record-type srfi-69:hash-table
+  (make-srfi-69-hash-table real-table associator size weakness
+			   equivalence-function hash-function)
+  hash-table?
+  (real-table ht-real-table)
+  (associator ht-associator)
+  ;; required for O(1) by SRFI-69.  It really makes a mess of things,
+  ;; and I'd like to compute it in O(n) and memoize it because it
+  ;; doesn't seem terribly useful, but SRFI-69 is final.
+  (size ht-size ht-size!)
+  ;; required for `hash-table-copy'
+  (weakness ht-weakness)
+  ;; used only to implement hash-table-equivalence-function; I don't
+  ;; use it internally other than for `ht-associator'.
+  (equivalence-function hash-table-equivalence-function)
+  (hash-function hash-table-hash-function))
+
+(define (guess-hash-function equal-proc)
+  "Guess a hash function for EQUAL-PROC, falling back on `hash', as
+specified in SRFI-69 for `make-hash-table'."
+  (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
+	((eq? eq? equal-proc) hashq)
+	((eq? eqv? equal-proc) hashv)
+	((eq? string=? equal-proc) string-hash)
+	((eq? string-ci=? equal-proc) string-ci-hash)
+	(else (@ (guile) hash))))
+
+(define (without-keyword-args rest-list)
+  "Answer REST-LIST with all keywords removed along with items that
+follow them."
+  (let lp ((acc '()) (rest-list rest-list))
+    (cond ((null? rest-list) (reverse! acc))
+	  ((keyword? (first rest-list))
+	   (lp acc (cddr rest-list)))
+	  (else (lp (cons (first rest-list) acc) (cdr rest-list))))))
+
+(define (guile-ht-ctor weakness)
+  "Answer the Guile HT constructor for the given WEAKNESS."
+  (case weakness
+    ((#f) (@ (guile) make-hash-table))
+    ((key) make-weak-key-hash-table)
+    ((value) make-weak-value-hash-table)
+    ((key-or-value) make-doubly-weak-hash-table)
+    (else (error "Invalid weak hash table type" weakness))))
+
+(define (equivalence-proc->associator equal-proc)
+  "Answer an `assoc'-like procedure that compares the argument key to
+alist keys with EQUAL-PROC."
+  (cond ((or (eq? equal? equal-proc)
+	     (eq? string=? equal-proc)) (@ (guile) assoc))
+	((eq? eq? equal-proc) assq)
+	((eq? eqv? equal-proc) assv)
+	(else (lambda (item alist)
+		(assoc item alist equal-proc)))))
+
+(define* (make-hash-table
+	  #\optional (equal-proc equal?)
+	  (hash-proc (guess-hash-function equal-proc))
+	  #\key (weak #f) #\rest guile-opts)
+  "Answer a new hash table using EQUAL-PROC as the comparison
+function, and HASH-PROC as the hash function.  See the reference
+manual for specifics, of which there are many."
+  (make-srfi-69-hash-table
+   (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
+   (equivalence-proc->associator equal-proc)
+   0 weak equal-proc hash-proc))
+
+(define (alist->hash-table alist . mht-args)
+  "Convert ALIST to a hash table created with MHT-ARGS."
+  (let* ((result (apply make-hash-table mht-args))
+	 (size (ht-size result)))
+    (with-hashx-values (hash-proc associator real-table) result
+      (for-each (lambda (pair)
+		  (let ((handle (hashx-get-handle hash-proc associator
+						  real-table (car pair))))
+		    (cond ((not handle)
+			   (set! size (1+ size))
+			   (hashx-set! hash-proc associator real-table
+				       (car pair) (cdr pair))))))
+		alist))
+    (ht-size! result size)
+    result))
+
+;;;; Accessing table items
+
+;; We use this to denote missing or unspecified values to avoid
+;; possible collision with *unspecified*.
+(define ht-unspecified (cons *unspecified* "ht-value"))
+
+(define (hash-table-ref ht key . default-thunk-lst)
+  "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
+isn't present, or signal an error if DEFAULT-THUNK isn't provided."
+  (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
+    (if (eq? ht-unspecified result)
+	(if (pair? default-thunk-lst)
+	    ((first default-thunk-lst))
+	    (error "Key not in table" key ht))
+	result)))
+
+(define (hash-table-ref/default ht key default)
+  "Lookup KEY in HT and answer the value.  Answer DEFAULT if KEY isn't
+present."
+  (hashx-invoke hashx-ref ht key default))
+
+(define (hash-table-set! ht key new-value)
+  "Set KEY to NEW-VALUE in HT."
+  (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
+    (if (eq? ht-unspecified (cdr handle))
+	(ht-size! ht (1+ (ht-size ht))))
+    (set-cdr! handle new-value))
+  *unspecified*)
+
+(define (hash-table-delete! ht key)
+  "Remove KEY's association in HT."
+  (with-hashx-values (h a real-ht) ht
+    (if (hashx-get-handle h a real-ht key)
+	(begin
+	  (ht-size! ht (1- (ht-size ht)))
+	  (hashx-remove! h a real-ht key))))
+  *unspecified*)
+
+(define (hash-table-exists? ht key)
+  "Return whether KEY is a key in HT."
+  (and (hashx-invoke hashx-get-handle ht key) #t))
+
+;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
+;;; avoid creating a handle in case DEFAULT-THUNK exits
+;;; `hash-table-update!' non-locally.
+(define (hash-table-update! ht key modifier . default-thunk-lst)
+  "Modify HT's value at KEY by passing its value to MODIFIER and
+setting it to the result thereof.  Invoke DEFAULT-THUNK for the old
+value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
+provided."
+  (with-hashx-values (hash-proc associator real-table) ht
+    (let ((handle (hashx-get-handle hash-proc associator real-table key)))
+      (cond (handle
+	     (set-cdr! handle (modifier (cdr handle))))
+	    (else
+	     (hashx-set! hash-proc associator real-table key
+			 (if (pair? default-thunk-lst)
+			     (modifier ((car default-thunk-lst)))
+			     (error "Key not in table" key ht)))
+	     (ht-size! ht (1+ (ht-size ht)))))))
+  *unspecified*)
+
+(define (hash-table-update!/default ht key modifier default)
+  "Modify HT's value at KEY by passing its old value, or DEFAULT if it
+doesn't have one, to MODIFIER, and setting it to the result thereof."
+  (hash-table-update! ht key modifier (lambda () default)))
+
+;;;; Accessing whole tables
+
+(define (hash-table-size ht)
+  "Return the number of associations in HT.  This is guaranteed O(1)
+for tables where #:weak was #f or not specified at creation time."
+  (if (ht-weakness ht)
+      (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
+      (ht-size ht)))
+
+(define (hash-table-keys ht)
+  "Return a list of the keys in HT."
+  (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))
+
+(define (hash-table-values ht)
+  "Return a list of the values in HT."
+  (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))
+
+(define (hash-table-walk ht proc)
+  "Call PROC with each key and value as two arguments."
+  (hash-table-fold ht (lambda (k v unspec)
+                        (call-with-values (lambda () (proc k v))
+                          (lambda vals unspec)))
+		   *unspecified*))
+
+(define (hash-table-fold ht f knil)
+  "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
+the result of the previous invocation, using KNIL as the first PREV.
+Answer the final F result."
+  (hash-fold f knil (ht-real-table ht)))
+
+(define (hash-table->alist ht)
+  "Return an alist for HT."
+  (hash-table-fold ht alist-cons '()))
+
+(define (hash-table-copy ht)
+  "Answer a copy of HT."
+  (with-hashx-values (h a real-ht) ht
+    (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
+	   (new-real-ht ((guile-ht-ctor weak) size)))
+      (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
+		 #f real-ht)
+      (make-srfi-69-hash-table		;real,assoc,size,weak,equiv,h
+       new-real-ht a size weak
+       (hash-table-equivalence-function ht) h))))
+
+(define (hash-table-merge! ht other-ht)
+  "Add all key/value pairs from OTHER-HT to HT, overriding HT's
+mappings where present.  Return HT."
+  (hash-table-fold
+   ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
+  ht)
+
+;;; srfi-69.scm ends here
+;;; 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
+;;; 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
+;;; srfi-9.scm --- define-record-type
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 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
+
+;;; 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 (throw-bad-struct s who)
+  (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) ...)))
+         (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
+                        #`(make-struct
+                           type-name 0
+                           #,@(map (lambda (getter index)
+                                     (lookup getter #`(struct-ref s #,index)))
+                                   #'(getter-id ...)
+                                   (iota (length #'(getter-id ...)))))))
+           (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-names)
+      (syntax-case constructor-spec ()
+        ((ctor field ...)
+         (every identifier? #'(field ...))
+         (let ((ctor-args (map (lambda (field)
+                                 (let ((name (syntax->datum field)))
+                                   (or (memq name field-names)
+                                       (syntax-violation
+                                        (syntax-case form ()
+                                          ((macro . args)
+                                           (syntax->datum #'macro)))
+                                        "unknown field in constructor spec"
+                                        form field))
+                                   (cons name field)))
+                               #'(field ...))))
+           #`(define-inlinable #,constructor-spec
+               (make-struct #,type-name 0
+                            #,@(map (lambda (name)
+                                      (assq-ref ctor-args name))
+                                    field-names)))))))
+
+    (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)
+      (let ((desc (if immutable? "pr" "pw")))
+        (string-concatenate (make-list count desc))))
+
+    (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))
+              (field-names (map syntax->datum field-ids))
+              (ctor-name   (syntax-case #'constructor-spec ()
+                             ((ctor args ...) #'ctor)))
+              (copier-id   (make-copier-id #'type-name)))
+         #`(begin
+             #,(constructor #'form #'type-name #'constructor-spec field-names)
+
+             (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
+;;; 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))))))
+;;; 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)))
+;;;; (statprof) -- a statistical profiler for Guile
+;;;; -*-scheme-*-
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2011, 2015  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;;;;    Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
+;;;; 
+;;;; 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{(statprof)} is intended to be a fairly simple
+;;statistical profiler for guile. It is in the early stages yet, so
+;;consider its output still suspect, and please report any bugs to
+;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at
+;;defaultvalue.org}.
+;;
+;;A simple use of statprof would look like this:
+;;
+;;@example
+;;  (statprof-reset 0 50000 #t)
+;;  (statprof-start)
+;;  (do-something)
+;;  (statprof-stop)
+;;  (statprof-display)
+;;@end example
+;;
+;;This would reset statprof, clearing all accumulated statistics, then
+;;start profiling, run some code, stop profiling, and finally display a
+;;gprof flat-style table of statistics which will look something like
+;;this:
+;;
+;;@example
+;;  %   cumulative      self              self    total
+;; time    seconds   seconds    calls  ms/call  ms/call  name
+;; 35.29      0.23      0.23     2002     0.11     0.11  -
+;; 23.53      0.15      0.15     2001     0.08     0.08  positive?
+;; 23.53      0.15      0.15     2000     0.08     0.08  +
+;; 11.76      0.23      0.08     2000     0.04     0.11  do-nothing
+;;  5.88      0.64      0.04     2001     0.02     0.32  loop
+;;  0.00      0.15      0.00        1     0.00   150.59  do-something
+;; ...
+;;@end example
+;;
+;;All of the numerical data with the exception of the calls column is
+;;statistically approximate. In the following column descriptions, and
+;;in all of statprof, "time" refers to execution time (both user and
+;;system), not wall clock time.
+;;
+;;@table @asis
+;;@item % time
+;;The percent of the time spent inside the procedure itself
+;;(not counting children).
+;;@item cumulative seconds
+;;The total number of seconds spent in the procedure, including
+;;children.
+;;@item self seconds
+;;The total number of seconds spent in the procedure itself (not counting
+;;children).
+;;@item calls
+;;The total number of times the procedure was called.
+;;@item self ms/call
+;;The average time taken by the procedure itself on each call, in ms.
+;;@item total ms/call
+;;The average time taken by each call to the procedure, including time
+;;spent in child functions.
+;;@item name
+;;The name of the procedure.
+;;@end table
+;;
+;;The profiler uses @code{eq?} and the procedure object itself to
+;;identify the procedures, so it won't confuse different procedures with
+;;the same name. They will show up as two different rows in the output.
+;;
+;;Right now the profiler is quite simplistic.  I cannot provide
+;;call-graphs or other higher level information.  What you see in the
+;;table is pretty much all there is. Patches are welcome :-)
+;;
+;;@section Implementation notes
+;;
+;;The profiler works by setting the unix profiling signal
+;;@code{ITIMER_PROF} to go off after the interval you define in the call
+;;to @code{statprof-reset}. When the signal fires, a sampling routine is
+;;run which looks at the current procedure that's executing, and then
+;;crawls up the stack, and for each procedure encountered, increments
+;;that procedure's sample count. Note that if a procedure is encountered
+;;multiple times on a given stack, it is only counted once. After the
+;;sampling is complete, the profiler resets profiling timer to fire
+;;again after the appropriate interval.
+;;
+;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
+;;how much CPU time (system and user -- which is also what
+;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing
+;;within a statprof-start/stop block.
+;;
+;;The profiler also tries to avoid counting or timing its own code as
+;;much as possible.
+;;
+;;; Code:
+
+;; When you add new features, please also add tests to ./tests/ if you
+;; have time, and then add the new files to ./run-tests.  Also, if
+;; anyone's bored, there are a lot of existing API bits that don't
+;; have tests yet.
+
+;; TODO
+;;
+;; Check about profiling C functions -- does profiling primitives work?
+;; Also look into stealing code from qprof so we can sample the C stack
+;; Call graphs?
+
+(define-module (statprof)
+  #\use-module (srfi srfi-1)
+  #\autoload   (ice-9 format) (format)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module (system vm program)
+  #\export (statprof-active?
+            statprof-start
+            statprof-stop
+            statprof-reset
+
+            statprof-accumulated-time
+            statprof-sample-count
+            statprof-fold-call-data
+            statprof-proc-call-data
+            statprof-call-data-name
+            statprof-call-data-calls
+            statprof-call-data-cum-samples
+            statprof-call-data-self-samples
+            statprof-call-data->stats
+           
+            statprof-stats-proc-name
+            statprof-stats-%-time-in-proc
+            statprof-stats-cum-secs-in-proc
+            statprof-stats-self-secs-in-proc
+            statprof-stats-calls
+            statprof-stats-self-secs-per-call
+            statprof-stats-cum-secs-per-call
+
+            statprof-display
+            statprof-display-anomolies
+
+            statprof-fetch-stacks
+            statprof-fetch-call-tree
+
+            statprof
+            with-statprof
+
+            gcprof))
+
+
+;; This profiler tracks two numbers for every function called while
+;; it's active.  It tracks the total number of calls, and the number
+;; of times the function was active when the sampler fired.
+;;
+;; Globally the profiler tracks the total time elapsed and the number
+;; of times the sampler was fired.
+;;
+;; Right now, this profiler is not per-thread and is not thread safe.
+
+(define accumulated-time #f)            ; total so far.
+(define last-start-time #f)             ; start-time when timer is active.
+(define sample-count #f)                ; total count of sampler calls.
+(define sampling-frequency #f)          ; in (seconds . microseconds)
+(define remaining-prof-time #f)         ; time remaining when prof suspended.
+(define profile-level 0)                ; for user start/stop nesting.
+(define %count-calls? #t)               ; whether to catch apply-frame.
+(define gc-time-taken 0)                ; gc time between statprof-start and
+                                        ; statprof-stop.
+(define record-full-stacks? #f)         ; if #t, stash away the stacks
+                                        ; for later analysis.
+(define stacks '())
+
+;; procedure-data will be a hash where the key is the function object
+;; itself and the value is the data. The data will be a vector like
+;; this: #(name call-count cum-sample-count self-sample-count)
+(define procedure-data #f)
+
+;; If you change the call-data data structure, you need to also change
+;; sample-uncount-frame.
+(define (make-call-data proc call-count cum-sample-count self-sample-count)
+  (vector proc call-count cum-sample-count self-sample-count))
+(define (call-data-proc cd) (vector-ref cd 0))
+(define (call-data-name cd) (procedure-name (call-data-proc cd)))
+(define (call-data-printable cd)
+  (or (call-data-name cd)
+      (with-output-to-string (lambda () (write (call-data-proc cd))))))
+(define (call-data-call-count cd) (vector-ref cd 1))
+(define (call-data-cum-sample-count cd) (vector-ref cd 2))
+(define (call-data-self-sample-count cd) (vector-ref cd 3))
+
+(define (inc-call-data-call-count! cd)
+  (vector-set! cd 1 (1+ (vector-ref cd 1))))
+(define (inc-call-data-cum-sample-count! cd)
+  (vector-set! cd 2 (1+ (vector-ref cd 2))))
+(define (inc-call-data-self-sample-count! cd)
+  (vector-set! cd 3 (1+ (vector-ref cd 3))))
+
+(define-macro (accumulate-time stop-time)
+  `(set! accumulated-time
+         (+ accumulated-time 0.0 (- ,stop-time last-start-time))))
+
+(define (get-call-data proc)
+  (let ((k (if (or (not (program? proc))
+                   (zero? (program-num-free-variables proc)))
+               proc
+               (program-objcode proc))))
+    (or (hashq-ref procedure-data k)
+        (let ((call-data (make-call-data proc 0 0 0)))
+          (hashq-set! procedure-data k call-data)
+          call-data))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SIGPROF handler
+
+(define (sample-stack-procs stack)
+  (let ((stacklen (stack-length stack))
+        (hit-count-call? #f))
+
+    (if record-full-stacks?
+        (set! stacks (cons stack stacks)))
+
+    (set! sample-count (+ sample-count 1))
+    ;; Now accumulate stats for the whole stack.
+    (let loop ((frame (stack-ref stack 0))
+               (procs-seen (make-hash-table 13))
+               (self #f))
+      (cond
+       ((not frame)
+        (hash-fold
+         (lambda (proc val accum)
+           (inc-call-data-cum-sample-count!
+            (get-call-data proc)))
+         #f
+         procs-seen)
+        (and=> (and=> self get-call-data)
+               inc-call-data-self-sample-count!))
+       ((frame-procedure frame)
+        => (lambda (proc)
+             (cond
+              ((eq? proc count-call)
+               ;; We're not supposed to be sampling count-call and
+               ;; its sub-functions, so loop again with a clean
+               ;; slate.
+               (set! hit-count-call? #t)
+               (loop (frame-previous frame) (make-hash-table 13) #f))
+              (else
+               (hashq-set! procs-seen proc #t)
+               (loop (frame-previous frame)
+                     procs-seen
+                     (or self proc))))))
+       (else
+        (loop (frame-previous frame) procs-seen self))))
+    hit-count-call?))
+
+(define inside-profiler? #f)
+
+(define (profile-signal-handler sig)
+  (set! inside-profiler? #t)
+
+  ;; FIXME: with-statprof should be able to set an outer frame for the
+  ;; stack cut
+  (if (positive? profile-level)
+      (let* ((stop-time (get-internal-run-time))
+             ;; cut down to the signal handler. note that this will only
+             ;; work if statprof.scm is compiled; otherwise we get
+             ;; `eval' on the stack instead, because if it's not
+             ;; compiled, profile-signal-handler is a thunk that
+             ;; tail-calls eval. perhaps we should always compile the
+             ;; signal handler instead...
+             (stack (or (make-stack #t profile-signal-handler)
+                        (pk 'what! (make-stack #t))))
+             (inside-apply-trap? (sample-stack-procs stack)))
+
+        (if (not inside-apply-trap?)
+            (begin
+              ;; disabling here is just a little more efficient, but
+              ;; not necessary given inside-profiler?.  We can't just
+              ;; disable unconditionally at the top of this function
+              ;; and eliminate inside-profiler? because it seems to
+              ;; confuse guile wrt re-enabling the trap when
+              ;; count-call finishes.
+              (if %count-calls?
+                  (set-vm-trace-level! (the-vm)
+                                       (1- (vm-trace-level (the-vm)))))
+              (accumulate-time stop-time)))
+        
+        (setitimer ITIMER_PROF
+                   0 0
+                   (car sampling-frequency)
+                   (cdr sampling-frequency))
+        
+        (if (not inside-apply-trap?)
+            (begin
+              (set! last-start-time (get-internal-run-time))
+              (if %count-calls?
+                  (set-vm-trace-level! (the-vm)
+                                       (1+ (vm-trace-level (the-vm)))))))))
+  
+  (set! inside-profiler? #f))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Count total calls.
+
+(define (count-call frame)
+  (if (not inside-profiler?)
+      (begin
+        (accumulate-time (get-internal-run-time))
+
+        (and=> (frame-procedure frame)
+               (lambda (proc)
+                 (inc-call-data-call-count!
+                  (get-call-data proc))))
+        
+        (set! last-start-time (get-internal-run-time)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (statprof-active?)
+  "Returns @code{#t} if @code{statprof-start} has been called more times
+than @code{statprof-stop}, @code{#f} otherwise."
+  (positive? profile-level))
+
+;; Do not call this from statprof internal functions -- user only.
+(define (statprof-start)
+  "Start the profiler.@code{}"
+  ;; After some head-scratching, I don't *think* I need to mask/unmask
+  ;; signals here, but if I'm wrong, please let me know.
+  (set! profile-level (+ profile-level 1))
+  (if (= profile-level 1)
+      (let* ((rpt remaining-prof-time)
+             (use-rpt? (and rpt
+                            (or (positive? (car rpt))
+                                (positive? (cdr rpt))))))
+        (set! remaining-prof-time #f)
+        (set! last-start-time (get-internal-run-time))
+        (set! gc-time-taken
+              (cdr (assq 'gc-time-taken (gc-stats))))
+        (if use-rpt?
+            (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt))
+            (setitimer ITIMER_PROF
+                       0 0
+                       (car sampling-frequency)
+                       (cdr sampling-frequency)))
+        (if %count-calls?
+            (add-hook! (vm-apply-hook (the-vm)) count-call))
+        (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+        #t)))
+  
+;; Do not call this from statprof internal functions -- user only.
+(define (statprof-stop)
+  "Stop the profiler.@code{}"
+  ;; After some head-scratching, I don't *think* I need to mask/unmask
+  ;; signals here, but if I'm wrong, please let me know.
+  (set! profile-level (- profile-level 1))
+  (if (zero? profile-level)
+      (begin
+        (set! gc-time-taken
+              (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
+        (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
+        (if %count-calls?
+            (remove-hook! (vm-apply-hook (the-vm)) count-call))
+        ;; I believe that we need to do this before getting the time
+        ;; (unless we want to make things even more complicated).
+        (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
+        (accumulate-time (get-internal-run-time))
+        (set! last-start-time #f))))
+
+(define* (statprof-reset sample-seconds sample-microseconds count-calls?
+                         #\optional full-stacks?)
+  "Reset the statprof sampler interval to @var{sample-seconds} and
+@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
+instrument procedure calls as well as collecting statistical profiling
+data. If @var{full-stacks?} is true, collect all sampled stacks into a
+list for later analysis.
+
+Enables traps and debugging as necessary."
+  (if (positive? profile-level)
+      (error "Can't reset profiler while profiler is running."))
+  (set! %count-calls? count-calls?)
+  (set! accumulated-time 0)
+  (set! last-start-time #f)
+  (set! sample-count 0)
+  (set! sampling-frequency (cons sample-seconds sample-microseconds))
+  (set! remaining-prof-time #f)
+  (set! procedure-data (make-hash-table 131))
+  (set! record-full-stacks? full-stacks?)
+  (set! stacks '())
+  (sigaction SIGPROF profile-signal-handler)
+  #t)
+
+(define (statprof-fold-call-data proc init)
+  "Fold @var{proc} over the call-data accumulated by statprof. Cannot be
+called while statprof is active. @var{proc} should take two arguments,
+@code{(@var{call-data} @var{prior-result})}.
+
+Note that a given proc-name may appear multiple times, but if it does,
+it represents different functions with the same name."
+  (if (positive? profile-level)
+      (error "Can't call statprof-fold-called while profiler is running."))
+
+  (hash-fold
+   (lambda (key value prior-result)
+     (proc value prior-result))
+   init
+   procedure-data))
+
+(define (statprof-proc-call-data proc)
+  "Returns the call-data associated with @var{proc}, or @code{#f} if
+none is available."
+  (if (positive? profile-level)
+      (error "Can't call statprof-fold-called while profiler is running."))
+
+  (hashq-ref procedure-data proc))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stats
+
+(define (statprof-call-data->stats call-data)
+  "Returns an object of type @code{statprof-stats}."
+  ;; returns (vector proc-name
+  ;;                 %-time-in-proc
+  ;;                 cum-seconds-in-proc
+  ;;                 self-seconds-in-proc
+  ;;                 num-calls
+  ;;                 self-secs-per-call
+  ;;                 total-secs-per-call)
+
+  (let* ((proc-name (call-data-printable call-data))
+         (self-samples (call-data-self-sample-count call-data))
+         (cum-samples (call-data-cum-sample-count call-data))
+         (all-samples (statprof-sample-count))
+         (secs-per-sample (/ (statprof-accumulated-time)
+                             (statprof-sample-count)))
+         (num-calls (and %count-calls? (statprof-call-data-calls call-data))))
+
+    (vector proc-name
+            (* (/ self-samples all-samples) 100.0)
+            (* cum-samples secs-per-sample 1.0)
+            (* self-samples secs-per-sample 1.0)
+            num-calls
+            (and num-calls ;; maybe we only sampled in children
+                 (if (zero? self-samples) 0.0
+                     (/ (* self-samples secs-per-sample) 1.0 num-calls)))
+            (and num-calls ;; cum-samples must be positive
+                 (/ (* cum-samples secs-per-sample)
+                    1.0
+                    ;; num-calls might be 0 if we entered statprof during the
+                    ;; dynamic extent of the call
+                    (max num-calls 1))))))
+
+(define (statprof-stats-proc-name stats) (vector-ref stats 0))
+(define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
+(define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2))
+(define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3))
+(define (statprof-stats-calls stats) (vector-ref stats 4))
+(define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5))
+(define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stats-sorter x y)
+  (let ((diff (- (statprof-stats-self-secs-in-proc x)
+                 (statprof-stats-self-secs-in-proc y))))
+    (positive?
+     (if (= diff 0)
+         (- (statprof-stats-cum-secs-in-proc x)
+            (statprof-stats-cum-secs-in-proc y))
+         diff))))
+
+(define (statprof-display . port)
+  "Displays a gprof-like summary of the statistics collected. Unless an
+optional @var{port} argument is passed, uses the current output port."
+  (if (null? port) (set! port (current-output-port)))
+  
+  (cond
+   ((zero? (statprof-sample-count))
+    (format port "No samples recorded.\n"))
+   (else
+    (let* ((stats-list (statprof-fold-call-data
+                        (lambda (data prior-value)
+                          (cons (statprof-call-data->stats data)
+                                prior-value))
+                        '()))
+           (sorted-stats (sort stats-list stats-sorter)))
+
+      (define (display-stats-line stats)
+        (if %count-calls?
+            (format  port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f  "
+                     (statprof-stats-%-time-in-proc stats)
+                     (statprof-stats-cum-secs-in-proc stats)
+                     (statprof-stats-self-secs-in-proc stats)
+                     (statprof-stats-calls stats)
+                     (* 1000 (statprof-stats-self-secs-per-call stats))
+                     (* 1000 (statprof-stats-cum-secs-per-call stats)))
+            (format  port "~6,2f ~9,2f ~9,2f  "
+                     (statprof-stats-%-time-in-proc stats)
+                     (statprof-stats-cum-secs-in-proc stats)
+                     (statprof-stats-self-secs-in-proc stats)))
+        (display (statprof-stats-proc-name stats) port)
+        (newline port))
+    
+      (if %count-calls?
+          (begin
+            (format  port "~5a ~10a   ~7a ~8a ~8a ~8a  ~8@a\n"
+                     "%  " "cumulative" "self" "" "self" "total" "")
+            (format  port "~5a  ~9a  ~8a ~8a ~8a ~8a  ~8@a\n"
+                     "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
+          (begin
+            (format  port "~5a ~10a   ~7a  ~8@a\n"
+                     "%" "cumulative" "self" "")
+            (format  port "~5a  ~10a  ~7a  ~8@a\n"
+                     "time" "seconds" "seconds" "name")))
+
+      (for-each display-stats-line sorted-stats)
+
+      (display "---\n" port)
+      (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
+      (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
+                     (statprof-accumulated-time)
+                     (/ gc-time-taken 1.0 internal-time-units-per-second))))))
+
+(define (statprof-display-anomolies)
+  "A sanity check that attempts to detect anomolies in statprof's
+statistics.@code{}"
+  (statprof-fold-call-data
+   (lambda (data prior-value)
+     (if (and %count-calls?
+              (zero? (call-data-call-count data))
+              (positive? (call-data-cum-sample-count data)))
+         (simple-format #t
+                        "==[~A ~A ~A]\n"
+                        (call-data-name data)
+                        (call-data-call-count data)
+                        (call-data-cum-sample-count data))))
+   #f)
+  (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
+  (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
+
+(define (statprof-accumulated-time)
+  "Returns the time accumulated during the last statprof run.@code{}"
+  (if (positive? profile-level)
+      (error "Can't get accumulated time while profiler is running."))
+  (/ accumulated-time internal-time-units-per-second))
+
+(define (statprof-sample-count)
+  "Returns the number of samples taken during the last statprof run.@code{}"
+  (if (positive? profile-level)
+      (error "Can't get accumulated time while profiler is running."))
+  sample-count)
+
+(define statprof-call-data-name call-data-name)
+(define statprof-call-data-calls call-data-call-count)
+(define statprof-call-data-cum-samples call-data-cum-sample-count)
+(define statprof-call-data-self-samples call-data-self-sample-count)
+
+(define (statprof-fetch-stacks)
+  "Returns a list of stacks, as they were captured since the last call
+to @code{statprof-reset}.
+
+Note that stacks are only collected if the @var{full-stacks?} argument
+to @code{statprof-reset} is true."
+  stacks)
+
+(define procedure=?
+  (lambda (a b)
+    (cond
+     ((eq? a b))
+     ((and (program? a) (program? b))
+      (eq? (program-objcode a) (program-objcode b)))
+     (else
+      #f))))
+
+;; tree ::= (car n . tree*)
+
+(define (lists->trees lists equal?)
+  (let lp ((in lists) (n-terminal 0) (tails '()))
+    (cond
+     ((null? in)
+      (let ((trees (map (lambda (tail)
+                          (cons (car tail)
+                                (lists->trees (cdr tail) equal?)))
+                        tails)))
+        (cons (apply + n-terminal (map cadr trees))
+              (sort trees
+                    (lambda (a b) (> (cadr a) (cadr b)))))))
+     ((null? (car in))
+      (lp (cdr in) (1+ n-terminal) tails))
+     ((find (lambda (x) (equal? (car x) (caar in)))
+            tails)
+      => (lambda (tail)
+           (lp (cdr in)
+               n-terminal
+               (assq-set! tails
+                          (car tail)
+                          (cons (cdar in) (cdr tail))))))
+     (else
+      (lp (cdr in)
+          n-terminal
+          (acons (caar in) (list (cdar in)) tails))))))
+
+(define (stack->procedures stack)
+  (filter identity
+          (unfold-right (lambda (x) (not x))
+                        frame-procedure
+                        frame-previous
+                        (stack-ref stack 0))))
+
+(define (statprof-fetch-call-tree)
+  "Return a call tree for the previous statprof run.
+
+The return value is a list of nodes, each of which is of the type:
+@code
+ node ::= (@var{proc} @var{count} . @var{nodes})
+@end code"
+  (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
+
+(define* (statprof thunk #\key (loop 1) (hz 100) (count-calls? #f)
+                   (full-stacks? #f))
+  "Profile the execution of @var{thunk}, and return its return values.
+
+The stack will be sampled @var{hz} times per second, and the thunk
+itself will be called @var{loop} times.
+
+If @var{count-calls?} is true, all procedure calls will be recorded. This
+operation is somewhat expensive.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
+@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
+  (dynamic-wind
+    (lambda ()
+      (statprof-reset (inexact->exact (floor (/ 1 hz)))
+                      (inexact->exact (* 1e6 (- (/ 1 hz)
+                                                (floor (/ 1 hz)))))
+                      count-calls?
+                      full-stacks?)
+      (statprof-start))
+    (lambda ()
+      (let lp ((i      loop)
+               (result '()))
+        (if (zero? i)
+            (apply values result)
+            (call-with-values thunk
+              (lambda result
+                (lp (1- i) result))))))
+    (lambda ()
+      (statprof-stop)
+      (statprof-display)
+      (set! procedure-data #f))))
+
+(define-macro (with-statprof . args)
+  "Profile the expressions in the body, and return the body's return values.
+
+Keyword arguments:
+
+@table @code
+@item #:loop
+Execute the body @var{loop} number of times, or @code{#f} for no looping
+
+default: @code{#f}
+@item #:hz
+Sampling rate
+
+default: @code{20}
+@item #:count-calls?
+Whether to instrument each function call (expensive)
+
+default: @code{#f}
+@item #:full-stacks?
+Whether to collect away all sampled stacks into a list
+
+default: @code{#f}
+@end table"
+  (define (kw-arg-ref kw args def)
+    (cond
+     ((null? args) (error "Invalid macro body"))
+     ((keyword? (car args))
+      (if (eq? (car args) kw)
+          (cadr args)
+          (kw-arg-ref kw (cddr args) def)))
+     ((eq? kw #f def) ;; asking for the body
+      args)
+     (else def))) ;; kw not found
+  `((@ (statprof) statprof)
+    (lambda () ,@(kw-arg-ref #f args #f))
+    #\loop ,(kw-arg-ref #\loop args 1)
+    #\hz ,(kw-arg-ref #\hz args 100)
+    #\count-calls? ,(kw-arg-ref #\count-calls? args #f)
+    #\full-stacks? ,(kw-arg-ref #\full-stacks? args #f)))
+
+(define* (gcprof thunk #\key (loop 1) (full-stacks? #f))
+  "Do an allocation profile of the execution of @var{thunk}.
+
+The stack will be sampled soon after every garbage collection, yielding
+an approximate idea of what is causing allocation in your program.
+
+Since GC does not occur very frequently, you may need to use the
+@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
+times.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
+@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
+  
+  (define (reset)
+    (if (positive? profile-level)
+        (error "Can't reset profiler while profiler is running."))
+    (set! accumulated-time 0)
+    (set! last-start-time #f)
+    (set! sample-count 0)
+    (set! %count-calls? #f)
+    (set! procedure-data (make-hash-table 131))
+    (set! record-full-stacks? full-stacks?)
+    (set! stacks '()))
+
+  (define (gc-callback)
+    (cond
+     (inside-profiler?)
+     (else
+      (set! inside-profiler? #t)
+
+      ;; FIXME: should be able to set an outer frame for the stack cut
+      (let ((stop-time (get-internal-run-time))
+            ;; Cut down to gc-callback, and then one before (the
+            ;; after-gc async).  See the note in profile-signal-handler
+            ;; also.
+            (stack (or (make-stack #t gc-callback 0 1)
+                       (pk 'what! (make-stack #t)))))
+        (sample-stack-procs stack)
+        (accumulate-time stop-time)
+        (set! last-start-time (get-internal-run-time)))
+      
+      (set! inside-profiler? #f))))
+
+  (define (start)
+    (set! profile-level (+ profile-level 1))
+    (if (= profile-level 1)
+        (begin
+          (set! remaining-prof-time #f)
+          (set! last-start-time (get-internal-run-time))
+          (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
+          (add-hook! after-gc-hook gc-callback)
+          (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+          #t)))
+
+  (define (stop)
+    (set! profile-level (- profile-level 1))
+    (if (zero? profile-level)
+        (begin
+          (set! gc-time-taken
+                (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
+          (remove-hook! after-gc-hook gc-callback)
+          (accumulate-time (get-internal-run-time))
+          (set! last-start-time #f))))
+
+  (dynamic-wind
+    (lambda ()
+      (reset)
+      (start))
+    (lambda ()
+      (let lp ((i loop))
+        (if (not (zero? i))
+            (begin
+              (thunk)
+              (lp (1- i))))))
+    (lambda ()
+      (stop)
+      (statprof-display)
+      (set! procedure-data #f))))
+;;;; (sxml apply-templates) -- xslt-like transformation for sxml
+;;;;
+;;;; 	Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;    Copyright 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as apply-templates.scm.
+;;;; 
+;;;; 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:
+;;
+;; Pre-order traversal of a tree and creation of a new tree:
+;;
+;;@smallexample
+;;	apply-templates:: tree x <templates> -> <new-tree>
+;;@end smallexample
+;; where
+;;@smallexample
+;; <templates> ::= (<template> ...)
+;; <template>  ::= (<node-test> <node-test> ... <node-test> . <handler>)
+;; <node-test> ::= an argument to node-typeof? above
+;; <handler>   ::= <tree> -> <new-tree>
+;;@end smallexample
+;;
+;; This procedure does a @emph{normal}, pre-order traversal of an SXML
+;; tree.  It walks the tree, checking at each node against the list of
+;; matching templates.
+;;
+;; If the match is found (which must be unique, i.e., unambiguous), the
+;; corresponding handler is invoked and given the current node as an
+;; argument. The result from the handler, which must be a @code{<tree>},
+;; takes place of the current node in the resulting tree.
+;; 
+;; The name of the function is not accidental: it resembles rather
+;; closely an @code{apply-templates} function of XSLT.
+;;
+;;; Code:
+
+(define-module (sxml apply-templates)
+  #\use-module (sxml ssax)
+  #\use-module ((sxml xpath) \:hide (filter))
+                         
+  #\export (apply-templates))
+
+(define (apply-templates tree templates)
+
+		; Filter the list of templates. If a template does not
+		; contradict the given node (that is, its head matches
+		; the type of the node), chop off the head and keep the
+		; rest as the result. All contradicting templates are removed.
+  (define (filter-templates node templates)
+    (cond
+     ((null? templates) templates)
+     ((not (pair? (car templates)))  ; A good template must be a list
+      (filter-templates node (cdr templates)))
+     (((node-typeof? (caar templates)) node)
+      (cons (cdar templates) (filter-templates node (cdr templates))))
+     (else
+      (filter-templates node (cdr templates)))))
+
+		; Here <templates> ::= [<template> | <handler>]
+		; If there is a <handler> in the above list, it must
+		; be only one. If found, return it; otherwise, return #f
+  (define (find-handler templates)
+    (and (pair? templates)
+	 (cond
+	  ((procedure? (car templates))
+	   (if (find-handler (cdr templates))
+	       (error "ambiguous template match"))
+	   (car templates))
+	  (else (find-handler (cdr templates))))))
+
+  (let loop ((tree tree) (active-templates '()))
+   ;(cout "active-templates: " active-templates nl "tree: " tree nl)
+    (if (nodeset? tree)
+	(map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
+	(let ((still-active-templates 
+	       (append 
+		(filter-templates tree active-templates)
+		(filter-templates tree templates))))
+	  (cond 
+	   ;((null? still-active-templates) '())
+	   ((find-handler still-active-templates) =>
+	    (lambda (handler) (handler tree)))
+	   ((not (pair? tree)) '())
+	   (else
+	    (loop (cdr tree) still-active-templates)))))))
+
+;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
+;;; templates.scm ends here
+;;;; (sxml fold) -- transformation of sxml via fold operations
+;;;;
+;;;; 	Copyright (C) 2009, 2010  Free Software Foundation, Inc.
+;;;;    Written 2007 by Andy Wingo <wingo at pobox dot com>.
+;;;; 
+;;;; 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{(sxml fold)} defines a number of variants of the @dfn{fold}
+;; algorithm for use in transforming SXML trees. Additionally it defines
+;; the layout operator, @code{fold-layout}, which might be described as
+;; a context-passing variant of SSAX's @code{pre-post-order}.
+;;
+;;; Code:
+
+(define-module (sxml fold)
+  #\use-module (srfi srfi-1)
+  #\export (foldt
+            foldts
+            foldts*
+            fold-values
+            foldts*-values
+            fold-layout))
+
+(define (atom? x)
+  (not (pair? x)))
+
+(define (foldt fup fhere tree)
+  "The standard multithreaded tree fold.
+
+@var{fup} is of type [a] -> a. @var{fhere} is of type object -> a.
+"
+  (if (atom? tree)
+      (fhere tree)
+      (fup (map (lambda (kid)
+                  (foldt fup fhere kid))
+                tree))))
+
+(define (foldts fdown fup fhere seed tree)
+  "The single-threaded tree fold originally defined in SSAX.
+@xref{sxml ssax,,(sxml ssax)}, for more information."
+  (if (atom? tree)
+      (fhere seed tree)
+      (fup seed
+           (fold (lambda (kid kseed)
+                  (foldts fdown fup fhere kseed kid))
+                 (fdown seed tree)
+                 tree)
+           tree)))
+
+(define (foldts* fdown fup fhere seed tree)
+  "A variant of @ref{sxml fold foldts,,foldts} that allows pre-order
+tree rewrites. Originally defined in Andy Wingo's 2007 paper,
+@emph{Applications of fold to XML transformation}."
+  (if (atom? tree)
+      (fhere seed tree)
+      (call-with-values
+          (lambda () (fdown seed tree))
+        (lambda (kseed tree)
+          (fup seed
+               (fold (lambda (kid kseed)
+                       (foldts* fdown fup fhere
+                                kseed kid))
+                     kseed
+                     tree)
+               tree)))))
+
+(define (fold-values proc list . seeds)
+  "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued
+seeds. Note that the order of the arguments differs from that of
+@code{fold}."
+  (if (null? list)
+      (apply values seeds)
+      (call-with-values
+          (lambda () (apply proc (car list) seeds))
+        (lambda seeds
+          (apply fold-values proc (cdr list) seeds)))))
+
+(define (foldts*-values fdown fup fhere tree . seeds)
+  "A variant of @ref{sxml fold foldts*,,foldts*} that allows
+multi-valued seeds. Originally defined in Andy Wingo's 2007 paper,
+@emph{Applications of fold to XML transformation}."
+  (if (atom? tree)
+      (apply fhere tree seeds)
+      (call-with-values
+          (lambda () (apply fdown tree seeds))
+        (lambda (tree . kseeds)
+          (call-with-values
+              (lambda ()
+                (apply fold-values
+                       (lambda (tree . seeds)
+                         (apply foldts*-values
+                                fdown fup fhere tree seeds))
+                       tree kseeds))
+            (lambda kseeds
+              (apply fup tree (append seeds kseeds))))))))
+
+(define (assq-ref alist key default)
+  (cond ((assq key alist) => cdr)
+        (else default)))
+
+(define (fold-layout tree bindings params layout stylesheet)
+  "A traversal combinator in the spirit of SSAX's @ref{sxml transform
+pre-post-order,,pre-post-order}.
+
+@code{fold-layout} was originally presented in Andy Wingo's 2007 paper,
+@emph{Applications of fold to XML transformation}.
+
+@example
+bindings := (<binding>...)
+binding  := (<tag> <bandler-pair>...)
+          | (*default* . <post-handler>)
+          | (*text* . <text-handler>)
+tag      := <symbol>
+handler-pair := (pre-layout . <pre-layout-handler>)
+          | (post . <post-handler>)
+          | (bindings . <bindings>)
+          | (pre . <pre-handler>)
+          | (macro . <macro-handler>)
+@end example
+
+@table @var
+@item pre-layout-handler
+A function of three arguments:
+
+@table @var
+@item kids
+the kids of the current node, before traversal
+@item params
+the params of the current node
+@item layout
+the layout coming into this node
+@end table
+
+@var{pre-layout-handler} is expected to use this information to return a
+layout to pass to the kids. The default implementation returns the
+layout given in the arguments.
+
+@item post-handler
+A function of five arguments:
+@table @var
+@item tag
+the current tag being processed
+@item params
+the params of the current node
+@item layout
+the layout coming into the current node, before any kids were processed
+@item klayout
+the layout after processing all of the children
+@item kids
+the already-processed child nodes
+@end table
+
+@var{post-handler} should return two values, the layout to pass to the
+next node and the final tree.
+
+@item text-handler
+@var{text-handler} is a function of three arguments:
+@table @var
+@item text
+the string
+@item params
+the current params
+@item layout
+the current layout
+@end table
+
+@var{text-handler} should return two values, the layout to pass to the
+next node and the value to which the string should transform.
+@end table
+"
+  (define (err . args)
+    (error "no binding available" args))
+  (define (fdown tree bindings pcont params layout ret)
+    (define (fdown-helper new-bindings new-layout cont)
+      (let ((cont-with-tag (lambda args
+                             (apply cont (car tree) args)))
+            (bindings (if new-bindings
+                          (append new-bindings bindings)
+                          bindings))
+            (style-params (assq-ref stylesheet (car tree) '())))
+        (cond
+         ((null? (cdr tree))
+          (values
+           '() bindings cont-with-tag (cons style-params params) new-layout '()))
+         ((and (pair? (cadr tree)) (eq? (caadr tree) '@))
+          (let ((params (cons (append (cdadr tree) style-params) params)))
+            (values
+             (cddr tree) bindings cont-with-tag params new-layout '())))
+         (else
+          (values
+           (cdr tree) bindings cont-with-tag (cons style-params params) new-layout '())))))
+    (define (no-bindings)
+      (fdown-helper #f layout (assq-ref bindings '*default* err)))
+    (define (macro macro-handler)
+      (fdown (apply macro-handler tree)
+             bindings pcont params layout ret))
+    (define (pre pre-handler)
+      (values '() bindings 
+              (lambda (params layout old-layout kids)
+                (values layout (reverse kids)))
+              params layout (apply pre-handler tree)))
+    (define (have-bindings tag-bindings)
+      (fdown-helper
+       (assq-ref tag-bindings 'bindings #f)
+       ((assq-ref tag-bindings 'pre-layout
+                  (lambda (tag params layout)
+                    layout))
+        tree params layout)
+       (assq-ref tag-bindings 'post
+                 (assq-ref bindings '*default* err))))
+    (let ((tag-bindings (assq-ref bindings (car tree) #f)))
+      (cond
+       ((not tag-bindings) (no-bindings))
+       ((assq-ref tag-bindings 'macro #f) => macro)
+       ((assq-ref tag-bindings 'pre #f) => pre)
+       (else (have-bindings tag-bindings)))))
+  (define (fup tree bindings cont params layout ret
+               kbindings kcont kparams klayout kret)
+    (call-with-values
+        (lambda ()
+          (kcont kparams layout klayout (reverse kret)))
+      (lambda (klayout kret)
+        (values bindings cont params klayout (cons kret ret)))))
+  (define (fhere tree bindings cont params layout ret)
+    (call-with-values
+        (lambda ()
+          ((assq-ref bindings '*text* err) tree params layout))
+      (lambda (tlayout tret)
+        (values bindings cont params tlayout (cons tret ret)))))
+  (call-with-values
+      (lambda ()
+        (foldts*-values
+         fdown fup fhere tree bindings #f (cons params '()) layout '()))
+    (lambda (bindings cont params layout ret)
+      (values (car ret) layout))))
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (sxml match)
+  #\export (sxml-match
+            sxml-match-let
+            sxml-match-let*)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-11)
+  #\use-module (ice-9 control))
+
+
+;;; Commentary:
+;;;
+;;; This module provides an SXML pattern matcher, written by Jim Bender.  This
+;;; allows application code to match on SXML nodes and attributes without having
+;;; to deal with the details of s-expression matching, without worrying about
+;;; the order of attributes, etc.
+;;;
+;;; It is fully documented in the Guile Reference Manual.
+;;;
+;;; Code:
+
+
+
+;;;
+;;; PLT compatibility layer.
+;;;
+
+(define-syntax-rule (syntax-object->datum stx)
+  (syntax->datum stx))
+
+(define-syntax-rule (void)
+  *unspecified*)
+
+(define (raise-syntax-error x msg obj sub)
+  (throw 'sxml-match-error x msg obj sub))
+
+(define-syntax module
+  (syntax-rules (provide require)
+    ((_ name lang (provide p_ ...) (require r_ ...)
+        body ...)
+     (begin body ...))))
+
+
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24.  It was written by Jim Bender <benderjg2@aol.com> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+;;
+;; Modified the `sxml-match1' macro to allow multiple-value returns (upstream
+;; was notified.)
+
+(include-from-path "sxml/sxml-match.ss")
+
+;;; match.scm ends here
+;;;; (sxml simple) -- a simple interface to the SSAX parser
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2013  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Originally written by Oleg Kiselyov <oleg at pobox dot com> as SXML-to-HTML.scm.
+;;;; 
+;;;; 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:
+;;
+;;A simple interface to XML parsing and serialization.
+;;
+;;; Code:
+
+(define-module (sxml simple)
+  #\use-module (sxml ssax input-parse)
+  #\use-module (sxml ssax)
+  #\use-module (sxml transform)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-13)
+  #\export (xml->sxml sxml->xml sxml->string))
+
+;; Helpers from upstream/SSAX.scm.
+;;
+
+;     ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We can prove from the general case below that if LIST-OF-FRAGS
+; has zero or one element, the result of the procedure is equal?
+; to its argument. This fact justifies the shortcut evaluation below.
+(define (ssax:reverse-collect-str fragments)
+  (cond
+    ((null? fragments) '())	; a shortcut
+    ((null? (cdr fragments)) fragments) ; see the comment above
+    (else
+      (let loop ((fragments fragments) (result '()) (strs '()))
+	(cond
+	  ((null? fragments)
+	    (if (null? strs) result
+	      (cons (string-concatenate/shared strs) result)))
+	  ((string? (car fragments))
+	    (loop (cdr fragments) result (cons (car fragments) strs)))
+	  (else
+	    (loop (cdr fragments)
+	      (cons
+		(car fragments)
+		(if (null? strs) result
+		  (cons (string-concatenate/shared strs) result)))
+	      '())))))))
+
+(define (read-internal-doctype-as-string port)
+  (string-concatenate/shared
+    (let loop ()
+      (let ((fragment
+	     (next-token '() '(#\]) "reading internal DOCTYPE" port)))
+	(if (eqv? #\> (peek-next-char port))
+	    (begin
+	      (read-char port)
+	      (cons fragment '()))
+	    (cons* fragment "]" (loop)))))))
+
+;; Ideas for the future for this interface:
+;;
+;;  * Allow doctypes to provide parsed entities
+;;
+;;  * Allow validation (the ELEMENTS value from the DOCTYPE handler
+;;    below)
+;;
+;;  * Parse internal DTDs
+;;
+;;  * Parse external DTDs
+;;
+(define* (xml->sxml #\optional (string-or-port (current-input-port)) #\key
+                    (namespaces '())
+                    (declare-namespaces? #t)
+                    (trim-whitespace? #f)
+                    (entities '())
+                    (default-entity-handler #f)
+                    (doctype-handler #f))
+  "Use SSAX to parse an XML document into SXML. Takes one optional
+argument, @var{string-or-port}, which defaults to the current input
+port."
+  ;; NAMESPACES: alist of PREFIX -> URI.  Specifies the symbol prefix
+  ;; that the user wants on elements of a given namespace in the
+  ;; resulting SXML, regardless of the abbreviated namespaces defined in
+  ;; the document by xmlns attributes.  If DECLARE-NAMESPACES? is true,
+  ;; these namespaces are treated as if they were declared in the DTD.
+
+  ;; ENTITIES: alist of SYMBOL -> STRING.
+
+  ;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
+  ;; A DOC-PREFIX of #f indicates that it comes from the user.
+  ;; Otherwise, prefixes are symbols.
+  (define (munge-namespaces namespaces)
+    (map (lambda (el)
+           (match el
+             ((prefix . uri-string)
+              (cons* (and declare-namespaces? prefix)
+                     prefix
+                     (ssax:uri-string->symbol uri-string)))))
+         namespaces))
+
+  (define (user-namespaces)
+    (munge-namespaces namespaces))
+
+  (define (user-entities)
+    (if (and default-entity-handler
+             (not (assq '*DEFAULT* entities)))
+        (acons '*DEFAULT* default-entity-handler entities)
+        entities))
+
+  (define (name->sxml name)
+    (match name
+      ((prefix . local-part)
+       (symbol-append prefix (string->symbol ":") local-part))
+      (_ name)))
+
+  (define (doctype-continuation seed)
+    (lambda* (#\key (entities '()) (namespaces '()))
+      (values #f
+              (append entities (user-entities))
+              (append (munge-namespaces namespaces) (user-namespaces))
+              seed)))
+
+  ;; The SEED in this parser is the SXML: initialized to '() at each new
+  ;; level by the fdown handlers; built in reverse by the fhere parsers;
+  ;; and reverse-collected by the fup handlers.
+  (define parser
+    (ssax:make-parser
+     NEW-LEVEL-SEED ; fdown
+     (lambda (elem-gi attributes namespaces expected-content seed)
+       '())
+   
+     FINISH-ELEMENT ; fup
+     (lambda (elem-gi attributes namespaces parent-seed seed)
+       (let ((seed (if trim-whitespace?
+                       (ssax:reverse-collect-str-drop-ws seed)
+                       (ssax:reverse-collect-str seed)))
+             (attrs (attlist-fold
+                     (lambda (attr accum)
+                       (cons (list (name->sxml (car attr)) (cdr attr))
+                             accum))
+                     '() attributes)))
+         (acons (name->sxml elem-gi)
+                (if (null? attrs)
+                    seed
+                    (cons (cons '@ attrs) seed))
+                parent-seed)))
+
+     CHAR-DATA-HANDLER ; fhere
+     (lambda (string1 string2 seed)
+       (if (string-null? string2)
+           (cons string1 seed)
+           (cons* string2 string1 seed)))
+
+     DOCTYPE
+     ;; -> ELEMS ENTITIES NAMESPACES SEED
+     ;;
+     ;; ELEMS is for validation and currently unused.
+     ;;
+     ;; ENTITIES is an alist of parsed entities (symbol -> string).
+     ;;
+     ;; NAMESPACES is as above.
+     ;;
+     ;; SEED builds up the content.
+     (lambda (port docname systemid internal-subset? seed)
+       (call-with-values
+           (lambda ()
+             (cond
+              (doctype-handler
+               (doctype-handler docname systemid
+                                (and internal-subset?
+                                     (read-internal-doctype-as-string port))))
+              (else
+               (when internal-subset?
+                 (ssax:skip-internal-dtd port))
+               (values))))
+         (doctype-continuation seed)))
+
+     UNDECL-ROOT
+     ;; This is like the DOCTYPE handler, but for documents that do not
+     ;; have a <!DOCTYPE!> entry.
+     (lambda (elem-gi seed)
+       (call-with-values
+           (lambda ()
+             (if doctype-handler
+                 (doctype-handler #f #f #f)
+                 (values)))
+        (doctype-continuation seed)))
+
+     PI
+     ((*DEFAULT*
+       . (lambda (port pi-tag seed)
+           (cons
+            (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+            seed))))))
+
+  (let* ((port (if (string? string-or-port)
+                   (open-input-string string-or-port)
+                   string-or-port))
+         (elements (reverse (parser port '()))))
+    `(*TOP* ,@elements)))
+
+(define check-name
+  (let ((*good-cache* (make-hash-table)))
+    (lambda (name)
+      (if (not (hashq-ref *good-cache* name))
+          (let* ((str (symbol->string name))
+                 (i (string-index str #\:))
+                 (head (or (and i (substring str 0 i)) str))
+                 (tail (and i (substring str (1+ i)))))
+            (and i (string-index (substring str (1+ i)) #\:)
+                 (error "Invalid QName: more than one colon" name))
+            (for-each
+             (lambda (s)
+               (and s
+                    (or (char-alphabetic? (string-ref s 0))
+                        (eq? (string-ref s 0) #\_)
+                        (error "Invalid name starting character" s name))
+                    (string-for-each
+                     (lambda (c)
+                       (or (char-alphabetic? c) (string-index "0123456789.-_" c)
+                           (error "Invalid name character" c s name)))
+                     s)))
+             (list head tail))
+            (hashq-set! *good-cache* name #t))))))
+
+;; The following two functions serialize tags and attributes. They are
+;; being used in the node handlers for the post-order function, see
+;; below.
+
+(define (attribute-value->xml value port)
+  (cond
+   ((pair? value)
+    (attribute-value->xml (car value) port)
+    (attribute-value->xml (cdr value) port))
+   ((null? value)
+    *unspecified*)
+   ((string? value)
+    (string->escaped-xml value port))
+   ((procedure? value)
+    (with-output-to-port port value))
+   (else
+    (string->escaped-xml
+     (call-with-output-string (lambda (port) (display value port)))
+     port))))
+
+(define (attribute->xml attr value port)
+  (check-name attr)
+  (display attr port)
+  (display "=\"" port)
+  (attribute-value->xml value port)
+  (display #\" port))
+
+(define (element->xml tag attrs body port)
+  (check-name tag)
+  (display #\< port)
+  (display tag port)
+  (if attrs
+      (let lp ((attrs attrs))
+        (if (pair? attrs)
+            (let ((attr (car attrs)))
+              (display #\space port)
+              (if (pair? attr)
+                  (attribute->xml (car attr) (cdr attr) port)
+                  (error "bad attribute" tag attr))
+              (lp (cdr attrs)))
+            (if (not (null? attrs))
+                (error "bad attributes" tag attrs)))))
+  (if (pair? body)
+      (begin
+        (display #\> port)
+        (let lp ((body body))
+          (cond
+           ((pair? body)
+            (sxml->xml (car body) port)
+            (lp (cdr body)))
+           ((null? body)
+            (display "</" port)
+            (display tag port)
+            (display ">" port))
+           (else
+            (error "bad element body" tag body)))))
+      (display " />" port)))
+
+;; FIXME: ensure name is valid
+(define (entity->xml name port)
+  (display #\& port)
+  (display name port)
+  (display #\; port))
+
+;; FIXME: ensure tag and str are valid
+(define (pi->xml tag str port)
+  (display "<?" port)
+  (display tag port)
+  (display #\space port)
+  (display str port)
+  (display "?>" port))
+
+(define* (sxml->xml tree #\optional (port (current-output-port)))
+  "Serialize the sxml tree @var{tree} as XML. The output will be written
+to the current output port, unless the optional argument @var{port} is
+present."
+  (cond
+   ((pair? tree)
+    (if (symbol? (car tree))
+        ;; An element.
+        (let ((tag (car tree)))
+          (case tag
+            ((*TOP*)
+             (sxml->xml (cdr tree) port))
+            ((*ENTITY*)
+             (if (and (list? (cdr tree)) (= (length (cdr tree)) 1))
+                 (entity->xml (cadr tree) port)
+                 (error "bad *ENTITY* args" (cdr tree))))
+            ((*PI*)
+             (if (and (list? (cdr tree)) (= (length (cdr tree)) 2))
+                 (pi->xml (cadr tree) (caddr tree) port)
+                 (error "bad *PI* args" (cdr tree))))
+            (else
+             (let* ((elems (cdr tree))
+                    (attrs (and (pair? elems) (pair? (car elems))
+                                (eq? '@ (caar elems))
+                                (cdar elems))))
+               (element->xml tag attrs (if attrs (cdr elems) elems) port)))))
+        ;; A nodelist.
+        (for-each (lambda (x) (sxml->xml x port)) tree)))
+   ((string? tree)
+    (string->escaped-xml tree port))
+   ((null? tree) *unspecified*)
+   ((not tree) *unspecified*)
+   ((eqv? tree #t) *unspecified*)
+   ((procedure? tree)
+    (with-output-to-port port tree))
+   (else
+    (string->escaped-xml
+     (call-with-output-string (lambda (port) (display tree port)))
+     port))))
+
+(define (sxml->string sxml)
+  "Detag an sxml tree @var{sxml} into a string. Does not perform any
+formatting."
+  (string-concatenate-reverse
+   (foldts
+    (lambda (seed tree)                 ; fdown
+      '())
+    (lambda (seed kid-seed tree)        ; fup
+      (append! kid-seed seed))
+    (lambda (seed tree)                 ; fhere
+      (if (string? tree) (cons tree seed) seed))
+    '()
+    sxml)))
+
+(define (make-char-quotator char-encoding)
+  (let ((bad-chars (list->char-set (map car char-encoding))))
+ 
+    ;; Check to see if str contains one of the characters in charset,
+    ;; from the position i onward. If so, return that character's index.
+    ;; otherwise, return #f
+    (define (index-cset str i charset)
+      (string-index str charset i))
+    
+    ;; The body of the function
+    (lambda (str port)
+      (let ((bad-pos (index-cset str 0 bad-chars)))
+        (if (not bad-pos)
+            (display str port)          ; str had all good chars
+            (let loop ((from 0) (to bad-pos))
+              (cond
+               ((>= from (string-length str)) *unspecified*)
+               ((not to)
+                (display (substring str from (string-length str)) port))
+               (else
+                (let ((quoted-char
+                       (cdr (assv (string-ref str to) char-encoding)))
+                      (new-to
+                       (index-cset str (+ 1 to) bad-chars)))
+                  (if (< from to)
+                      (display (substring str from to) port))
+                  (display quoted-char port)
+                  (loop (1+ to) new-to))))))))))
+
+;; Given a string, check to make sure it does not contain characters
+;; such as '<' or '&' that require encoding. Return either the original
+;; string, or a list of string fragments with special characters
+;; replaced by appropriate character entities.
+
+(define string->escaped-xml
+  (make-char-quotator
+   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
+
+;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
+;;; simple.scm ends here
+
+;;;; (sxml ssax) -- the SSAX parser
+;;;;
+;;;; 	Copyright (C) 2009, 2010,2012,2013  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm.
+;;;; 
+;;;; 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:
+;;
+;@subheading Functional XML parsing framework
+;@subsubheading SAX/DOM and SXML parsers with support for XML Namespaces and validation
+;
+; This is a package of low-to-high level lexing and parsing procedures
+; that can be combined to yield a SAX, a DOM, a validating parser, or
+; a parser intended for a particular document type. The procedures in
+; the package can be used separately to tokenize or parse various
+; pieces of XML documents. The package supports XML Namespaces,
+; internal and external parsed entities, user-controlled handling of
+; whitespace, and validation. This module therefore is intended to be
+; a framework, a set of "Lego blocks" you can use to build a parser
+; following any discipline and performing validation to any degree. As
+; an example of the parser construction, this file includes a
+; semi-validating SXML parser.
+
+; The present XML framework has a "sequential" feel of SAX yet a
+; "functional style" of DOM. Like a SAX parser, the framework scans the
+; document only once and permits incremental processing. An application
+; that handles document elements in order can run as efficiently as
+; possible. @emph{Unlike} a SAX parser, the framework does not require
+; an application register stateful callbacks and surrender control to
+; the parser. Rather, it is the application that can drive the framework
+; -- calling its functions to get the current lexical or syntax element.
+; These functions do not maintain or mutate any state save the input
+; port. Therefore, the framework permits parsing of XML in a pure
+; functional style, with the input port being a monad (or a linear,
+; read-once parameter).
+
+; Besides the @var{port}, there is another monad -- @var{seed}. Most of
+; the middle- and high-level parsers are single-threaded through the
+; @var{seed}. The functions of this framework do not process or affect
+; the @var{seed} in any way: they simply pass it around as an instance
+; of an opaque datatype. User functions, on the other hand, can use the
+; seed to maintain user's state, to accumulate parsing results, etc. A
+; user can freely mix his own functions with those of the framework. On
+; the other hand, the user may wish to instantiate a high-level parser:
+; @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter
+; case, the user must provide functions of specific signatures, which
+; are called at predictable moments during the parsing: to handle
+; character data, element data, or processing instructions (PI). The
+; functions are always given the @var{seed}, among other parameters, and
+; must return the new @var{seed}.
+
+; From a functional point of view, XML parsing is a combined
+; pre-post-order traversal of a "tree" that is the XML document
+; itself. This down-and-up traversal tells the user about an element
+; when its start tag is encountered. The user is notified about the
+; element once more, after all element's children have been
+; handled. The process of XML parsing therefore is a fold over the
+; raw XML document. Unlike a fold over trees defined in [1], the
+; parser is necessarily single-threaded -- obviously as elements
+; in a text XML document are laid down sequentially. The parser
+; therefore is a tree fold that has been transformed to accept an
+; accumulating parameter [1,2].
+
+; Formally, the denotational semantics of the parser can be expressed
+; as
+;@smallexample
+; parser:: (Start-tag -> Seed -> Seed) ->
+;	   (Start-tag -> Seed -> Seed -> Seed) ->
+;	   (Char-Data -> Seed -> Seed) ->
+;	   XML-text-fragment -> Seed -> Seed
+; parser fdown fup fchar "<elem attrs> content </elem>" seed
+;  = fup "<elem attrs>" seed
+;	(parser fdown fup fchar "content" (fdown "<elem attrs>" seed))
+;
+; parser fdown fup fchar "char-data content" seed
+;  = parser fdown fup fchar "content" (fchar "char-data" seed)
+;
+; parser fdown fup fchar "elem-content content" seed
+;  = parser fdown fup fchar "content" (
+;	parser fdown fup fchar "elem-content" seed)
+;@end smallexample
+
+; Compare the last two equations with the left fold
+;@smallexample
+; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
+;@end smallexample
+
+; The real parser created by @code{SSAX:make-parser} is slightly more
+; complicated, to account for processing instructions, entity
+; references, namespaces, processing of document type declaration, etc.
+
+
+; The XML standard document referred to in this module is
+;	@uref{http://www.w3.org/TR/1998/REC-xml-19980210.html}
+;
+; The present file also defines a procedure that parses the text of an
+; XML document or of a separate element into SXML, an S-expression-based
+; model of an XML Information Set. SXML is also an Abstract Syntax Tree
+; of an XML document. SXML is similar but not identical to DOM; SXML is
+; particularly suitable for Scheme-based XML/HTML authoring, SXPath
+; queries, and tree transformations. See SXML.html for more details.
+; SXML is a term implementation of evaluation of the XML document [3].
+; The other implementation is context-passing.
+
+; The present frameworks fully supports the XML Namespaces Recommendation:
+;	@uref{http://www.w3.org/TR/REC-xml-names/}
+; Other links:
+;@table @asis
+;@item [1]
+; Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
+; Proc. ICFP'98, 1998, pp. 273-279.
+;@item [2]
+; Richard S. Bird, The promotion and accumulation strategies in
+; transformational programming, ACM Trans. Progr. Lang. Systems,
+; 6(4):487-504, October 1984.
+;@item [3]
+; Ralf Hinze, "Deriving Backtracking Monad Transformers,"
+; Functional Pearl. Proc ICFP'00, pp. 186-197.
+;@end table
+;;
+;;; Code:
+
+(define-module (sxml ssax)
+  #\use-module (sxml ssax input-parse)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-13)
+
+  #\export     (current-ssax-error-port
+                with-ssax-error-to-port
+                xml-token? xml-token-kind xml-token-head
+                make-empty-attlist attlist-add
+                attlist-null?
+                attlist-remove-top
+                attlist->alist attlist-fold
+                define-parsed-entity!
+                reset-parsed-entity-definitions!
+                ssax:uri-string->symbol
+                ssax:skip-internal-dtd
+                ssax:read-pi-body-as-string
+                ssax:reverse-collect-str-drop-ws
+                ssax:read-markup-token
+                ssax:read-cdata-body
+                ssax:read-char-ref
+                ssax:read-attributes
+                ssax:complete-start-tag
+                ssax:read-external-id
+                ssax:read-char-data
+                ssax:xml->sxml
+                ssax:make-parser
+                ssax:make-pi-parser
+                ssax:make-elem-parser))
+
+(define (parser-error port message . rest)
+  (apply throw 'parser-error port message rest))
+(define ascii->char integer->char)
+(define char->ascii char->integer)
+
+(define current-ssax-error-port
+  (make-parameter (current-error-port)))
+
+(define *current-ssax-error-port*
+  (parameter-fluid current-ssax-error-port))
+
+(define (with-ssax-error-to-port port thunk)
+  (parameterize ((current-ssax-error-port port))
+    (thunk)))
+
+(define (ssax:warn port . args)
+  (with-output-to-port (current-ssax-error-port)
+    (lambda ()
+      (display ";;; SSAX warning: ")
+      (for-each display args)
+      (newline))))
+
+(define (ucscode->string codepoint)
+  (string (integer->char codepoint)))
+
+(define char-newline #\newline)
+(define char-return #\return)
+(define char-tab #\tab)
+(define nl "\n")
+
+;; This isn't a great API, but a more proper fix will involve hacking
+;; SSAX.
+(define (reset-parsed-entity-definitions!)
+  "Restore the set of parsed entity definitions to its initial state."
+  (set! ssax:predefined-parsed-entities
+        '((amp . "&")
+          (lt . "<")
+          (gt . ">")
+          (apos . "'")
+          (quot . "\""))))
+
+(define (define-parsed-entity! entity str)
+  "Define a new parsed entity. @var{entity} should be a symbol.
+
+Instances of &@var{entity}; in XML text will be replaced with the
+string @var{str}, which will then be parsed."
+  (set! ssax:predefined-parsed-entities
+        (acons entity str ssax:predefined-parsed-entities)))
+
+;; Execute a sequence of forms and return the result of the _first_ one.
+;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with
+;; side effects and return a value that must be computed before some or
+;; all of the side effects happen.
+(define-syntax begin0
+  (syntax-rules ()
+    ((begin0 form form1 ... ) 
+      (let ((val form)) form1 ... val))))
+
+; Like let* but allowing for multiple-value bindings
+(define-syntax let*-values
+  (syntax-rules ()
+    ((let*-values () . bodies) (begin . bodies))
+    ((let*-values (((var) initializer) . rest) . bodies)
+      (let ((var initializer))		; a single var optimization
+	(let*-values rest . bodies)))
+    ((let*-values ((vars initializer) . rest) . bodies)
+      (call-with-values (lambda () initializer) ; the most generic case
+	(lambda vars (let*-values rest . bodies))))))
+
+;; needed for some dumb reason
+(define inc 1+)
+(define dec 1-)
+
+(define-syntax include-from-path/filtered
+  (lambda (x)
+    (define (read-filtered accept-list file)
+      (with-input-from-file (%search-load-path file)
+        (lambda ()
+          (let loop ((sexp (read)) (out '()))
+            (cond
+             ((eof-object? sexp) (reverse out))
+             ((and (pair? sexp) (memq (car sexp) accept-list))
+              (loop (read) (cons sexp out)))
+             (else
+              (loop (read) out)))))))
+    (syntax-case x ()
+      ((_ accept-list file)
+       (with-syntax (((exp ...) (datum->syntax
+                                 x 
+                                 (read-filtered
+                                  (syntax->datum #'accept-list)
+                                  (syntax->datum #'file)))))
+         #'(begin exp ...))))))
+
+(include-from-path "sxml/upstream/assert.scm")
+(include-from-path/filtered
+ (define define-syntax ssax:define-labeled-arg-macro)
+ "sxml/upstream/SSAX.scm")
+;;;; (sxml ssax input-parse) -- a simple lexer
+;;;;
+;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as input-parse.scm.
+;;;; 
+;;;; 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:
+;;
+;; A simple lexer.
+;;
+;; The procedures in this module surprisingly often suffice to parse an
+;; input stream. They either skip, or build and return tokens, according
+;; to inclusion or delimiting semantics. The list of characters to
+;; expect, include, or to break at may vary from one invocation of a
+;; function to another. This allows the functions to easily parse even
+;; context-sensitive languages.
+;;
+;; EOF is generally frowned on, and thrown up upon if encountered.
+;; Exceptions are mentioned specifically. The list of expected
+;; characters (characters to skip until, or break-characters) may
+;; include an EOF "character", which is to be coded as the symbol,
+;; @code{*eof*}.
+;;
+;; The input stream to parse is specified as a @dfn{port}, which is
+;; usually the last (and optional) argument. It defaults to the current
+;; input port if omitted.
+;;
+;; If the parser encounters an error, it will throw an exception to the
+;; key @code{parser-error}. The arguments will be of the form
+;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
+;;
+;; The first argument is a port, which typically points to the offending
+;; character or its neighborhood. You can then use @code{port-column}
+;; and @code{port-line} to query the current position. @var{message} is
+;; the description of the error. Other arguments supply more details
+;; about the problem.
+;;
+;;; Code:
+
+(define-module (sxml ssax input-parse)
+  #\use-module (ice-9 rdelim)
+  #\export (peek-next-char
+            assert-curr-char
+            skip-until
+            skip-while
+            next-token
+            next-token-of
+            read-text-line
+            read-string
+            find-string-from-port?))
+
+(define ascii->char integer->char)
+(define char->ascii char->integer)
+(define char-newline #\newline)
+(define char-return #\return)
+(define inc 1+)
+(define dec 1-)
+
+;; rewrite oleg's define-opt into define* style
+(define-macro (define-opt bindings body . body-rest)
+  (let* ((rev-bindings (reverse bindings))
+         (opt-bindings
+          (and (pair? rev-bindings) (pair? (car rev-bindings))
+               (eq? 'optional (caar rev-bindings))
+               (cdar rev-bindings))))
+    (if opt-bindings
+	`(define* ,(append (reverse (cons #\optional (cdr rev-bindings)))
+			  opt-bindings)
+	   ,body ,@body-rest)
+	`(define* ,bindings ,body ,@body-rest))))
+
+(define (parser-error port message . rest)
+  (apply throw 'parser-error port message rest))
+
+(include-from-path "sxml/upstream/input-parse.scm")
+
+;; This version for guile is quite speedy, due to read-delimited (which
+;; is implemented in C).
+(define-opt (next-token prefix-skipped-chars break-chars
+			(optional (comment "") (port (current-input-port))) )
+  (let ((delims (list->string (delete '*eof* break-chars))))
+    (if (eof-object? (if (null? prefix-skipped-chars)
+                         (peek-char port)
+                         (skip-while prefix-skipped-chars port)))
+        (if (memq '*eof* break-chars)
+            ""
+            (parser-error port "EOF while reading a token " comment))
+        (let ((token (read-delimited delims port 'peek)))
+          (if (and (eof-object? (peek-char port))
+                   (not (memq '*eof* break-chars)))
+              (parser-error port "EOF while reading a token " comment)
+              token)))))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+  (read-line port))
+
+;; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org)
+;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu)
+;; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu)
+;; Modified 2004 Andy Wingo <wingo at pobox dot com>
+;; This function is from SLIB's strsrch.scm, and is in the public domain.
+(define (find-string-from-port? str <input-port> . max-no-char)
+  "Looks for @var{str} in @var{<input-port>}, optionally within the
+first @var{max-no-char} characters."
+  (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
+  (letrec
+      ((no-chars-read 0)
+       (peeked? #f)
+       (my-peek-char			; Return a peeked char or #f
+        (lambda () (and (or (not (number? max-no-char))
+                            (< no-chars-read max-no-char))
+                        (let ((c (peek-char <input-port>)))
+                          (cond (peeked? c)
+                                ((eof-object? c) #f)
+                                ((procedure? max-no-char)
+                                 (set! peeked? #t)
+                                 (if (max-no-char c) #f c))
+                                ((eqv? max-no-char c) #f)
+                                (else c))))))
+       (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
+                          (set! no-chars-read  (+ 1 no-chars-read))))
+       (match-1st-char                  ; of the string str
+        (lambda ()
+          (let ((c (my-peek-char)))
+            (and c
+                 (begin (next-char)
+                        (if (char=? c (string-ref str 0))
+                            (match-other-chars 1)
+                            (match-1st-char)))))))
+       ;; There has been a partial match, up to the point pos-to-match
+       ;; (for example, str[0] has been found in the stream)
+       ;; Now look to see if str[pos-to-match] for would be found, too
+       (match-other-chars
+        (lambda (pos-to-match)
+          (if (>= pos-to-match (string-length str))
+              no-chars-read             ; the entire string has matched
+              (let ((c (my-peek-char)))
+                (and c
+                     (if (not (char=? c (string-ref str pos-to-match)))
+                         (backtrack 1 pos-to-match)
+                         (begin (next-char)
+                                (match-other-chars (+ 1 pos-to-match)))))))))
+
+       ;; There had been a partial match, but then a wrong char showed up.
+       ;; Before discarding previously read (and matched) characters, we check
+       ;; to see if there was some smaller partial match. Note, characters read
+       ;; so far (which matter) are those of str[0..matched-substr-len - 1]
+       ;; In other words, we will check to see if there is such i>0 that
+       ;; substr(str,0,j) = substr(str,i,matched-substr-len)
+       ;; where j=matched-substr-len - i
+       (backtrack
+        (lambda (i matched-substr-len)
+          (let ((j (- matched-substr-len i)))
+            (if (<= j 0)
+                ;; backed off completely to the begining of str
+                (match-1st-char)
+                (let loop ((k 0))
+                  (if (>= k j)
+                      (match-other-chars j) ; there was indeed a shorter match
+                      (if (char=? (string-ref str k)
+                                  (string-ref str (+ i k)))
+                          (loop (+ 1 k))
+                          (backtrack (+ 1 i) matched-substr-len))))))))
+       )
+    (match-1st-char)))
+;;;; (sxml transform) -- pre- and post-order sxml transformation
+;;;;
+;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as SXML-tree-trans.scm.
+;;;; 
+;;;; 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:
+;;
+;;@heading SXML expression tree transformers
+;
+;@subheading Pre-Post-order traversal of a tree and creation of a new tree
+;@smallexample
+;pre-post-order:: <tree> x <bindings> -> <new-tree>
+;@end smallexample
+; where
+;@smallexample
+; <bindings> ::= (<binding> ...)
+; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+;               (<trigger-symbol> *macro* . <handler>) |
+;		(<trigger-symbol> <new-bindings> . <handler>) |
+;		(<trigger-symbol> . <handler>)
+; <trigger-symbol> ::= XMLname | *text* | *default*
+; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+;@end smallexample
+;
+; The pre-post-order function visits the nodes and nodelists
+; pre-post-order (depth-first). For each @code{<Node>} of the form
+; @code{(@var{name} <Node> ...)}, it looks up an association with the
+; given @var{name} among its @var{<bindings>}. If failed,
+; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
+; an error if the latter attempt fails as well. Having found a binding,
+; the @code{pre-post-order} function first checks to see if the binding
+; is of the form
+;@smallexample
+;	(<trigger-symbol> *preorder* . <handler>)
+;@end smallexample
+;
+; If it is, the handler is 'applied' to the current node. Otherwise, the
+; pre-post-order function first calls itself recursively for each child
+; of the current node, with @var{<new-bindings>} prepended to the
+; @var{<bindings>} in effect. The result of these calls is passed to the
+; @var{<handler>} (along with the head of the current @var{<Node>}). To
+; be more precise, the handler is _applied_ to the head of the current
+; node and its processed children. The result of the handler, which
+; should also be a @code{<tree>}, replaces the current @var{<Node>}. If
+; the current @var{<Node>} is a text string or other atom, a special
+; binding with a symbol @code{*text*} is looked up.
+;
+; A binding can also be of a form
+;@smallexample
+;	(<trigger-symbol> *macro* . <handler>)
+;@end smallexample
+; This is equivalent to @code{*preorder*} described above. However, the
+; result is re-processed again, with the current stylesheet.
+;;
+;;; Code:
+
+(define-module (sxml transform)
+  #\export (SRV:send-reply
+            foldts
+            post-order
+            pre-post-order
+            replace-range))
+
+;; Upstream version:
+; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
+
+; Like let* but allowing for multiple-value bindings
+(define-macro (let*-values bindings . body)
+  (if (null? bindings) (cons 'begin body)
+      (apply
+       (lambda (vars initializer)
+	 (let ((cont 
+		(cons 'let*-values
+		      (cons (cdr bindings) body))))
+	   (cond
+	    ((not (pair? vars))		; regular let case, a single var
+	     `(let ((,vars ,initializer)) ,cont))
+	    ((null? (cdr vars))		; single var, see the prev case
+	     `(let ((,(car vars) ,initializer)) ,cont))
+	   (else			; the most generic case
+	    `(call-with-values (lambda () ,initializer)
+	      (lambda ,vars ,cont))))))
+       (car bindings))))
+
+(define (SRV:send-reply . fragments)
+  "Output the @var{fragments} to the current output port.
+
+The fragments are a list of strings, characters, numbers, thunks,
+@code{#f}, @code{#t} -- and other fragments. The function traverses the
+tree depth-first, writes out strings and characters, executes thunks,
+and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
+anything was written at all; otherwise the result is @code{#f} If
+@code{#t} occurs among the fragments, it is not written out but causes
+the result of @code{SRV:send-reply} to be @code{#t}."
+  (let loop ((fragments fragments) (result #f))
+    (cond
+      ((null? fragments) result)
+      ((not (car fragments)) (loop (cdr fragments) result))
+      ((null? (car fragments)) (loop (cdr fragments) result))
+      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
+      ((pair? (car fragments))
+        (loop (cdr fragments) (loop (car fragments) result)))
+      ((procedure? (car fragments))
+        ((car fragments))
+        (loop (cdr fragments) #t))
+      (else
+        (display (car fragments))
+        (loop (cdr fragments) #t)))))
+
+
+
+;------------------------------------------------------------------------
+;	          Traversal of an SXML tree or a grove:
+;			a <Node> or a <Nodelist>
+;
+; A <Node> and a <Nodelist> are mutually-recursive datatypes that
+; underlie the SXML tree:
+;	<Node> ::= (name . <Nodelist>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; 	<Nodelist> ::= (<Node> ...)
+; Nodelists, and Nodes other than text strings are both lists. A
+; <Nodelist> however is either an empty list, or a list whose head is
+; not a symbol (an atom in general). A symbol at the head of a node is
+; either an XML name (in which case it's a tag of an XML element), or
+; an administrative name such as '@'.
+; See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+;; see the commentary for docs
+(define (pre-post-order tree bindings)
+  (let* ((default-binding (assq '*default* bindings))
+	 (text-binding (or (assq '*text* bindings) default-binding))
+	 (text-handler			; Cache default and text bindings
+	   (and text-binding
+	     (if (procedure? (cdr text-binding))
+	         (cdr text-binding) (cddr text-binding)))))
+    (let loop ((tree tree))
+      (cond
+	((null? tree) '())
+	((not (pair? tree))
+	  (let ((trigger '*text*))
+	    (if text-handler (text-handler trigger tree)
+	      (error "Unknown binding for " trigger " and no default"))))
+	((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
+	(else				; tree is an SXML node
+	  (let* ((trigger (car tree))
+		 (binding (or (assq trigger bindings) default-binding)))
+	    (cond
+	      ((not binding) 
+		(error "Unknown binding for " trigger " and no default"))
+	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
+		(apply (cdr binding) trigger (map loop (cdr tree))))
+	      ((eq? '*preorder* (cadr binding))
+		(apply (cddr binding) tree))
+	      ((eq? '*macro* (cadr binding))
+		(loop (apply (cddr binding) tree)))
+	      (else			    ; (cadr binding) is a local binding
+		(apply (cddr binding) trigger 
+		  (pre-post-order (cdr tree) (append (cadr binding) bindings)))
+		))))))))
+
+; post-order is a strict subset of pre-post-order without *preorder*
+; (let alone *macro*) traversals. 
+; Now pre-post-order is actually faster than the old post-order.
+; The function post-order is deprecated and is aliased below for
+; backward compatibility.
+(define post-order pre-post-order)
+
+;------------------------------------------------------------------------
+;			Extended tree fold
+; tree = atom | (node-name tree ...)
+;
+; foldts fdown fup fhere seed (Leaf str) = fhere seed str
+; foldts fdown fup fhere seed (Nd kids) =
+;         fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
+
+; procedure fhere: seed -> atom -> seed
+; procedure fdown: seed -> node -> seed
+; procedure fup: parent-seed -> last-kid-seed -> node -> seed
+; foldts returns the final seed
+
+(define (foldts fdown fup fhere seed tree)
+  (cond
+   ((null? tree) seed)
+   ((not (pair? tree))		; An atom
+    (fhere seed tree))
+   (else
+    (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
+      (if (null? kids)
+	  (fup seed kid-seed tree)
+	  (loop (foldts fdown fup fhere kid-seed (car kids))
+		(cdr kids)))))))
+
+;------------------------------------------------------------------------
+; Traverse a forest depth-first and cut/replace ranges of nodes.
+;
+; The nodes that define a range don't have to have the same immediate
+; parent, don't have to be on the same level, and the end node of a
+; range doesn't even have to exist. A replace-range procedure removes
+; nodes from the beginning node of the range up to (but not including)
+; the end node of the range.  In addition, the beginning node of the
+; range can be replaced by a node or a list of nodes. The range of
+; nodes is cut while depth-first traversing the forest. If all
+; branches of the node are cut a node is cut as well.  The procedure
+; can cut several non-overlapping ranges from a forest.
+
+;	replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+; where
+;	type FOREST = (NODE ...)
+;	type NODE = Atom | (Name . FOREST) | FOREST
+;
+; The range of nodes is specified by two predicates, beg-pred and end-pred.
+;	beg-pred:: NODE -> #f | FOREST
+;	end-pred:: NODE -> #f | FOREST
+; The beg-pred predicate decides on the beginning of the range. The node
+; for which the predicate yields non-#f marks the beginning of the range
+; The non-#f value of the predicate replaces the node. The value can be a
+; list of nodes. The replace-range procedure then traverses the tree and skips
+; all the nodes, until the end-pred yields non-#f. The value of the end-pred
+; replaces the end-range node. The new end node and its brothers will be
+; re-scanned.
+; The predicates are evaluated pre-order. We do not descend into a node that
+; is marked as the beginning of the range.
+
+(define (replace-range beg-pred end-pred forest)
+
+  ; loop forest keep? new-forest
+  ; forest is the forest to traverse
+  ; new-forest accumulates the nodes we will keep, in the reverse
+  ; order
+  ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
+  ; traverse its children and keep those that are not in the skip range.
+  ; If keep? is #f, skip the current node if atomic. Otherwise,
+  ; traverse its children. If all children are skipped, skip the node
+  ; as well.
+
+  (define (loop forest keep? new-forest)
+    (if (null? forest) (values (reverse new-forest) keep?)
+	(let ((node (car forest)))
+	  (if keep?
+	      (cond			; accumulate mode
+	       ((beg-pred node) =>	; see if the node starts the skip range
+		(lambda (repl-branches)	; if so, skip/replace the node
+		  (loop (cdr forest) #f 
+			(append (reverse repl-branches) new-forest))))
+	       ((not (pair? node))	; it's an atom, keep it
+		(loop (cdr forest) keep? (cons node new-forest)))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node))) ; or is it a nodelist?
+		  ((new-kids keep?)		 ; traverse its children
+		   (loop (if node? (cdr node) node) #t '())))
+		 (loop (cdr forest) keep?
+		       (cons 
+			(if node? (cons (car node) new-kids) new-kids)
+			new-forest)))))
+	      ; skip mode
+	      (cond
+	       ((end-pred node) =>	; end the skip range
+		(lambda (repl-branches)	; repl-branches will be re-scanned
+		  (loop (append repl-branches (cdr forest)) #t
+			new-forest)))
+	       ((not (pair? node))	; it's an atom, skip it
+		(loop (cdr forest) keep? new-forest))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node)))  ; or is it a nodelist?
+		  ((new-kids keep?)		  ; traverse its children
+		   (loop (if node? (cdr node) node) #f '())))
+		 (loop (cdr forest) keep?
+		       (if (or keep? (pair? new-kids))
+			   (cons
+			    (if node? (cons (car node) new-kids) new-kids)
+			    new-forest)
+			   new-forest)		; if all kids are skipped
+		       ))))))))			; skip the node too
+  
+  (let*-values (((new-forest keep?) (loop forest #t '())))
+     new-forest))
+
+;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
+;;; transform.scm ends here
+;	Functional XML parsing framework: SAX/DOM and SXML parsers
+;	      with support for XML Namespaces and validation
+;
+; This is a package of low-to-high level lexing and parsing procedures
+; that can be combined to yield a SAX, a DOM, a validating parsers, or
+; a parser intended for a particular document type. The procedures in
+; the package can be used separately to tokenize or parse various
+; pieces of XML documents. The package supports XML Namespaces,
+; internal and external parsed entities, user-controlled handling of
+; whitespace, and validation. This module therefore is intended to be
+; a framework, a set of "Lego blocks" you can use to build a parser
+; following any discipline and performing validation to any degree. As
+; an example of the parser construction, this file includes a
+; semi-validating SXML parser.
+
+; The present XML framework has a "sequential" feel of SAX yet a
+; "functional style" of DOM. Like a SAX parser, the framework scans
+; the document only once and permits incremental processing. An
+; application that handles document elements in order can run as
+; efficiently as possible. _Unlike_ a SAX parser, the framework does
+; not require an application register stateful callbacks and surrender
+; control to the parser. Rather, it is the application that can drive
+; the framework -- calling its functions to get the current lexical or
+; syntax element. These functions do not maintain or mutate any state
+; save the input port. Therefore, the framework permits parsing of XML
+; in a pure functional style, with the input port being a monad (or a
+; linear, read-once parameter).
+
+; Besides the PORT, there is another monad -- SEED. Most of the
+; middle- and high-level parsers are single-threaded through the
+; seed. The functions of this framework do not process or affect the
+; SEED in any way: they simply pass it around as an instance of an
+; opaque datatype.  User functions, on the other hand, can use the
+; seed to maintain user's state, to accumulate parsing results, etc. A
+; user can freely mix his own functions with those of the
+; framework. On the other hand, the user may wish to instantiate a
+; high-level parser: ssax:make-elem-parser or ssax:make-parser.  In
+; the latter case, the user must provide functions of specific
+; signatures, which are called at predictable moments during the
+; parsing: to handle character data, element data, or processing
+; instructions (PI). The functions are always given the SEED, among
+; other parameters, and must return the new SEED.
+
+; From a functional point of view, XML parsing is a combined
+; pre-post-order traversal of a "tree" that is the XML document
+; itself. This down-and-up traversal tells the user about an element
+; when its start tag is encountered. The user is notified about the
+; element once more, after all element's children have been
+; handled. The process of XML parsing therefore is a fold over the
+; raw XML document. Unlike a fold over trees defined in [1], the
+; parser is necessarily single-threaded -- obviously as elements
+; in a text XML document are laid down sequentially. The parser
+; therefore is a tree fold that has been transformed to accept an
+; accumulating parameter [1,2].
+
+; Formally, the denotational semantics of the parser can be expressed
+; as
+; parser:: (Start-tag -> Seed -> Seed) ->
+;	   (Start-tag -> Seed -> Seed -> Seed) ->
+;	   (Char-Data -> Seed -> Seed) ->
+;	   XML-text-fragment -> Seed -> Seed
+; parser fdown fup fchar "<elem attrs> content </elem>" seed
+;  = fup "<elem attrs>" seed
+;	(parser fdown fup fchar "content" (fdown "<elem attrs>" seed))
+;
+; parser fdown fup fchar "char-data content" seed
+;  = parser fdown fup fchar "content" (fchar "char-data" seed)
+;
+; parser fdown fup fchar "elem-content content" seed
+;  = parser fdown fup fchar "content" (
+;	parser fdown fup fchar "elem-content" seed)
+
+; Compare the last two equations with the left fold
+; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
+
+; The real parser created my ssax:make-parser is slightly more complicated,
+; to account for processing instructions, entity references, namespaces,
+; processing of document type declaration, etc.
+
+
+; The XML standard document referred to in this module is
+;	http://www.w3.org/TR/1998/REC-xml-19980210.html
+;
+; The present file also defines a procedure that parses the text of an
+; XML document or of a separate element into SXML, an
+; S-expression-based model of an XML Information Set. SXML is also an
+; Abstract Syntax Tree of an XML document. SXML is similar
+; but not identical to DOM; SXML is particularly suitable for
+; Scheme-based XML/HTML authoring, SXPath queries, and tree
+; transformations. See SXML.html for more details.
+; SXML is a term implementation of evaluation of the XML document [3].
+; The other implementation is context-passing.
+
+; The present frameworks fully supports the XML Namespaces Recommendation:
+;	http://www.w3.org/TR/REC-xml-names/
+; Other links:
+; [1] Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
+; Proc. ICFP'98, 1998, pp. 273-279.
+; [2] Richard S. Bird, The promotion and accumulation strategies in
+; transformational programming, ACM Trans. Progr. Lang. Systems,
+; 6(4):487-504, October 1984.
+; [3] Ralf Hinze, "Deriving Backtracking Monad Transformers,"
+; Functional Pearl. Proc ICFP'00, pp. 186-197.
+
+; IMPORT
+; parser-error ssax:warn, see Handling of errors, below
+; functions declared in files util.scm, input-parse.scm and look-for-str.scm
+; char-encoding.scm for various platform-specific character-encoding functions.
+; From SRFI-13: string-concatenate/shared and string-concatenate-reverse/shared
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+
+; Handling of errors
+; This package relies on a function parser-error, which must be defined
+; by a user of the package. The function has the following signature:
+;	parser-error PORT MESSAGE SPECIALISING-MSG*
+; Many procedures of this package call 'parser-error' whenever a
+; parsing, well-formedness or validation error is encountered. The
+; first argument is a port, which typically points to the offending
+; character or its neighborhood. Most of the Scheme systems let the
+; user query a PORT for the current position. The MESSAGE argument
+; indicates a failed XML production or a failed XML constraint. The
+; latter is referred to by its anchor name in the XML Recommendation
+; or XML Namespaces Recommendation. The parsing library (e.g.,
+; next-token, assert-curr-char) invoke 'parser-error' as well, in
+; exactly the same way.  See input-parse.scm for more details.
+; See
+;	http://pair.com/lisovsky/download/parse-error.scm
+; for an excellent example of such a redefined parser-error function.
+;
+; In addition, the present code invokes a function ssax:warn
+;   ssax:warn PORT MESSAGE SPECIALISING-MSG*
+; to notify the user about warnings that are NOT errors but still
+; may alert the user.
+;
+; Again, parser-error and ssax:warn are supposed to be defined by the
+; user. However, if a run-test macro below is set to include
+; self-tests, this present code does provide the definitions for these
+; functions to allow tests to run.
+
+; Misc notes
+; It seems it is highly desirable to separate tests out in a dedicated
+; file.
+;
+; Jim Bender wrote on Mon, 9 Sep 2002 20:03:42 EDT on the SSAX-SXML
+; mailing list (message A fine-grained "lego")
+; The task was to record precise source location information, as PLT
+; does with its current XML parser. That parser records the start and
+; end location (filepos, line#, column#) for pi, elements, attributes,
+; chuncks of "pcdata".
+; As suggested above, though, in some cases I needed to be able force
+; open an interface that did not yet exist. For instance, I added an
+; "end-char-data-hook", which would be called at the end of char-data
+; fragment. This returns a function of type (seed -> seed) which is
+; invoked on the current seed only if read-char-data has indeed reached
+; the end of a block of char data (after reading a new token.
+; But the deepest interface that I needed to expose was that of reading
+; attributes. In the official distribution, this is not even a separate
+; function. Instead, it is embedded within SSAX:read-attributes.  This
+; required some small re-structuring as well.
+; This definitely will not be to everyone's taste (nor needed by most).
+; Certainly, the existing make-parser interface addresses most custom
+; needs. And likely 80-90 lines of a "link specification" to create a
+; parser from many tiny little lego blocks may please only a few, while
+; appalling others.
+; The code is available at http://celtic.benderweb.net/ssax-lego.plt or 
+; http://celtic.benderweb.net/ssax-lego.tar.gz
+; In the examples directory, I provide:
+; - a unit version of the make-parser interface,
+; - a simple SXML parser using that interface, 
+; - an SXML parser which directly uses the "new lego",
+; - a pseudo-SXML parser, which records source location information
+; - and lastly a parser which returns the structures used in PLT's xml 
+; collection, with source location information
+
+; $Id: SSAX.scm,v 5.1 2004/07/07 16:02:30 sperber Exp $
+;^^^^^^^^^
+
+
+	; See the Makefile in the ../tests directory
+	; (in particular, the rule vSSAX) for an example of how
+	; to run this code on various Scheme systems.
+	; See SSAX examples for many samples of using this code,
+	; again, on a variety of Scheme systems.
+	; See http://ssax.sf.net/
+
+
+; The following macro runs built-in test cases -- or does not run,
+; depending on which of the two cases below you commented out
+; Case 1: no tests:
+;(define-macro run-test (lambda body '(begin #f)))
+;(define-syntax run-test (syntax-rules () ((run-test . args) (begin #f))))
+
+; Case 2: with tests.
+; The following macro could've been defined just as
+; (define-macro run-test (lambda body `(begin (display "\n-->Test\n") ,@body)))
+;
+; Instead, it's more involved, to make up for case-insensitivity of
+; symbols on some Scheme systems. In Gambit, symbols are case
+; sensitive: (eq? 'A 'a) is #f and (eq? 'Aa (string->symbol "Aa")) is
+; #t.  On some systems, symbols are case-insensitive and just the
+; opposite is true.  Therefore, we introduce a notation '"ASymbol" (a
+; quoted string) that stands for a case-_sensitive_ ASymbol -- on any
+; R5RS Scheme system. This notation is valid only within the body of
+; run-test.
+; The notation is implemented by scanning the run-test's
+; body and replacing every occurrence of (quote "str") with the result
+; of (string->symbol "str"). We can do such a replacement at macro-expand
+; time (rather than at run time).
+
+; Here's the previous version of run-test, implemented as a low-level
+; macro. 
+; (define-macro run-test
+;   (lambda body
+;     (define (re-write body)
+;       (cond
+;        ((vector? body)
+; 	(list->vector (re-write (vector->list body))))
+;        ((not (pair? body)) body)
+;        ((and (eq? 'quote (car body)) (pair? (cdr body))
+; 	     (string? (cadr body)))
+; 	(string->symbol (cadr body)))
+;        (else (cons (re-write (car body)) (re-write (cdr body))))))
+;     (cons 'begin (re-write body))))
+;
+; For portability, it is re-written as syntax-rules. The syntax-rules
+; version is less powerful: for example, it can't handle
+; (case x (('"Foo") (do-on-Foo))) whereas the low-level macro
+; could correctly place a case-sensitive symbol at the right place.
+; We also do not scan vectors (because we don't use them here).
+; Twice-deep quasiquotes aren't handled either.
+; Still, the syntax-rules version satisfies our immediate needs.
+; Incidentally, I originally didn't believe that the macro below
+; was at all possible.
+; 
+; The macro is written in a continuation-passing style. A continuation
+; typically has the following structure: (k-head ! . args)
+; When the continuation is invoked, we expand into
+; (k-head <computed-result> . arg). That is, the dedicated symbol !
+; is the placeholder for the result.
+;
+; It seems that the most modular way to write the run-test macro would
+; be the following
+;
+; (define-syntax run-test
+;  (syntax-rules ()
+;   ((run-test . ?body)
+;     (letrec-syntax
+;       ((scan-exp			; (scan-exp body k)
+; 	 (syntax-rules (quote quasiquote !)
+; 	   ((scan-exp (quote (hd . tl)) k)
+; 	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+; 	   ((scan-exp (quote x) (k-head ! . args))
+; 	     (k-head 
+; 	       (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+; 	       . args))
+; 	   ((scan-exp (hd . tl) k)
+; 	     (scan-exp hd (do-tl ! scan-exp tl k)))
+; 	   ((scan-exp x (k-head ! . args))
+; 	     (k-head x . args))))
+; 	(do-tl
+; 	  (syntax-rules (!)
+; 	    ((do-tl processed-hd fn () (k-head ! . args))
+; 	      (k-head (processed-hd) . args))
+; 	    ((do-tl processed-hd fn old-tl k)
+; 	      (fn old-tl (do-cons ! processed-hd k)))))
+; 	...
+; 	(do-finish
+; 	  (syntax-rules ()
+; 	    ((do-finish (new-body)) new-body)
+; 	    ((do-finish new-body) (begin . new-body))))
+; 	...
+;       (scan-exp ?body (do-finish !))
+; ))))
+;
+; Alas, that doesn't work on all systems. We hit yet another dark
+; corner of the R5RS macros. The reason is that run-test is used in
+; the code below to introduce definitions. For example:
+; (run-test
+;  (define (ssax:warn port msg . other-msg)
+;    (apply cerr (cons* nl "Warning: " msg other-msg)))
+; )
+; This code expands to
+; (begin
+;    (define (ssax:warn port msg . other-msg) ...))
+; so the definition gets spliced in into the top level. Right?
+; Well, On Petite Chez Scheme it is so. However, many other systems
+; don't like this approach. The reason is that the invocation of
+; (run-test (define (ssax:warn port msg . other-msg) ...))
+; first expands into
+; (letrec-syntax (...) 
+;   (scan-exp ((define (ssax:warn port msg . other-msg) ...)) ...))
+; because of the presence of (letrec-syntax ...), the begin form that
+; is generated eventually is no longer at the top level! The begin
+; form in Scheme is an overloading of two distinct forms: top-level
+; begin and the other begin. The forms have different rules: for example,
+; (begin (define x 1)) is OK for a top-level begin but not OK for
+; the other begin. Some Scheme systems see the that the macro
+; (run-test ...) expands into (letrec-syntax ...) and decide right there
+; that any further (begin ...) forms are NOT top-level begin forms.
+; The only way out is to make sure all our macros are top-level.
+; The best approach <sigh> seems to be to make run-test one huge
+; top-level macro.
+
+
+(define-syntax run-test
+ (syntax-rules (define)
+   ((run-test "scan-exp" (define vars body))
+    (define vars (run-test "scan-exp" body)))
+   ((run-test "scan-exp" ?body)
+    (letrec-syntax
+      ((scan-exp			; (scan-exp body k)
+	 (syntax-rules (quote quasiquote !)
+	   ((scan-exp '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-exp (quote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quasiquote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quote x) (k-head ! . args))
+	     (k-head 
+	       (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	   ((scan-exp (hd . tl) k)
+	     (scan-exp hd (do-tl ! scan-exp tl k)))
+	   ((scan-exp x (k-head ! . args))
+	     (k-head x . args))))
+	(do-tl
+	  (syntax-rules (!)
+	    ((do-tl processed-hd fn () (k-head ! . args))
+	      (k-head (processed-hd) . args))
+	    ((do-tl processed-hd fn old-tl k)
+	      (fn old-tl (do-cons ! processed-hd k)))))
+	(do-cons
+	  (syntax-rules (!)
+	    ((do-cons processed-tl processed-hd (k-head ! . args))
+	      (k-head (processed-hd . processed-tl) . args))))
+	(do-wrap
+	  (syntax-rules (!)
+	    ((do-wrap val fn (k-head ! . args))
+	      (k-head (fn val) . args))))
+	(do-finish
+	  (syntax-rules ()
+	    ((do-finish new-body) new-body)))
+
+	(scan-lit-lst			; scan literal list
+	  (syntax-rules (quote unquote unquote-splicing !)
+	   ((scan-lit-lst '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-lit-lst (quote (hd . tl)) k)
+	     (do-tl quote scan-lit-lst ((hd . tl)) k))
+	   ((scan-lit-lst (unquote x) k)
+	     (scan-exp x (do-wrap ! unquote k)))
+	   ((scan-lit-lst (unquote-splicing x) k)
+	     (scan-exp x (do-wrap ! unquote-splicing k)))
+	   ((scan-lit-lst (quote x) (k-head ! . args))
+	     (k-head 
+	       ,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	    ((scan-lit-lst (hd . tl) k)
+	      (scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
+	    ((scan-lit-lst x (k-head ! . args))
+	      (k-head x . args))))
+	)
+      (scan-exp ?body (do-finish !))))
+  ((run-test body ...)
+   (begin
+     (run-test "scan-exp" body) ...))
+))
+
+;========================================================================
+;				Data Types
+
+; TAG-KIND
+;	a symbol 'START, 'END, 'PI, 'DECL, 'COMMENT, 'CDSECT
+;		or 'ENTITY-REF that identifies a markup token
+
+; UNRES-NAME
+;	a name (called GI in the XML Recommendation) as given in an xml
+;	document for a markup token: start-tag, PI target, attribute name.
+;	If a GI is an NCName, UNRES-NAME is this NCName converted into
+;	a Scheme symbol. If a GI is a QName, UNRES-NAME is a pair of
+;	symbols: (PREFIX . LOCALPART)
+
+; RES-NAME
+;	An expanded name, a resolved version of an UNRES-NAME.
+;	For an element or an attribute name with a non-empty namespace URI,
+;	RES-NAME is a pair of symbols, (URI-SYMB . LOCALPART).
+;	Otherwise, it's a single symbol.
+
+; ELEM-CONTENT-MODEL
+;	A symbol:
+;	ANY	  - anything goes, expect an END tag.
+;	EMPTY-TAG - no content, and no END-tag is coming
+;	EMPTY	  - no content, expect the END-tag as the next token
+;	PCDATA    - expect character data only, and no children elements
+;	MIXED
+;	ELEM-CONTENT
+
+; URI-SYMB
+;	A symbol representing a namespace URI -- or other symbol chosen
+;	by the user to represent URI. In the former case,
+;	URI-SYMB is created by %-quoting of bad URI characters and
+;	converting the resulting string into a symbol.
+
+; NAMESPACES
+;	A list representing namespaces in effect. An element of the list
+;	has one of the following forms:
+;	(PREFIX URI-SYMB . URI-SYMB) or
+;	(PREFIX USER-PREFIX . URI-SYMB)
+;		USER-PREFIX is a symbol chosen by the user
+;		to represent the URI.
+;	(#f USER-PREFIX . URI-SYMB)
+;		Specification of the user-chosen prefix and a URI-SYMBOL.
+;	(*DEFAULT* USER-PREFIX . URI-SYMB)
+;		Declaration of the default namespace
+;	(*DEFAULT* #f . #f)
+;		Un-declaration of the default namespace. This notation
+;		represents overriding of the previous declaration
+;	A NAMESPACES list may contain several elements for the same PREFIX.
+;	The one closest to the beginning of the list takes effect.
+
+; ATTLIST
+;	An ordered collection of (NAME . VALUE) pairs, where NAME is
+;	a RES-NAME or an UNRES-NAME. The collection is an ADT
+
+; STR-HANDLER
+;	A procedure of three arguments: STRING1 STRING2 SEED
+;	returning a new SEED
+;	The procedure is supposed to handle a chunk of character data
+;	STRING1 followed by a chunk of character data STRING2.
+;	STRING2 is a short string, often "\n" and even ""
+
+; ENTITIES
+;	An assoc list of pairs:
+;	   (named-entity-name . named-entity-body)
+;	where named-entity-name is a symbol under which the entity was
+;	declared, named-entity-body is either a string, or
+;	(for an external entity) a thunk that will return an
+;	input port (from which the entity can be read).
+;	named-entity-body may also be #f. This is an indication that a
+;	named-entity-name is currently being expanded. A reference to
+;	this named-entity-name will be an error: violation of the
+;	WFC nonrecursion.
+;
+;       As an extension to the original SSAX, Guile allows a
+;       named-entity-name of *DEFAULT* to indicate a fallback procedure,
+;       called as (FALLBACK PORT NAME).  The procedure should return a
+;       string.
+
+; XML-TOKEN -- a record
+
+; In Gambit, you can use the following declaration:
+; (define-structure xml-token kind head)
+; The following declaration is "standard" as it follows SRFI-9:
+;;(define-record-type  xml-token  (make-xml-token kind head)  xml-token?
+;;  (kind  xml-token-kind)
+;;  (head  xml-token-head) )
+; No field mutators are declared as SSAX is a pure functional parser
+;
+; But to make the code more portable, we define xml-token simply as
+; a pair. It suffices for us. Furthermore, xml-token-kind and xml-token-head
+; can be defined as simple procedures. However, they are declared as
+; macros below for efficiency.
+
+(define (make-xml-token kind head) (cons kind head))
+(define xml-token? pair?)
+(define-syntax xml-token-kind 
+  (syntax-rules () ((xml-token-kind token) (car token))))
+(define-syntax xml-token-head 
+  (syntax-rules () ((xml-token-head token) (cdr token))))
+
+; (define-macro xml-token-kind (lambda (token) `(car ,token)))
+; (define-macro xml-token-head (lambda (token) `(cdr ,token)))
+
+; This record represents a markup, which is, according to the XML
+; Recommendation, "takes the form of start-tags, end-tags, empty-element tags,
+; entity references, character references, comments, CDATA section delimiters,
+; document type declarations, and processing instructions."
+;
+;	kind -- a TAG-KIND
+;	head -- an UNRES-NAME. For xml-tokens of kinds 'COMMENT and
+;		'CDSECT, the head is #f
+;
+; For example,
+;	<P>  => kind='START, head='P
+;	</P> => kind='END, head='P
+;	<BR/> => kind='EMPTY-EL, head='BR
+;	<!DOCTYPE OMF ...> => kind='DECL, head='DOCTYPE
+;	<?xml version="1.0"?> => kind='PI, head='xml
+;	&my-ent; => kind = 'ENTITY-REF, head='my-ent
+; 
+; Character references are not represented by xml-tokens as these references
+; are transparently resolved into the corresponding characters.
+;
+
+
+
+; XML-DECL -- a record
+
+; The following is Gambit-specific, see below for a portable declaration
+;(define-structure xml-decl elems entities notations)
+
+; The record represents a datatype of an XML document: the list of
+; declared elements and their attributes, declared notations, list of
+; replacement strings or loading procedures for parsed general
+; entities, etc. Normally an xml-decl record is created from a DTD or
+; an XML Schema, although it can be created and filled in in many other
+; ways (e.g., loaded from a file).
+;
+; elems: an (assoc) list of decl-elem or #f. The latter instructs
+;	the parser to do no validation of elements and attributes.
+;
+; decl-elem: declaration of one element:
+;	(elem-name elem-content decl-attrs)
+;	elem-name is an UNRES-NAME for the element.
+;	elem-content is an ELEM-CONTENT-MODEL.
+;	decl-attrs is an ATTLIST, of (ATTR-NAME . VALUE) associations
+; !!!This element can declare a user procedure to handle parsing of an
+; element (e.g., to do a custom validation, or to build a hash of
+; IDs as they're encountered).
+;
+; decl-attr: an element of an ATTLIST, declaration of one attribute
+;	(attr-name content-type use-type default-value)
+;	attr-name is an UNRES-NAME for the declared attribute
+;	content-type is a symbol: CDATA, NMTOKEN, NMTOKENS, ...
+;		or a list of strings for the enumerated type.
+;	use-type is a symbol: REQUIRED, IMPLIED, FIXED
+;	default-value is a string for the default value, or #f if not given.
+;
+;
+
+; see a function make-empty-xml-decl to make a XML declaration entry
+; suitable for a non-validating parsing.
+
+
+;-------------------------
+; Utilities
+
+;   ssax:warn PORT MESSAGE SPECIALISING-MSG*
+; to notify the user about warnings that are NOT errors but still
+; may alert the user.
+; Result is unspecified.
+; We need to define the function to allow the self-tests to run.
+; Normally the definition of ssax:warn is to be provided by the user.
+(run-test
+ (define (ssax:warn port msg . other-msg)
+   (apply cerr (cons* nl "Warning: " msg other-msg)))
+)
+
+
+;   parser-error PORT MESSAGE SPECIALISING-MSG*
+; to let the user know of a syntax error or a violation of a
+; well-formedness or validation constraint.
+; Result is unspecified.
+; We need to define the function to allow the self-tests to run.
+; Normally the definition of parser-error is to be provided by the user.
+(run-test
+ (define (parser-error port msg . specializing-msgs)
+   (apply error (cons msg specializing-msgs)))
+)
+
+; The following is a function that is often used in validation tests,
+; to make sure that the computed result matches the expected one.
+; This function is a standard equal? predicate with one exception.
+; On Scheme systems where (string->symbol "A") and a symbol A
+; are the same, equal_? is precisely equal?
+; On other Scheme systems, we compare symbols disregarding their case.
+; Since this function is used only in tests, we don't have to
+; strive to make it efficient.
+(run-test
+ (define (equal_? e1 e2)
+   (if (eq? 'A (string->symbol "A")) (equal? e1 e2)
+       (cond
+	((symbol? e1)
+	 (and (symbol? e2) 
+	      (string-ci=? (symbol->string e1) (symbol->string e2))))
+	((pair? e1)
+	 (and (pair? e2)
+	      (equal_? (car e1) (car e2)) (equal_? (cdr e1) (cdr e2))))
+	((vector? e1)
+	 (and (vector? e2) (equal_? (vector->list e1) (vector->list e2))))
+	(else
+	 (equal? e1 e2)))))
+)
+
+; The following function, which is often used in validation tests,
+; lets us conveniently enter newline, CR and tab characters in a character
+; string.
+;	unesc-string: ESC-STRING -> STRING
+; where ESC-STRING is a character string that may contain
+;    %n  -- for #\newline
+;    %r  -- for #\return
+;    %t  -- for #\tab
+;    %%  -- for #\%
+;
+; The result of unesc-string is a character string with all %-combinations
+; above replaced with their character equivalents
+
+(run-test
+ (define (unesc-string str)
+   (call-with-input-string str
+     (lambda (port)
+       (let loop ((frags '()))
+	 (let* ((token (next-token '() '(#\% *eof*) "unesc-string" port))
+		(cterm (read-char port))
+		(frags (cons token frags)))
+	   (if (eof-object? cterm) (string-concatenate-reverse/shared frags)
+	     (let ((cchar (read-char port)))  ; char after #\%
+	       (if (eof-object? cchar)
+		 (error "unexpected EOF after reading % in unesc-string:" str)
+		 (loop
+		   (cons
+		     (case cchar
+		       ((#\n) (string #\newline))
+		       ((#\r) (string char-return))
+		       ((#\t) (string char-tab))
+		       ((#\%) "%")
+		       (else (error "bad %-char in unesc-string:" cchar)))
+		     frags))))))))))
+)
+	     
+
+; Test if a string is made of only whitespace
+; An empty string is considered made of whitespace as well
+(define (string-whitespace? str)
+  (let ((len (string-length str)))
+    (cond
+     ((zero? len) #t)
+     ((= 1 len) (char-whitespace? (string-ref str 0)))
+     ((= 2 len) (and (char-whitespace? (string-ref str 0))
+		     (char-whitespace? (string-ref str 1))))
+     (else
+      (let loop ((i 0))
+	(or (>= i len)
+	    (and (char-whitespace? (string-ref str i))
+		 (loop (inc i)))))))))
+
+; Find val in alist
+; Return (values found-el remaining-alist) or
+;	 (values #f alist)
+
+(define (assq-values val alist)
+  (let loop ((alist alist) (scanned '()))
+    (cond
+     ((null? alist) (values #f scanned))
+     ((equal? val (caar alist))
+      (values (car alist) (append scanned (cdr alist))))
+     (else
+      (loop (cdr alist) (cons (car alist) scanned))))))
+
+; From SRFI-1
+(define (fold-right kons knil lis1)
+    (let recur ((lis lis1))
+       (if (null? lis) knil
+	    (let ((head (car lis)))
+	      (kons head (recur (cdr lis)))))))
+
+; Left fold combinator for a single list
+(define (fold kons knil lis1)
+  (let lp ((lis lis1) (ans knil))
+    (if (null? lis) ans
+      (lp (cdr lis) (kons (car lis) ans)))))
+
+
+
+;========================================================================
+;		Lower-level parsers and scanners
+;
+; They deal with primitive lexical units (Names, whitespaces, tags)
+; and with pieces of more generic productions. Most of these parsers
+; must be called in appropriate context. For example, ssax:complete-start-tag
+; must be called only when the start-tag has been detected and its GI
+; has been read.
+
+;------------------------------------------------------------------------
+;			Low-level parsing code
+
+; Skip the S (whitespace) production as defined by
+; [3] S ::= (#x20 | #x9 | #xD | #xA)
+; The procedure returns the first not-whitespace character it
+; encounters while scanning the PORT. This character is left
+; on the input stream.
+
+(define ssax:S-chars (map ascii->char '(32 10 9 13)))
+
+(define (ssax:skip-S port)
+  (skip-while ssax:S-chars port))
+
+
+; Read a Name lexem and return it as string
+; [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':'
+;                  | CombiningChar | Extender
+; [5] Name ::= (Letter | '_' | ':') (NameChar)*
+;
+; This code supports the XML Namespace Recommendation REC-xml-names,
+; which modifies the above productions as follows:
+;
+; [4] NCNameChar ::= Letter | Digit | '.' | '-' | '_'
+;                       | CombiningChar | Extender
+; [5] NCName ::= (Letter | '_') (NCNameChar)*
+; As the Rec-xml-names says,
+; "An XML document conforms to this specification if all other tokens
+; [other than element types and attribute names] in the document which
+; are required, for XML conformance, to match the XML production for
+; Name, match this specification's production for NCName."
+; Element types and attribute names must match the production QName,
+; defined below.
+
+; Check to see if a-char may start a NCName
+(define (ssax:ncname-starting-char? a-char)
+  (and (char? a-char)
+    (or
+      (char-alphabetic? a-char)
+      (char=? #\_ a-char))))
+
+
+; Read a NCName starting from the current position in the PORT and
+; return it as a symbol.
+(define (ssax:read-NCName port)
+  (let ((first-char (peek-char port)))
+    (or (ssax:ncname-starting-char? first-char)
+      (parser-error port "XMLNS [4] for '" first-char "'")))
+  (string->symbol
+    (next-token-of
+      (lambda (c)
+        (cond
+          ((eof-object? c) #f)
+          ((char-alphabetic? c) c)
+          ((string-index "0123456789.-_" c) c)
+          (else #f)))
+      port)))
+
+; Read a (namespace-) Qualified Name, QName, from the current
+; position in the PORT.
+; From REC-xml-names:
+;	[6] QName ::= (Prefix ':')? LocalPart
+;	[7] Prefix ::= NCName
+;	[8] LocalPart ::= NCName
+; Return: an UNRES-NAME
+(define (ssax:read-QName port)
+  (let ((prefix-or-localpart (ssax:read-NCName port)))
+    (case (peek-char port)
+      ((#\:)			; prefix was given after all
+       (read-char port)		; consume the colon
+       (cons prefix-or-localpart (ssax:read-NCName port)))
+      (else prefix-or-localpart) ; Prefix was omitted
+      )))
+
+; The prefix of the pre-defined XML namespace
+(define ssax:Prefix-XML (string->symbol "xml"))
+
+(run-test
+ (assert (eq? '_
+		 (call-with-input-string "_" ssax:read-NCName)))
+ (assert (eq? '_
+		 (call-with-input-string "_" ssax:read-QName)))
+ (assert (eq? (string->symbol "_abc_")
+	      (call-with-input-string "_abc_;" ssax:read-NCName)))
+ (assert (eq? (string->symbol "_abc_")
+	      (call-with-input-string "_abc_;" ssax:read-QName)))
+ (assert (eq? (string->symbol "_a.b")
+	      (call-with-input-string "_a.b " ssax:read-QName)))
+ (assert (equal? (cons (string->symbol "_a.b") (string->symbol "d.1-ef-"))
+	      (call-with-input-string "_a.b:d.1-ef-;" ssax:read-QName)))
+ (assert (equal? (cons (string->symbol "a") (string->symbol "b"))
+	      (call-with-input-string "a:b:c" ssax:read-QName)))
+
+ (assert (failed? (call-with-input-string ":abc" ssax:read-NCName)))
+ (assert (failed? (call-with-input-string "1:bc" ssax:read-NCName)))
+)
+
+; Compare one RES-NAME or an UNRES-NAME with the other.
+; Return a symbol '<, '>, or '= depending on the result of
+; the comparison.
+; Names without PREFIX are always smaller than those with the PREFIX.
+(define name-compare
+  (letrec ((symbol-compare
+	    (lambda (symb1 symb2)
+	      (cond 
+	       ((eq? symb1 symb2) '=)
+	       ((string<? (symbol->string symb1) (symbol->string symb2))
+		'<)
+	       (else '>)))))
+    (lambda (name1 name2)
+      (cond
+       ((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2)
+			    '<))
+       ((symbol? name2) '>)
+       ((eq? name2 ssax:largest-unres-name) '<)
+       ((eq? name1 ssax:largest-unres-name) '>)
+       ((eq? (car name1) (car name2))	; prefixes the same
+	(symbol-compare (cdr name1) (cdr name2)))
+       (else (symbol-compare (car name1) (car name2)))))))
+
+; An UNRES-NAME that is postulated to be larger than anything that can occur in
+; a well-formed XML document.
+; name-compare enforces this postulate.
+(define ssax:largest-unres-name (cons 
+				  (string->symbol "#LARGEST-SYMBOL")
+				  (string->symbol "#LARGEST-SYMBOL")))
+
+(run-test
+ (assert (eq? '= (name-compare 'ABC 'ABC)))
+ (assert (eq? '< (name-compare 'ABC 'ABCD)))
+ (assert (eq? '> (name-compare 'XB 'ABCD)))
+ (assert (eq? '> (name-compare '(HTML . PRE) 'PRE)))
+ (assert (eq? '< (name-compare 'HTML '(HTML . PRE))))
+ (assert (eq? '= (name-compare '(HTML . PRE) '(HTML . PRE))))
+ (assert (eq? '< (name-compare '(HTML . PRE) '(XML . PRE))))
+ (assert (eq? '> (name-compare '(HTML . PRE) '(HTML . P))))
+ (assert (eq? '< (name-compare '(HTML . PRE) ssax:largest-unres-name)))
+ (assert (eq? '< (name-compare '(ZZZZ . ZZZ) ssax:largest-unres-name)))
+ (assert (eq? '> (name-compare ssax:largest-unres-name '(ZZZZ . ZZZ) )))
+)
+
+
+
+; procedure:	ssax:read-markup-token PORT
+; This procedure starts parsing of a markup token. The current position
+; in the stream must be #\<. This procedure scans enough of the input stream
+; to figure out what kind of a markup token it is seeing. The procedure returns
+; an xml-token structure describing the token. Note, generally reading
+; of the current markup is not finished! In particular, no attributes of
+; the start-tag token are scanned.
+;
+; Here's a detailed break out of the return values and the position in the PORT
+; when that particular value is returned:
+;	PI-token:	only PI-target is read.
+;			To finish the Processing Instruction and disregard it,
+;			call ssax:skip-pi. ssax:read-attributes may be useful
+;			as well (for PIs whose content is attribute-value
+;			pairs)
+;	END-token:	The end tag is read completely; the current position
+;			is right after the terminating #\> character.	
+;	COMMENT		is read and skipped completely. The current position
+;			is right after "-->" that terminates the comment.
+;	CDSECT		The current position is right after "<!CDATA["
+;			Use ssax:read-cdata-body to read the rest.
+;	DECL		We have read the keyword (the one that follows "<!")
+;			identifying this declaration markup. The current
+;			position is after the keyword (usually a
+;			whitespace character)
+;
+;	START-token	We have read the keyword (GI) of this start tag.
+;			No attributes are scanned yet. We don't know if this
+;			tag has an empty content either.
+;			Use ssax:complete-start-tag to finish parsing of
+;			the token.
+
+(define ssax:read-markup-token ; procedure ssax:read-markup-token port
+ (let ()
+  		; we have read "<!-". Skip through the rest of the comment
+		; Return the 'COMMENT token as an indication we saw a comment
+		; and skipped it.
+  (define (skip-comment port)
+    (assert-curr-char '(#\-) "XML [15], second dash" port)
+    (if (not (find-string-from-port? "-->" port))
+      (parser-error port "XML [15], no -->"))
+    (make-xml-token 'COMMENT #f))
+
+  		; we have read "<![" that must begin a CDATA section
+  (define (read-cdata port)
+    (assert (string=? "CDATA[" (read-string 6 port)))
+    (make-xml-token 'CDSECT #f))
+
+  (lambda (port)
+    (assert-curr-char '(#\<) "start of the token" port)
+    (case (peek-char port)
+      ((#\/) (read-char port)
+       (begin0 (make-xml-token 'END (ssax:read-QName port))
+	       (ssax:skip-S port)
+	       (assert-curr-char '(#\>) "XML [42]" port)))
+      ((#\?) (read-char port) (make-xml-token 'PI (ssax:read-NCName port)))
+      ((#\!)
+       (case (peek-next-char port)
+	 ((#\-) (read-char port) (skip-comment port))
+	 ((#\[) (read-char port) (read-cdata port))
+	 (else (make-xml-token 'DECL (ssax:read-NCName port)))))
+      (else (make-xml-token 'START (ssax:read-QName port)))))
+))
+
+
+; The current position is inside a PI. Skip till the rest of the PI
+(define (ssax:skip-pi port)      
+  (if (not (find-string-from-port? "?>" port))
+    (parser-error port "Failed to find ?> terminating the PI")))
+
+
+; The current position is right after reading the PITarget. We read the
+; body of PI and return is as a string. The port will point to the
+; character right after '?>' combination that terminates PI.
+; [16] PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
+
+(define (ssax:read-pi-body-as-string port)
+  (ssax:skip-S port)		; skip WS after the PI target name
+  (string-concatenate/shared
+    (let loop ()
+      (let ((pi-fragment
+	     (next-token '() '(#\?) "reading PI content" port)))
+	(if (eqv? #\> (peek-next-char port))
+	    (begin
+	      (read-char port)
+	      (cons pi-fragment '()))
+	    (cons* pi-fragment "?" (loop)))))))
+
+(run-test
+ (assert (equal? "p1 content "
+    (call-with-input-string "<?pi1  p1 content ?>"
+      (lambda (port)
+	(ssax:read-markup-token port)
+	(ssax:read-pi-body-as-string port)))))
+ (assert (equal? "pi2? content? ?"
+    (call-with-input-string "<?pi2 pi2? content? ??>"
+      (lambda (port)
+	(ssax:read-markup-token port)
+	(ssax:read-pi-body-as-string port)))))
+)
+
+;(define (ssax:read-pi-body-as-name-values port)
+
+; The current pos in the port is inside an internal DTD subset
+; (e.g., after reading #\[ that begins an internal DTD subset)
+; Skip until the "]>" combination that terminates this DTD
+(define (ssax:skip-internal-dtd port)      
+  (if (not (find-string-from-port? "]>" port))
+    (parser-error port
+		  "Failed to find ]> terminating the internal DTD subset")))
+
+
+; procedure+: 	ssax:read-cdata-body PORT STR-HANDLER SEED
+;
+; This procedure must be called after we have read a string "<![CDATA["
+; that begins a CDATA section. The current position must be the first
+; position of the CDATA body. This function reads _lines_ of the CDATA
+; body and passes them to a STR-HANDLER, a character data consumer.
+;
+; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
+; The first STRING1 argument to STR-HANDLER never contains a newline.
+; The second STRING2 argument often will. On the first invocation of
+; the STR-HANDLER, the seed is the one passed to ssax:read-cdata-body
+; as the third argument. The result of this first invocation will be
+; passed as the seed argument to the second invocation of the line
+; consumer, and so on. The result of the last invocation of the
+; STR-HANDLER is returned by the ssax:read-cdata-body.  Note a
+; similarity to the fundamental 'fold' iterator.
+;
+; Within a CDATA section all characters are taken at their face value,
+; with only three exceptions:
+;	CR, LF, and CRLF are treated as line delimiters, and passed
+;	as a single #\newline to the STR-HANDLER
+;	"]]>" combination is the end of the CDATA section.
+;	&gt; is treated as an embedded #\> character
+; Note, &lt; and &amp; are not specially recognized (and are not expanded)!
+
+(define ssax:read-cdata-body 
+  (let ((cdata-delimiters (list char-return #\newline #\] #\&)))
+
+    (lambda (port str-handler seed)
+      (let loop ((seed seed))
+	(let ((fragment (next-token '() cdata-delimiters
+				    "reading CDATA" port)))
+			; that is, we're reading the char after the 'fragment'
+     (case (read-char port)	
+       ((#\newline) (loop (str-handler fragment nl seed)))
+       ((#\])
+	(if (not (eqv? (peek-char port) #\]))
+	    (loop (str-handler fragment "]" seed))
+	    (let check-after-second-braket
+		((seed (if (string-null? fragment) seed
+			   (str-handler fragment "" seed))))
+	      (case (peek-next-char port)	; after the second bracket
+		((#\>) (read-char port)	seed)	; we have read "]]>"
+		((#\]) (check-after-second-braket
+			(str-handler "]" "" seed)))
+		(else (loop (str-handler "]]" "" seed)))))))
+       ((#\&)		; Note that #\& within CDATA may stand for itself
+	(let ((ent-ref 	; it does not have to start an entity ref
+               (next-token-of (lambda (c) 
+		 (and (not (eof-object? c)) (char-alphabetic? c) c)) port)))
+	  (cond		; "&gt;" is to be replaced with #\>
+	   ((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;))
+	    (read-char port)
+	    (loop (str-handler fragment ">" seed)))
+	   (else
+	    (loop 
+	     (str-handler ent-ref ""
+			  (str-handler fragment "&" seed)))))))
+       (else		; Must be CR: if the next char is #\newline, skip it
+         (if (eqv? (peek-char port) #\newline) (read-char port))
+         (loop (str-handler fragment nl seed)))
+       ))))))
+
+; a few lines of validation code
+(run-test (letrec
+  ((consumer (lambda (fragment foll-fragment seed)
+     (cons* (if (equal? foll-fragment (string #\newline))
+		" NL" foll-fragment) fragment seed)))
+   (test (lambda (str expected-result)
+	   (newline) (display "body: ") (write str)
+	   (newline) (display "Result: ")
+	   (let ((result
+		   (reverse 
+		     (call-with-input-string (unesc-string str)
+		       (lambda (port) (ssax:read-cdata-body port consumer '()))
+		       ))))
+	     (write result)
+	     (assert (equal? result expected-result)))))
+   )
+  (test "]]>" '())
+  (test "abcd]]>" '("abcd" ""))
+  (test "abcd]]]>" '("abcd" "" "]" ""))
+  (test "abcd]]]]>" '("abcd" "" "]" "" "]" ""))
+  (test "abcd]]]]]>" '("abcd" "" "]" "" "]" "" "]" ""))
+  (test "abcd]]]a]]>" '("abcd" "" "]" "" "]]" "" "a" ""))
+  (test "abc%r%ndef%n]]>" '("abc" " NL" "def" " NL"))
+  (test "%r%n%r%n]]>" '("" " NL" "" " NL"))
+  (test "%r%n%r%na]]>" '("" " NL" "" " NL" "a" ""))
+  (test "%r%r%r%na]]>" '("" " NL" "" " NL" "" " NL" "a" ""))
+  (test "abc&!!!]]>" '("abc" "&" "" "" "!!!" ""))
+  (test "abc]]&gt;&gt&amp;]]]&gt;and]]>"
+    '("abc" "" "]]" "" "" ">" "" "&" "gt" "" "" "&" "amp" "" ";" "" "]" ""
+      "]]" "" "" ">" "and" ""))
+))
+
+            
+; procedure+:	ssax:read-char-ref PORT
+;
+; [66]  CharRef ::=  '&#' [0-9]+ ';' 
+;                  | '&#x' [0-9a-fA-F]+ ';'
+;
+; This procedure must be called after we we have read "&#" 
+; that introduces a char reference.
+; The procedure reads this reference and returns the corresponding char
+; The current position in PORT will be after ";" that terminates
+; the char reference
+; Faults detected:
+;	WFC: XML-Spec.html#wf-Legalchar
+;
+; According to Section "4.1 Character and Entity References"
+; of the XML Recommendation:
+;  "[Definition: A character reference refers to a specific character
+;   in the ISO/IEC 10646 character set, for example one not directly
+;   accessible from available input devices.]"
+; Therefore, we use a ucscode->string function to convert a character
+; code into the character -- *regardless* of the current character
+; encoding of the input stream.
+
+(define (ssax:read-char-ref port)
+  (let* ((base
+           (cond ((eqv? (peek-char port) #\x) (read-char port) 16)
+                 (else 10)))
+         (name (next-token '() '(#\;) "XML [66]" port))
+         (char-code (string->number name base)))
+    (read-char port)	; read the terminating #\; char
+    (if (integer? char-code) (ucscode->string char-code)
+      (parser-error port "[wf-Legalchar] broken for '" name "'"))))
+
+
+; procedure+:	ssax:handle-parsed-entity PORT NAME ENTITIES 
+;		CONTENT-HANDLER STR-HANDLER SEED
+;
+; Expand and handle a parsed-entity reference
+; port - a PORT
+; name - the name of the parsed entity to expand, a symbol
+; entities - see ENTITIES
+; content-handler -- procedure PORT ENTITIES SEED
+;	that is supposed to return a SEED
+; str-handler - a STR-HANDLER. It is called if the entity in question
+; turns out to be a pre-declared entity
+;
+; The result is the one returned by CONTENT-HANDLER or STR-HANDLER
+; Faults detected:
+;	WFC: XML-Spec.html#wf-entdeclared
+;	WFC: XML-Spec.html#norecursion
+
+(define ssax:predefined-parsed-entities
+  `(
+    (,(string->symbol "amp") . "&")
+    (,(string->symbol "lt") . "<")
+    (,(string->symbol "gt") . ">")
+    (,(string->symbol "apos") . "'")
+    (,(string->symbol "quot") . "\"")))
+
+(define (ssax:handle-parsed-entity port name entities
+				   content-handler str-handler seed)
+  (cond	  ; First we check the list of the declared entities
+   ((assq name entities) =>
+    (lambda (decl-entity)
+      (let ((ent-body (cdr decl-entity)) ; mark the list to prevent recursion
+	    (new-entities (cons (cons name #f) entities)))
+	(cond
+	 ((string? ent-body)
+	  (call-with-input-string ent-body
+	     (lambda (port) (content-handler port new-entities seed))))
+	 ((procedure? ent-body)
+	  (let ((port (ent-body)))
+	    (begin0
+	     (content-handler port new-entities seed)
+	     (close-input-port port))))
+	 (else
+	  (parser-error port "[norecursion] broken for " name))))))
+   ((assq name ssax:predefined-parsed-entities)
+    => (lambda (decl-entity)
+         (str-handler (cdr decl-entity) "" seed)))
+   ((assq '*DEFAULT* entities) =>
+    (lambda (decl-entity)
+      (let ((fallback (cdr decl-entity))
+	    (new-entities (cons (cons name #f) entities)))
+	(cond
+	 ((procedure? fallback)
+          (call-with-input-string (fallback port name)
+	     (lambda (port) (content-handler port new-entities seed))))
+	 (else
+	  (parser-error port "[norecursion] broken for " name))))))
+   (else (parser-error port "[wf-entdeclared] broken for " name))))
+
+
+
+; The ATTLIST Abstract Data Type
+; Currently is implemented as an assoc list sorted in the ascending
+; order of NAMES.
+
+(define (make-empty-attlist) '())
+
+; Add a name-value pair to the existing attlist preserving the order
+; Return the new list, in the sorted ascending order.
+; Return #f if a pair with the same name already exists in the attlist
+
+(define (attlist-add attlist name-value)
+  (if (null? attlist) (cons name-value attlist)
+      (case (name-compare (car name-value) (caar attlist))
+	((=) #f)
+	((<) (cons name-value attlist))
+	(else (cons (car attlist) (attlist-add (cdr attlist) name-value)))
+	)))
+
+(define attlist-null? null?)
+
+; Given an non-null attlist, return a pair of values: the top and the rest
+(define (attlist-remove-top attlist)
+  (values (car attlist) (cdr attlist)))
+
+(define (attlist->alist attlist) attlist)
+(define attlist-fold fold)
+
+; procedure+:	ssax:read-attributes PORT ENTITIES
+;
+; This procedure reads and parses a production Attribute*
+; [41] Attribute ::= Name Eq AttValue
+; [10] AttValue ::=  '"' ([^<&"] | Reference)* '"' 
+;                 | "'" ([^<&'] | Reference)* "'"
+; [25] Eq ::= S? '=' S?
+;
+;
+; The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string)
+; pairs. The current character on the PORT is a non-whitespace character
+; that is not an ncname-starting character.
+;
+; Note the following rules to keep in mind when reading an 'AttValue'
+; "Before the value of an attribute is passed to the application
+; or checked for validity, the XML processor must normalize it as follows: 
+; - a character reference is processed by appending the referenced
+;   character to the attribute value 
+; - an entity reference is processed by recursively processing the
+;   replacement text of the entity [see ENTITIES]
+;   [named entities amp lt gt quot apos are assumed pre-declared]
+; - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20
+;   to the normalized value, except that only a single #x20 is appended for a
+;   "#xD#xA" sequence that is part of an external parsed entity or the
+;   literal entity value of an internal parsed entity 
+; - other characters are processed by appending them to the normalized value "
+;
+;
+; Faults detected:
+;	WFC: XML-Spec.html#CleanAttrVals
+;	WFC: XML-Spec.html#uniqattspec
+
+(define ssax:read-attributes  ; ssax:read-attributes port entities
+ (let ((value-delimeters (append ssax:S-chars '(#\< #\&))))
+		; Read the AttValue from the PORT up to the delimiter
+		; (which can be a single or double-quote character,
+		; or even a symbol *eof*)
+		; 'prev-fragments' is the list of string fragments, accumulated
+		; so far, in reverse order.
+		; Return the list of fragments with newly read fragments
+		; prepended.
+  (define (read-attrib-value delimiter port entities prev-fragments)
+    (let* ((new-fragments
+	    (cons (next-token '() (cons delimiter value-delimeters)
+		              "XML [10]" port)
+	     prev-fragments))
+	   (cterm (read-char port)))
+      (cond
+	((or (eof-object? cterm) (eqv? cterm delimiter))
+	  new-fragments)
+	((eqv? cterm char-return)	; treat a CR and CRLF as a LF
+	  (if (eqv? (peek-char port) #\newline) (read-char port))
+	  (read-attrib-value delimiter port entities
+	                     (cons " " new-fragments)))
+	((memv cterm ssax:S-chars)
+	  (read-attrib-value delimiter port entities
+	                     (cons " " new-fragments)))
+	((eqv? cterm #\&)
+	  (cond
+	    ((eqv? (peek-char port) #\#)
+	      (read-char port)
+	      (read-attrib-value delimiter port entities
+		(cons (ssax:read-char-ref port) new-fragments)))
+	    (else
+	      (read-attrib-value delimiter port entities
+		(read-named-entity port entities new-fragments)))))
+	(else (parser-error port "[CleanAttrVals] broken")))))
+
+		; we have read "&" that introduces a named entity reference.
+		; read this reference and return the result of
+		; normalizing of the corresponding string
+		; (that is, read-attrib-value is applied to the replacement
+		; text of the entity)
+		; The current position will be after ";" that terminates
+		; the entity reference
+  (define (read-named-entity port entities fragments)
+    (let ((name (ssax:read-NCName port)))
+      (assert-curr-char '(#\;) "XML [68]" port)
+      (ssax:handle-parsed-entity port name entities
+	(lambda (port entities fragments)
+	  (read-attrib-value '*eof* port entities fragments))
+	(lambda (str1 str2 fragments)
+	  (if (equal? "" str2) (cons str1 fragments)
+	      (cons* str2 str1 fragments)))
+	fragments)))
+
+  (lambda (port entities)
+    (let loop ((attr-list (make-empty-attlist)))
+      (if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list
+	  (let ((name (ssax:read-QName port)))
+	    (ssax:skip-S port)
+	    (assert-curr-char '(#\=) "XML [25]" port)
+	    (ssax:skip-S port)
+	    (let ((delimiter 
+		   (assert-curr-char '(#\' #\" ) "XML [10]" port)))
+	      (loop 
+	       (or (attlist-add attr-list 
+		     (cons name 
+			   (string-concatenate-reverse/shared
+			     (read-attrib-value delimiter port entities
+						      '()))))
+		   (parser-error port "[uniqattspec] broken for " name))))))))
+))
+
+; a few lines of validation code
+(run-test (letrec
+    ((test (lambda (str decl-entities expected-res)
+	     (newline) (display "input: ") (write str)
+	     (newline) (display "Result: ")
+	     (let ((result
+		     (call-with-input-string (unesc-string str)
+		       (lambda (port)
+			 (ssax:read-attributes port decl-entities)))))
+	       (write result) (newline)
+	       (assert (equal? result expected-res))))))
+    (test "" '() '())
+    (test "href='http://a%tb%r%n%r%n%nc'" '()
+	  `((,(string->symbol "href") . "http://a b   c")))
+    (test "href='http://a%tb%r%r%n%rc'" '()
+	  `((,(string->symbol "href") . "http://a b   c")))
+    (test "_1 ='12&amp;' _2= \"%r%n%t12&#10;3\">" '()
+	  `((_1 . "12&") (_2 . ,(unesc-string "  12%n3"))))
+    (test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  '((ent . "&lt;xx&gt;"))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+	    (,(string->symbol "Next") . "12<xx>34")))
+    (test "%tAbc='&lt;&amp;&gt;&#x0d;'%nNext='12&ent;34' />" 
+	  '((ent . "&lt;xx&gt;"))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%r"))
+	    (,(string->symbol "Next") . "12<xx>34")))
+    (test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&en;34' />" 
+	  `((en . ,(lambda () (open-input-string "&quot;xx&apos;"))))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+	    (,(string->symbol "Next") . "12\"xx'34")))
+    (test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  '((ent . "&lt;&ent1;T;&gt;") (ent1 . "&amp;"))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+	    (,(string->symbol "Next") . "12<&T;>34")))
+    (test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  `((*DEFAULT* . ,(lambda (port name)
+                            (case name
+                              ((ent) "&lt;&ent1;T;&gt;")
+                              ((ent1) "&amp;")
+                              (else (error "unrecognized" name))))))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+	    (,(string->symbol "Next") . "12<&T;>34")))
+    (assert (failed?
+	(test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  '((ent . "<&ent1;T;&gt;") (ent1 . "&amp;")) '())))
+    (assert (failed?
+	(test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  '((ent . "&lt;&ent;T;&gt;") (ent1 . "&amp;")) '())))
+    (assert (failed?
+	(test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  '((ent . "&lt;&ent1;T;&gt;") (ent1 . "&ent;")) '())))
+    (test "html:href='http://a%tb%r%n%r%n%nc'" '()
+	  `(((,(string->symbol "html") . ,(string->symbol "href"))
+	     . "http://a b   c")))
+    (test "html:href='ref1' html:src='ref2'" '()
+	  `(((,(string->symbol "html") . ,(string->symbol "href"))
+	     . "ref1")
+	    ((,(string->symbol "html") . ,(string->symbol "src"))
+	     . "ref2")))
+    (test "html:href='ref1' xml:html='ref2'" '()
+	  `(((,(string->symbol "html") . ,(string->symbol "href"))
+	     . "ref1")
+	    ((,ssax:Prefix-XML . ,(string->symbol "html"))
+	     . "ref2")))
+    (assert (failed? (test "html:href='ref1' html:href='ref2'" '() '())))
+    (assert (failed? (test "html:href='<' html:href='ref2'" '() '())))
+    (assert (failed? (test "html:href='ref1' html:href='&ref2;'" '() '())))
+))
+
+; ssax:resolve-name PORT UNRES-NAME NAMESPACES apply-default-ns?
+;
+; Convert an UNRES-NAME to a RES-NAME given the appropriate NAMESPACES
+; declarations.
+; the last parameter apply-default-ns? determines if the default
+; namespace applies (for instance, it does not for attribute names)
+;
+; Per REC-xml-names/#nsc-NSDeclared, "xml" prefix is considered pre-declared
+; and bound to the namespace name "http://www.w3.org/XML/1998/namespace".
+;
+; This procedure tests for the namespace constraints:
+; http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared
+
+(define (ssax:resolve-name port unres-name namespaces apply-default-ns?)
+  (cond
+   ((pair? unres-name)		; it's a QNAME
+    (cons 
+     (cond
+     ((assq (car unres-name) namespaces) => cadr)
+     ((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML)
+     (else
+      (parser-error port "[nsc-NSDeclared] broken; prefix " (car unres-name))))
+     (cdr unres-name)))
+   (apply-default-ns?		; Do apply the default namespace, if any
+    (let ((default-ns (assq '*DEFAULT* namespaces)))
+      (if (and default-ns (cadr default-ns))
+	  (cons (cadr default-ns) unres-name)
+	  unres-name)))		; no default namespace declared
+   (else unres-name)))		; no prefix, don't apply the default-ns
+	   
+	  
+(run-test
+ (let* ((namespaces
+	'((HTML UHTML . URN-HTML)
+	  (HTML UHTML-1 . URN-HTML)
+	  (A    UHTML . URN-HTML)))
+	(namespaces-def
+	 (cons
+	  '(*DEFAULT* DEF . URN-DEF) namespaces))
+	(namespaces-undef
+	 (cons
+	  '(*DEFAULT* #f . #f) namespaces-def))
+	(port (current-input-port)))
+
+   (assert (equal? 'ABC 
+		   (ssax:resolve-name port 'ABC namespaces #t)))
+   (assert (equal? '(DEF . ABC)
+		   (ssax:resolve-name port 'ABC namespaces-def #t)))
+   (assert (equal? 'ABC
+		   (ssax:resolve-name port 'ABC namespaces-def #f)))
+   (assert (equal? 'ABC
+		   (ssax:resolve-name port 'ABC namespaces-undef #t)))
+   (assert (equal? '(UHTML . ABC)
+		   (ssax:resolve-name port '(HTML . ABC) namespaces-def #t)))
+   (assert (equal? '(UHTML . ABC)
+		   (ssax:resolve-name port '(HTML . ABC) namespaces-def #f)))
+   (assert (equal? `(,ssax:Prefix-XML . space)
+		   (ssax:resolve-name port 
+		       `(,(string->symbol "xml") . space) namespaces-def #f)))
+   (assert (failed?
+		   (ssax:resolve-name port '(XXX . ABC) namespaces-def #f)))
+))
+
+
+; procedure+:	ssax:uri-string->symbol URI-STR
+; Convert a URI-STR to an appropriate symbol
+(define (ssax:uri-string->symbol uri-str)
+  (string->symbol uri-str))
+
+; procedure+:	ssax:complete-start-tag TAG PORT ELEMS ENTITIES NAMESPACES
+;
+; This procedure is to complete parsing of a start-tag markup. The
+; procedure must be called after the start tag token has been
+; read. TAG is an UNRES-NAME. ELEMS is an instance of xml-decl::elems;
+; it can be #f to tell the function to do _no_ validation of elements
+; and their attributes.
+;
+; This procedure returns several values:
+;  ELEM-GI: a RES-NAME.
+;  ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING)
+;	pairs. The list does NOT include xmlns attributes.
+;  NAMESPACES: the input list of namespaces amended with namespace
+;	(re-)declarations contained within the start-tag under parsing
+;  ELEM-CONTENT-MODEL
+
+; On exit, the current position in PORT will be the first character after
+; #\> that terminates the start-tag markup.
+;
+; Faults detected:
+;	VC: XML-Spec.html#enum 
+;	VC: XML-Spec.html#RequiredAttr
+;	VC: XML-Spec.html#FixedAttr
+;	VC: XML-Spec.html#ValueType
+;	WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved)
+;	VC: XML-Spec.html#elementvalid 
+;	WFC: REC-xml-names/#dt-NSName
+
+; Note, although XML Recommendation does not explicitly say it,
+; xmlns and xmlns: attributes don't have to be declared (although they
+; can be declared, to specify their default value)
+
+; Procedure:  ssax:complete-start-tag tag-head port elems entities namespaces
+(define ssax:complete-start-tag
+
+ (let ((xmlns (string->symbol "xmlns"))
+       (largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f)))
+
+  ; Scan through the attlist and validate it, against decl-attrs
+  ; Return an assoc list with added fixed or implied attrs.
+  ; Note that both attlist and decl-attrs are ATTLISTs, and therefore,
+  ; sorted
+  (define (validate-attrs port attlist decl-attrs)
+
+    ; Check to see decl-attr is not of use type REQUIRED. Add
+    ; the association with the default value, if any declared
+    (define (add-default-decl decl-attr result)
+      (let*-values
+	 (((attr-name content-type use-type default-value)
+	   (apply values decl-attr)))
+	 (and (eq? use-type 'REQUIRED)
+	      (parser-error port "[RequiredAttr] broken for" attr-name))
+	 (if default-value
+	     (cons (cons attr-name default-value) result)
+	     result)))
+
+    (let loop ((attlist attlist) (decl-attrs decl-attrs) (result '()))
+      (if (attlist-null? attlist)
+	  (attlist-fold add-default-decl result decl-attrs)
+	  (let*-values
+	   (((attr attr-others)
+	     (attlist-remove-top attlist))
+	    ((decl-attr other-decls)
+	     (if (attlist-null? decl-attrs)
+		 (values largest-dummy-decl-attr decl-attrs)
+		 (attlist-remove-top decl-attrs)))
+	    )
+	   (case (name-compare (car attr) (car decl-attr))
+	     ((<) 
+	      (if (or (eq? xmlns (car attr))
+		      (and (pair? (car attr)) (eq? xmlns (caar attr))))
+		  (loop attr-others decl-attrs (cons attr result))
+		  (parser-error port "[ValueType] broken for " attr)))
+	     ((>) 
+	      (loop attlist other-decls 
+		    (add-default-decl decl-attr result)))
+	     (else	; matched occurrence of an attr with its declaration
+	      (let*-values
+	       (((attr-name content-type use-type default-value)
+		 (apply values decl-attr)))
+	       ; Run some tests on the content of the attribute
+	       (cond
+		((eq? use-type 'FIXED)
+		 (or (equal? (cdr attr) default-value)
+		     (parser-error port "[FixedAttr] broken for " attr-name)))
+		((eq? content-type 'CDATA) #t) ; everything goes
+		((pair? content-type)
+		 (or (member (cdr attr) content-type)
+		     (parser-error port "[enum] broken for " attr-name "="
+			    (cdr attr))))
+		(else
+		 (ssax:warn port "declared content type " content-type
+		       " not verified yet")))
+	       (loop attr-others other-decls (cons attr result)))))
+	   ))))
+	    
+
+  ; Add a new namespace declaration to namespaces.
+  ; First we convert the uri-str to a uri-symbol and search namespaces for
+  ; an association (_ user-prefix . uri-symbol).
+  ; If found, we return the argument namespaces with an association
+  ; (prefix user-prefix . uri-symbol) prepended.
+  ; Otherwise, we prepend (prefix uri-symbol . uri-symbol)
+  (define (add-ns port prefix uri-str namespaces)
+    (and (equal? "" uri-str)
+	 (parser-error port "[dt-NSName] broken for " prefix))
+    (let ((uri-symbol (ssax:uri-string->symbol uri-str)))
+      (let loop ((nss namespaces))
+	(cond 
+	 ((null? nss)
+	  (cons (cons* prefix uri-symbol uri-symbol) namespaces))
+	 ((eq? uri-symbol (cddar nss))
+	  (cons (cons* prefix (cadar nss) uri-symbol) namespaces))
+	 (else (loop (cdr nss)))))))
+      
+  ; partition attrs into proper attrs and new namespace declarations
+  ; return two values: proper attrs and the updated namespace declarations
+  (define (adjust-namespace-decl port attrs namespaces)
+    (let loop ((attrs attrs) (proper-attrs '()) (namespaces namespaces))
+      (cond
+       ((null? attrs) (values proper-attrs namespaces))
+       ((eq? xmlns (caar attrs))	; re-decl of the default namespace
+	(loop (cdr attrs) proper-attrs 
+	      (if (equal? "" (cdar attrs))	; un-decl of the default ns
+		  (cons (cons* '*DEFAULT* #f #f) namespaces)
+		  (add-ns port '*DEFAULT* (cdar attrs) namespaces))))
+       ((and (pair? (caar attrs)) (eq? xmlns (caaar attrs)))
+	(loop (cdr attrs) proper-attrs
+	      (add-ns port (cdaar attrs) (cdar attrs) namespaces)))
+       (else
+	(loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces)))))
+
+    ; The body of the function
+ (lambda (tag-head port elems entities namespaces)
+  (let*-values
+   (((attlist) (ssax:read-attributes port entities))
+    ((empty-el-tag?)
+     (begin
+       (ssax:skip-S port)
+       (and
+	(eqv? #\/ 
+	      (assert-curr-char '(#\> #\/) "XML [40], XML [44], no '>'" port))
+	(assert-curr-char '(#\>) "XML [44], no '>'" port))))
+    ((elem-content decl-attrs)	; see xml-decl for their type
+     (if elems			; elements declared: validate!
+	 (cond
+	  ((assoc tag-head elems) =>
+	   (lambda (decl-elem)		; of type xml-decl::decl-elem
+	     (values
+	      (if empty-el-tag? 'EMPTY-TAG (cadr decl-elem))
+	      (caddr decl-elem))))
+	  (else
+	   (parser-error port "[elementvalid] broken, no decl for " tag-head)))
+	 (values		; non-validating parsing
+	  (if empty-el-tag? 'EMPTY-TAG 'ANY)
+	  #f)			; no attributes declared
+	 ))
+    ((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs)
+		      (attlist->alist attlist)))
+    ((proper-attrs namespaces)
+     (adjust-namespace-decl port merged-attrs namespaces))
+    )
+   ;(cerr "proper attrs: " proper-attrs nl)
+   ; build the return value
+   (values
+    (ssax:resolve-name port tag-head namespaces #t)
+    (fold-right
+     (lambda (name-value attlist)
+       (or
+	(attlist-add attlist
+	   (cons (ssax:resolve-name port (car name-value) namespaces #f)
+		 (cdr name-value)))
+	(parser-error port "[uniqattspec] after NS expansion broken for " 
+	       name-value)))
+     (make-empty-attlist)
+     proper-attrs)
+    namespaces
+    elem-content)))))
+
+(run-test
+ (let* ((urn-a (string->symbol "urn:a"))
+	(urn-b (string->symbol "urn:b"))
+	(urn-html (string->symbol "http://w3c.org/html"))
+	(namespaces
+	 `((#f '"UHTML" . ,urn-html)
+	   ('"A"  '"UA" . ,urn-a)))
+	  (test
+	   (lambda (tag-head-name elems str)
+	     (call-with-input-string str
+		(lambda (port)
+		  (call-with-values
+		      (lambda ()
+			      (ssax:complete-start-tag
+			       (call-with-input-string tag-head-name
+				      (lambda (port) (ssax:read-QName port)))
+			       port
+			       elems '() namespaces))
+		    list))))))
+
+   ; First test with no validation of elements
+   ;(test "TAG1" #f "")
+   (assert (equal? `('"TAG1" () ,namespaces ANY)
+		   (test "TAG1" #f ">")))
+   (assert (equal? `('"TAG1" () ,namespaces EMPTY-TAG)
+		   (test "TAG1" #f "/>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "a")) ,namespaces EMPTY-TAG)
+		   (test "TAG1" #f "HREF='a'/>")))
+   (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a"))
+		     ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
+		   (test "TAG1" #f "HREF='a' xmlns='urn:a'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "a"))
+		     ,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
+		   (test "TAG1" #f "HREF='a' xmlns=''>")))
+   (assert (failed? (test "UA:TAG1" #f "HREF='a' xmlns=''/>")))
+   (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
+		     ,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
+		   (test "A:TAG1" #f "A:HREF='a' xmlns=''>")))
+   (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
+		     ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) ANY)
+		   (test "A:TAG1" #f "A:HREF='a' xmlns='urn:b'>")))
+   (assert (failed? (test "B:TAG1" #f "A:HREF='a' xmlns:b=''/>")))
+   (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a"))
+		     ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+		   (test "B:TAG1" #f "A:HREF='a' xmlns:B='urn:b'>")))
+   (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
+					 ((,urn-b . '"SRC") . "b"))
+		     ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+		   (test "B:TAG1" #f 
+			 "B:SRC='b' A:HREF='a' xmlns:B='urn:b'>")))
+   (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
+					 ((,urn-b . '"HREF") . "b"))
+			  ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
+		   (test "B:TAG1" #f 
+			 "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:b'>")))
+   ; must be an error! Duplicate attr
+   (assert (failed? (test "B:TAG1" #f
+			  "HREF=\"b\" HREF='a' xmlns:B='urn:a'/>")))
+   ; must be an error! Duplicate attr after ns expansion
+   (assert (failed? (test "B:TAG1" #f 
+			  "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:a'/>")))
+   (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a")
+					(('"UA" . '"HREF") . "b"))
+		     ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
+		   (test "TAG1" #f 
+			 "A:HREF=\"b\" HREF='a' xmlns='urn:a'>")))
+   (assert (equal? `('"TAG1" ((('"UHTML" . '"HREF") . "a")
+			      ((,urn-b . '"HREF") . "b"))
+		     ,(append `(
+			 ('"HTML" '"UHTML" . ,urn-html)
+			 ('"B" ,urn-b . ,urn-b))
+			      namespaces) ANY)
+		   (test "TAG1" #f 
+			 "B:HREF=\"b\" xmlns:B='urn:b' xmlns:HTML='http://w3c.org/html' HTML:HREF='a' >")))
+
+   ; Now test the validating parsing
+   ; No decl for tag1
+   (assert (failed? (test "TAG1" '((TAG2 ANY ()))
+			  "B:HREF='b' xmlns:B='urn:b'>")))
+   ; No decl for HREF elem
+;;   (cond-expand
+;;    ((not (or scm mit-scheme))	; Regretfully, SCM treats '() as #f
+;;     (assert (failed?
+;;	      (test "TAG1" '(('"TAG1" ANY ()))
+;;		    "B:HREF='b' xmlns:B='urn:b'>"))))
+;;    (else #t))
+   ; No decl for HREF elem
+   (assert (failed?
+	    (test "TAG1" '(('"TAG1" ANY (('"HREF1" CDATA IMPLIED #f))))
+	    "B:HREF='b' xmlns:B='urn:b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces EMPTY-TAG)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+	     "HREF='b'/>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+	     "HREF='b'>")))
+   ; Req'd attribute not given error
+   (assert (failed? 
+	    (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
+		  ">")))
+   ; Wrong content-type of the attribute
+   (assert (failed? 
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c") REQUIRED #f))))
+	     "HREF='b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c" "b") IMPLIED #f))))
+	     "HREF='b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "c"))))
+	     "HREF='b'>")))
+   ; Bad fixed attribute
+   (assert (failed? 
+	 (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "c"))))
+	       "HREF='b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b"))))
+	     "HREF='b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b")))) ">")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "b")))) ">")))
+   (assert (equal? `('"TAG1" () ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED #f)))) ">")))
+   ; Undeclared attr
+   (assert (failed? 
+	(test "TAG1"
+	      '(('"TAG1" PCDATA ((('"A" . '"HREF") CDATA IMPLIED "c"))))
+	      "HREF='b'>")))
+   (assert (equal? `('"TAG1" (('"HREF" . "b") (('"UA" . '"HREF") . "c"))
+			  ,namespaces PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+				       (('"A" . '"HREF") CDATA IMPLIED "c"))))
+	     "HREF='b'>")))
+   (assert (equal? `(('"UA" . '"TAG1")
+		     (('"HREF" . "b") (('"UA" . '"HREF") . "c"))
+		     ,namespaces PCDATA)
+       (test "A:TAG1" '((('"A" . '"TAG1") PCDATA
+			 (('"HREF" NMTOKEN REQUIRED #f)
+			  (('"A" . '"HREF") CDATA IMPLIED "c"))))
+	     "HREF='b'>")))
+   (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+		     ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+       (test "B:TAG1" '((('"B" . '"TAG1") PCDATA (('"HREF" CDATA REQUIRED #f)
+			   (('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
+	     "HREF='b'>")))
+   (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
+			  ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+       (test "B:TAG1" '((('"B" . '"TAG1") PCDATA
+			 ((('"B" . '"HREF") CDATA REQUIRED #f)
+			  (('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
+	     "B:HREF='b'>")))
+   (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+		     ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+			   ('"xmlns" CDATA IMPLIED "urn:b"))))
+	     "HREF='b'>")))
+   ; xmlns not declared
+   (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
+		     ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
+       (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
+			   )))
+	     "HREF='b' xmlns='urn:b'>")))
+   ; xmlns:B not declared
+   (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
+		     ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
+       (test "B:TAG1" '((('"B" . '"TAG1") PCDATA
+			 ((('"B" . '"HREF") CDATA REQUIRED #f)
+			   )))
+	     "B:HREF='b' xmlns:B='urn:b'>")))
+))
+
+; procedure+:	ssax:read-external-id PORT
+;
+; This procedure parses an ExternalID production:
+; [75] ExternalID ::= 'SYSTEM' S SystemLiteral
+;		| 'PUBLIC' S PubidLiteral S SystemLiteral
+; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") 
+; [12] PubidLiteral ::=  '"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
+; [13] PubidChar ::=  #x20 | #xD | #xA | [a-zA-Z0-9]
+;                         | [-'()+,./:=?;!*#@$_%]
+;
+; This procedure is supposed to be called when an ExternalID is expected;
+; that is, the current character must be either #\S or #\P that start
+; correspondingly a SYSTEM or PUBLIC token. This procedure returns the
+; SystemLiteral as a string. A PubidLiteral is disregarded if present.
+ 
+(define (ssax:read-external-id port)
+  (let ((discriminator (ssax:read-NCName port)))
+    (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" port)
+    (ssax:skip-S port)
+    (let ((delimiter 
+          (assert-curr-char '(#\' #\" ) "XML [11], XML [12]" port)))
+      (cond
+        ((eq? discriminator (string->symbol "SYSTEM"))
+          (begin0
+            (next-token '() (list delimiter) "XML [11]" port)
+            (read-char port)	; reading the closing delim
+            ))
+         ((eq? discriminator (string->symbol "PUBLIC"))
+           (skip-until (list delimiter) port)
+           (assert-curr-char ssax:S-chars "space after PubidLiteral" port)
+           (ssax:skip-S port)
+           (let* ((delimiter 
+                  (assert-curr-char '(#\' #\" ) "XML [11]" port))
+                  (systemid
+                    (next-token '() (list delimiter) "XML [11]" port)))
+                (read-char port)	; reading the closing delim
+                systemid))
+         (else
+           (parser-error port "XML [75], " discriminator 
+		  " rather than SYSTEM or PUBLIC"))))))
+
+
+;-----------------------------------------------------------------------------
+;			Higher-level parsers and scanners
+;
+; They parse productions corresponding to the whole (document) entity
+; or its higher-level pieces (prolog, root element, etc).
+
+
+; Scan the Misc production in the context
+; [1]  document ::=  prolog element Misc*
+; [22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)?
+; [27] Misc ::= Comment | PI |  S
+;
+; The following function should be called in the prolog or epilog contexts.
+; In these contexts, whitespaces are completely ignored.
+; The return value from ssax:scan-Misc is either a PI-token,
+; a DECL-token, a START token, or EOF.
+; Comments are ignored and not reported.
+
+(define (ssax:scan-Misc port)
+  (let loop ((c (ssax:skip-S port)))
+    (cond
+      ((eof-object? c) c)
+      ((not (char=? c #\<))
+        (parser-error port "XML [22], char '" c "' unexpected"))
+      (else
+        (let ((token (ssax:read-markup-token port)))
+          (case (xml-token-kind token)
+            ((COMMENT) (loop (ssax:skip-S port)))
+            ((PI DECL START) token)
+            (else 
+              (parser-error port "XML [22], unexpected token of kind "
+		     (xml-token-kind token)
+		     ))))))))
+
+; procedure+:	ssax:read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
+;
+; This procedure is to read the character content of an XML document
+; or an XML element.
+; [43] content ::= 
+;	(element | CharData | Reference | CDSect | PI
+; 	| Comment)*
+; To be more precise, the procedure reads CharData, expands CDSect
+; and character entities, and skips comments. The procedure stops
+; at a named reference, EOF, at the beginning of a PI or a start/end tag.
+;
+; port
+;	a PORT to read
+; expect-eof?
+;	a boolean indicating if EOF is normal, i.e., the character
+;	data may be terminated by the EOF. EOF is normal
+;	while processing a parsed entity.
+; str-handler
+;	a STR-HANDLER
+; seed
+;	an argument passed to the first invocation of STR-HANDLER.
+;
+; The procedure returns two results: SEED and TOKEN.
+; The SEED is the result of the last invocation of STR-HANDLER, or the
+; original seed if STR-HANDLER was never called.
+;
+; TOKEN can be either an eof-object (this can happen only if
+; expect-eof? was #t), or:
+;     - an xml-token describing a START tag or an END-tag;
+;	For a start token, the caller has to finish reading it.
+;     - an xml-token describing the beginning of a PI. It's up to an
+;	application to read or skip through the rest of this PI;
+;     - an xml-token describing a named entity reference.
+;
+; CDATA sections and character references are expanded inline and
+; never returned. Comments are silently disregarded.
+;
+; As the XML Recommendation requires, all whitespace in character data
+; must be preserved. However, a CR character (#xD) must be disregarded
+; if it appears before a LF character (#xA), or replaced by a #xA character
+; otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also
+; the canonical XML Recommendation.
+
+	; ssax:read-char-data port expect-eof? str-handler seed
+(define ssax:read-char-data
+ (let
+     ((terminators-usual (list #\< #\& char-return))
+      (terminators-usual-eof (list #\< '*eof* #\& char-return))
+
+      (handle-fragment
+       (lambda (fragment str-handler seed)
+	 (if (string-null? fragment) seed
+	     (str-handler fragment "" seed))))
+      )
+
+   (lambda (port expect-eof? str-handler seed)
+
+     ; Very often, the first character we encounter is #\<
+     ; Therefore, we handle this case in a special, fast path
+     (if (eqv? #\< (peek-char port))
+
+         ; The fast path
+	 (let ((token (ssax:read-markup-token port)))
+	   (case (xml-token-kind token)
+	     ((START END)	; The most common case
+	      (values seed token))
+	     ((CDSECT)
+	      (let ((seed (ssax:read-cdata-body port str-handler seed)))
+		(ssax:read-char-data port expect-eof? str-handler seed)))
+	     ((COMMENT) (ssax:read-char-data port expect-eof?
+					     str-handler seed))
+	     (else
+	      (values seed token))))
+
+
+         ; The slow path
+	 (let ((char-data-terminators
+		(if expect-eof? terminators-usual-eof terminators-usual)))
+
+	   (let loop ((seed seed))
+	     (let* ((fragment
+		     (next-token '() char-data-terminators 
+				 "reading char data" port))
+		    (term-char (peek-char port)) ; one of char-data-terminators
+		    )
+	       (if (eof-object? term-char)
+		   (values
+		    (handle-fragment fragment str-handler seed)
+		    term-char)
+		   (case term-char
+		     ((#\<)
+		      (let ((token (ssax:read-markup-token port)))
+			(case (xml-token-kind token)
+			  ((CDSECT)
+			   (loop
+			    (ssax:read-cdata-body port str-handler
+			        (handle-fragment fragment str-handler seed))))
+			  ((COMMENT)
+			   (loop (handle-fragment fragment str-handler seed)))
+			  (else
+			   (values
+			    (handle-fragment fragment str-handler seed)
+			    token)))))
+		     ((#\&)
+		      (case (peek-next-char port)
+			((#\#) (read-char port) 
+			 (loop (str-handler fragment
+				       (ssax:read-char-ref port)
+				       seed)))
+			(else
+			 (let ((name (ssax:read-NCName port)))
+			   (assert-curr-char '(#\;) "XML [68]" port)
+			   (values
+			    (handle-fragment fragment str-handler seed)
+			    (make-xml-token 'ENTITY-REF name))))))
+		     (else		; This must be a CR character
+		      (if (eqv? (peek-next-char port) #\newline)
+			  (read-char port))
+		      (loop (str-handler fragment (string #\newline) seed))))
+		   ))))))))
+
+
+; a few lines of validation code
+(run-test (letrec
+  ((a-tag (make-xml-token 'START (string->symbol "BR")))
+   (a-ref (make-xml-token 'ENTITY-REF (string->symbol "lt")))
+   (eof-object (lambda () eof-object)) ; a unique value
+   (str-handler (lambda (fragment foll-fragment seed)
+     (if (string-null? foll-fragment) (cons fragment seed)
+	 (cons* foll-fragment fragment seed))))
+   (test (lambda (str expect-eof? expected-data expected-token)
+	   (newline) (display "body: ") (write str)
+	   (newline) (display "Result: ")
+	  (let*-values
+	   (((seed token)
+	     (call-with-input-string (unesc-string str)
+		(lambda (port)
+		 (ssax:read-char-data port expect-eof? str-handler '()))))
+	    ((result) (reverse seed)))
+	   (write result)
+	   (display " ")
+	   (display token)
+	   (assert (equal? result (map unesc-string expected-data))
+	           (if (eq? expected-token eof-object)
+		     (eof-object? token)
+		     (equal? token expected-token))))))
+   )
+  (test "" #t '() eof-object)
+  (assert (failed? (test "" #f '() eof-object)))
+  (test "  " #t '("  ") eof-object)
+  (test "<BR/>" #f '() a-tag)
+  (test " <BR  />" #f '(" ") a-tag)
+
+  (test " &lt;" #f '(" ") a-ref)
+  (test " a&lt;" #f '(" a") a-ref)
+  (test " a &lt;" #f '(" a ") a-ref)
+
+  (test " <!-- comment--> a  a<BR/>" #f '(" " " a  a") a-tag)
+  (test " <!-- comment-->%ra  a<BR/>" #f '(" " "" "%n" "a  a") a-tag)
+  (test " <!-- comment-->%r%na  a<BR/>" #f '(" " "" "%n" "a  a") a-tag)
+  (test " <!-- comment-->%r%na%t%r%r%na<BR/>" #f
+	'(" " "" "%n" "a%t" "%n" "" "%n" "a") a-tag)
+  (test "a<!-- comment--> a  a<BR/>" #f '("a" " a  a") a-tag)
+  (test "&#x21;<BR/>" #f '("" "!") a-tag)
+  (test "&#x21;%n<BR/>" #f '("" "!" "%n") a-tag)
+  (test "%t&#x21;%n<BR/>" #f '("%t" "!" "%n") a-tag)
+  (test "%t&#x21;%na a<BR/>" #f '("%t" "!" "%na a") a-tag)
+  (test "%t&#x21;%ra a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag)
+  (test "%t&#x21;%r%na a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag)
+
+  (test " %ta &#x21;   b <BR/>" #f '(" %ta " "!" "   b ") a-tag)
+  (test " %ta &#x20;   b <BR/>" #f '(" %ta " " " "   b ") a-tag)
+
+  (test "<![CDATA[<]]><BR/>" #f '("<") a-tag)
+  (test "<![CDATA[]]]><BR/>" #f '("]") a-tag)
+  (test "%t<![CDATA[<]]><BR/>" #f '("%t" "<") a-tag)
+  (test "%t<![CDATA[<]]>a b<BR/>" #f '("%t" "<" "a b") a-tag)
+  (test "%t<![CDATA[<]]>  a b<BR/>" #f '("%t" "<" "  a b") a-tag)
+
+  (test "%td <![CDATA[  <%r%r%n]]>  a b<BR/>" #f 
+	'("%td " "  <" "%n" "" "%n" "  a b") a-tag)
+))
+
+
+
+; procedure+:	ssax:assert-token TOKEN KIND GI
+; Make sure that TOKEN is of anticipated KIND and has anticipated GI
+; Note GI argument may actually be a pair of two symbols, Namespace
+; URI or the prefix, and of the localname.
+; If the assertion fails, error-cont is evaluated by passing it
+; three arguments: token kind gi. The result of error-cont is returned.
+(define (ssax:assert-token token kind gi error-cont)
+  (or
+    (and (xml-token? token)
+      (eq? kind (xml-token-kind token))
+      (equal? gi (xml-token-head token)))
+    (error-cont token kind gi)))
+
+;========================================================================
+;		Highest-level parsers: XML to SXML
+
+; These parsers are a set of syntactic forms to instantiate a SSAX parser.
+; A user can instantiate the parser to do the full validation, or
+; no validation, or any particular validation. The user specifies
+; which PI he wants to be notified about. The user tells what to do
+; with the parsed character and element data. The latter handlers
+; determine if the parsing follows a SAX or a DOM model.
+
+; syntax: ssax:make-pi-parser my-pi-handlers
+; Create a parser to parse and process one Processing Element (PI).
+
+; my-pi-handlers
+;	An assoc list of pairs (PI-TAG . PI-HANDLER)
+;	where PI-TAG is an NCName symbol, the PI target, and
+;	PI-HANDLER is a procedure PORT PI-TAG SEED
+;	where PORT points to the first symbol after the PI target.
+;	The handler should read the rest of the PI up to and including
+;	the combination '?>' that terminates the PI. The handler should
+;	return a new seed.
+;	One of the PI-TAGs may be the symbol *DEFAULT*. The corresponding
+;	handler will handle PIs that no other handler will. If the
+;	*DEFAULT* PI-TAG is not specified, ssax:make-pi-parser will assume
+;	the default handler that skips the body of the PI
+;	
+; The output of the ssax:make-pi-parser is a procedure
+;	PORT PI-TAG SEED
+; that will parse the current PI according to the user-specified handlers.
+;
+; The previous version of ssax:make-pi-parser was a low-level macro:
+; (define-macro ssax:make-pi-parser
+;   (lambda (my-pi-handlers)
+;   `(lambda (port target seed)
+;     (case target
+; 	; Generate the body of the case statement
+;       ,@(let loop ((pi-handlers my-pi-handlers) (default #f))
+; 	 (cond
+; 	  ((null? pi-handlers)
+; 	   (if default `((else (,default port target seed)))
+; 	       '((else
+; 		  (ssax:warn port "Skipping PI: " target nl)
+; 		  (ssax:skip-pi port)
+; 		  seed))))
+; 	  ((eq? '*DEFAULT* (caar pi-handlers))
+; 	   (loop (cdr pi-handlers) (cdar pi-handlers)))
+; 	  (else
+; 	   (cons
+; 	    `((,(caar pi-handlers)) (,(cdar pi-handlers) port target seed))
+; 	    (loop (cdr pi-handlers) default)))))))))
+
+(define-syntax ssax:make-pi-parser
+  (syntax-rules ()
+    ((ssax:make-pi-parser orig-handlers)
+     (letrec-syntax 
+	; Generate the clauses of the case statement
+      ((loop
+	 (syntax-rules (*DEFAULT*)
+	   ((loop () #f accum port target seed) 	; no default
+	    (make-case 
+	      ((else
+		 (ssax:warn port "Skipping PI: " target nl)
+		 (ssax:skip-pi port)
+		 seed)
+		. accum)
+	      () target))
+	   ((loop () default accum port target seed)
+	    (make-case 
+	      ((else (default port target seed)) . accum)
+	      () target))
+	   ((loop ((*DEFAULT* . default) . handlers) old-def accum
+	      port target seed)
+	    (loop handlers default accum port target seed))
+	   ((loop ((tag . handler) . handlers) default accum port target seed)
+	    (loop handlers default
+	      (((tag) (handler port target seed)) . accum)
+	      port target seed))
+	   ))
+	(make-case 			; Reverse the clauses, make the 'case'
+	  (syntax-rules ()
+	    ((make-case () clauses target)
+	     (case target . clauses))
+	    ((make-case (clause . clauses) accum target)
+	     (make-case clauses (clause . accum) target)))
+	  ))
+      (lambda (port target seed)
+	(loop orig-handlers #f () port target seed))
+       ))))
+
+(run-test
+ (pp (ssax:make-pi-parser ()))
+ (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed)))))
+ (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed))
+			   (html . list)
+			   (*DEFAULT* . ssax:warn))))
+)
+
+; syntax: ssax:make-elem-parser my-new-level-seed my-finish-element
+;				my-char-data-handler my-pi-handlers
+
+; Create a parser to parse and process one element, including its
+; character content or children elements. The parser is typically
+; applied to the root element of a document.
+
+; my-new-level-seed
+;	procedure ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED
+;		where ELEM-GI is a RES-NAME of the element
+;		about to be processed.
+;	This procedure is to generate the seed to be passed
+;	to handlers that process the content of the element.
+;	This is the function identified as 'fdown' in the denotational
+;	semantics of the XML parser given in the title comments to this
+;	file.
+;
+; my-finish-element
+;	procedure ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED
+;	This procedure is called when parsing of ELEM-GI is finished.
+;	The SEED is the result from the last content parser (or
+;	from my-new-level-seed if the element has the empty content).
+;	PARENT-SEED is the same seed as was passed to my-new-level-seed.
+;	The procedure is to generate a seed that will be the result
+;	of the element parser.
+;	This is the function identified as 'fup' in the denotational
+;	semantics of the XML parser given in the title comments to this
+;	file.
+;
+; my-char-data-handler
+;	A STR-HANDLER
+;
+; my-pi-handlers
+;	See ssax:make-pi-handler above
+;
+
+; The generated parser is a
+;	procedure START-TAG-HEAD PORT ELEMS ENTITIES
+;	NAMESPACES PRESERVE-WS? SEED
+; The procedure must be called after the start tag token has been
+; read. START-TAG-HEAD is an UNRES-NAME from the start-element tag.
+; ELEMS is an instance of xml-decl::elems.
+; See ssax:complete-start-tag::preserve-ws?
+
+; Faults detected:
+;	VC: XML-Spec.html#elementvalid 
+;	WFC: XML-Spec.html#GIMatch
+
+
+(define-syntax ssax:make-elem-parser
+  (syntax-rules ()
+    ((ssax:make-elem-parser my-new-level-seed my-finish-element
+                            my-char-data-handler my-pi-handlers)
+  
+   (lambda (start-tag-head port elems entities namespaces
+			   preserve-ws? seed)
+
+     (define xml-space-gi (cons ssax:Prefix-XML
+				(string->symbol "space")))
+
+     (let handle-start-tag ((start-tag-head start-tag-head)
+			    (port port) (entities entities)
+			    (namespaces namespaces)
+			    (preserve-ws? preserve-ws?) (parent-seed seed))
+       (let*-values
+	(((elem-gi attributes namespaces expected-content)
+	  (ssax:complete-start-tag start-tag-head port elems
+				   entities namespaces))
+	 ((seed)
+	  (my-new-level-seed elem-gi attributes
+			      namespaces expected-content parent-seed)))
+	(case expected-content
+	  ((EMPTY-TAG)
+	   (my-finish-element
+	    elem-gi attributes namespaces parent-seed seed))
+	  ((EMPTY)		; The end tag must immediately follow
+	   (ssax:assert-token 
+	    (and (eqv? #\< (ssax:skip-S port)) (ssax:read-markup-token port))
+	    'END  start-tag-head
+	    (lambda (token exp-kind exp-head)
+	      (parser-error port "[elementvalid] broken for " token 
+		     " while expecting "
+		     exp-kind exp-head)))
+	   (my-finish-element
+	    elem-gi attributes namespaces parent-seed seed))
+	  (else		; reading the content...
+	   (let ((preserve-ws?  ; inherit or set the preserve-ws? flag
+		  (cond
+		   ((assoc xml-space-gi attributes) =>
+		    (lambda (name-value)
+		      (equal? "preserve" (cdr name-value))))
+		   (else preserve-ws?))))
+	     (let loop ((port port) (entities entities)
+			(expect-eof? #f) (seed seed))
+	       (let*-values
+		(((seed term-token)
+		  (ssax:read-char-data port expect-eof?
+				       my-char-data-handler seed)))
+		(if (eof-object? term-token)
+		    seed
+		    (case (xml-token-kind term-token)
+		      ((END)
+		       (ssax:assert-token term-token 'END  start-tag-head
+			  (lambda (token exp-kind exp-head)
+			    (parser-error port "[GIMatch] broken for "
+				   term-token " while expecting "
+				   exp-kind exp-head)))
+		       (my-finish-element
+			elem-gi attributes namespaces parent-seed seed))
+		      ((PI)
+		       (let ((seed 
+			  ((ssax:make-pi-parser my-pi-handlers)
+			   port (xml-token-head term-token) seed)))
+			 (loop port entities expect-eof? seed)))
+		      ((ENTITY-REF)
+		       (let ((seed
+			      (ssax:handle-parsed-entity
+			       port (xml-token-head term-token)
+			       entities
+			       (lambda (port entities seed)
+				 (loop port entities #t seed))
+			       my-char-data-handler
+			       seed))) ; keep on reading the content after ent
+			 (loop port entities expect-eof? seed)))
+		      ((START)		; Start of a child element
+		       (if (eq? expected-content 'PCDATA)
+			   (parser-error port "[elementvalid] broken for "
+				  elem-gi
+				  " with char content only; unexpected token "
+				  term-token))
+			   ; Do other validation of the element content
+			   (let ((seed
+				  (handle-start-tag
+				     (xml-token-head term-token)
+				     port entities namespaces
+				     preserve-ws? seed)))
+			     (loop port entities expect-eof? seed)))
+		      (else
+		       (parser-error port "XML [43] broken for "
+				     term-token))))))))
+	  )))
+))))
+
+
+; syntax: ssax:make-parser user-handler-tag user-handler-proc ...
+;
+; Create an XML parser, an instance of the XML parsing framework.
+; This will be a SAX, a DOM, or a specialized parser depending
+; on the supplied user-handlers.
+
+; user-handler-tag is a symbol that identifies a procedural expression
+; that follows the tag. Given below are tags and signatures of the
+; corresponding procedures. Not all tags have to be specified. If some
+; are omitted, reasonable defaults will apply.
+;
+
+; tag: DOCTYPE
+; handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED
+; If internal-subset? is #t, the current position in the port
+; is right after we have read #\[ that begins the internal DTD subset.
+; We must finish reading of this subset before we return
+; (or must call skip-internal-subset if we aren't interested in reading it).
+; The port at exit must be at the first symbol after the whole
+; DOCTYPE declaration.
+; The handler-procedure must generate four values:
+;	ELEMS ENTITIES NAMESPACES SEED
+; See xml-decl::elems for ELEMS. It may be #f to switch off the validation.
+; NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs.
+; The default handler-procedure skips the internal subset,
+; if any, and returns (values #f '() '() seed)
+
+; tag: UNDECL-ROOT
+; handler-procedure: ELEM-GI SEED
+; where ELEM-GI is an UNRES-NAME of the root element. This procedure
+; is called when an XML document under parsing contains _no_ DOCTYPE
+; declaration.
+; The handler-procedure, as a DOCTYPE handler procedure above,
+; must generate four values:
+;	ELEMS ENTITIES NAMESPACES SEED
+; The default handler-procedure returns (values #f '() '() seed)
+
+; tag: DECL-ROOT
+; handler-procedure: ELEM-GI SEED
+; where ELEM-GI is an UNRES-NAME of the root element. This procedure
+; is called when an XML document under parsing does contains the DOCTYPE
+; declaration.
+; The handler-procedure must generate a new SEED (and verify
+; that the name of the root element matches the doctype, if the handler
+; so wishes). 
+; The default handler-procedure is the identity function.
+
+; tag: NEW-LEVEL-SEED
+; handler-procedure: see ssax:make-elem-parser, my-new-level-seed
+
+; tag: FINISH-ELEMENT
+; handler-procedure: see ssax:make-elem-parser, my-finish-element
+
+; tag: CHAR-DATA-HANDLER
+; handler-procedure: see ssax:make-elem-parser, my-char-data-handler
+
+; tag: PI
+; handler-procedure: see ssax:make-pi-parser
+; The default value is '()
+ 
+; The generated parser is a
+;	procedure PORT SEED
+
+; This procedure parses the document prolog and then exits to
+; an element parser (created by ssax:make-elem-parser) to handle
+; the rest.
+;
+; [1]  document ::=  prolog element Misc*
+; [22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)?
+; [27] Misc ::= Comment | PI |  S
+;
+; [28] doctypedecl ::=  '<!DOCTYPE' S Name (S ExternalID)? S? 
+;			('[' (markupdecl | PEReference | S)* ']' S?)? '>'
+; [29] markupdecl ::= elementdecl | AttlistDecl
+;                      | EntityDecl
+;                      | NotationDecl | PI
+;                      | Comment 
+;
+
+
+; This is ssax:make-parser with all the (specialization) handlers given
+; as positional arguments. It is called by ssax:make-parser, see below
+(define-syntax ssax:make-parser/positional-args
+  (syntax-rules ()
+    ((ssax:make-parser/positional-args
+       *handler-DOCTYPE
+       *handler-UNDECL-ROOT
+       *handler-DECL-ROOT
+       *handler-NEW-LEVEL-SEED
+       *handler-FINISH-ELEMENT
+       *handler-CHAR-DATA-HANDLER
+       *handler-PI)
+  (lambda (port seed)
+
+     ; We must've just scanned the DOCTYPE token 
+     ; Handle the doctype declaration and exit to
+     ; scan-for-significant-prolog-token-2, and eventually, to the
+     ; element parser.
+     (define (handle-decl port token-head seed)
+       (or (eq? (string->symbol "DOCTYPE") token-head)
+	   (parser-error port "XML [22], expected DOCTYPE declaration, found "
+		  token-head))
+       (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" port)
+       (ssax:skip-S port)
+       (let*-values
+	(((docname) (ssax:read-QName port))
+	 ((systemid)
+	  (and (ssax:ncname-starting-char? (ssax:skip-S port))
+	       (ssax:read-external-id port)))
+	 ((internal-subset?)
+	  (begin (ssax:skip-S port)
+	    (eqv? #\[ (assert-curr-char '(#\> #\[)
+					"XML [28], end-of-DOCTYPE" port))))
+	 ((elems entities namespaces seed)
+	  (*handler-DOCTYPE port docname systemid
+			    internal-subset? seed))
+	 )
+	(scan-for-significant-prolog-token-2 port elems entities namespaces
+					     seed)))
+
+
+     ; Scan the leading PIs until we encounter either a doctype declaration
+     ; or a start token (of the root element)
+     ; In the latter two cases, we exit to the appropriate continuation
+     (define (scan-for-significant-prolog-token-1 port seed)
+       (let ((token (ssax:scan-Misc port)))
+	 (if (eof-object? token)
+	     (parser-error port "XML [22], unexpected EOF")
+	     (case (xml-token-kind token)
+	       ((PI)
+		(let ((seed 
+		       ((ssax:make-pi-parser *handler-PI)
+			port (xml-token-head token) seed)))
+		  (scan-for-significant-prolog-token-1 port seed)))
+	       ((DECL) (handle-decl port (xml-token-head token) seed))
+	       ((START)
+		(let*-values
+		 (((elems entities namespaces seed)
+		   (*handler-UNDECL-ROOT (xml-token-head token) seed)))
+		 (element-parser (xml-token-head token) port elems
+				 entities namespaces #f seed)))
+	       (else (parser-error port "XML [22], unexpected markup "
+				   token))))))
+
+
+     ; Scan PIs after the doctype declaration, till we encounter
+     ; the start tag of the root element. After that we exit
+     ; to the element parser
+     (define (scan-for-significant-prolog-token-2 port elems entities
+						  namespaces seed)
+       (let ((token (ssax:scan-Misc port)))
+	 (if (eof-object? token)
+	     (parser-error port "XML [22], unexpected EOF")
+	     (case (xml-token-kind token)
+	       ((PI)
+		(let ((seed 
+		       ((ssax:make-pi-parser *handler-PI)
+			port (xml-token-head token) seed)))
+		  (scan-for-significant-prolog-token-2 port elems entities
+						       namespaces seed)))
+	       ((START)
+		(element-parser (xml-token-head token) port elems
+		  entities namespaces #f
+		  (*handler-DECL-ROOT (xml-token-head token) seed)))
+	       (else (parser-error port "XML [22], unexpected markup "
+				   token))))))
+
+
+     ; A procedure start-tag-head port elems entities namespaces
+     ;		 preserve-ws? seed
+     (define element-parser
+       (ssax:make-elem-parser *handler-NEW-LEVEL-SEED
+			      *handler-FINISH-ELEMENT
+			      *handler-CHAR-DATA-HANDLER
+			      *handler-PI))
+
+     ; Get the ball rolling ...
+     (scan-for-significant-prolog-token-1 port seed)
+))))
+
+
+
+; The following meta-macro turns a regular macro (with positional
+; arguments) into a form with keyword (labeled) arguments.  We later
+; use the meta-macro to convert ssax:make-parser/positional-args into
+; ssax:make-parser. The latter provides a prettier (with labeled
+; arguments and defaults) interface to
+; ssax:make-parser/positional-args
+;
+; ssax:define-labeled-arg-macro LABELED-ARG-MACRO-NAME 
+;		(POS-MACRO-NAME ARG-DESCRIPTOR ...)
+; expands into the definition of a macro
+;	LABELED-ARG-MACRO-NAME KW-NAME KW-VALUE KW-NAME1 KW-VALUE1 ...
+; which, in turn, expands into
+;	POS-MACRO-NAME ARG1 ARG2 ...
+; where each ARG1 etc. comes either from KW-VALUE or from
+; the deafult part of ARG-DESCRIPTOR. ARG1 corresponds to the first
+; ARG-DESCRIPTOR, ARG2 corresponds to the second descriptor, etc.
+; Here ARG-DESCRIPTOR describes one argument of the positional macro.
+; It has the form 
+;	(ARG-NAME DEFAULT-VALUE)
+; or
+;	(ARG-NAME)
+; In the latter form, the default value is not given, so that the invocation of
+; LABELED-ARG-MACRO-NAME must mention the corresponding parameter.
+; ARG-NAME can be anything: an identifier, a string, or even a number.
+
+
+(define-syntax ssax:define-labeled-arg-macro
+  (syntax-rules ()
+    ((ssax:define-labeled-arg-macro
+       labeled-arg-macro-name
+       (positional-macro-name
+	 (arg-name . arg-def) ...))
+      (define-syntax labeled-arg-macro-name
+	(syntax-rules ()
+	  ((labeled-arg-macro-name . kw-val-pairs)
+	    (letrec-syntax
+	      ((find 
+		 (syntax-rules (arg-name ...)
+		   ((find k-args (arg-name . default) arg-name
+		      val . others)	   ; found arg-name among kw-val-pairs
+		    (next val . k-args)) ...
+		   ((find k-args key arg-no-match-name val . others)
+		     (find k-args key . others))
+		   ((find k-args (arg-name default)) ; default must be here
+		     (next default . k-args)) ...
+		   ))
+		(next			; pack the continuation to find
+		  (syntax-rules ()
+		    ((next val vals key . keys)
+		      (find ((val . vals) . keys) key . kw-val-pairs))
+		    ((next val vals)	; processed all arg-descriptors
+		      (rev-apply (val) vals))))
+		(rev-apply
+		  (syntax-rules ()
+		    ((rev-apply form (x . xs))
+		      (rev-apply (x . form) xs))
+		    ((rev-apply form ()) form))))
+	      (next positional-macro-name () 
+		(arg-name . arg-def) ...))))))))
+
+
+; The definition of ssax:make-parser
+(ssax:define-labeled-arg-macro ssax:make-parser
+  (ssax:make-parser/positional-args
+    (DOCTYPE
+      (lambda (port docname systemid internal-subset? seed)
+	(when internal-subset?
+	  (ssax:warn port "Internal DTD subset is not currently handled ")
+	  (ssax:skip-internal-dtd port))
+	(ssax:warn port "DOCTYPE DECL " docname " " 
+	  systemid " found and skipped")
+	(values #f '() '() seed)
+	))
+    (UNDECL-ROOT
+      (lambda (elem-gi seed) (values #f '() '() seed)))
+    (DECL-ROOT
+      (lambda (elem-gi seed) seed))
+    (NEW-LEVEL-SEED)		; required
+    (FINISH-ELEMENT)		; required
+    (CHAR-DATA-HANDLER)		; required
+    (PI ())
+    ))
+
+(run-test
+ (letrec ((simple-parser
+	   (lambda (str doctype-fn)
+	     (call-with-input-string str
+		 (lambda (port)
+		   ((ssax:make-parser
+		     NEW-LEVEL-SEED 
+		     (lambda (elem-gi attributes namespaces
+				      expected-content seed)
+		       '())
+   
+		     FINISH-ELEMENT
+		     (lambda (elem-gi attributes namespaces parent-seed seed)
+		       (let
+			   ((seed (if (null? namespaces) (reverse seed)
+				      (cons (list '*NAMESPACES* namespaces)
+					    (reverse seed)))))
+			 (let ((seed (if (attlist-null? attributes) seed
+					 (cons 
+					  (cons '@ 
+					   (map (lambda (attr)
+					      (list (car attr) (cdr attr)))
+						(attlist->alist attributes)))
+					  seed))))
+			   (cons (cons elem-gi seed) parent-seed))))
+
+		     CHAR-DATA-HANDLER
+		     (lambda (string1 string2 seed)
+		       (if (string-null? string2) (cons string1 seed)
+			   (cons* string2 string1 seed)))
+
+		     DOCTYPE
+		     (lambda (port docname systemid internal-subset? seed)
+		       (when internal-subset?
+			  (ssax:warn port
+			    "Internal DTD subset is not currently handled ")
+			  (ssax:skip-internal-dtd port))
+		       (ssax:warn port "DOCTYPE DECL " docname " "
+			     systemid " found and skipped")
+		       (doctype-fn docname seed))
+
+		     UNDECL-ROOT
+		     (lambda (elem-gi seed)
+		       (doctype-fn elem-gi seed))
+		     )
+		    port '())))))
+
+	  (dummy-doctype-fn (lambda (elem-gi seed) (values #f '() '() seed)))
+	  (test
+	   (lambda (str doctype-fn expected)
+	     (cout nl "Parsing: " str nl)
+	     (let ((result (simple-parser (unesc-string str) doctype-fn)))
+	       (write result)
+	       (assert (equal? result expected)))))
+	  )
+
+   (test "<BR/>" dummy-doctype-fn '(('"BR")))
+   (assert (failed? (test "<BR>" dummy-doctype-fn '())))
+   (test "<BR></BR>" dummy-doctype-fn '(('"BR")))
+   (assert (failed? (test "<BR></BB>" dummy-doctype-fn '())))
+
+   (test "   <A HREF='URL'> link <I>itlink </I> &amp;amp;</A>"
+	 dummy-doctype-fn 
+	 '(('"A" (@ ('"HREF" "URL")) " link " ('"I" "itlink ")
+	    " " "&" "amp;")))
+
+   (test
+      "   <A HREF='URL' xml:space='preserve'> link <I>itlink </I> &amp;amp;</A>" dummy-doctype-fn 
+      '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
+	   " link " ('"I" "itlink ") " " "&" "amp;")))
+
+   (test "   <A HREF='URL' xml:space='preserve'> link <I xml:space='default'>itlink </I> &amp;amp;</A>" dummy-doctype-fn
+	 '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
+	      " link "
+	      ('"I" (@ (('"xml" . '"space") "default")) "itlink ")
+	      " " "&" "amp;")))
+   (test "<itemize><item>This   is item 1 </item>%n<!-- Just:a comment --><item>Item 2</item>%n </itemize>" dummy-doctype-fn 
+	 `(('"itemize" ('"item" "This   is item 1 ")
+	    ,(unesc-string "%n") ('"item" "Item 2") ,(unesc-string "%n "))))
+  (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]&gt;]]></P>"
+	dummy-doctype-fn  `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">")))
+
+  (test " <P><![CDATA[<BR>%r<![CDATA[<BR>]]&gt;]]></P>"
+	dummy-doctype-fn `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">")))
+
+  (test "<?xml version='1.0'?>%n%n<Reports TStamp='1'></Reports>"
+	dummy-doctype-fn '(('"Reports" (@ ('"TStamp" "1")))))
+  (test "%n<?PI xxx?><!-- Comment %n -%r-->%n<?PI1 zzz?><T/>" 
+	dummy-doctype-fn '(('"T")))
+  (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>"
+	(lambda (elem-gi seed) (assert (equal? elem-gi ''"T"))
+		(values #f '() '() seed))
+	'(('"T")))
+  (test "<!DOCTYPE T PUBLIC '//EN/T' \"system1\" [ <!ELEMENT a 'aa'> ]>%n<?pi?><T/>" 
+	(lambda (elem-gi seed) (assert (equal? elem-gi ''"T"))
+		(values #f '() '() seed))
+	'(('"T")))
+  (test "<BR/>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR")))
+  (test "<BR></BR>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR")))
+  (assert (failed? (test "<BR>aa</BR>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" EMPTY ())) '() '() seed)) '())))
+  (test "<BR>aa</BR>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" PCDATA ())) '() '() seed)) '(('"BR" "aa")))
+  (assert (failed? (test "<BR>a<I>a</I></BR>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" PCDATA ())) '() '() seed)) '())))
+  (test "<BR>a<I>a</I></BR>"
+	(lambda (elem-gi seed)
+	  (values '(('"BR" ANY ()) ('"I" PCDATA ())) '() '() seed))
+	  '(('"BR" "a" ('"I" "a"))))
+
+
+  (test "<DIV>Example: \"&example;\"</DIV>"
+	(lambda (elem-gi seed)
+	  (values #f '((example . "<P>An    ampersand (&#38;) may   be escaped numerically (&#38;#38;) or with a general entity (&amp;amp;).</P>")) '() seed))
+	'(('"DIV" "Example: \""
+	   ('"P" "An    ampersand (" "&" ") may   be escaped numerically (" "&" "#38;) or with a general entity (" "&" "amp;).") "\"")))
+ (test "<DIV>Example: \"&example;\" <P/></DIV>"
+	(lambda (elem-gi seed)
+	  (values #f '(('"quote" . "<I>example:</I> ex")
+		       ('"example" . "<Q>&quote;!</Q>?")) '() seed))
+	  '(('"DIV" "Example: \"" ('"Q" ('"I" "example:") " ex" "!") "?"
+		 "\" "  ('"P"))))
+ (assert (failed?
+   (test "<DIV>Example: \"&example;\" <P/></DIV>"
+	(lambda (elem-gi seed)
+	  (values #f '(('"quote" . "<I>example:")
+		       ('"example" . "<Q>&quote;</I>!</Q>?")) '() seed))
+	'())))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values #f '() '() seed))
+       '((('"URI1" . '"DIV") (@ ('"B" "B") (('"URI1" . '"B") "A"))
+	  (*NAMESPACES* (('"A" '"URI1" . '"URI1")
+			 (*DEFAULT* '"URI1" . '"URI1")))
+	  (('"URI1" . '"P")
+	   (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"URI1" . '"URI1")
+			  (*DEFAULT* '"URI1" . '"URI1")))
+	   ('"BR"
+	    (*NAMESPACES* ((*DEFAULT* #f . #f)
+			   ('"A" '"URI1" . '"URI1")
+			   (*DEFAULT* '"URI1" . '"URI1"))))))))
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values #f '() '((#f '"UA" . '"URI1")) seed))
+       '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A"))
+	  (*NAMESPACES* (('"A" '"UA" . '"URI1")
+			 (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+	  (('"UA" . '"P")
+	   (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1")
+			  (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+	   ('"BR"
+	    (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1")
+			   (*DEFAULT* '"UA" . '"URI1")
+			   (#f '"UA" . '"URI1"))))))))
+ ; uniqattr should fail
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values 
+	   `(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+		       (('"A" . '"B") CDATA IMPLIED #f)
+		       (('"C" . '"B") CDATA IMPLIED "xx")
+		       (('"xmlns" . '"C") CDATA IMPLIED "URI1")
+		       ))
+	     (('"A" . '"P") ANY ()) ('"BR" '"EMPTY" ()))
+	   '() '((#f '"UA" . '"URI1")) seed))
+	'())))
+ ; prefix C undeclared
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values 
+	   '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+		       ('"xmlns"  CDATA IMPLIED "URI1")
+		       (('"A" . '"B") CDATA IMPLIED #f)
+		       (('"C" . '"B") CDATA IMPLIED "xx")
+		       ))
+	     (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+	   '() '((#f '"UA" . '"URI1")) seed))
+	'())))
+
+ ; contradiction to xmlns declaration
+ (assert (failed?
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values 
+	   '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+		       ('"xmlns"  CDATA FIXED "URI2")
+		       (('"A" . '"B") CDATA IMPLIED #f)
+		       ))
+	     (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+	   '() '((#f '"UA" . '"URI1")) seed))
+	'())))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values 
+	   '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+		       ('"xmlns"  CDATA FIXED "URI1")
+		       (('"A" . '"B") CDATA IMPLIED #f)
+		       ))
+	     (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+	   '() '((#f '"UA" . '"URI1")) seed))
+       '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A"))
+	  (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1")
+			 ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+	  (('"UA" . '"P")
+	   (*NAMESPACES* ((*DEFAULT* #f . #f) 
+			  (*DEFAULT* '"UA" . '"URI1")
+			  ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1")))
+	   ('"BR"
+	    (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1")
+			   ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1"))))))))
+
+ (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>"
+	(lambda (elem-gi seed)
+	  (values 
+	   '(('"DIV" ANY (('"B" CDATA IMPLIED #f)
+			  (('"A" . '"B") CDATA IMPLIED #f)
+			  (('"C" . '"B") CDATA IMPLIED "xx")
+			  (('"xmlns" . '"C") CDATA IMPLIED "URI2")
+		       ))
+	     (('"A" . '"P") ANY ()) ('"BR" EMPTY ()))
+	   '() '((#f '"UA" . '"URI1")) seed))
+	'((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A")
+			       (('"URI2" . '"B") "xx"))
+	   (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1")
+			  ('"A" '"UA" . '"URI1")
+			  ('"C" '"URI2" . '"URI2")
+			  (#f '"UA" . '"URI1")))
+	   (('"UA" . '"P")
+	    (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1")
+			   ('"A" '"UA" . '"URI1")
+			   ('"C" '"URI2" . '"URI2") (#f '"UA" . '"URI1")))
+	    ('"BR" 
+	     (*NAMESPACES* ((*DEFAULT* #f . #f)
+			    (*DEFAULT* '"UA" . '"URI1")
+			    ('"A" '"UA" . '"URI1")
+			    ('"C" '"URI2" . '"URI2")
+			    (#f '"UA" . '"URI1"))))))))
+))
+
+   
+
+;========================================================================
+;		Highest-level parsers: XML to SXML
+;
+
+; First, a few utility procedures that turned out useful
+
+;     ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We can prove from the general case below that if LIST-OF-FRAGS
+; has zero or one element, the result of the procedure is equal?
+; to its argument. This fact justifies the shortcut evaluation below.
+(define (ssax:reverse-collect-str fragments)
+  (cond
+    ((null? fragments) '())	; a shortcut
+    ((null? (cdr fragments)) fragments) ; see the comment above
+    (else
+      (let loop ((fragments fragments) (result '()) (strs '()))
+	(cond
+	  ((null? fragments)
+	    (if (null? strs) result
+	      (cons (string-concatenate/shared strs) result)))
+	  ((string? (car fragments))
+	    (loop (cdr fragments) result (cons (car fragments) strs)))
+	  (else
+	    (loop (cdr fragments)
+	      (cons
+		(car fragments)
+		(if (null? strs) result
+		  (cons (string-concatenate/shared strs) result)))
+	      '())))))))
+
+
+;     ssax:reverse-collect-str-drop-ws LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We also drop "unsignificant" whitespace, that is, whitespace
+; in front, behind and between elements. The whitespace that
+; is included in character data is not affected.
+; We use this procedure to "intelligently" drop "insignificant"
+; whitespace in the parsed SXML. If the strict compliance with
+; the XML Recommendation regarding the whitespace is desired, please
+; use the ssax:reverse-collect-str procedure instead.
+
+(define (ssax:reverse-collect-str-drop-ws fragments)
+  (cond 
+    ((null? fragments) '())		; a shortcut
+    ((null? (cdr fragments))		; another shortcut
+     (if (and (string? (car fragments)) (string-whitespace? (car fragments)))
+       '() fragments))			; remove trailing ws
+    (else
+      (let loop ((fragments fragments) (result '()) (strs '())
+		  (all-whitespace? #t))
+	(cond
+	  ((null? fragments)
+	    (if all-whitespace? result	; remove leading ws
+	      (cons (string-concatenate/shared strs) result)))
+	  ((string? (car fragments))
+	    (loop (cdr fragments) result (cons (car fragments) strs)
+	      (and all-whitespace?
+		(string-whitespace? (car fragments)))))
+	  (else
+	    (loop (cdr fragments)
+	      (cons
+		(car fragments)
+		(if all-whitespace? result
+		  (cons (string-concatenate/shared strs) result)))
+	      '() #t)))))))
+
+
+; procedure: ssax:xml->sxml PORT NAMESPACE-PREFIX-ASSIG
+;
+; This is an instance of a SSAX parser above that returns an SXML
+; representation of the XML document to be read from PORT.
+; NAMESPACE-PREFIX-ASSIG is a list of (USER-PREFIX . URI-STRING)
+; that assigns USER-PREFIXes to certain namespaces identified by
+; particular URI-STRINGs. It may be an empty list.
+; The procedure returns an SXML tree. The port points out to the
+; first character after the root element.
+
+(define (ssax:xml->sxml port namespace-prefix-assig)
+  (letrec
+      ((namespaces
+	(map (lambda (el)
+	       (cons* #f (car el) (ssax:uri-string->symbol (cdr el))))
+	     namespace-prefix-assig))
+
+       (RES-NAME->SXML
+	(lambda (res-name)
+	  (string->symbol
+	   (string-append
+	    (symbol->string (car res-name))
+	    ":"
+	    (symbol->string (cdr res-name))))))
+
+       )
+    (let ((result
+	   (reverse
+	    ((ssax:make-parser
+	     NEW-LEVEL-SEED 
+	     (lambda (elem-gi attributes namespaces
+			      expected-content seed)
+	       '())
+   
+	     FINISH-ELEMENT
+	     (lambda (elem-gi attributes namespaces parent-seed seed)
+	       (let ((seed (ssax:reverse-collect-str seed))
+		     (attrs
+		      (attlist-fold
+		       (lambda (attr accum)
+			 (cons (list 
+				(if (symbol? (car attr)) (car attr)
+				    (RES-NAME->SXML (car attr)))
+				(cdr attr)) accum))
+		       '() attributes)))
+		 (cons
+		  (cons 
+		   (if (symbol? elem-gi) elem-gi
+		       (RES-NAME->SXML elem-gi))
+		   (if (null? attrs) seed
+		       (cons (cons '@ attrs) seed)))
+		  parent-seed)))
+
+	     CHAR-DATA-HANDLER
+	     (lambda (string1 string2 seed)
+	       (if (string-null? string2) (cons string1 seed)
+		   (cons* string2 string1 seed)))
+
+	     DOCTYPE
+	     (lambda (port docname systemid internal-subset? seed)
+	       (when internal-subset?
+		     (ssax:warn port
+			   "Internal DTD subset is not currently handled ")
+		     (ssax:skip-internal-dtd port))
+	       (ssax:warn port "DOCTYPE DECL " docname " "
+		     systemid " found and skipped")
+	       (values #f '() namespaces seed))
+
+	     UNDECL-ROOT
+	     (lambda (elem-gi seed)
+	       (values #f '() namespaces seed))
+
+	     PI
+	     ((*DEFAULT* .
+		(lambda (port pi-tag seed)
+		  (cons
+		   (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+		   seed))))
+	     )
+	    port '()))))
+      (cons '*TOP*
+	    (if (null? namespace-prefix-assig) result
+		(cons
+		 (list '@ (cons '*NAMESPACES* 
+				 (map (lambda (ns) (list (car ns) (cdr ns)))
+				      namespace-prefix-assig)))
+		      result)))
+)))
+
+; For backwards compatibility
+(define SSAX:XML->SXML ssax:xml->sxml)
+
+ 
+; a few lines of validation code
+(run-test (letrec
+    ((test (lambda (str namespace-assig expected-res)
+	  (newline) (display "input: ")
+	  (write (unesc-string str)) (newline) (display "Result: ")
+	  (let ((result
+		 (call-with-input-string (unesc-string str)
+		     (lambda (port)
+		       (ssax:xml->sxml port namespace-assig)))))
+	    (pp result)
+	    (assert (equal_? result expected-res))))))
+
+    (test " <BR/>" '() '(*TOP* (BR)))
+    (test "<BR></BR>" '() '(*TOP* (BR)))
+    (test " <BR CLEAR='ALL'%nCLASS='Class1'/>" '()
+	  '(*TOP* (BR (@ (CLEAR "ALL") (CLASS "Class1")))))
+    (test "   <A HREF='URL'>  link <I>itlink </I> &amp;amp;</A>" '()
+	  '(*TOP* (A (@ (HREF "URL")) "  link " (I "itlink ") " &amp;")))
+    (test "   <A HREF='URL' xml:space='preserve'>  link <I>itlink </I> &amp;amp;</A>" '()
+	  '(*TOP* (A (@ (xml:space "preserve") (HREF "URL"))
+		     "  link " (I "itlink ") " &amp;")))
+    (test "   <A HREF='URL' xml:space='preserve'>  link <I xml:space='default'>itlink </I> &amp;amp;</A>" '()
+	  '(*TOP* (A (@ (xml:space "preserve") (HREF "URL"))
+		     "  link " (I (@ (xml:space "default"))
+				  "itlink ") " &amp;")))
+    (test " <P><?pi1  p1 content ?>?<?pi2 pi2? content? ??></P>" '()
+	  '(*TOP* (P (*PI* pi1 "p1 content ") "?"
+		     (*PI* pi2 "pi2? content? ?"))))
+    (test " <P>some text <![CDATA[<]]>1%n&quot;<B>strong</B>&quot;%r</P>"
+	  '()
+	  `(*TOP* (P ,(unesc-string "some text <1%n\"")
+		      (B "strong") ,(unesc-string "\"%n"))))
+    (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]&gt;]]></P>" '()
+	  `(*TOP* (P ,(unesc-string "<BR>%n<![CDATA[<BR>]]>"))))
+;    (test "<T1><T2>it&apos;s%r%nand   that%n</T2>%r%n%r%n%n</T1>" '()
+;	  '(*TOP* (T1 (T2 "it's%nand   that%n") "%n%n%n")))
+    (test "<T1><T2>it&apos;s%r%nand   that%n</T2>%r%n%r%n%n</T1>" '()
+	  `(*TOP* (T1 (T2 ,(unesc-string "it's%nand   that%n")) ,(unesc-string "%n%n%n"))))
+    (test "<T1><T2>it&apos;s%rand   that%n</T2>%r%n%r%n%n</T1>" '()
+	  `(*TOP* (T1 (T2 ,(unesc-string "it's%nand   that%n")) ,(unesc-string "%n%n%n"))))
+    (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>" '()
+	  '(*TOP* (T)))
+    (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '()
+	  `(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound"))
+                ,nl (NET (@ (certified "certified")) " 67 ") ,nl
+                (GROSS " 95 ") ,nl)
+		  ))
+;     (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '()
+; 	  '(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound"))
+;                "%n" (NET (@ (certified "certified")) " 67 ")
+;                "%n" (GROSS " 95 ") "%n")
+; 		  ))
+    (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" '()
+	  '(*TOP* (URI1:DIV (@ (URI1:B "A") (B "B")) (URI1:P (BR)))))
+    (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" '((UA . "URI1"))
+	  '(*TOP* (@ (*NAMESPACES* (UA "URI1")))
+		  (UA:DIV (@ (UA:B "A") (B "B")) (UA:P (BR)))))
+
+    ; A few tests from XML Namespaces Recommendation
+    (test (string-append
+	   "<x xmlns:edi='http://ecommerce.org/schema'>"
+           "<!-- the 'taxClass' attribute's  ns http://ecommerce.org/schema -->"
+           "<lineItem edi:taxClass='exempt'>Baby food</lineItem>" nl
+           "</x>") '()
+	   `(*TOP* 
+	     (x (lineItem
+		 (@ (http://ecommerce.org/schema:taxClass "exempt"))
+            "Baby food") ,nl)))
+    (test (string-append 
+	   "<x xmlns:edi='http://ecommerce.org/schema'>"
+           "<!-- the 'taxClass' attribute's  ns http://ecommerce.org/schema -->"
+           "<lineItem edi:taxClass='exempt'>Baby food</lineItem>"
+           "</x>") '((EDI . "http://ecommerce.org/schema"))
+	   '(*TOP*
+	     (@ (*NAMESPACES* (EDI "http://ecommerce.org/schema")))
+	     (x (lineItem
+		 (@ (EDI:taxClass "exempt"))
+            "Baby food"))))
+
+    (test (string-append
+	   "<bk:book xmlns:bk='urn:loc.gov:books' "
+                     "xmlns:isbn='urn:ISBN:0-395-36341-6'>"
+	   "<bk:title>Cheaper by the Dozen</bk:title>"
+           "<isbn:number>1568491379</isbn:number></bk:book>")
+	  '()
+	  '(*TOP* (urn:loc.gov:books:book
+		   (urn:loc.gov:books:title "Cheaper by the Dozen")
+		   (urn:ISBN:0-395-36341-6:number "1568491379"))))
+
+    (test (string-append
+	   "<!-- initially, the default namespace is 'books' -->"
+           "<book xmlns='urn:loc.gov:books' "
+           "xmlns:isbn='urn:ISBN:0-395-36341-6'>"
+           "<title>Cheaper by the Dozen</title>"
+           "<isbn:number>1568491379</isbn:number>"
+	   "<notes>"
+	   "<!-- make HTML the default namespace for some commentary -->"
+	   "<p xmlns='urn:w3-org-ns:HTML'>"
+	   "This is a <i>funny</i> book!"
+            "</p>"
+            "</notes>"
+            "</book>") '()
+	    '(*TOP* (urn:loc.gov:books:book
+		   (urn:loc.gov:books:title "Cheaper by the Dozen")
+		   (urn:ISBN:0-395-36341-6:number "1568491379")
+		   (urn:loc.gov:books:notes
+		    (urn:w3-org-ns:HTML:p 
+		     "This is a " (urn:w3-org-ns:HTML:i "funny")
+		     " book!")))))
+
+    (test (string-append
+	   "<Beers>"
+           "<!-- the default namespace is now that of HTML -->"
+           "<table xmlns='http://www.w3.org/TR/REC-html40'>"
+           "<th><td>Name</td><td>Origin</td><td>Description</td></th>"
+           "<tr>"
+           "<!-- no default namespace inside table cells -->"
+           "<td><brandName xmlns=\"\">Huntsman</brandName></td>"
+           "<td><origin xmlns=''>Bath, UK</origin></td>"
+           "<td>"
+              "<details xmlns=''><class>Bitter</class><hop>Fuggles</hop>"
+              "<pro>Wonderful hop, light alcohol, good summer beer</pro>"
+              "<con>Fragile; excessive variance pub to pub</con>"
+              "</details>"
+	   "</td>"
+           "</tr>"
+           "</table>"
+           "</Beers>")
+	      '((html . "http://www.w3.org/TR/REC-html40"))
+	      '(*TOP*
+		(@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40")))
+		(Beers (html:table
+                (html:th (html:td "Name")
+                         (html:td "Origin")
+                         (html:td "Description"))
+                (html:tr (html:td (brandName "Huntsman"))
+                         (html:td (origin "Bath, UK"))
+                         (html:td 
+			  (details 
+			   (class "Bitter")
+			(hop "Fuggles")
+			(pro "Wonderful hop, light alcohol, good summer beer")
+			(con "Fragile; excessive variance pub to pub"))))))))
+
+    (test (string-append
+       "<!-- 1 --><RESERVATION xmlns:HTML='http://www.w3.org/TR/REC-html40'>"
+       "<!-- 2 --><NAME HTML:CLASS=\"largeSansSerif\">Layman, A</NAME>"
+       "<!-- 3 --><SEAT CLASS='Y' HTML:CLASS=\"largeMonotype\">33B</SEAT>"
+       "<!-- 4 --><HTML:A HREF='/cgi-bin/ResStatus'>Check Status</HTML:A>"
+       "<!-- 5 --><DEPARTURE>1997-05-24T07:55:00+1</DEPARTURE></RESERVATION>")
+	  '((HTML . "http://www.w3.org/TR/REC-html40"))
+	  '(*TOP*
+	    (@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40")))
+	     (RESERVATION
+	      (NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A")
+	      (SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B")
+	      (HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status")
+	      (DEPARTURE "1997-05-24T07:55:00+1"))))
+    ; Part of RDF from the XML Infoset
+        (test (string-concatenate/shared '(
+   "<?xml version='1.0' encoding='utf-8' standalone='yes'?>"
+   "<!-- this can be decoded as US-ASCII or iso-8859-1 as well,"
+   "  since it contains no characters outside the US-ASCII repertoire -->"
+   "<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'"
+   "         xmlns:rdfs='http://www.w3.org/2000/01/rdf-schema#'"
+   "          xmlns='http://www.w3.org/2001/02/infoset#'>"
+   "<rdfs:Class ID='Boolean'/>"
+   "<Boolean ID='Boolean.true'/>"
+   "<Boolean ID='Boolean.false'/>"
+   "<!--Info item classes-->"
+   "<rdfs:Class ID='InfoItem'/>"
+   "<rdfs:Class ID='Document' rdfs:subClassOf='#InfoItem'/>"
+   "<rdfs:Class ID='Element' rdfs:subClassOf='#InfoItem'/>"
+   "<rdfs:Class ID='Attribute' rdfs:subClassOf='#InfoItem'/>"
+   "<rdfs:Class ID='InfoItemSet'
+      rdfs:subClassOf='http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag'/>"
+   "<rdfs:Class ID='AttributeSet' rdfs:subClassOf='#InfoItemSet'/>"
+   "<!--Info item properties-->"
+   "<rdfs:Property ID='allDeclarationsProcessed'>"
+   "<rdfs:domain resource='#Document'/>"
+   "<rdfs:range resource='#Boolean'/></rdfs:Property>"
+   "<rdfs:Property ID='attributes'>"
+   "<rdfs:domain resource='#Element'/>"
+   "<rdfs:range resource='#AttributeSet'/>"
+   "</rdfs:Property>"
+   "</rdf:RDF>"))
+   '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+     (RDFS . "http://www.w3.org/2000/01/rdf-schema#")
+     (ISET . "http://www.w3.org/2001/02/infoset#"))
+   '(*TOP* (@ (*NAMESPACES*
+         (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+         (RDFS "http://www.w3.org/2000/01/rdf-schema#")
+         (ISET "http://www.w3.org/2001/02/infoset#")))
+       (*PI* xml "version='1.0' encoding='utf-8' standalone='yes'")
+       (RDF:RDF
+	(RDFS:Class (@ (ID "Boolean")))
+	(ISET:Boolean (@ (ID "Boolean.true")))
+	(ISET:Boolean (@ (ID "Boolean.false")))
+	(RDFS:Class (@ (ID "InfoItem")))
+	(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Document")))
+	(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Element")))
+	(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Attribute")))
+	(RDFS:Class
+	 (@ (RDFS:subClassOf
+	     "http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag")
+	    (ID "InfoItemSet")))
+	(RDFS:Class
+	 (@ (RDFS:subClassOf "#InfoItemSet") (ID "AttributeSet")))
+	(RDFS:Property
+	 (@ (ID "allDeclarationsProcessed"))
+	 (RDFS:domain (@ (resource "#Document")))
+	 (RDFS:range (@ (resource "#Boolean"))))
+	(RDFS:Property
+	 (@ (ID "attributes"))
+	 (RDFS:domain (@ (resource "#Element")))
+	 (RDFS:range (@ (resource "#AttributeSet")))))))
+	  
+    ; Part of RDF from RSS of the Daemon News Mall
+        (test (string-concatenate/shared (list-intersperse '(
+  "<?xml version='1.0'?><rdf:RDF "
+    "xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' "
+     "xmlns='http://my.netscape.com/rdf/simple/0.9/'>"
+     "<channel>"
+     "<title>Daemon News Mall</title>"
+     "<link>http://mall.daemonnews.org/</link>"
+     "<description>Central source for all your BSD needs</description>"
+     "</channel>"
+     "<item>"
+     "<title>Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95</title>"
+     "<link>http://mall.daemonnews.org/?page=shop/flypage&amp;product_id=880</link>"
+     "</item>"
+     "<item>"
+     "<title>The Design and Implementation of the 4.4BSD Operating System $54.95</title>"
+     "<link>http://mall.daemonnews.org/?page=shop/flypage&amp;product_id=912&amp;category_id=1761</link>"
+     "</item>"
+     "</rdf:RDF>")
+   (string #\newline)
+   ))
+   '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+     (RSS . "http://my.netscape.com/rdf/simple/0.9/")
+     (ISET . "http://www.w3.org/2001/02/infoset#"))
+   `(*TOP* (@ (*NAMESPACES*
+         (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+         (RSS "http://my.netscape.com/rdf/simple/0.9/")
+         (ISET "http://www.w3.org/2001/02/infoset#")))
+       (*PI* xml "version='1.0'")
+       (RDF:RDF ,nl
+                (RSS:channel ,nl
+                  (RSS:title "Daemon News Mall") ,nl
+                  (RSS:link "http://mall.daemonnews.org/") ,nl
+                  (RSS:description "Central source for all your BSD needs") ,nl) ,nl
+                (RSS:item ,nl
+                  (RSS:title
+                    "Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95") ,nl
+                  (RSS:link
+                    "http://mall.daemonnews.org/?page=shop/flypage&product_id=880") ,nl) ,nl
+                (RSS:item ,nl
+                  (RSS:title
+                    "The Design and Implementation of the 4.4BSD Operating System $54.95") ,nl
+                  (RSS:link
+                    "http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761") ,nl) ,nl)))
+
+    (test (string-concatenate/shared
+       '("<Forecasts TStamp='958082142'>"
+	 "<TAF TStamp='958066200' LatLon='36.583, -121.850' BId='724915'"
+	 "  SName='KMRY, MONTEREY PENINSULA'>"
+	 "<VALID TRange='958068000, 958154400'>111730Z 111818</VALID>"
+	 "<PERIOD TRange='958068000, 958078800'>"
+	 "<PREVAILING>31010KT P6SM FEW030</PREVAILING>"
+	 "</PERIOD>"
+	 "<PERIOD TRange='958078800, 958104000' Title='FM2100'>"
+	 "<PREVAILING>29016KT P6SM FEW040</PREVAILING>"
+	 "</PERIOD>"
+	 "<PERIOD TRange='958104000, 958154400' Title='FM0400'>"
+	 "<PREVAILING>29010KT P6SM SCT200</PREVAILING>"
+	 "<VAR Title='BECMG 0708' TRange='958114800, 958118400'>VRB05KT</VAR>"
+	 "</PERIOD></TAF>"
+	 "</Forecasts>"))
+	  '()
+	  '(*TOP* (Forecasts
+		   (@ (TStamp "958082142"))
+		   (TAF (@ (TStamp "958066200")
+			   (SName "KMRY, MONTEREY PENINSULA")
+			   (LatLon "36.583, -121.850")
+			   (BId "724915"))
+              (VALID (@ (TRange "958068000, 958154400")) "111730Z 111818")
+              (PERIOD (@ (TRange "958068000, 958078800"))
+                      (PREVAILING "31010KT P6SM FEW030"))
+              (PERIOD (@ (Title "FM2100") (TRange "958078800, 958104000"))
+                      (PREVAILING "29016KT P6SM FEW040"))
+              (PERIOD (@ (Title "FM0400") (TRange "958104000, 958154400"))
+                      (PREVAILING "29010KT P6SM SCT200")
+                      (VAR (@ (Title "BECMG 0708")
+                              (TRange "958114800, 958118400"))
+                           "VRB05KT"))))))
+))
+
+(run-test
+ (newline)
+ (display "All tests passed")
+ (newline)
+)
+;		XML/HTML processing in Scheme
+;		SXML expression tree transformers
+;
+; IMPORT
+; A prelude appropriate for your Scheme system
+;	(myenv-bigloo.scm, myenv-mit.scm, etc.)
+;
+; EXPORT
+; (provide SRV:send-reply
+;	   post-order pre-post-order replace-range)
+;
+; See vSXML-tree-trans.scm for the validation code, which also
+; serves as usage examples.
+;
+; $Id: SXML-tree-trans.scm,v 1.6 2003/04/25 19:16:15 oleg Exp $
+
+
+; Output the 'fragments'
+; The fragments are a list of strings, characters,
+; numbers, thunks, #f, #t -- and other fragments.
+; The function traverses the tree depth-first, writes out
+; strings and characters, executes thunks, and ignores
+; #f and '().
+; The function returns #t if anything was written at all;
+; otherwise the result is #f
+; If #t occurs among the fragments, it is not written out
+; but causes the result of SRV:send-reply to be #t
+
+(define (SRV:send-reply . fragments)
+  (let loop ((fragments fragments) (result #f))
+    (cond
+      ((null? fragments) result)
+      ((not (car fragments)) (loop (cdr fragments) result))
+      ((null? (car fragments)) (loop (cdr fragments) result))
+      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
+      ((pair? (car fragments))
+        (loop (cdr fragments) (loop (car fragments) result)))
+      ((procedure? (car fragments))
+        ((car fragments))
+        (loop (cdr fragments) #t))
+      (else
+        (display (car fragments))
+        (loop (cdr fragments) #t)))))
+
+
+
+;------------------------------------------------------------------------
+;	          Traversal of an SXML tree or a grove:
+;			a <Node> or a <Nodelist>
+;
+; A <Node> and a <Nodelist> are mutually-recursive datatypes that
+; underlie the SXML tree:
+;	<Node> ::= (name . <Nodelist>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; 	<Nodelist> ::= (<Node> ...)
+; Nodelists, and Nodes other than text strings are both lists. A
+; <Nodelist> however is either an empty list, or a list whose head is
+; not a symbol (an atom in general). A symbol at the head of a node is
+; either an XML name (in which case it's a tag of an XML element), or
+; an administrative name such as '@'.
+; See SXPath.scm and SSAX.scm for more information on SXML.
+
+
+; Pre-Post-order traversal of a tree and creation of a new tree:
+;	pre-post-order:: <tree> x <bindings> -> <new-tree>
+; where
+; <bindings> ::= (<binding> ...)
+; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
+;               (<trigger-symbol> *macro* . <handler>) |
+;		(<trigger-symbol> <new-bindings> . <handler>) |
+;		(<trigger-symbol> . <handler>)
+; <trigger-symbol> ::= XMLname | *text* | *default*
+; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
+;
+; The pre-post-order function visits the nodes and nodelists
+; pre-post-order (depth-first).  For each <Node> of the form (name
+; <Node> ...) it looks up an association with the given 'name' among
+; its <bindings>. If failed, pre-post-order tries to locate a
+; *default* binding. It's an error if the latter attempt fails as
+; well.  Having found a binding, the pre-post-order function first
+; checks to see if the binding is of the form
+;	(<trigger-symbol> *preorder* . <handler>)
+; If it is, the handler is 'applied' to the current node. Otherwise,
+; the pre-post-order function first calls itself recursively for each
+; child of the current node, with <new-bindings> prepended to the
+; <bindings> in effect. The result of these calls is passed to the
+; <handler> (along with the head of the current <Node>). To be more
+; precise, the handler is _applied_ to the head of the current node
+; and its processed children. The result of the handler, which should
+; also be a <tree>, replaces the current <Node>. If the current <Node>
+; is a text string or other atom, a special binding with a symbol
+; *text* is looked up.
+;
+; A binding can also be of a form
+;	(<trigger-symbol> *macro* . <handler>)
+; This is equivalent to *preorder* described above. However, the result
+; is re-processed again, with the current stylesheet.
+
+(define (pre-post-order tree bindings)
+  (let* ((default-binding (assq '*default* bindings))
+	 (text-binding (or (assq '*text* bindings) default-binding))
+	 (text-handler			; Cache default and text bindings
+	   (and text-binding
+	     (if (procedure? (cdr text-binding))
+	         (cdr text-binding) (cddr text-binding)))))
+    (let loop ((tree tree))
+      (cond
+	((null? tree) '())
+	((not (pair? tree))
+	  (let ((trigger '*text*))
+	    (if text-handler (text-handler trigger tree)
+	      (error "Unknown binding for " trigger " and no default"))))
+	((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
+	(else				; tree is an SXML node
+	  (let* ((trigger (car tree))
+		 (binding (or (assq trigger bindings) default-binding)))
+	    (cond
+	      ((not binding) 
+		(error "Unknown binding for " trigger " and no default"))
+	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
+		(apply (cdr binding) trigger (map loop (cdr tree))))
+	      ((eq? '*preorder* (cadr binding))
+		(apply (cddr binding) tree))
+	      ((eq? '*macro* (cadr binding))
+		(loop (apply (cddr binding) tree)))
+	      (else			    ; (cadr binding) is a local binding
+		(apply (cddr binding) trigger 
+		  (pre-post-order (cdr tree) (append (cadr binding) bindings)))
+		))))))))
+
+; post-order is a strict subset of pre-post-order without *preorder*
+; (let alone *macro*) traversals. 
+; Now pre-post-order is actually faster than the old post-order.
+; The function post-order is deprecated and is aliased below for
+; backward compatibility.
+(define post-order pre-post-order)
+
+;------------------------------------------------------------------------
+;			Extended tree fold
+; tree = atom | (node-name tree ...)
+;
+; foldts fdown fup fhere seed (Leaf str) = fhere seed str
+; foldts fdown fup fhere seed (Nd kids) =
+;         fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
+
+; procedure fhere: seed -> atom -> seed
+; procedure fdown: seed -> node -> seed
+; procedure fup: parent-seed -> last-kid-seed -> node -> seed
+; foldts returns the final seed
+
+(define (foldts fdown fup fhere seed tree)
+  (cond
+   ((null? tree) seed)
+   ((not (pair? tree))		; An atom
+    (fhere seed tree))
+   (else
+    (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
+      (if (null? kids)
+	  (fup seed kid-seed tree)
+	  (loop (foldts fdown fup fhere kid-seed (car kids))
+		(cdr kids)))))))
+
+;------------------------------------------------------------------------
+; Traverse a forest depth-first and cut/replace ranges of nodes.
+;
+; The nodes that define a range don't have to have the same immediate
+; parent, don't have to be on the same level, and the end node of a
+; range doesn't even have to exist. A replace-range procedure removes
+; nodes from the beginning node of the range up to (but not including)
+; the end node of the range.  In addition, the beginning node of the
+; range can be replaced by a node or a list of nodes. The range of
+; nodes is cut while depth-first traversing the forest. If all
+; branches of the node are cut a node is cut as well.  The procedure
+; can cut several non-overlapping ranges from a forest.
+
+;	replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
+; where
+;	type FOREST = (NODE ...)
+;	type NODE = Atom | (Name . FOREST) | FOREST
+;
+; The range of nodes is specified by two predicates, beg-pred and end-pred.
+;	beg-pred:: NODE -> #f | FOREST
+;	end-pred:: NODE -> #f | FOREST
+; The beg-pred predicate decides on the beginning of the range. The node
+; for which the predicate yields non-#f marks the beginning of the range
+; The non-#f value of the predicate replaces the node. The value can be a
+; list of nodes. The replace-range procedure then traverses the tree and skips
+; all the nodes, until the end-pred yields non-#f. The value of the end-pred
+; replaces the end-range node. The new end node and its brothers will be
+; re-scanned.
+; The predicates are evaluated pre-order. We do not descend into a node that
+; is marked as the beginning of the range.
+
+(define (replace-range beg-pred end-pred forest)
+
+  ; loop forest keep? new-forest
+  ; forest is the forest to traverse
+  ; new-forest accumulates the nodes we will keep, in the reverse
+  ; order
+  ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
+  ; traverse its children and keep those that are not in the skip range.
+  ; If keep? is #f, skip the current node if atomic. Otherwise,
+  ; traverse its children. If all children are skipped, skip the node
+  ; as well.
+
+  (define (loop forest keep? new-forest)
+    (if (null? forest) (values (reverse new-forest) keep?)
+	(let ((node (car forest)))
+	  (if keep?
+	      (cond			; accumulate mode
+	       ((beg-pred node) =>	; see if the node starts the skip range
+		(lambda (repl-branches)	; if so, skip/replace the node
+		  (loop (cdr forest) #f 
+			(append (reverse repl-branches) new-forest))))
+	       ((not (pair? node))	; it's an atom, keep it
+		(loop (cdr forest) keep? (cons node new-forest)))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node))) ; or is it a nodelist?
+		  ((new-kids keep?)		 ; traverse its children
+		   (loop (if node? (cdr node) node) #t '())))
+		 (loop (cdr forest) keep?
+		       (cons 
+			(if node? (cons (car node) new-kids) new-kids)
+			new-forest)))))
+	      ; skip mode
+	      (cond
+	       ((end-pred node) =>	; end the skip range
+		(lambda (repl-branches)	; repl-branches will be re-scanned
+		  (loop (append repl-branches (cdr forest)) #t
+			new-forest)))
+	       ((not (pair? node))	; it's an atom, skip it
+		(loop (cdr forest) keep? new-forest))
+	       (else
+		(let*-values
+		 (((node?) (symbol? (car node)))  ; or is it a nodelist?
+		  ((new-kids keep?)		  ; traverse its children
+		   (loop (if node? (cdr node) node) #f '())))
+		 (loop (cdr forest) keep?
+		       (if (or keep? (pair? new-kids))
+			   (cons
+			    (if node? (cons (car node) new-kids) new-kids)
+			    new-forest)
+			   new-forest)		; if all kids are skipped
+		       ))))))))			; skip the node too
+  
+  (let*-values (((new-forest keep?) (loop forest #t '())))
+     new-forest))
+
+;			XML processing in Scheme
+;		     SXPath -- SXML Query Language
+;
+; SXPath is a query language for SXML, an instance of XML Information
+; set (Infoset) in the form of s-expressions. See SSAX.scm for the
+; definition of SXML and more details. SXPath is also a translation into
+; Scheme of an XML Path Language, XPath:
+;	http://www.w3.org/TR/xpath
+; XPath and SXPath describe means of selecting a set of Infoset's items
+; or their properties.
+;
+; To facilitate queries, XPath maps the XML Infoset into an explicit
+; tree, and introduces important notions of a location path and a
+; current, context node. A location path denotes a selection of a set of
+; nodes relative to a context node. Any XPath tree has a distinguished,
+; root node -- which serves as the context node for absolute location
+; paths. Location path is recursively defined as a location step joined
+; with a location path. A location step is a simple query of the
+; database relative to a context node. A step may include expressions
+; that further filter the selected set. Each node in the resulting set
+; is used as a context node for the adjoining location path. The result
+; of the step is a union of the sets returned by the latter location
+; paths.
+;
+; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+; suitable for querying as it is. Bowing to the XPath specification,
+; we will refer to SXML information items as 'Nodes':
+; 	<Node> ::= <Element> | <attributes-coll> | <attrib>
+; 		   | "text string" | <PI>
+; This production can also be described as
+;	<Node> ::= (name . <Nodeset>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; 	<Nodeset> ::= (<Node> ...)
+; Nodesets, and Nodes other than text strings are both lists. A
+; <Nodeset> however is either an empty list, or a list whose head is not
+; a symbol.  A symbol at the head of a node is either an XML name (in
+; which case it's a tag of an XML element), or an administrative name
+; such as '@'.  This uniform list representation makes processing rather
+; simple and elegant, while avoiding confusion. The multi-branch tree
+; structure formed by the mutually-recursive datatypes <Node> and
+; <Nodeset> lends itself well to processing by functional languages.
+;
+; A location path is in fact a composite query over an XPath tree or
+; its branch. A singe step is a combination of a projection, selection
+; or a transitive closure. Multiple steps are combined via join and
+; union operations. This insight allows us to _elegantly_ implement
+; XPath as a sequence of projection and filtering primitives --
+; converters -- joined by _combinators_. Each converter takes a node
+; and returns a nodeset which is the result of the corresponding query
+; relative to that node. A converter can also be called on a set of
+; nodes. In that case it returns a union of the corresponding queries over
+; each node in the set. The union is easily implemented as a list
+; append operation as all nodes in a SXML tree are considered
+; distinct, by XPath conventions. We also preserve the order of the
+; members in the union. Query combinators are high-order functions:
+; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+; and compose or otherwise combine them. We will be concerned with
+; only relative location paths [XPath]: an absolute location path is a
+; relative path applied to the root node.
+;
+; Similarly to XPath, SXPath defines full and abbreviated notations
+; for location paths. In both cases, the abbreviated notation can be
+; mechanically expanded into the full form by simple rewriting
+; rules. In case of SXPath the corresponding rules are given as
+; comments to a sxpath function, below. The regression test suite at
+; the end of this file shows a representative sample of SXPaths in
+; both notations, juxtaposed with the corresponding XPath
+; expressions. Most of the samples are borrowed literally from the
+; XPath specification, while the others are adjusted for our running
+; example, tree1.
+;
+; To do:
+; Rename filter to node-filter or ns-filter
+; Use ;=== for chapters, ;--- for sections, and ;^^^ for end sections
+;
+; $Id: SXPath-old.scm,v 1.4 2004/07/07 16:02:31 sperber Exp $
+
+
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv.scm
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv-scm.scm
+	; See http://pobox.com/~oleg/ftp/Scheme/myenv-bigloo.scm
+;(module SXPath
+;  (include "myenv-bigloo.scm"))		; For use with Bigloo 2.2b
+;(load "myenv-scm.scm")		; For use with SCM v5d2
+;(include "myenv.scm")		; For use with Gambit-C 3.0
+
+
+
+(define (nodeset? x)
+  (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+;-------------------------
+; Basic converters and applicators
+; A converter is a function
+;	type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; The following function implements a 'Node test' as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+;
+; The function node-typeof? takes a type criterion and returns a function,
+; which, when applied to a node, will tell if the node satisfies
+; the test.
+;	node-typeof? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is a symbol, one of the following:
+;	id		- tests if the Node has the right name (id)
+;	@		- tests if the Node is an <attributes-coll>
+;	*		- tests if the Node is an <Element>
+;	*text*		- tests if the Node is a text node
+;	*PI*		- tests if the Node is a PI node
+;	*any*		- #t for any type of Node
+
+(define (node-typeof? crit)
+  (lambda (node)
+    (case crit
+      ((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
+      ((*any*) #t)
+      ((*text*) (string? node))
+      (else
+       (and (pair? node) (eq? crit (car node))))
+)))
+
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+  (lambda (node)
+    (eq? other node)))
+
+(define (node-equal? other)
+  (lambda (node)
+    (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+
+(define (node-pos n)
+  (lambda (nodeset)
+    (cond
+     ((not (nodeset? nodeset)) '())
+     ((null? nodeset) nodeset)
+     ((eqv? n 1) (list (car nodeset)))
+     ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+     (else
+      (assert (positive? n))
+      ((node-pos (dec n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (filter pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
+      (if (null? lst)
+	  (reverse res)
+	  (let ((pred-result (pred? (car lst))))
+	    (loop (cdr lst)
+		  (if (and pred-result (not (null? pred-result)))
+		      (cons (car lst) res)
+		      res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset -- 
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+
+(define (take-until pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		'()
+		(cons (car lst) (loop (cdr lst)))))
+	  ))))
+
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have not been processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+
+(define (take-after pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		(cdr lst)
+		(loop (cdr lst))))
+	  ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+
+(define (map-union proc lst)
+  (if (null? lst) lst
+      (let ((proc-res (proc (car lst))))
+	((if (nodeset? proc-res) append cons)
+	 proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse 
+  (lambda (node-or-nodeset)
+    (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+	(reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+
+(define (node-trace title)
+  (lambda (node-or-nodeset)
+    (cout nl "-->")
+    (display title)
+    (display " :")
+    (pretty-print node-or-nodeset)
+    node-or-nodeset))
+
+
+;-------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+
+(define (select-kids test-pred?)
+  (lambda (node)		; node or node-set
+    (cond 
+     ((null? node) node)
+     ((not (pair? node)) '())   ; No children
+     ((symbol? (car node))
+      ((filter test-pred?) (cdr node)))	; it's a single node
+     (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (selectors selectors))
+      (if (null? selectors) nodeset
+	  (loop 
+	   (if (nodeset? nodeset)
+	       (map-union (car selectors) nodeset)
+	       ((car selectors) nodeset))
+	   (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+;    ((apply node-reduce converters) nodeset)
+; is equivalent to
+;    (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (converters converters))
+      (if (null? converters) nodeset
+	  (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+;   (lambda (node-or-nodeset)
+;     (if (null? converters) node-or-nodeset
+; 	(append 
+; 	 ((car converters) node-or-nodeset)
+; 	 ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+  (lambda (node-or-nodeset)
+    (let loop ((result '()) (converters converters))
+      (if (null? converters) result
+	  (loop (append result (or ((car converters) node-or-nodeset) '()))
+		(cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+;      (node-or
+;        (select-kids f)
+;	 (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (node-typeof? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+
+(define (node-closure test-pred?)	    
+  (lambda (node)		; Nodeset or node
+    (let loop ((parent node) (result '()))
+      (if (null? parent) result
+	  (loop ((select-kids (node-typeof? '*)) parent)
+		(append result
+			((select-kids test-pred?) parent)))
+	  ))))
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+;  parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones.  Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+; Note that the parent:: axis can be used with an attribute node as well!
+
+(define (node-parent rootnode)
+  (lambda (node)		; Nodeset or node
+    (if (nodeset? node) (map-union (node-parent rootnode) node)
+	(let ((pred
+	       (node-or
+		(node-reduce
+		 (node-self (node-typeof? '*))
+		 (select-kids (node-eq? node)))
+		(node-join
+		 (select-kids (node-typeof? '@))
+		 (select-kids (node-eq? node))))))
+	  ((node-or
+	    (node-self pred)
+	    (node-closure pred))
+	   rootnode)))))
+
+;-------------------------
+; Evaluate an abbreviated SXPath
+;	sxpath:: AbbrPath -> Converter, or
+;	sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
+; AbbrPath is a list. It is translated to the full SXPath according
+; to the following rewriting rules
+; (sxpath '()) -> (node-join)
+; (sxpath '(path-component ...)) ->
+;		(node-join (sxpath1 path-component) (sxpath '(...)))
+; (sxpath1 '//) -> (node-or 
+;		     (node-self (node-typeof? '*any*))
+;		      (node-closure (node-typeof? '*any*)))
+; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
+; (sxpath1 '(eq? x))    -> (select-kids (node-eq? x))
+; (sxpath1 ?symbol)     -> (select-kids (node-typeof? ?symbol)
+; (sxpath1 procedure)   -> procedure
+; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
+; (sxpath1 '(path reducer ...)) ->
+;		(node-reduce (sxpath path) (sxpathr reducer) ...)
+; (sxpathr number)      -> (node-pos number)
+; (sxpathr path-filter) -> (filter (sxpath path-filter))
+
+(define (sxpath path)
+  (lambda (nodeset)
+    (let loop ((nodeset nodeset) (path path))
+    (cond
+     ((null? path) nodeset)
+     ((nodeset? nodeset)
+      (map-union (sxpath path) nodeset))
+     ((procedure? (car path))
+      (loop ((car path) nodeset) (cdr path)))
+     ((eq? '// (car path))
+      (loop
+       ((if (nodeset? nodeset) append cons) nodeset
+	((node-closure (node-typeof? '*any*)) nodeset))
+       (cdr path)))
+     ((symbol? (car path))
+      (loop ((select-kids (node-typeof? (car path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'equal? (caar path)))
+      (loop ((select-kids (apply node-equal? (cdar path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'eq? (caar path)))
+      (loop ((select-kids (apply node-eq? (cdar path))) nodeset)
+	    (cdr path)))
+     ((pair? (car path))
+      (let reducer ((nodeset 
+		     (if (symbol? (caar path))
+			 ((select-kids (node-typeof? (caar path))) nodeset)
+			 (loop nodeset (caar path))))
+		    (reducing-path (cdar path)))
+	(cond
+	 ((null? reducing-path) (loop nodeset (cdr path)))
+	 ((number? (car reducing-path))
+	  (reducer ((node-pos (car reducing-path)) nodeset)
+		   (cdr reducing-path)))
+	 (else
+	  (reducer ((filter (sxpath (car reducing-path))) nodeset)
+		   (cdr reducing-path))))))
+     (else
+      (error "Invalid path step: " (car path)))
+))))
+
+;------------------------------------------------------------------------
+; Sample XPath/SXPath expressions: regression test suite for the
+; implementation above.
+
+; A running example
+
+(define tree1 
+  '(html
+    (head (title "Slides"))
+    (body
+     (p (@ (align "center"))
+	(table (@ (style "font-size: x-large"))
+	       (tr
+		(td (@ (align "right")) "Talks ")
+		(td (@ (align "center")) " = ")
+		(td " slides + transition"))
+	       (tr (td)
+		   (td (@ (align "center")) " = ")
+		   (td " data + control"))
+	       (tr (td)
+		   (td (@ (align "center")) " = ")
+		   (td " programs"))))
+     (ul
+      (li (a (@ (href "slides/slide0001.gif")) "Introduction"))
+      (li (a (@ (href "slides/slide0010.gif")) "Summary")))
+     )))
+
+
+; Example from a posting "Re: DrScheme and XML", 
+; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
+; http://www.deja.com/getdoc.xp?AN=553507805
+(define tree3
+  '(poem (@ (title "The Lovesong of J. Alfred Prufrock")
+	    (poet "T. S. Eliot"))
+	 (stanza
+	  (line "Let us go then, you and I,")
+	  (line "When the evening is spread out against the sky")
+	  (line "Like a patient etherized upon a table:"))
+	 (stanza
+	  (line "In the room the women come and go")
+	  (line "Talking of Michaelangelo."))))
+
+; Validation Test harness
+
+(define-syntax run-test
+ (syntax-rules (define)
+   ((run-test "scan-exp" (define vars body))
+    (define vars (run-test "scan-exp" body)))
+   ((run-test "scan-exp" ?body)
+    (letrec-syntax
+      ((scan-exp			; (scan-exp body k)
+	 (syntax-rules (quote quasiquote !)
+	   ((scan-exp '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-exp (quote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quasiquote (hd . tl)) k)
+	     (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
+	   ((scan-exp (quote x) (k-head ! . args))
+	     (k-head 
+	       (if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	   ((scan-exp (hd . tl) k)
+	     (scan-exp hd (do-tl ! scan-exp tl k)))
+	   ((scan-exp x (k-head ! . args))
+	     (k-head x . args))))
+	(do-tl
+	  (syntax-rules (!)
+	    ((do-tl processed-hd fn () (k-head ! . args))
+	      (k-head (processed-hd) . args))
+	    ((do-tl processed-hd fn old-tl k)
+	      (fn old-tl (do-cons ! processed-hd k)))))
+	(do-cons
+	  (syntax-rules (!)
+	    ((do-cons processed-tl processed-hd (k-head ! . args))
+	      (k-head (processed-hd . processed-tl) . args))))
+	(do-wrap
+	  (syntax-rules (!)
+	    ((do-wrap val fn (k-head ! . args))
+	      (k-head (fn val) . args))))
+	(do-finish
+	  (syntax-rules ()
+	    ((do-finish new-body) new-body)))
+
+	(scan-lit-lst			; scan literal list
+	  (syntax-rules (quote unquote unquote-splicing !)
+	   ((scan-lit-lst '() (k-head ! . args))
+	     (k-head '() . args))
+	   ((scan-lit-lst (quote (hd . tl)) k)
+	     (do-tl quote scan-lit-lst ((hd . tl)) k))
+	   ((scan-lit-lst (unquote x) k)
+	     (scan-exp x (do-wrap ! unquote k)))
+	   ((scan-lit-lst (unquote-splicing x) k)
+	     (scan-exp x (do-wrap ! unquote-splicing k)))
+	   ((scan-lit-lst (quote x) (k-head ! . args))
+	     (k-head 
+	       ,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
+	       . args))
+	    ((scan-lit-lst (hd . tl) k)
+	      (scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
+	    ((scan-lit-lst x (k-head ! . args))
+	      (k-head x . args))))
+	)
+      (scan-exp ?body (do-finish !))))
+  ((run-test body ...)
+   (begin
+     (run-test "scan-exp" body) ...))
+))
+
+; Overwrite the above macro to switch the tests off
+; (define-macro (run-test selector node expected-result) #f)
+
+; Location path, full form: child::para 
+; Location path, abbreviated form: para
+; selects the para element children of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
+       )
+      (expected '((para (@) "para") (para (@) "second par")))
+      )
+  (run-test (select-kids (node-typeof? 'para)) tree expected)
+  (run-test (sxpath '(para)) tree expected)
+)
+
+; Location path, full form: child::* 
+; Location path, abbreviated form: *
+; selects all element children of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected
+       '((para (@) "para") (br (@)) (para "second par")))
+      )
+  (run-test (select-kids (node-typeof? '*)) tree expected)
+  (run-test (sxpath '(*)) tree expected)
+)
+
+
+
+; Location path, full form: child::text() 
+; Location path, abbreviated form: text()
+; selects all text node children of the context node
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected
+       '("cdata"))
+      )
+  (run-test (select-kids (node-typeof? '*text*)) tree expected)
+  (run-test (sxpath '(*text*)) tree expected)
+)
+
+
+; Location path, full form: child::node() 
+; Location path, abbreviated form: node()
+; selects all the children of the context node, whatever their node type
+(let* ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
+       )
+      (expected (cdr tree))
+      )
+  (run-test (select-kids (node-typeof? '*any*)) tree expected)
+  (run-test (sxpath '(*any*)) tree expected)
+)
+
+; Location path, full form: child::*/child::para 
+; Location path, abbreviated form: */para
+; selects all para grandchildren of the context node
+
+(let ((tree
+       '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para "third para")))
+       )
+      (expected
+       '((para "third para")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '*))
+	      (select-kids (node-typeof? 'para)))
+   tree expected)
+  (run-test (sxpath '(* para)) tree expected)
+)
+
+
+; Location path, full form: attribute::name 
+; Location path, abbreviated form: @name
+; selects the 'name' attribute of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para (@) "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((name "elem")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '@))
+	      (select-kids (node-typeof? 'name)))
+   tree expected)
+  (run-test (sxpath '(@ name)) tree expected)
+)
+
+; Location path, full form:  attribute::* 
+; Location path, abbreviated form: @*
+; selects all the attributes of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((name "elem") (id "idz")))
+      )
+  (run-test
+   (node-join (select-kids (node-typeof? '@))
+	      (select-kids (node-typeof? '*)))
+   tree expected)
+  (run-test (sxpath '(@ *)) tree expected)
+)
+
+
+; Location path, full form: descendant::para 
+; Location path, abbreviated form: .//para
+; selects the para element descendants of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para (@) "para") (para "second par") (para (@) "third para")))
+      )
+  (run-test
+   (node-closure (node-typeof? 'para))
+   tree expected)
+  (run-test (sxpath '(// para)) tree expected)
+)
+
+; Location path, full form: self::para 
+; Location path, abbreviated form: _none_
+; selects the context node if it is a para element; otherwise selects nothing
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      )
+  (run-test (node-self (node-typeof? 'para)) tree '())
+  (run-test (node-self (node-typeof? 'elem)) tree (list tree))
+)
+
+; Location path, full form: descendant-or-self::node()
+; Location path, abbreviated form: //
+; selects the context node, all the children (including attribute nodes)
+; of the context node, and all the children of all the (element)
+; descendants of the context node.
+; This is _almost_ a powerset of the context node.
+(let* ((tree
+       '(para (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       (cons tree
+	(append (cdr tree)
+       '((@) "para" (@) "second par"
+	 (@ (name "aa")) (para (@) "third para")
+	 (@) "third para"))))
+      )
+  (run-test
+   (node-or
+    (node-self (node-typeof? '*any*))
+    (node-closure (node-typeof? '*any*)))
+   tree expected)
+  (run-test (sxpath '(//)) tree expected)
+)
+
+; Location path, full form: ancestor::div 
+; Location path, abbreviated form: _none_
+; selects all div ancestors of the context node
+; This Location expression is equivalent to the following:
+;	/descendant-or-self::div[descendant::node() = curr_node]
+; This shows that the ancestor:: axis is actually redundant. Still,
+; it can be emulated as the following SXPath expression demonstrates.
+
+; The insight behind "ancestor::div" -- selecting all "div" ancestors
+; of the current node -- is
+;  S[ancestor::div] context_node =
+;    { y | y=subnode*(root), context_node=subnode(subnode*(y)),
+;          isElement(y), name(y) = "div" }
+; We observe that
+;    { y | y=subnode*(root), pred(y) }
+; can be expressed in SXPath as 
+;    ((node-or (node-self pred) (node-closure pred)) root-node)
+; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to 
+; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
+; context_node=subnode(subnode*(y)) is tantamount to
+; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
+; the composition of converters-predicates in the filtering context.
+
+(let*
+    ((root
+	 '(div (@ (name "elem") (id "idz")) 
+		(para (@) "para") (br (@)) "cdata" (para (@) "second par")
+		(div (@ (name "aa")) (para (@) "third para"))))
+     (context-node	; /descendant::any()[child::text() == "third para"]
+      (car
+       ((node-closure 
+	 (select-kids
+	  (node-equal? "third para")))
+       root)))
+    (pred
+     (node-reduce (node-self (node-typeof? 'div))
+		  (node-closure (node-eq? context-node))
+		  ))
+     )
+  (run-test
+   (node-or
+     (node-self pred)
+     (node-closure pred))
+   root 
+   (cons root
+	 '((div (@ (name "aa")) (para (@) "third para")))))
+)
+
+
+
+; Location path, full form: child::div/descendant::para 
+; Location path, abbreviated form: div//para
+; selects the para element descendants of the div element
+; children of the context node
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")
+	     (div (para "fourth para"))))
+       )
+      (expected
+       '((para (@) "third para") (para "fourth para")))
+      )
+  (run-test
+   (node-join 
+    (select-kids (node-typeof? 'div))
+    (node-closure (node-typeof? 'para)))
+   tree expected)
+  (run-test (sxpath '(div // para)) tree expected)
+)
+
+
+; Location path, full form: /descendant::olist/child::item 
+; Location path, abbreviated form: //olist/item
+; selects all the item elements that have an olist parent (which is not root)
+; and that are in the same document as the context node
+; See the following test.
+
+; Location path, full form: /descendant::td/attribute::align 
+; Location path, abbreviated form: //td/@align
+; Selects 'align' attributes of all 'td' elements in tree1
+(let ((tree tree1)
+      (expected
+       '((align "right") (align "center") (align "center") (align "center"))
+      ))
+  (run-test
+   (node-join 
+    (node-closure (node-typeof? 'td))
+    (select-kids (node-typeof? '@))
+    (select-kids (node-typeof? 'align)))
+   tree expected)
+  (run-test (sxpath '(// td @ align)) tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align] 
+; Location path, abbreviated form: //td[@align]
+; Selects all td elements that have an attribute 'align' in tree1
+(let ((tree tree1)
+      (expected
+       '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
+	 (td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
+       ))
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-typeof? 'align)))))
+   tree expected)
+  (run-test (sxpath `(// td ,(node-self (sxpath '(@ align)))))  tree expected)
+  (run-test (sxpath '(// (td (@ align)))) tree expected)
+  (run-test (sxpath '(// ((td) (@ align)))) tree expected)
+  ; note! (sxpath ...) is a converter. Therefore, it can be used
+  ; as any other converter, for example, in the full-form SXPath.
+  ; Thus we can mix the full and abbreviated form SXPath's freely.
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (sxpath '(@ align))))
+   tree expected)
+)
+
+
+; Location path, full form: /descendant::td[attribute::align = "right"] 
+; Location path, abbreviated form: //td[@align = "right"]
+; Selects all td elements that have an attribute align = "right" in tree1
+(let ((tree tree1)
+      (expected
+       '((td (@ (align "right")) "Talks "))
+       ))
+  (run-test
+   (node-reduce 
+    (node-closure (node-typeof? 'td))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(align "right"))))))
+   tree expected)
+  (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
+)
+
+; Location path, full form: child::para[position()=1] 
+; Location path, abbreviated form: para[1]
+; selects the first para child of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para (@) "para"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos 1))
+   tree expected)
+  (run-test (sxpath '((para 1))) tree expected)
+)
+
+; Location path, full form: child::para[position()=last()] 
+; Location path, abbreviated form: para[last()]
+; selects the last para child of the context node
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      (expected
+       '((para "second par"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos -1))
+   tree expected)
+  (run-test (sxpath '((para -1))) tree expected)
+)
+
+; Illustrating the following Note of Sec 2.5 of XPath:
+; "NOTE: The location path //para[1] does not mean the same as the
+; location path /descendant::para[1]. The latter selects the first
+; descendant para element; the former selects all descendant para
+; elements that are the first para children of their parents."
+
+(let ((tree
+       '(elem (@ (name "elem") (id "idz")) 
+	(para (@) "para") (br (@)) "cdata" (para "second par")
+	(div (@ (name "aa")) (para (@) "third para")))
+       )
+      )
+  (run-test
+   (node-reduce	; /descendant::para[1] in SXPath
+    (node-closure (node-typeof? 'para))
+    (node-pos 1))
+   tree '((para (@) "para")))
+  (run-test (sxpath '(// (para 1))) tree
+	    '((para (@) "para") (para (@) "third para")))
+)
+
+; Location path, full form: parent::node()
+; Location path, abbreviated form: ..
+; selects the parent of the context node. The context node may be
+; an attribute node!
+; For the last test:
+; Location path, full form: parent::*/attribute::name
+; Location path, abbreviated form: ../@name
+; Selects the name attribute of the parent of the context node
+
+(let* ((tree
+	'(elem (@ (name "elem") (id "idz")) 
+	       (para (@) "para") (br (@)) "cdata" (para "second par")
+	       (div (@ (name "aa")) (para (@) "third para")))
+	)
+       (para1		; the first para node
+	(car ((sxpath '(para)) tree)))
+       (para3		; the third para node
+	(car ((sxpath '(div para)) tree)))
+       (div		; div node
+	(car ((sxpath '(// div)) tree)))
+       )
+  (run-test
+   (node-parent tree)
+   para1 (list tree))
+  (run-test
+   (node-parent tree)
+   para3 (list div))
+  (run-test		; checking the parent of an attribute node
+   (node-parent tree)
+   ((sxpath '(@ name)) div) (list div))
+  (run-test
+   (node-join
+    (node-parent tree)
+    (select-kids (node-typeof? '@))
+    (select-kids (node-typeof? 'name)))
+   para3 '((name "aa")))
+  (run-test
+   (sxpath `(,(node-parent tree) @ name))
+   para3 '((name "aa")))
+)
+
+; Location path, full form: following-sibling::chapter[position()=1]
+; Location path, abbreviated form: none
+; selects the next chapter sibling of the context node
+; The path is equivalent to
+;  let cnode = context-node
+;    in
+;	parent::* / child::chapter [take-after node_eq(self::*,cnode)] 
+;		[position()=1]
+(let* ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (chapter (@ (id "four")) "Chap 4 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+       (a-node	; to be used as a context node
+	(car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
+       (expected
+       '((chapter (@ (id "three")) "Chap 3 text")))
+      )
+  (run-test
+   (node-reduce
+    (node-join
+     (node-parent tree)
+     (select-kids (node-typeof? 'chapter)))
+    (take-after (node-eq? a-node))
+    (node-pos 1)
+    )
+   a-node expected)
+)
+
+; preceding-sibling::chapter[position()=1]
+; selects the previous chapter sibling of the context node
+; The path is equivalent to
+;  let cnode = context-node
+;    in
+;	parent::* / child::chapter [take-until node_eq(self::*,cnode)] 
+;		[position()=-1]
+(let* ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (chapter (@ (id "four")) "Chap 4 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+       (a-node	; to be used as a context node
+	(car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
+       (expected
+       '((chapter (@ (id "two")) "Chap 2 text")))
+      )
+  (run-test
+   (node-reduce
+    (node-join
+     (node-parent tree)
+     (select-kids (node-typeof? 'chapter)))
+    (take-until (node-eq? a-node))
+    (node-pos -1)
+    )
+   a-node expected)
+)
+
+
+; /descendant::figure[position()=42]
+; selects the forty-second figure element in the document
+; See the next example, which is more general.
+
+; Location path, full form:
+;    child::table/child::tr[position()=2]/child::td[position()=3] 
+; Location path, abbreviated form: table/tr[2]/td[3]
+; selects the third td of the second tr of the table
+(let ((tree ((node-closure (node-typeof? 'p)) tree1))
+      (expected
+       '((td " data + control"))
+       ))
+  (run-test
+   (node-join
+    (select-kids (node-typeof? 'table))
+    (node-reduce (select-kids (node-typeof? 'tr))
+		 (node-pos 2))
+    (node-reduce (select-kids (node-typeof? 'td))
+		 (node-pos 3)))
+   tree expected)
+  (run-test (sxpath '(table (tr 2) (td 3))) tree expected)
+)
+
+
+; Location path, full form:
+;		child::para[attribute::type='warning'][position()=5] 
+; Location path, abbreviated form: para[@type='warning'][5]
+; selects the fifth para child of the context node that has a type
+; attribute with value warning
+(let ((tree
+       '(chapter
+	 (para "para1")
+	 (para (@ (type "warning")) "para 2")
+	 (para (@ (type "warning")) "para 3")
+	 (para (@ (type "warning")) "para 4")
+	 (para (@ (type "warning")) "para 5")
+	 (para (@ (type "warning")) "para 6"))
+       )
+      (expected
+       '((para (@ (type "warning")) "para 6"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(type "warning")))))
+    (node-pos 5))
+   tree expected)
+  (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 )  ))
+	    tree expected)
+  (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 )  ))
+	    tree expected)
+)
+
+
+; Location path, full form:
+;		child::para[position()=5][attribute::type='warning'] 
+; Location path, abbreviated form: para[5][@type='warning']
+; selects the fifth para child of the context node if that child has a 'type'
+; attribute with value warning
+(let ((tree
+       '(chapter
+	 (para "para1")
+	 (para (@ (type "warning")) "para 2")
+	 (para (@ (type "warning")) "para 3")
+	 (para (@ (type "warning")) "para 4")
+	 (para (@ (type "warning")) "para 5")
+	 (para (@ (type "warning")) "para 6"))
+       )
+      (expected
+       '((para (@ (type "warning")) "para 5"))
+      ))
+  (run-test
+   (node-reduce
+    (select-kids (node-typeof? 'para))
+    (node-pos 5)
+    (filter
+     (node-join
+      (select-kids (node-typeof? '@))
+      (select-kids (node-equal? '(type "warning"))))))
+   tree expected)
+  (run-test (sxpath '( (( (para 5))  (@ (equal? (type "warning"))))))
+	    tree expected)
+  (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
+	    tree expected)
+)
+
+; Location path, full form:
+;		child::*[self::chapter or self::appendix]
+; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
+; selects the chapter and appendix children of the context node
+(let ((tree
+       '(document
+	 (preface "preface")
+	 (chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (epilogue "Epilogue text")
+	 (appendix (@ (id "A")) "App A text")
+	 (References "References"))
+       )
+      (expected
+       '((chapter (@ (id "one")) "Chap 1 text")
+	 (chapter (@ (id "two")) "Chap 2 text")
+	 (chapter (@ (id "three")) "Chap 3 text")
+	 (appendix (@ (id "A")) "App A text"))
+      ))
+  (run-test
+   (node-join
+    (select-kids (node-typeof? '*))
+    (filter
+     (node-or
+      (node-self (node-typeof? 'chapter))
+      (node-self (node-typeof? 'appendix)))))
+   tree expected)
+  (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
+				  (node-self (node-typeof? 'appendix)))))
+	    tree expected)
+)
+
+
+; Location path, full form: child::chapter[child::title='Introduction'] 
+; Location path, abbreviated form: chapter[title = 'Introduction']
+; selects the chapter children of the context node that have one or more
+; title children with string-value equal to Introduction
+; See a similar example: //td[@align = "right"] above.
+
+; Location path, full form: child::chapter[child::title] 
+; Location path, abbreviated form: chapter[title]
+; selects the chapter children of the context node that have one or
+; more title children
+; See a similar example //td[@align] above.
+
+(cerr nl "Example with tree3: extracting the first lines of every stanza" nl)
+(let ((tree tree3)
+      (expected
+       '("Let us go then, you and I," "In the room the women come and go")
+      ))
+  (run-test
+   (node-join
+    (node-closure (node-typeof? 'stanza))
+    (node-reduce 
+     (select-kids (node-typeof? 'line)) (node-pos 1))
+    (select-kids (node-typeof? '*text*)))
+   tree expected)
+  (run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
+)
+
+;
+; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
+;
+; If (and ?expr ?expr ...) evaluates to anything but #f, the result
+; is the value of that expression.
+; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
+; The error message will show the failed expressions, as well
+; as the values of selected variables (or expressions, in general).
+; The user may explicitly specify the expressions whose
+; values are to be printed upon assertion failure -- as ?r-exp that
+; follow the identifier 'report:'
+; Typically, ?r-exp is either a variable or a string constant.
+; If the user specified no ?r-exp, the values of variables that are
+; referenced in ?expr will be printed upon the assertion failure.
+
+(define-syntax assert
+  (syntax-rules (report\:)
+    ((assert "doit" (expr ...) (r-exp ...))
+     (cond
+      ((and expr ...) => (lambda (x) x))
+      (else
+       (error "assertion failure: ~a" (list '(and expr ...) r-exp ...)))))
+    ((assert "collect" (expr ...))
+     (assert "doit" (expr ...) ()))
+    ((assert "collect" (expr ...) report\: r-exp ...)
+     (assert "doit" (expr ...) (r-exp ...)))
+    ((assert "collect" (expr ...) expr1 stuff ...)
+     (assert "collect" (expr ... expr1) stuff ...))
+    ((assert stuff ...)
+     (assert "collect" () stuff ...))))
+
+(define-syntax assure
+  (syntax-rules ()
+    ((assure exp error-msg)
+     (assert exp report\: error-msg))));****************************************************************************
+;			Simple Parsing of input
+;
+; The following simple functions surprisingly often suffice to parse
+; an input stream. They either skip, or build and return tokens,
+; according to inclusion or delimiting semantics. The list of
+; characters to expect, include, or to break at may vary from one
+; invocation of a function to another. This allows the functions to
+; easily parse even context-sensitive languages.
+;
+; EOF is generally frowned on, and thrown up upon if encountered.
+; Exceptions are mentioned specifically. The list of expected characters 
+; (characters to skip until, or break-characters) may include an EOF
+; "character", which is to be coded as symbol *eof*
+;
+; The input stream to parse is specified as a PORT, which is usually
+; the last (and optional) argument. It defaults to the current input
+; port if omitted.
+;
+; IMPORT
+; This package relies on a function parser-error, which must be defined
+; by a user of the package. The function has the following signature:
+;	parser-error PORT MESSAGE SPECIALISING-MSG*
+; Many procedures of this package call parser-error to report a parsing
+; error.  The first argument is a port, which typically points to the
+; offending character or its neighborhood. Most of the Scheme systems
+; let the user query a PORT for the current position. MESSAGE is the
+; description of the error. Other arguments supply more details about
+; the problem.
+; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed.
+; From SRFI-13, string-concatenate-reverse
+; If a particular implementation lacks SRFI-13 support, please
+; include the file srfi-13-local.scm
+;
+; $Id: input-parse.scm,v 1.7 2004/07/07 16:02:31 sperber Exp $
+
+;------------------------------------------------------------------------
+
+; -- procedure+: peek-next-char [PORT]
+; 	advances to the next character in the PORT and peeks at it.
+; 	This function is useful when parsing LR(1)-type languages
+; 	(one-char-read-ahead).
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (peek-next-char (optional (port (current-input-port))))
+  (read-char port) 
+  (peek-char port)) 
+
+
+;------------------------------------------------------------------------
+
+; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT]
+;	Reads a character from the PORT and looks it up
+;	in the CHAR-LIST of expected characters
+;	If the read character was found among expected, it is returned
+;	Otherwise, the procedure writes a nasty message using STRING
+;	as a comment, and quits.
+;	The optional argument PORT defaults to the current input port.
+;
+(define-opt (assert-curr-char expected-chars comment
+			      (optional (port (current-input-port))))
+  (let ((c (read-char port)))
+    (if (memv c expected-chars) c
+    (parser-error port "Wrong character " c
+    	   " (0x" (if (eof-object? c) "*eof*"
+    	   	    (number->string (char->integer c) 16)) ") "
+    	   comment ". " expected-chars " expected"))))
+    	   
+
+; -- procedure+: skip-until CHAR-LIST [PORT]
+;	Reads and skips characters from the PORT until one of the break
+;	characters is encountered. This break character is returned.
+;	The break characters are specified as the CHAR-LIST. This list
+;	may include EOF, which is to be coded as a symbol *eof*
+;
+; -- procedure+: skip-until NUMBER [PORT]
+;	Skips the specified NUMBER of characters from the PORT and returns #f
+;
+;	The optional argument PORT defaults to the current input port.
+
+
+(define-opt (skip-until arg (optional (port (current-input-port))) )
+  (cond
+   ((number? arg)		; skip 'arg' characters
+      (do ((i arg (dec i)))
+      	  ((not (positive? i)) #f)
+      	  (if (eof-object? (read-char port))
+      	    (parser-error port "Unexpected EOF while skipping "
+			 arg " characters"))))
+   (else			; skip until break-chars (=arg)
+     (let loop ((c (read-char port)))
+       (cond
+         ((memv c arg) c)
+         ((eof-object? c)
+           (if (memq '*eof* arg) c
+             (parser-error port "Unexpected EOF while skipping until " arg)))
+         (else (loop (read-char port))))))))
+
+
+; -- procedure+: skip-while CHAR-LIST [PORT]
+;	Reads characters from the PORT and disregards them,
+;	as long as they are mentioned in the CHAR-LIST.
+;	The first character (which may be EOF) peeked from the stream
+;	that is NOT a member of the CHAR-LIST is returned. This character
+;	is left on the stream.
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (skip-while skip-chars (optional (port (current-input-port))) )
+  (do ((c (peek-char port) (peek-char port)))
+      ((not (memv c skip-chars)) c)
+      (read-char port)))
+ 
+; whitespace const
+
+;------------------------------------------------------------------------
+;				Stream tokenizers
+
+
+; -- procedure+: 
+;    next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT]
+;	skips any number of the prefix characters (members of the
+;	PREFIX-CHAR-LIST), if any, and reads the sequence of characters
+;	up to (but not including) a break character, one of the
+;	BREAK-CHAR-LIST.
+;	The string of characters thus read is returned.
+;	The break character is left on the input stream
+;	The list of break characters may include EOF, which is to be coded as
+;	a symbol *eof*. Otherwise, EOF is fatal, generating an error message
+;	including a specified COMMENT-STRING (if any)
+;
+;	The optional argument PORT defaults to the current input port.
+;
+; Note: since we can't tell offhand how large the token being read is
+; going to be, we make a guess, pre-allocate a string, and grow it by
+; quanta if necessary. The quantum is always the length of the string
+; before it was extended the last time. Thus the algorithm does
+; a Fibonacci-type extension, which has been proven optimal.
+; Note, explicit port specification in read-char, peek-char helps.
+
+; Procedure: input-parse:init-buffer
+; returns an initial buffer for next-token* procedures.
+; The input-parse:init-buffer may allocate a new buffer per each invocation:
+;	(define (input-parse:init-buffer) (make-string 32))
+; Size 32 turns out to be fairly good, on average.
+; That policy is good only when a Scheme system is multi-threaded with
+; preemptive scheduling, or when a Scheme system supports shared substrings.
+; In all the other cases, it's better for input-parse:init-buffer to
+; return the same static buffer. next-token* functions return a copy
+; (a substring) of accumulated data, so the same buffer can be reused.
+; We shouldn't worry about an incoming token being too large:
+; next-token will use another chunk automatically. Still, 
+; the best size for the static buffer is to allow most of the tokens to fit in.
+; Using a static buffer _dramatically_ reduces the amount of produced garbage
+; (e.g., during XML parsing).
+
+(define input-parse:init-buffer
+  (let ((buffer (make-string 512)))
+    (lambda () buffer)))
+  
+
+		; See a better version below
+(define-opt (next-token-old prefix-skipped-chars break-chars
+			(optional (comment "") (port (current-input-port))) )
+  (let* ((buffer (input-parse:init-buffer))
+	 (curr-buf-len (string-length buffer))
+	 (quantum curr-buf-len))
+    (let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
+      (cond
+        ((memv c break-chars) (substring buffer 0 i))
+    	((eof-object? c)
+    	  (if (memq '*eof* break-chars)
+    	    (substring buffer 0 i)		; was EOF expected?
+    	    (parser-error port "EOF while reading a token " comment)))
+    	(else
+    	  (if (>= i curr-buf-len)	; make space for i-th char in buffer
+    	    (begin			; -> grow the buffer by the quantum
+    	      (set! buffer (string-append buffer (make-string quantum)))
+    	      (set! quantum curr-buf-len)
+    	      (set! curr-buf-len (string-length buffer))))
+    	  (string-set! buffer i c)
+    	  (read-char port)			; move to the next char
+    	  (loop (inc i) (peek-char port))
+    	  )))))
+
+
+; A better version of next-token, which accumulates the characters
+; in chunks, and later on reverse-concatenates them, using
+; SRFI-13 if available.
+; The overhead of copying characters is only 100% (or even smaller: bulk
+; string copying might be well-optimised), compared to the (hypothetical)
+; circumstance if we had known the size of the token beforehand.
+; For small tokens, the code performs just as above. For large
+; tokens, we expect an improvement. Note, the code also has no
+; assignments. 
+; See next-token-comp.scm
+
+(define-opt (next-token prefix-skipped-chars break-chars
+		  (optional (comment "") (port (current-input-port))) )
+  (let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '())
+	      (c (skip-while prefix-skipped-chars port)))
+    (let ((curr-buf-len (string-length buffer)))
+      (let loop ((i 0) (c c))
+	(cond
+	  ((memv c break-chars)
+	    (if (null? filled-buffer-l) (substring buffer 0 i)
+	      (string-concatenate-reverse filled-buffer-l buffer i)))
+	  ((eof-object? c)
+	    (if (memq '*eof* break-chars)	; was EOF expected?
+	      (if (null? filled-buffer-l) (substring buffer 0 i)
+		(string-concatenate-reverse filled-buffer-l buffer i))
+	      (parser-error port "EOF while reading a token " comment)))
+	  ((>= i curr-buf-len)
+	    (outer (make-string curr-buf-len)
+	      (cons buffer filled-buffer-l) c))
+	  (else
+	    (string-set! buffer i c)
+	    (read-char port)			; move to the next char
+	    (loop (inc i) (peek-char port))))))))
+
+; -- procedure+: next-token-of INC-CHARSET [PORT]
+;	Reads characters from the PORT that belong to the list of characters
+;	INC-CHARSET. The reading stops at the first character which is not
+;	a member of the set. This character is left on the stream.
+;	All the read characters are returned in a string.
+;
+; -- procedure+: next-token-of PRED [PORT]
+;	Reads characters from the PORT for which PRED (a procedure of one
+;	argument) returns non-#f. The reading stops at the first character
+;	for which PRED returns #f. That character is left on the stream.
+;	All the results of evaluating of PRED up to #f are returned in a
+;	string.
+;
+;	PRED is a procedure that takes one argument (a character
+;	or the EOF object) and returns a character or #f. The returned
+;	character does not have to be the same as the input argument
+;	to the PRED. For example,
+;	(next-token-of (lambda (c)
+;			  (cond ((eof-object? c) #f)
+;				((char-alphabetic? c) (char-downcase c))
+;				(else #f))))
+;	will try to read an alphabetic token from the current
+;	input port, and return it in lower case.
+; 
+;	The optional argument PORT defaults to the current input port.
+;
+; This procedure is similar to next-token but only it implements
+; an inclusion rather than delimiting semantics.
+
+(define-opt (next-token-of incl-list/pred
+			   (optional (port (current-input-port))) )
+  (let* ((buffer (input-parse:init-buffer))
+	 (curr-buf-len (string-length buffer)))
+  (if (procedure? incl-list/pred)
+    (let outer ((buffer buffer) (filled-buffer-l '()))
+      (let loop ((i 0))
+	(if (>= i curr-buf-len)		; make sure we have space
+	  (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+	  (let ((c (incl-list/pred (peek-char port))))
+	    (if c
+	      (begin
+		(string-set! buffer i c)
+		(read-char port)			; move to the next char
+		(loop (inc i)))
+	      ; incl-list/pred decided it had had enough
+	      (if (null? filled-buffer-l) (substring buffer 0 i)
+		(string-concatenate-reverse filled-buffer-l buffer i)))))))
+
+    ; incl-list/pred is a list of allowed characters
+    (let outer ((buffer buffer) (filled-buffer-l '()))
+      (let loop ((i 0))
+	(if (>= i curr-buf-len)		; make sure we have space
+	  (outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
+	  (let ((c (peek-char port)))
+	    (cond
+	      ((not (memv c incl-list/pred))
+		(if (null? filled-buffer-l) (substring buffer 0 i)
+		  (string-concatenate-reverse filled-buffer-l buffer i)))
+	      (else
+		(string-set! buffer i c)
+		(read-char port)			; move to the next char
+		(loop (inc i))))))))
+    )))
+
+
+; -- procedure+: read-text-line [PORT]
+;	Reads one line of text from the PORT, and returns it as a string.
+;	A line is a (possibly empty) sequence of characters terminated
+;	by CR, CRLF or LF (or even the end of file).
+;	The terminating character (or CRLF combination) is removed from
+;	the input stream. The terminating character(s) is not a part
+;	of the return string either.
+;	If EOF is encountered before any character is read, the return
+;	value is EOF.
+; 
+;	The optional argument PORT defaults to the current input port.
+
+(define *read-line-breaks* (list char-newline char-return '*eof*))
+
+(define-opt (read-text-line (optional (port (current-input-port))) )
+  (if (eof-object? (peek-char port)) (peek-char port)
+    (let* ((line
+             (next-token '() *read-line-breaks*
+			 "reading a line" port))
+           (c (read-char port)))	; must be either \n or \r or EOF
+       (and (eqv? c char-return) (eqv? (peek-char port) #\newline)
+         (read-char port))			; skip \n that follows \r
+       line)))
+
+
+; -- procedure+: read-string N [PORT]
+;	Reads N characters from the PORT, and  returns them in a string.
+;	If EOF is encountered before N characters are read, a shorter string
+;	will be returned.
+;	If N is not positive, an empty string will be returned.
+;	The optional argument PORT defaults to the current input port.
+
+(define-opt (read-string n (optional (port (current-input-port))) )
+  (if (not (positive? n)) ""
+    (let ((buffer (make-string n)))
+      (let loop ((i 0) (c (read-char port)))
+        (if (eof-object? c) (substring buffer 0 i)
+          (let ((i1 (inc i)))
+            (string-set! buffer i c)
+            (if (= i1 n) buffer
+              (loop i1 (read-char port)))))))))
+
+;;;; (sxml xpath) -- SXPath
+;;;;
+;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
+;;;;    Written 2001 by Oleg Kiselyov <oleg at pobox dot com> SXPath.scm.
+;;;; 
+;;;; 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:
+;;
+;;@heading SXPath: SXML Query Language
+;;
+;; SXPath is a query language for SXML, an instance of XML Information
+;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)}
+;; for the definition of SXML and more details. SXPath is also a
+;; translation into Scheme of an XML Path Language,
+;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe
+;; means of selecting a set of Infoset's items or their properties.
+;;
+;; To facilitate queries, XPath maps the XML Infoset into an explicit
+;; tree, and introduces important notions of a location path and a
+;; current, context node. A location path denotes a selection of a set of
+;; nodes relative to a context node. Any XPath tree has a distinguished,
+;; root node -- which serves as the context node for absolute location
+;; paths. Location path is recursively defined as a location step joined
+;; with a location path. A location step is a simple query of the
+;; database relative to a context node. A step may include expressions
+;; that further filter the selected set. Each node in the resulting set
+;; is used as a context node for the adjoining location path. The result
+;; of the step is a union of the sets returned by the latter location
+;; paths.
+;;
+;; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+;; suitable for querying as it is. Bowing to the XPath specification,
+;; we will refer to SXML information items as 'Nodes':
+;;@example
+;; 	<Node> ::= <Element> | <attributes-coll> | <attrib>
+;; 		   | "text string" | <PI>
+;;@end example
+;; This production can also be described as
+;;@example
+;;	<Node> ::= (name . <Nodeset>) | "text string"
+;;@end example
+;; An (ordered) set of nodes is just a list of the constituent nodes:
+;;@example
+;; 	<Nodeset> ::= (<Node> ...)
+;;@end example
+;; Nodesets, and Nodes other than text strings are both lists. A
+;; <Nodeset> however is either an empty list, or a list whose head is not
+;; a symbol.  A symbol at the head of a node is either an XML name (in
+;; which case it's a tag of an XML element), or an administrative name
+;; such as '@@'.  This uniform list representation makes processing rather
+;; simple and elegant, while avoiding confusion. The multi-branch tree
+;; structure formed by the mutually-recursive datatypes <Node> and
+;; <Nodeset> lends itself well to processing by functional languages.
+;;
+;; A location path is in fact a composite query over an XPath tree or
+;; its branch. A singe step is a combination of a projection, selection
+;; or a transitive closure. Multiple steps are combined via join and
+;; union operations. This insight allows us to @emph{elegantly}
+;; implement XPath as a sequence of projection and filtering primitives
+;; -- converters -- joined by @dfn{combinators}. Each converter takes a
+;; node and returns a nodeset which is the result of the corresponding
+;; query relative to that node. A converter can also be called on a set
+;; of nodes. In that case it returns a union of the corresponding
+;; queries over each node in the set. The union is easily implemented as
+;; a list append operation as all nodes in a SXML tree are considered
+;; distinct, by XPath conventions. We also preserve the order of the
+;; members in the union. Query combinators are high-order functions:
+;; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+;; and compose or otherwise combine them. We will be concerned with only
+;; relative location paths [XPath]: an absolute location path is a
+;; relative path applied to the root node.
+;;
+;; Similarly to XPath, SXPath defines full and abbreviated notations
+;; for location paths. In both cases, the abbreviated notation can be
+;; mechanically expanded into the full form by simple rewriting
+;; rules. In case of SXPath the corresponding rules are given as
+;; comments to a sxpath function, below. The regression test suite at
+;; the end of this file shows a representative sample of SXPaths in
+;; both notations, juxtaposed with the corresponding XPath
+;; expressions. Most of the samples are borrowed literally from the
+;; XPath specification, while the others are adjusted for our running
+;; example, tree1.
+;;
+;;; Code:
+
+(define-module (sxml xpath)
+  #\use-module (ice-9 pretty-print)
+  #\export (nodeset? node-typeof? node-eq? node-equal? node-pos
+            filter take-until take-after map-union node-reverse
+            node-trace select-kids node-self node-join node-reduce
+            node-or node-closure node-parent
+            sxpath))
+
+;; Upstream version:
+; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $
+
+(define (nodeset? x)
+  (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+;-------------------------
+; Basic converters and applicators
+; A converter is a function
+;	type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; The following function implements a 'Node test' as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+;
+; The function node-typeof? takes a type criterion and returns a function,
+; which, when applied to a node, will tell if the node satisfies
+; the test.
+;	node-typeof? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is a symbol, one of the following:
+;	id		- tests if the Node has the right name (id)
+;	@		- tests if the Node is an <attributes-coll>
+;	*		- tests if the Node is an <Element>
+;	*text*		- tests if the Node is a text node
+;	*PI*		- tests if the Node is a PI node
+;	*any*		- #t for any type of Node
+
+(define (node-typeof? crit)
+  (lambda (node)
+    (case crit
+      ((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
+      ((*any*) #t)
+      ((*text*) (string? node))
+      (else
+       (and (pair? node) (eq? crit (car node))))
+)))
+
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+  (lambda (node)
+    (eq? other node)))
+
+(define (node-equal? other)
+  (lambda (node)
+    (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+
+(define (node-pos n)
+  (lambda (nodeset)
+    (cond
+     ((not (nodeset? nodeset)) '())
+     ((null? nodeset) nodeset)
+     ((eqv? n 1) (list (car nodeset)))
+     ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+     (else
+      (or (positive? n) (error "yikes!"))
+      ((node-pos (1- n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (filter pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
+      (if (null? lst)
+	  (reverse res)
+	  (let ((pred-result (pred? (car lst))))
+	    (loop (cdr lst)
+		  (if (and pred-result (not (null? pred-result)))
+		      (cons (car lst) res)
+		      res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset -- 
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+
+(define (take-until pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		'()
+		(cons (car lst) (loop (cdr lst)))))
+	  ))))
+
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f or
+; nil. Return the elements of the input nodeset that have not been processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+
+(define (take-after pred?)
+  (lambda (lst)	; a nodeset or a node (will be converted to a singleton nset)
+    (let loop ((lst (if (nodeset? lst) lst (list lst))))
+      (if (null? lst) lst
+	  (let ((pred-result (pred? (car lst))))
+	    (if (and pred-result (not (null? pred-result)))
+		(cdr lst)
+		(loop (cdr lst))))
+	  ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+
+(define (map-union proc lst)
+  (if (null? lst) lst
+      (let ((proc-res (proc (car lst))))
+	((if (nodeset? proc-res) append cons)
+	 proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse 
+  (lambda (node-or-nodeset)
+    (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+	(reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+
+(define (node-trace title)
+  (lambda (node-or-nodeset)
+    (display "\n-->")
+    (display title)
+    (display " :")
+    (pretty-print node-or-nodeset)
+    node-or-nodeset))
+
+
+;-------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+
+(define (select-kids test-pred?)
+  (lambda (node)		; node or node-set
+    (cond 
+     ((null? node) node)
+     ((not (pair? node)) '())   ; No children
+     ((symbol? (car node))
+      ((filter test-pred?) (cdr node)))	; it's a single node
+     (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (selectors selectors))
+      (if (null? selectors) nodeset
+	  (loop 
+	   (if (nodeset? nodeset)
+	       (map-union (car selectors) nodeset)
+	       ((car selectors) nodeset))
+	   (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+;    ((apply node-reduce converters) nodeset)
+; is equivalent to
+;    (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+  (lambda (nodeset)		; Nodeset or node
+    (let loop ((nodeset nodeset) (converters converters))
+      (if (null? converters) nodeset
+	  (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+;   (lambda (node-or-nodeset)
+;     (if (null? converters) node-or-nodeset
+; 	(append 
+; 	 ((car converters) node-or-nodeset)
+; 	 ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+  (lambda (node-or-nodeset)
+    (let loop ((result '()) (converters converters))
+      (if (null? converters) result
+	  (loop (append result (or ((car converters) node-or-nodeset) '()))
+		(cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+;      (node-or
+;        (select-kids f)
+;	 (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (node-typeof? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+
+(define (node-closure test-pred?)	    
+  (lambda (node)		; Nodeset or node
+    (let loop ((parent node) (result '()))
+      (if (null? parent) result
+	  (loop ((select-kids (node-typeof? '*)) parent)
+		(append result
+			((select-kids test-pred?) parent)))
+	  ))))
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+;  parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones.  Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+; Note that the parent:: axis can be used with an attribute node as well!
+
+(define (node-parent rootnode)
+  (lambda (node)		; Nodeset or node
+    (if (nodeset? node) (map-union (node-parent rootnode) node)
+	(let ((pred
+	       (node-or
+		(node-reduce
+		 (node-self (node-typeof? '*))
+		 (select-kids (node-eq? node)))
+		(node-join
+		 (select-kids (node-typeof? '@))
+		 (select-kids (node-eq? node))))))
+	  ((node-or
+	    (node-self pred)
+	    (node-closure pred))
+	   rootnode)))))
+
+;-------------------------
+; Evaluate an abbreviated SXPath
+;	sxpath:: AbbrPath -> Converter, or
+;	sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
+; AbbrPath is a list. It is translated to the full SXPath according
+; to the following rewriting rules
+; (sxpath '()) -> (node-join)
+; (sxpath '(path-component ...)) ->
+;		(node-join (sxpath1 path-component) (sxpath '(...)))
+; (sxpath1 '//) -> (node-or 
+;		     (node-self (node-typeof? '*any*))
+;		      (node-closure (node-typeof? '*any*)))
+; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
+; (sxpath1 '(eq? x))    -> (select-kids (node-eq? x))
+; (sxpath1 ?symbol)     -> (select-kids (node-typeof? ?symbol)
+; (sxpath1 procedure)   -> procedure
+; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
+; (sxpath1 '(path reducer ...)) ->
+;		(node-reduce (sxpath path) (sxpathr reducer) ...)
+; (sxpathr number)      -> (node-pos number)
+; (sxpathr path-filter) -> (filter (sxpath path-filter))
+
+(define (sxpath path)
+  (lambda (nodeset)
+    (let loop ((nodeset nodeset) (path path))
+    (cond
+     ((null? path) nodeset)
+     ((nodeset? nodeset)
+      (map-union (sxpath path) nodeset))
+     ((procedure? (car path))
+      (loop ((car path) nodeset) (cdr path)))
+     ((eq? '// (car path))
+      (loop
+       ((if (nodeset? nodeset) append cons) nodeset
+	((node-closure (node-typeof? '*any*)) nodeset))
+       (cdr path)))
+     ((symbol? (car path))
+      (loop ((select-kids (node-typeof? (car path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'equal? (caar path)))
+      (loop ((select-kids (apply node-equal? (cdar path))) nodeset)
+	    (cdr path)))
+     ((and (pair? (car path)) (eq? 'eq? (caar path)))
+      (loop ((select-kids (apply node-eq? (cdar path))) nodeset)
+	    (cdr path)))
+     ((pair? (car path))
+      (let reducer ((nodeset 
+		     (if (symbol? (caar path))
+			 ((select-kids (node-typeof? (caar path))) nodeset)
+			 (loop nodeset (caar path))))
+		    (reducing-path (cdar path)))
+	(cond
+	 ((null? reducing-path) (loop nodeset (cdr path)))
+	 ((number? (car reducing-path))
+	  (reducer ((node-pos (car reducing-path)) nodeset)
+		   (cdr reducing-path)))
+	 (else
+	  (reducer ((filter (sxpath (car reducing-path))) nodeset)
+		   (cdr reducing-path))))))
+     (else
+      (error "Invalid path step: " (car path)))))))
+
+;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774
+;;; xpath.scm ends here
+;;; ck, to facilitate applicative-order macro programming
+
+;;; Copyright (C) 2012 Free Software Foundation, Inc
+;;; Copyright (C) 2009, 2011 Oleg Kiselyov
+;;;
+;;; 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
+;;;
+;;;
+;;; Originally written by Oleg Kiselyov and later contributed to Guile.
+;;;
+;;; Based on the CK machine introduced in:
+;;;
+;;; Matthias Felleisen and Daniel P. Friedman: Control operators, the
+;;; SECD machine, and the lambda-calculus.  In Martin Wirsing, editor,
+;;; Formal Description of Programming Concepts III, pages
+;;; 193-217. Elsevier, Amsterdam, 1986.
+;;;
+;;; See http://okmij.org/ftp/Scheme/macros.html#ck-macros for details.
+;;;
+
+(define-module (system base ck)
+  #\export (ck))
+
+(define-syntax ck
+  (syntax-rules (quote)
+    ((ck () 'v) v)                      ; yield the value on empty stack
+
+    ((ck (((op ...) ea ...) . s) 'v)    ; re-focus on the other argument, ea
+     (ck-arg s (op ... 'v) ea ...))
+
+    ((ck s (op ea ...))                 ; Focus: handling an application;
+     (ck-arg s (op) ea ...))))          ; check if args are values
+
+(define-syntax ck-arg
+  (syntax-rules (quote)
+    ((ck-arg s (op va ...))             ; all arguments are evaluated,
+     (op s va ...))                     ; do the redex
+
+    ((ck-arg s (op ...) 'v ea1 ...)     ; optimization when the first ea
+     (ck-arg s (op ... 'v) ea1 ...))    ; was already a value
+
+    ((ck-arg s (op ...) ea ea1 ...)     ; focus on ea, to evaluate it
+     (ck (((op ...) ea1 ...) . s) ea))))
+;;; High-level compiler interface
+
+;; Copyright (C) 2001, 2009, 2010, 2011, 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
+
+;;; Code:
+
+(define-module (system base compile)
+  #\use-module (system base syntax)
+  #\use-module (system base language)
+  #\use-module (system base message)
+  #\use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 optargs)
+  #\use-module (ice-9 receive)
+  #\export (compiled-file-name
+            compile-file
+            compile-and-load
+            read-and-compile
+            compile
+            decompile))
+
+
+;;;
+;;; Compiler
+;;;
+
+(define (call-once thunk)
+  (let ((entered #f))
+    (dynamic-wind
+        (lambda ()
+          (if entered
+              (error "thunk may only be entered once: ~a" thunk))
+          (set! entered #t))
+        thunk
+        (lambda () #t))))
+
+;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
+(define* (call-with-output-file/atomic filename proc #\optional reference)
+  (let* ((template (string-append filename ".XXXXXX"))
+         (tmp (mkstemp! template "wb")))
+    (call-once
+     (lambda ()
+       (with-throw-handler #t
+         (lambda ()
+           (proc tmp)
+           ;; Chmodding by name instead of by port allows this chmod to
+           ;; work on systems without fchmod, like MinGW.
+           (let ((perms (or (false-if-exception (stat:perms (stat reference)))
+                            (lognot (umask)))))
+             (chmod template (logand #o0666 perms)))
+           (close-port tmp)
+           (rename-file template filename))
+         (lambda args
+           (close-port tmp)
+           (delete-file template)))))))
+
+(define (ensure-language x)
+  (if (language? x)
+      x
+      (lookup-language x)))
+
+;; Throws an exception if `dir' is not writable.  The mkdir occurs
+;; before the check, so that we avoid races (possibly due to parallel
+;; compilation).
+;;
+(define (ensure-directory dir)
+  (catch 'system-error
+    (lambda ()
+      (mkdir dir))
+    (lambda (k subr fmt args rest)
+      (let ((errno (and (pair? rest) (car rest))))
+        (cond
+         ((eqv? errno EEXIST)
+          ;; Assume it's a writable directory, to avoid TOCTOU errors,
+          ;; as well as UID/EUID mismatches that occur with access(2).
+          #t)
+         ((eqv? errno ENOENT)
+          (ensure-directory (dirname dir))
+          (ensure-directory dir))
+         (else
+          (throw k subr fmt args rest)))))))
+
+;;; This function is among the trickiest I've ever written. I tried many
+;;; variants. In the end, simple is best, of course.
+;;;
+;;; After turning this around a number of times, it seems that the
+;;; desired behavior is that .go files should exist in a path, for
+;;; searching. That is orthogonal to this function. For writing .go
+;;; files, either you know where they should go, in which case you tell
+;;; compile-file explicitly, as in the srcdir != builddir case; or you
+;;; don't know, in which case this function is called, and we just put
+;;; them in your own ccache dir in ~/.cache/guile/ccache.
+;;;
+;;; See also boot-9.scm:load.
+(define (compiled-file-name file)
+  ;; FIXME: would probably be better just to append SHA1(canon-path)
+  ;; to the %compile-fallback-path, to avoid deep directory stats.
+  (define (canonical->suffix canon)
+    (cond
+     ((string-prefix? "/" canon) canon)
+     ((and (> (string-length canon) 2)
+           (eqv? (string-ref canon 1) #\:))
+      ;; Paths like C:... transform to /C...
+      (string-append "/" (substring canon 0 1) (substring canon 2)))
+     (else canon)))
+  (define (compiled-extension)
+    (cond ((or (null? %load-compiled-extensions)
+               (string-null? (car %load-compiled-extensions)))
+           (warn "invalid %load-compiled-extensions"
+                 %load-compiled-extensions)
+           ".go")
+          (else (car %load-compiled-extensions))))
+  (and %compile-fallback-path
+       (let ((f (string-append
+                 %compile-fallback-path
+                 (canonical->suffix (canonicalize-path file))
+                 (compiled-extension))))
+         (and (false-if-exception (ensure-directory (dirname f)))
+              f))))
+
+(define* (compile-file file #\key
+                       (output-file #f)
+                       (from (current-language))
+                       (to 'objcode)
+                       (env (default-environment from))
+                       (opts '())
+                       (canonicalization 'relative))
+  (with-fluids ((%file-port-name-canonicalization canonicalization))
+    (let* ((comp (or output-file (compiled-file-name file)
+                     (error "failed to create path for auto-compiled file"
+                            file)))
+           (in (open-input-file file))
+           (enc (file-encoding in)))
+      ;; Choose the input encoding deterministically.
+      (set-port-encoding! in (or enc "UTF-8"))
+
+      (ensure-directory (dirname comp))
+      (call-with-output-file/atomic comp
+        (lambda (port)
+          ((language-printer (ensure-language to))
+           (read-and-compile in #\env env #\from from #\to to #\opts opts)
+           port))
+        file)
+      comp)))
+
+(define* (compile-and-load file #\key (from (current-language)) (to 'value)
+                           (env (current-module)) (opts '())
+                           (canonicalization 'relative))
+  (with-fluids ((%file-port-name-canonicalization canonicalization))
+    (read-and-compile (open-input-file file)
+                      #\from from #\to to #\opts opts
+                      #\env env)))
+
+
+;;;
+;;; Compiler interface
+;;;
+
+(define (compile-passes from to opts)
+  (map cdr
+       (or (lookup-compilation-order from to)
+           (error "no way to compile" from "to" to))))
+
+(define (compile-fold passes exp env opts)
+  (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
+    (if (null? passes)
+        (values x e cenv)
+        (receive (x e new-cenv) ((car passes) x e opts)
+          (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
+
+(define (find-language-joint from to)
+  (let lp ((in (reverse (or (lookup-compilation-order from to)
+                            (error "no way to compile" from "to" to))))
+           (lang to))
+    (cond ((null? in) to)
+          ((language-joiner lang) lang)
+          (else
+           (lp (cdr in) (caar in))))))
+
+(define (default-language-joiner lang)
+  (lambda (exps env)
+    (if (and (pair? exps) (null? (cdr exps)))
+        (car exps)
+        (error
+         "Multiple expressions read and compiled, but language has no joiner"
+         lang))))
+
+(define (read-and-parse lang port cenv)
+  (let ((exp ((language-reader lang) port cenv)))
+    (cond
+     ((eof-object? exp) exp)
+     ((language-parser lang) => (lambda (parse) (parse exp)))
+     (else exp))))
+
+(define* (read-and-compile port #\key
+                           (from (current-language))
+                           (to 'objcode)
+                           (env (default-environment from))
+                           (opts '()))
+  (let ((from (ensure-language from))
+        (to (ensure-language to)))
+    (let ((joint (find-language-joint from to)))
+      (parameterize ((current-language from))
+        (let lp ((exps '()) (env #f) (cenv env))
+          (let ((x (read-and-parse (current-language) port cenv)))
+            (cond
+             ((eof-object? x)
+              (close-port port)
+              (compile ((or (language-joiner joint)
+                            (default-language-joiner joint))
+                        (reverse exps)
+                        env)
+                       #\from joint #\to to
+                       ;; env can be false if no expressions were read.
+                       #\env (or env (default-environment joint))
+                       #\opts opts))
+             (else
+              ;; compile-fold instead of compile so we get the env too
+              (receive (jexp jenv jcenv)
+                  (compile-fold (compile-passes (current-language) joint opts)
+                                x cenv opts)
+                (lp (cons jexp exps) jenv jcenv))))))))))
+
+(define* (compile x #\key
+                  (from (current-language))
+                  (to 'value)
+                  (env (default-environment from))
+                  (opts '()))
+
+  (let ((warnings (memq #\warnings opts)))
+    (if (pair? warnings)
+        (let ((warnings (cadr warnings)))
+          ;; Sanity-check the requested warnings.
+          (for-each (lambda (w)
+                      (or (lookup-warning-type w)
+                          (warning 'unsupported-warning #f w)))
+                    warnings))))
+
+  (receive (exp env cenv)
+      (compile-fold (compile-passes from to opts) x env opts)
+    exp))
+
+
+;;;
+;;; Decompiler interface
+;;;
+
+(define (decompile-passes from to opts)
+  (map cdr
+       (or (lookup-decompilation-order from to)
+           (error "no way to decompile" from "to" to))))
+
+(define (decompile-fold passes exp env opts)
+  (if (null? passes)
+      (values exp env)
+      (receive (exp env) ((car passes) exp env opts)
+        (decompile-fold (cdr passes) exp env opts))))
+
+(define* (decompile x #\key
+                    (env #f)
+                    (from 'value)
+                    (to 'assembly)
+                    (opts '()))
+  (decompile-fold (decompile-passes from to opts)
+                  x
+                  env
+                  opts))
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 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 program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (system base lalr)
+
+  ;; XXX: In theory this import is not needed but the evaluator (not the
+  ;; compiler) complains about `lexical-token' being unbound when expanding
+  ;; `(define-record-type lexical-token ...)' if we omit it.
+  #\use-module (srfi srfi-9)
+
+  #\export (lalr-parser print-states
+
+            make-lexical-token lexical-token?
+            lexical-token-category
+            lexical-token-source
+            lexical-token-value
+
+            make-source-location source-location?
+            source-location-input
+            source-location-line
+            source-location-column
+            source-location-offset
+            source-location-length
+            source-location->source-properties
+
+            ;; `lalr-parser' is a defmacro, which produces code that refers to
+            ;; these drivers.
+            lr-driver glr-driver))
+
+;; The LALR parser generator was written by Dominique Boucher.  It's available
+;; from http://code.google.com/p/lalr-scm/ and released under the LGPLv3+.
+(include-from-path "system/base/lalr.upstream.scm")
+
+(define (source-location->source-properties loc)
+  `((filename . ,(source-location-input loc))
+    (line . ,(source-location-line loc))
+    (column . ,(source-location-column loc))))
+;;;
+;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
+;;;
+;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
+;; Copyright 1993, 2010 Dominique Boucher
+;;
+;; This program 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 program 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 General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(define *lalr-scm-version* "2.5.0")
+
+
+(cond-expand 
+
+ ;; -- Gambit-C
+ (gambit
+
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (def-macro (BITS-PER-WORD) 28)
+  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+
+  (define pprint pretty-print)
+  (define lalr-keyword? keyword?)
+  (define (note-source-location lvalue tok) lvalue))
+ 
+ ;; -- 
+ (bigloo
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (define pprint (lambda (obj) (write obj) (newline)))
+  (define lalr-keyword? keyword?)
+  (def-macro (BITS-PER-WORD) 29)
+  (def-macro (logical-or x . y) `(bit-or ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+ 
+ ;; -- Chicken
+ (chicken
+  
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (define pprint pretty-print)
+  (define lalr-keyword? symbol?)
+  (def-macro (BITS-PER-WORD) 30)
+  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- STKlos
+ (stklos
+  (require "pp")
+
+  (define (pprint form) (pp form \:port (current-output-port)))
+
+  (define lalr-keyword? keyword?)
+  (define-macro (BITS-PER-WORD) 30)
+  (define-macro (logical-or x . y) `(bit-or ,x ,@y))
+  (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- Guile
+ (guile
+  (use-modules (ice-9 pretty-print))
+  (use-modules (srfi srfi-9))
+
+  (define pprint pretty-print)
+  (define lalr-keyword? symbol?)
+  (define-macro (BITS-PER-WORD) 30)
+  (define-macro (logical-or x . y) `(logior ,x ,@y))
+  (define-macro (lalr-error msg obj) `(error ,msg ,obj))
+  (define (note-source-location lvalue tok)
+    (if (and (supports-source-properties? lvalue)
+             (not (source-property lvalue 'loc))
+             (lexical-token? tok))
+        (set-source-property! lvalue 'loc (lexical-token-source tok)))
+    lvalue))
+
+
+ ;; -- Kawa
+ (kawa
+  (require 'pretty-print)
+  (define (BITS-PER-WORD) 30)
+  (define logical-or logior)
+  (define (lalr-keyword? obj) (keyword? obj))
+  (define (pprint obj) (pretty-print obj))
+  (define (lalr-error msg obj) (error msg obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- SISC
+ (sisc
+  (import logicops)
+  (import record)
+	
+  (define pprint pretty-print)
+  (define lalr-keyword? symbol?)
+  (define-macro BITS-PER-WORD (lambda () 32))
+  (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
+  (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+       
+ (else
+  (error "Unsupported Scheme system")))
+
+
+(define-record-type lexical-token
+  (make-lexical-token category source value)
+  lexical-token?
+  (category lexical-token-category)
+  (source   lexical-token-source)
+  (value    lexical-token-value))
+
+
+(define-record-type source-location
+  (make-source-location input line column offset length)
+  source-location?
+  (input   source-location-input)
+  (line    source-location-line)
+  (column  source-location-column)
+  (offset  source-location-offset)
+  (length  source-location-length))
+
+
+
+      ;; - Macros pour la gestion des vecteurs de bits
+
+(define-macro (lalr-parser . arguments)
+  (define (set-bit v b)
+    (let ((x (quotient b (BITS-PER-WORD)))
+	  (y (expt 2 (remainder b (BITS-PER-WORD)))))
+      (vector-set! v x (logical-or (vector-ref v x) y))))
+
+  (define (bit-union v1 v2 n)
+    (do ((i 0 (+ i 1)))
+	((= i n))
+      (vector-set! v1 i (logical-or (vector-ref v1 i)
+				    (vector-ref v2 i)))))
+
+  ;; - Macro pour les structures de donnees
+
+  (define (new-core)              (make-vector 4 0))
+  (define (set-core-number! c n)  (vector-set! c 0 n))
+  (define (set-core-acc-sym! c s) (vector-set! c 1 s))
+  (define (set-core-nitems! c n)  (vector-set! c 2 n))
+  (define (set-core-items! c i)   (vector-set! c 3 i))
+  (define (core-number c)         (vector-ref c 0))
+  (define (core-acc-sym c)        (vector-ref c 1))
+  (define (core-nitems c)         (vector-ref c 2))
+  (define (core-items c)          (vector-ref c 3))
+
+  (define (new-shift)              (make-vector 3 0))
+  (define (set-shift-number! c x)  (vector-set! c 0 x))
+  (define (set-shift-nshifts! c x) (vector-set! c 1 x))
+  (define (set-shift-shifts! c x)  (vector-set! c 2 x))
+  (define (shift-number s)         (vector-ref s 0))
+  (define (shift-nshifts s)        (vector-ref s 1))
+  (define (shift-shifts s)         (vector-ref s 2))
+
+  (define (new-red)                (make-vector 3 0))
+  (define (set-red-number! c x)    (vector-set! c 0 x))
+  (define (set-red-nreds! c x)     (vector-set! c 1 x))
+  (define (set-red-rules! c x)     (vector-set! c 2 x))
+  (define (red-number c)           (vector-ref c 0))
+  (define (red-nreds c)            (vector-ref c 1))
+  (define (red-rules c)            (vector-ref c 2))
+
+
+  (define (new-set nelem)
+    (make-vector nelem 0))
+
+
+  (define (vector-map f v)
+    (let ((vm-n (- (vector-length v) 1)))
+      (let loop ((vm-low 0) (vm-high vm-n))
+	(if (= vm-low vm-high)
+	    (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
+	    (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
+	      (loop vm-low vm-middle)
+	      (loop (+ vm-middle 1) vm-high))))))
+
+
+  ;; - Constantes
+  (define STATE-TABLE-SIZE 1009)
+
+
+  ;; - Tableaux 
+  (define rrhs         #f)
+  (define rlhs         #f)
+  (define ritem        #f)
+  (define nullable     #f)
+  (define derives      #f)
+  (define fderives     #f)
+  (define firsts       #f)
+  (define kernel-base  #f)
+  (define kernel-end   #f)
+  (define shift-symbol #f)
+  (define shift-set    #f)
+  (define red-set      #f)
+  (define state-table  #f)
+  (define acces-symbol #f)
+  (define reduction-table #f)
+  (define shift-table  #f)
+  (define consistent   #f)
+  (define lookaheads   #f)
+  (define LA           #f)
+  (define LAruleno     #f)
+  (define lookback     #f)
+  (define goto-map     #f)
+  (define from-state   #f)
+  (define to-state     #f)
+  (define includes     #f)
+  (define F            #f)
+  (define action-table #f)
+
+  ;; - Variables
+  (define nitems          #f)
+  (define nrules          #f)
+  (define nvars           #f)
+  (define nterms          #f)
+  (define nsyms           #f)
+  (define nstates         #f)
+  (define first-state     #f)
+  (define last-state      #f)
+  (define final-state     #f)
+  (define first-shift     #f)
+  (define last-shift      #f)
+  (define first-reduction #f)
+  (define last-reduction  #f)
+  (define nshifts         #f)
+  (define maxrhs          #f)
+  (define ngotos          #f)
+  (define token-set-size  #f)
+
+  (define driver-name     'lr-driver)
+
+  (define (glr-driver?)
+    (eq? driver-name 'glr-driver))
+  (define (lr-driver?)
+    (eq? driver-name 'lr-driver))
+
+  (define (gen-tables! tokens gram )
+    (initialize-all)
+    (rewrite-grammar
+     tokens
+     gram
+     (lambda (terms terms/prec vars gram gram/actions)
+       (set! the-terminals/prec (list->vector terms/prec))
+       (set! the-terminals (list->vector terms))
+       (set! the-nonterminals (list->vector vars))
+       (set! nterms (length terms))
+       (set! nvars  (length vars))
+       (set! nsyms  (+ nterms nvars))
+       (let ((no-of-rules (length gram/actions))
+	     (no-of-items (let loop ((l gram/actions) (count 0))
+			    (if (null? l)
+				count
+				(loop (cdr l) (+ count (length (caar l))))))))
+	 (pack-grammar no-of-rules no-of-items gram)
+	 (set-derives)
+	 (set-nullable)
+	 (generate-states)
+	 (lalr)
+	 (build-tables)
+	 (compact-action-table terms)
+	 gram/actions))))
+
+
+  (define (initialize-all)
+    (set! rrhs         #f)
+    (set! rlhs         #f)
+    (set! ritem        #f)
+    (set! nullable     #f)
+    (set! derives      #f)
+    (set! fderives     #f)
+    (set! firsts       #f)
+    (set! kernel-base  #f)
+    (set! kernel-end   #f)
+    (set! shift-symbol #f)
+    (set! shift-set    #f)
+    (set! red-set      #f)
+    (set! state-table  (make-vector STATE-TABLE-SIZE '()))
+    (set! acces-symbol #f)
+    (set! reduction-table #f)
+    (set! shift-table  #f)
+    (set! consistent   #f)
+    (set! lookaheads   #f)
+    (set! LA           #f)
+    (set! LAruleno     #f)
+    (set! lookback     #f)
+    (set! goto-map     #f)
+    (set! from-state   #f)
+    (set! to-state     #f)
+    (set! includes     #f)
+    (set! F            #f)
+    (set! action-table #f)
+    (set! nstates         #f)
+    (set! first-state     #f)
+    (set! last-state      #f)
+    (set! final-state     #f)
+    (set! first-shift     #f)
+    (set! last-shift      #f)
+    (set! first-reduction #f)
+    (set! last-reduction  #f)
+    (set! nshifts         #f)
+    (set! maxrhs          #f)
+    (set! ngotos          #f)
+    (set! token-set-size  #f)
+    (set! rule-precedences '()))
+
+
+  (define (pack-grammar no-of-rules no-of-items gram)
+    (set! nrules (+  no-of-rules 1))
+    (set! nitems no-of-items)
+    (set! rlhs (make-vector nrules #f))
+    (set! rrhs (make-vector nrules #f))
+    (set! ritem (make-vector (+ 1 nitems) #f))
+
+    (let loop ((p gram) (item-no 0) (rule-no 1))
+      (if (not (null? p))
+	  (let ((nt (caar p)))
+	    (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
+	      (if (null? prods)
+		  (loop (cdr p) it-no2 rl-no2)
+		  (begin
+		    (vector-set! rlhs rl-no2 nt)
+		    (vector-set! rrhs rl-no2 it-no2)
+		    (let loop3 ((rhs (car prods)) (it-no3 it-no2))
+		      (if (null? rhs)
+			  (begin
+			    (vector-set! ritem it-no3 (- rl-no2))
+			    (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
+			  (begin
+			    (vector-set! ritem it-no3 (car rhs))
+			    (loop3 (cdr rhs) (+ it-no3 1))))))))))))
+
+
+  (define (set-derives)
+    (define delts (make-vector (+ nrules 1) 0))
+    (define dset  (make-vector nvars -1))
+
+    (let loop ((i 1) (j 0))		; i = 0
+      (if (< i nrules)
+	  (let ((lhs (vector-ref rlhs i)))
+	    (if (>= lhs 0)
+		(begin
+		  (vector-set! delts j (cons i (vector-ref dset lhs)))
+		  (vector-set! dset lhs j)
+		  (loop (+ i 1) (+ j 1)))
+		(loop (+ i 1) j)))))
+
+    (set! derives (make-vector nvars 0))
+
+    (let loop ((i 0))
+      (if (< i nvars)
+	  (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
+		     (if (< j 0)
+			 s
+			 (let ((x (vector-ref delts j)))
+			   (loop2 (cdr x) (cons (car x) s)))))))
+	    (vector-set! derives i q)
+	    (loop (+ i 1))))))
+
+
+
+  (define (set-nullable)
+    (set! nullable (make-vector nvars #f))
+    (let ((squeue (make-vector nvars #f))
+	  (rcount (make-vector (+ nrules 1) 0))
+	  (rsets  (make-vector nvars #f))
+	  (relts  (make-vector (+ nitems nvars 1) #f)))
+      (let loop ((r 0) (s2 0) (p 0))
+	(let ((*r (vector-ref ritem r)))
+	  (if *r
+	      (if (< *r 0)
+		  (let ((symbol (vector-ref rlhs (- *r))))
+		    (if (and (>= symbol 0)
+			     (not (vector-ref nullable symbol)))
+			(begin
+			  (vector-set! nullable symbol #t)
+			  (vector-set! squeue s2 symbol)
+			  (loop (+ r 1) (+ s2 1) p))))
+		  (let loop2 ((r1 r) (any-tokens #f))
+		    (let* ((symbol (vector-ref ritem r1)))
+		      (if (> symbol 0)
+			  (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
+			  (if (not any-tokens)
+			      (let ((ruleno (- symbol)))
+				(let loop3 ((r2 r) (p2 p))
+				  (let ((symbol (vector-ref ritem r2)))
+				    (if (> symbol 0)
+					(begin
+					  (vector-set! rcount ruleno
+						       (+ (vector-ref rcount ruleno) 1))
+					  (vector-set! relts p2
+						       (cons (vector-ref rsets symbol)
+							     ruleno))
+					  (vector-set! rsets symbol p2)
+					  (loop3 (+ r2 1) (+ p2 1)))
+					(loop (+ r2 1) s2 p2)))))
+			      (loop (+ r1 1) s2 p))))))
+	      (let loop ((s1 0) (s3 s2))
+		(if (< s1 s3)
+		    (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
+		      (if p
+			  (let* ((x (vector-ref relts p))
+				 (ruleno (cdr x))
+				 (y (- (vector-ref rcount ruleno) 1)))
+			    (vector-set! rcount ruleno y)
+			    (if (= y 0)
+				(let ((symbol (vector-ref rlhs ruleno)))
+				  (if (and (>= symbol 0)
+					   (not (vector-ref nullable symbol)))
+				      (begin
+					(vector-set! nullable symbol #t)
+					(vector-set! squeue s4 symbol)
+					(loop2 (car x) (+ s4 1)))
+				      (loop2 (car x) s4)))
+				(loop2 (car x) s4))))
+		      (loop (+ s1 1) s4)))))))))
+
+
+
+  (define (set-firsts)
+    (set! firsts (make-vector nvars '()))
+
+    ;; -- initialization
+    (let loop ((i 0))
+      (if (< i nvars)
+	  (let loop2 ((sp (vector-ref derives i)))
+	    (if (null? sp)
+		(loop (+ i 1))
+		(let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
+		  (if (< -1 sym nvars)
+		      (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
+		  (loop2 (cdr sp)))))))
+
+    ;; -- reflexive and transitive closure
+    (let loop ((continue #t))
+      (if continue
+	  (let loop2 ((i 0) (cont #f))
+	    (if (>= i nvars)
+		(loop cont)
+		(let* ((x (vector-ref firsts i))
+		       (y (let loop3 ((l x) (z x))
+			    (if (null? l)
+				z
+				(loop3 (cdr l)
+				       (sunion (vector-ref firsts (car l)) z))))))
+		  (if (equal? x y)
+		      (loop2 (+ i 1) cont)
+		      (begin
+			(vector-set! firsts i y)
+			(loop2 (+ i 1) #t))))))))
+
+    (let loop ((i 0))
+      (if (< i nvars)
+	  (begin
+	    (vector-set! firsts i (sinsert i (vector-ref firsts i)))
+	    (loop (+ i 1))))))
+
+
+
+
+  (define (set-fderives)
+    (set! fderives (make-vector nvars #f))
+
+    (set-firsts)
+
+    (let loop ((i 0))
+      (if (< i nvars)
+	  (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
+		     (if (null? l)
+			 fd
+			 (loop2 (cdr l)
+				(sunion (vector-ref derives (car l)) fd))))))
+	    (vector-set! fderives i x)
+	    (loop (+ i 1))))))
+
+
+  (define (closure core)
+    ;; Initialization
+    (define ruleset (make-vector nrules #f))
+
+    (let loop ((csp core))
+      (if (not (null? csp))
+	  (let ((sym (vector-ref ritem (car csp))))
+	    (if (< -1 sym nvars)
+		(let loop2 ((dsp (vector-ref fderives sym)))
+		  (if (not (null? dsp))
+		      (begin
+			(vector-set! ruleset (car dsp) #t)
+			(loop2 (cdr dsp))))))
+	    (loop (cdr csp)))))
+
+    (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
+      (if (< ruleno nrules)
+	  (if (vector-ref ruleset ruleno)
+	      (let ((itemno (vector-ref rrhs ruleno)))
+		(let loop2 ((c csp) (itemsetv2 itemsetv))
+		  (if (and (pair? c)
+			   (< (car c) itemno))
+		      (loop2 (cdr c) (cons (car c) itemsetv2))
+		      (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
+	      (loop (+ ruleno 1) csp itemsetv))
+	  (let loop2 ((c csp) (itemsetv2 itemsetv))
+	    (if (pair? c)
+		(loop2 (cdr c) (cons (car c) itemsetv2))
+		(reverse itemsetv2))))))
+
+
+
+  (define (allocate-item-sets)
+    (set! kernel-base (make-vector nsyms 0))
+    (set! kernel-end  (make-vector nsyms #f)))
+
+
+  (define (allocate-storage)
+    (allocate-item-sets)
+    (set! red-set (make-vector (+ nrules 1) 0)))
+
+					; --
+
+
+  (define (initialize-states)
+    (let ((p (new-core)))
+      (set-core-number! p 0)
+      (set-core-acc-sym! p #f)
+      (set-core-nitems! p 1)
+      (set-core-items! p '(0))
+
+      (set! first-state (list p))
+      (set! last-state first-state)
+      (set! nstates 1)))
+
+
+
+  (define (generate-states)
+    (allocate-storage)
+    (set-fderives)
+    (initialize-states)
+    (let loop ((this-state first-state))
+      (if (pair? this-state)
+	  (let* ((x (car this-state))
+		 (is (closure (core-items x))))
+	    (save-reductions x is)
+	    (new-itemsets is)
+	    (append-states)
+	    (if (> nshifts 0)
+		(save-shifts x))
+	    (loop (cdr this-state))))))
+
+
+  (define (new-itemsets itemset)
+    ;; - Initialization
+    (set! shift-symbol '())
+    (let loop ((i 0))
+      (if (< i nsyms)
+	  (begin
+	    (vector-set! kernel-end i '())
+	    (loop (+ i 1)))))
+
+    (let loop ((isp itemset))
+      (if (pair? isp)
+	  (let* ((i (car isp))
+		 (sym (vector-ref ritem i)))
+	    (if (>= sym 0)
+		(begin
+		  (set! shift-symbol (sinsert sym shift-symbol))
+		  (let ((x (vector-ref kernel-end sym)))
+		    (if (null? x)
+			(begin
+			  (vector-set! kernel-base sym (cons (+ i 1) x))
+			  (vector-set! kernel-end sym (vector-ref kernel-base sym)))
+			(begin
+			  (set-cdr! x (list (+ i 1)))
+			  (vector-set! kernel-end sym (cdr x)))))))
+	    (loop (cdr isp)))))
+
+    (set! nshifts (length shift-symbol)))
+
+
+
+  (define (get-state sym)
+    (let* ((isp  (vector-ref kernel-base sym))
+	   (n    (length isp))
+	   (key  (let loop ((isp1 isp) (k 0))
+		   (if (null? isp1)
+		       (modulo k STATE-TABLE-SIZE)
+		       (loop (cdr isp1) (+ k (car isp1))))))
+	   (sp   (vector-ref state-table key)))
+      (if (null? sp)
+	  (let ((x (new-state sym)))
+	    (vector-set! state-table key (list x))
+	    (core-number x))
+	  (let loop ((sp1 sp))
+	    (if (and (= n (core-nitems (car sp1)))
+		     (let loop2 ((i1 isp) (t (core-items (car sp1))))
+		       (if (and (pair? i1)
+				(= (car i1)
+				   (car t)))
+			   (loop2 (cdr i1) (cdr t))
+			   (null? i1))))
+		(core-number (car sp1))
+		(if (null? (cdr sp1))
+		    (let ((x (new-state sym)))
+		      (set-cdr! sp1 (list x))
+		      (core-number x))
+		    (loop (cdr sp1))))))))
+
+
+  (define (new-state sym)
+    (let* ((isp  (vector-ref kernel-base sym))
+	   (n    (length isp))
+	   (p    (new-core)))
+      (set-core-number! p nstates)
+      (set-core-acc-sym! p sym)
+      (if (= sym nvars) (set! final-state nstates))
+      (set-core-nitems! p n)
+      (set-core-items! p isp)
+      (set-cdr! last-state (list p))
+      (set! last-state (cdr last-state))
+      (set! nstates (+ nstates 1))
+      p))
+
+
+					; --
+
+  (define (append-states)
+    (set! shift-set
+	  (let loop ((l (reverse shift-symbol)))
+	    (if (null? l)
+		'()
+		(cons (get-state (car l)) (loop (cdr l)))))))
+
+					; --
+
+  (define (save-shifts core)
+    (let ((p (new-shift)))
+      (set-shift-number! p (core-number core))
+      (set-shift-nshifts! p nshifts)
+      (set-shift-shifts! p shift-set)
+      (if last-shift
+	  (begin
+	    (set-cdr! last-shift (list p))
+	    (set! last-shift (cdr last-shift)))
+	  (begin
+	    (set! first-shift (list p))
+	    (set! last-shift first-shift)))))
+
+  (define (save-reductions core itemset)
+    (let ((rs (let loop ((l itemset))
+		(if (null? l)
+		    '()
+		    (let ((item (vector-ref ritem (car l))))
+		      (if (< item 0)
+			  (cons (- item) (loop (cdr l)))
+			  (loop (cdr l))))))))
+      (if (pair? rs)
+	  (let ((p (new-red)))
+	    (set-red-number! p (core-number core))
+	    (set-red-nreds!  p (length rs))
+	    (set-red-rules!  p rs)
+	    (if last-reduction
+		(begin
+		  (set-cdr! last-reduction (list p))
+		  (set! last-reduction (cdr last-reduction)))
+		(begin
+		  (set! first-reduction (list p))
+		  (set! last-reduction first-reduction)))))))
+
+
+					; --
+
+  (define (lalr)
+    (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
+    (set-accessing-symbol)
+    (set-shift-table)
+    (set-reduction-table)
+    (set-max-rhs)
+    (initialize-LA)
+    (set-goto-map)
+    (initialize-F)
+    (build-relations)
+    (digraph includes)
+    (compute-lookaheads))
+
+  (define (set-accessing-symbol)
+    (set! acces-symbol (make-vector nstates #f))
+    (let loop ((l first-state))
+      (if (pair? l)
+	  (let ((x (car l)))
+	    (vector-set! acces-symbol (core-number x) (core-acc-sym x))
+	    (loop (cdr l))))))
+
+  (define (set-shift-table)
+    (set! shift-table (make-vector nstates #f))
+    (let loop ((l first-shift))
+      (if (pair? l)
+	  (let ((x (car l)))
+	    (vector-set! shift-table (shift-number x) x)
+	    (loop (cdr l))))))
+
+  (define (set-reduction-table)
+    (set! reduction-table (make-vector nstates #f))
+    (let loop ((l first-reduction))
+      (if (pair? l)
+	  (let ((x (car l)))
+	    (vector-set! reduction-table (red-number x) x)
+	    (loop (cdr l))))))
+
+  (define (set-max-rhs)
+    (let loop ((p 0) (curmax 0) (length 0))
+      (let ((x (vector-ref ritem p)))
+	(if x
+	    (if (>= x 0)
+		(loop (+ p 1) curmax (+ length 1))
+		(loop (+ p 1) (max curmax length) 0))
+	    (set! maxrhs curmax)))))
+
+  (define (initialize-LA)
+    (define (last l)
+      (if (null? (cdr l))
+	  (car l)
+	  (last (cdr l))))
+
+    (set! consistent (make-vector nstates #f))
+    (set! lookaheads (make-vector (+ nstates 1) #f))
+
+    (let loop ((count 0) (i 0))
+      (if (< i nstates)
+	  (begin
+	    (vector-set! lookaheads i count)
+	    (let ((rp (vector-ref reduction-table i))
+		  (sp (vector-ref shift-table i)))
+	      (if (and rp
+		       (or (> (red-nreds rp) 1)
+			   (and sp
+				(not
+				 (< (vector-ref acces-symbol
+						(last (shift-shifts sp)))
+				    nvars)))))
+		  (loop (+ count (red-nreds rp)) (+ i 1))
+		  (begin
+		    (vector-set! consistent i #t)
+		    (loop count (+ i 1))))))
+
+	  (begin
+	    (vector-set! lookaheads nstates count)
+	    (let ((c (max count 1)))
+	      (set! LA (make-vector c #f))
+	      (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
+	      (set! LAruleno (make-vector c -1))
+	      (set! lookback (make-vector c #f)))
+	    (let loop ((i 0) (np 0))
+	      (if (< i nstates)
+		  (if (vector-ref consistent i)
+		      (loop (+ i 1) np)
+		      (let ((rp (vector-ref reduction-table i)))
+			(if rp
+			    (let loop2 ((j (red-rules rp)) (np2 np))
+			      (if (null? j)
+				  (loop (+ i 1) np2)
+				  (begin
+				    (vector-set! LAruleno np2 (car j))
+				    (loop2 (cdr j) (+ np2 1)))))
+			    (loop (+ i 1) np))))))))))
+
+
+  (define (set-goto-map)
+    (set! goto-map (make-vector (+ nvars 1) 0))
+    (let ((temp-map (make-vector (+ nvars 1) 0)))
+      (let loop ((ng 0) (sp first-shift))
+	(if (pair? sp)
+	    (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
+	      (if (pair? i)
+		  (let ((symbol (vector-ref acces-symbol (car i))))
+		    (if (< symbol nvars)
+			(begin
+			  (vector-set! goto-map symbol
+				       (+ 1 (vector-ref goto-map symbol)))
+			  (loop2 (cdr i) (+ ng2 1)))
+			(loop2 (cdr i) ng2)))
+		  (loop ng2 (cdr sp))))
+
+	    (let loop ((k 0) (i 0))
+	      (if (< i nvars)
+		  (begin
+		    (vector-set! temp-map i k)
+		    (loop (+ k (vector-ref goto-map i)) (+ i 1)))
+
+		  (begin
+		    (do ((i 0 (+ i 1)))
+			((>= i nvars))
+		      (vector-set! goto-map i (vector-ref temp-map i)))
+
+		    (set! ngotos ng)
+		    (vector-set! goto-map nvars ngotos)
+		    (vector-set! temp-map nvars ngotos)
+		    (set! from-state (make-vector ngotos #f))
+		    (set! to-state (make-vector ngotos #f))
+
+		    (do ((sp first-shift (cdr sp)))
+			((null? sp))
+		      (let* ((x (car sp))
+			     (state1 (shift-number x)))
+			(do ((i (shift-shifts x) (cdr i)))
+			    ((null? i))
+			  (let* ((state2 (car i))
+				 (symbol (vector-ref acces-symbol state2)))
+			    (if (< symbol nvars)
+				(let ((k (vector-ref temp-map symbol)))
+				  (vector-set! temp-map symbol (+ k 1))
+				  (vector-set! from-state k state1)
+				  (vector-set! to-state k state2))))))))))))))
+
+
+  (define (map-goto state symbol)
+    (let loop ((low (vector-ref goto-map symbol))
+	       (high (- (vector-ref goto-map (+ symbol 1)) 1)))
+      (if (> low high)
+	  (begin
+	    (display (list "Error in map-goto" state symbol)) (newline)
+	    0)
+	  (let* ((middle (quotient (+ low high) 2))
+		 (s (vector-ref from-state middle)))
+	    (cond
+	     ((= s state)
+	      middle)
+	     ((< s state)
+	      (loop (+ middle 1) high))
+	     (else
+	      (loop low (- middle 1))))))))
+
+
+  (define (initialize-F)
+    (set! F (make-vector ngotos #f))
+    (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
+
+    (let ((reads (make-vector ngotos #f)))
+
+      (let loop ((i 0) (rowp 0))
+	(if (< i ngotos)
+	    (let* ((rowf (vector-ref F rowp))
+		   (stateno (vector-ref to-state i))
+		   (sp (vector-ref shift-table stateno)))
+	      (if sp
+		  (let loop2 ((j (shift-shifts sp)) (edges '()))
+		    (if (pair? j)
+			(let ((symbol (vector-ref acces-symbol (car j))))
+			  (if (< symbol nvars)
+			      (if (vector-ref nullable symbol)
+				  (loop2 (cdr j) (cons (map-goto stateno symbol)
+						       edges))
+				  (loop2 (cdr j) edges))
+			      (begin
+				(set-bit rowf (- symbol nvars))
+				(loop2 (cdr j) edges))))
+			(if (pair? edges)
+			    (vector-set! reads i (reverse edges))))))
+	      (loop (+ i 1) (+ rowp 1)))))
+      (digraph reads)))
+
+  (define (add-lookback-edge stateno ruleno gotono)
+    (let ((k (vector-ref lookaheads (+ stateno 1))))
+      (let loop ((found #f) (i (vector-ref lookaheads stateno)))
+	(if (and (not found) (< i k))
+	    (if (= (vector-ref LAruleno i) ruleno)
+		(loop #t i)
+		(loop found (+ i 1)))
+
+	    (if (not found)
+		(begin (display "Error in add-lookback-edge : ")
+		       (display (list stateno ruleno gotono)) (newline))
+		(vector-set! lookback i
+			     (cons gotono (vector-ref lookback i))))))))
+
+
+  (define (transpose r-arg n)
+    (let ((new-end (make-vector n #f))
+	  (new-R  (make-vector n #f)))
+      (do ((i 0 (+ i 1)))
+	  ((= i n))
+	(let ((x (list 'bidon)))
+	  (vector-set! new-R i x)
+	  (vector-set! new-end i x)))
+      (do ((i 0 (+ i 1)))
+	  ((= i n))
+	(let ((sp (vector-ref r-arg i)))
+	  (if (pair? sp)
+	      (let loop ((sp2 sp))
+		(if (pair? sp2)
+		    (let* ((x (car sp2))
+			   (y (vector-ref new-end x)))
+		      (set-cdr! y (cons i (cdr y)))
+		      (vector-set! new-end x (cdr y))
+		      (loop (cdr sp2))))))))
+      (do ((i 0 (+ i 1)))
+	  ((= i n))
+	(vector-set! new-R i (cdr (vector-ref new-R i))))
+
+      new-R))
+
+
+
+  (define (build-relations)
+
+    (define (get-state stateno symbol)
+      (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
+		 (stno stateno))
+	(if (null? j)
+	    stno
+	    (let ((st2 (car j)))
+	      (if (= (vector-ref acces-symbol st2) symbol)
+		  st2
+		  (loop (cdr j) st2))))))
+
+    (set! includes (make-vector ngotos #f))
+    (do ((i 0 (+ i 1)))
+	((= i ngotos))
+      (let ((state1 (vector-ref from-state i))
+	    (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
+	(let loop ((rulep (vector-ref derives symbol1))
+		   (edges '()))
+	  (if (pair? rulep)
+	      (let ((*rulep (car rulep)))
+		(let loop2 ((rp (vector-ref rrhs *rulep))
+			    (stateno state1)
+			    (states (list state1)))
+		  (let ((*rp (vector-ref ritem rp)))
+		    (if (> *rp 0)
+			(let ((st (get-state stateno *rp)))
+			  (loop2 (+ rp 1) st (cons st states)))
+			(begin
+
+			  (if (not (vector-ref consistent stateno))
+			      (add-lookback-edge stateno *rulep i))
+
+			  (let loop2 ((done #f)
+				      (stp (cdr states))
+				      (rp2 (- rp 1))
+				      (edgp edges))
+			    (if (not done)
+				(let ((*rp (vector-ref ritem rp2)))
+				  (if (< -1 *rp nvars)
+				      (loop2 (not (vector-ref nullable *rp))
+					     (cdr stp)
+					     (- rp2 1)
+					     (cons (map-goto (car stp) *rp) edgp))
+				      (loop2 #t stp rp2 edgp)))
+
+				(loop (cdr rulep) edgp))))))))
+	      (vector-set! includes i edges)))))
+    (set! includes (transpose includes ngotos)))
+
+
+
+  (define (compute-lookaheads)
+    (let ((n (vector-ref lookaheads nstates)))
+      (let loop ((i 0))
+	(if (< i n)
+	    (let loop2 ((sp (vector-ref lookback i)))
+	      (if (pair? sp)
+		  (let ((LA-i (vector-ref LA i))
+			(F-j  (vector-ref F (car sp))))
+		    (bit-union LA-i F-j token-set-size)
+		    (loop2 (cdr sp)))
+		  (loop (+ i 1))))))))
+
+
+
+  (define (digraph relation)
+    (define infinity (+ ngotos 2))
+    (define INDEX (make-vector (+ ngotos 1) 0))
+    (define VERTICES (make-vector (+ ngotos 1) 0))
+    (define top 0)
+    (define R relation)
+
+    (define (traverse i)
+      (set! top (+ 1 top))
+      (vector-set! VERTICES top i)
+      (let ((height top))
+	(vector-set! INDEX i height)
+	(let ((rp (vector-ref R i)))
+	  (if (pair? rp)
+	      (let loop ((rp2 rp))
+		(if (pair? rp2)
+		    (let ((j (car rp2)))
+		      (if (= 0 (vector-ref INDEX j))
+			  (traverse j))
+		      (if (> (vector-ref INDEX i)
+			     (vector-ref INDEX j))
+			  (vector-set! INDEX i (vector-ref INDEX j)))
+		      (let ((F-i (vector-ref F i))
+			    (F-j (vector-ref F j)))
+			(bit-union F-i F-j token-set-size))
+		      (loop (cdr rp2))))))
+	  (if (= (vector-ref INDEX i) height)
+	      (let loop ()
+		(let ((j (vector-ref VERTICES top)))
+		  (set! top (- top 1))
+		  (vector-set! INDEX j infinity)
+		  (if (not (= i j))
+		      (begin
+			(bit-union (vector-ref F i)
+				   (vector-ref F j)
+				   token-set-size)
+			(loop)))))))))
+
+    (let loop ((i 0))
+      (if (< i ngotos)
+	  (begin
+	    (if (and (= 0 (vector-ref INDEX i))
+		     (pair? (vector-ref R i)))
+		(traverse i))
+	    (loop (+ i 1))))))
+
+
+  ;; ----------------------------------------------------------------------
+  ;; operator precedence management
+  ;; ----------------------------------------------------------------------
+      
+  ;; a vector of precedence descriptors where each element
+  ;; is of the form (terminal type precedence)
+  (define the-terminals/prec #f)   ; terminal symbols with precedence 
+					; the precedence is an integer >= 0
+  (define (get-symbol-precedence sym)
+    (caddr (vector-ref the-terminals/prec sym)))
+					; the operator type is either 'none, 'left, 'right, or 'nonassoc
+  (define (get-symbol-assoc sym)
+    (cadr (vector-ref the-terminals/prec sym)))
+
+  (define rule-precedences '())
+  (define (add-rule-precedence! rule sym)
+    (set! rule-precedences
+	  (cons (cons rule sym) rule-precedences)))
+
+  (define (get-rule-precedence ruleno)
+    (cond
+     ((assq ruleno rule-precedences)
+      => (lambda (p)
+	   (get-symbol-precedence (cdr p))))
+     (else
+      ;; process the rule symbols from left to right
+      (let loop ((i    (vector-ref rrhs ruleno))
+		 (prec 0))
+	(let ((item (vector-ref ritem i)))
+	  ;; end of rule
+	  (if (< item 0)
+	      prec
+	      (let ((i1 (+ i 1)))
+		(if (>= item nvars)
+		    ;; it's a terminal symbol
+		    (loop i1 (get-symbol-precedence (- item nvars)))
+		    (loop i1 prec)))))))))
+
+  ;; ----------------------------------------------------------------------
+  ;; Build the various tables
+  ;; ----------------------------------------------------------------------
+
+  (define expected-conflicts 0)
+
+  (define (build-tables)
+
+    (define (resolve-conflict sym rule)
+      (let ((sym-prec   (get-symbol-precedence sym))
+	    (sym-assoc  (get-symbol-assoc sym))
+	    (rule-prec  (get-rule-precedence rule)))
+	(cond
+	 ((> sym-prec rule-prec)     'shift)
+	 ((< sym-prec rule-prec)     'reduce)
+	 ((eq? sym-assoc 'left)      'reduce)
+	 ((eq? sym-assoc 'right)     'shift)
+	 (else                       'none))))
+
+    (define conflict-messages '())
+
+    (define (add-conflict-message . l)
+      (set! conflict-messages (cons l conflict-messages)))
+
+    (define (log-conflicts)
+      (if (> (length conflict-messages) expected-conflicts)
+	  (for-each
+	   (lambda (message)
+	     (for-each display message)
+	     (newline))
+	   conflict-messages)))
+
+    ;; --- Add an action to the action table
+    (define (add-action state symbol new-action)
+      (let* ((state-actions (vector-ref action-table state))
+	     (actions       (assv symbol state-actions)))
+	(if (pair? actions)
+	    (let ((current-action (cadr actions)))
+	      (if (not (= new-action current-action))
+		  ;; -- there is a conflict 
+		  (begin
+		    (if (and (<= current-action 0) (<= new-action 0))
+			;; --- reduce/reduce conflict
+			(begin
+			  (add-conflict-message
+			   "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) 
+			   ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
+			  (if (glr-driver?)
+			      (set-cdr! (cdr actions) (cons new-action (cddr actions)))
+			      (set-car! (cdr actions) (max current-action new-action))))
+			;; --- shift/reduce conflict
+			;; can we resolve the conflict using precedences?
+			(case (resolve-conflict symbol (- current-action))
+			  ;; -- shift
+			  ((shift)   (if (glr-driver?)
+					 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
+					 (set-car! (cdr actions) new-action)))
+			  ;; -- reduce
+			  ((reduce)  #f) ; well, nothing to do...
+			  ;; -- signal a conflict!
+			  (else      (add-conflict-message
+				      "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
+				      ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
+				     (if (glr-driver?)
+					 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
+					 (set-car! (cdr actions) new-action))))))))
+          
+	    (vector-set! action-table state (cons (list symbol new-action) state-actions)))
+	))
+
+    (define (add-action-for-all-terminals state action)
+      (do ((i 1 (+ i 1)))
+	  ((= i nterms))
+	(add-action state i action)))
+
+    (set! action-table (make-vector nstates '()))
+
+    (do ((i 0 (+ i 1)))			; i = state
+	((= i nstates))
+      (let ((red (vector-ref reduction-table i)))
+	(if (and red (>= (red-nreds red) 1))
+	    (if (and (= (red-nreds red) 1) (vector-ref consistent i))
+		(if (glr-driver?)
+		    (add-action-for-all-terminals i (- (car (red-rules red))))
+		    (add-action i 'default (- (car (red-rules red)))))
+		(let ((k (vector-ref lookaheads (+ i 1))))
+		  (let loop ((j (vector-ref lookaheads i)))
+		    (if (< j k)
+			(let ((rule (- (vector-ref LAruleno j)))
+			      (lav  (vector-ref LA j)))
+			  (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
+			    (if (< token nterms)
+				(begin
+				  (let ((in-la-set? (modulo x 2)))
+				    (if (= in-la-set? 1)
+					(add-action i token rule)))
+				  (if (= y (BITS-PER-WORD))
+				      (loop2 (+ token 1)
+					     (vector-ref lav (+ z 1))
+					     1
+					     (+ z 1))
+				      (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
+			  (loop (+ j 1)))))))))
+
+      (let ((shiftp (vector-ref shift-table i)))
+	(if shiftp
+	    (let loop ((k (shift-shifts shiftp)))
+	      (if (pair? k)
+		  (let* ((state (car k))
+			 (symbol (vector-ref acces-symbol state)))
+		    (if (>= symbol nvars)
+			(add-action i (- symbol nvars) state))
+		    (loop (cdr k))))))))
+
+    (add-action final-state 0 'accept)
+    (log-conflicts))
+
+  (define (compact-action-table terms)
+    (define (most-common-action acts)
+      (let ((accums '()))
+	(let loop ((l acts))
+	  (if (pair? l)
+	      (let* ((x (cadar l))
+		     (y (assv x accums)))
+		(if (and (number? x) (< x 0))
+		    (if y
+			(set-cdr! y (+ 1 (cdr y)))
+			(set! accums (cons `(,x . 1) accums))))
+		(loop (cdr l)))))
+
+	(let loop ((l accums) (max 0) (sym #f))
+	  (if (null? l)
+	      sym
+	      (let ((x (car l)))
+		(if (> (cdr x) max)
+		    (loop (cdr l) (cdr x) (car x))
+		    (loop (cdr l) max sym)))))))
+
+    (define (translate-terms acts)
+      (map (lambda (act)
+	     (cons (list-ref terms (car act))
+		   (cdr act)))
+	   acts))
+
+    (do ((i 0 (+ i 1)))
+	((= i nstates))
+      (let ((acts (vector-ref action-table i)))
+	(if (vector? (vector-ref reduction-table i))
+	    (let ((act (most-common-action acts)))
+	      (vector-set! action-table i
+			   (cons `(*default* ,(if act act '*error*))
+				 (translate-terms
+				  (lalr-filter (lambda (x)
+						 (not (and (= (length x) 2)
+							   (eq? (cadr x) act))))
+					       acts)))))
+	    (vector-set! action-table i
+			 (cons `(*default* *error*)
+			       (translate-terms acts)))))))
+
+
+
+  ;; --
+
+  (define (rewrite-grammar tokens grammar k)
+
+    (define eoi '*eoi*)
+
+    (define (check-terminal term terms)
+      (cond
+       ((not (valid-terminal? term))
+	(lalr-error "invalid terminal: " term))
+       ((member term terms)
+	(lalr-error "duplicate definition of terminal: " term))))
+
+    (define (prec->type prec)
+      (cdr (assq prec '((left_     . left)
+			(right_    . right)
+			(nonassoc_ . nonassoc)))))
+
+    (cond
+     ;; --- a few error conditions
+     ((not (list? tokens))
+      (lalr-error "Invalid token list_ " tokens))
+     ((not (pair? grammar))
+      (lalr-error "Grammar definition must have a non-empty list of productions" '()))
+
+     (else
+      ;; --- check the terminals
+      (let loop1 ((lst            tokens)
+		  (rev-terms      '())
+		  (rev-terms/prec '())
+		  (prec-level     0))
+	(if (pair? lst)
+	    (let ((term (car lst)))
+	      (cond
+	       ((pair? term)
+		(if (and (memq (car term) '(left_ right_ nonassoc_))
+			 (not (null? (cdr term))))
+		    (let ((prec    (+ prec-level 1))
+			  (optype  (prec->type (car term))))
+		      (let loop-toks ((l             (cdr term))
+				      (rev-terms      rev-terms)
+				      (rev-terms/prec rev-terms/prec))
+			(if (null? l)
+			    (loop1 (cdr lst) rev-terms rev-terms/prec prec)
+			    (let ((term (car l)))
+			      (check-terminal term rev-terms)
+			      (loop-toks
+			       (cdr l)
+			       (cons term rev-terms)
+			       (cons (list term optype prec) rev-terms/prec))))))
+
+		    (lalr-error "invalid operator precedence specification_ " term)))
+
+	       (else
+		(check-terminal term rev-terms)
+		(loop1 (cdr lst)
+		       (cons term rev-terms)
+		       (cons (list term 'none 0) rev-terms/prec)
+		       prec-level))))
+
+	    ;; --- check the grammar rules
+	    (let loop2 ((lst grammar) (rev-nonterm-defs '()))
+	      (if (pair? lst)
+		  (let ((def (car lst)))
+		    (if (not (pair? def))
+			(lalr-error "Nonterminal definition must be a non-empty list" '())
+			(let ((nonterm (car def)))
+			  (cond ((not (valid-nonterminal? nonterm))
+				 (lalr-error "Invalid nonterminal_" nonterm))
+				((or (member nonterm rev-terms)
+				     (assoc nonterm rev-nonterm-defs))
+				 (lalr-error "Nonterminal previously defined_" nonterm))
+				(else
+				 (loop2 (cdr lst)
+					(cons def rev-nonterm-defs)))))))
+		  (let* ((terms        (cons eoi            (cons 'error          (reverse rev-terms))))
+			 (terms/prec   (cons '(eoi none 0)  (cons '(error none 0) (reverse rev-terms/prec))))
+			 (nonterm-defs (reverse rev-nonterm-defs))
+			 (nonterms     (cons '*start* (map car nonterm-defs))))
+		    (if (= (length nonterms) 1)
+			(lalr-error "Grammar must contain at least one nonterminal" '())
+			(let loop-defs ((defs      (cons `(*start* (,(cadr nonterms) ,eoi) \_ $1)
+							 nonterm-defs))
+					(ruleno    0)
+					(comp-defs '()))
+			  (if (pair? defs)
+			      (let* ((nonterm-def  (car defs))
+				     (compiled-def (rewrite-nonterm-def
+						    nonterm-def
+						    ruleno
+						    terms nonterms)))
+				(loop-defs (cdr defs)
+					   (+ ruleno (length compiled-def))
+					   (cons compiled-def comp-defs)))
+
+			      (let ((compiled-nonterm-defs (reverse comp-defs)))
+				(k terms
+				   terms/prec
+				   nonterms
+				   (map (lambda (x) (cons (caaar x) (map cdar x)))
+					compiled-nonterm-defs)
+				   (apply append compiled-nonterm-defs))))))))))))))
+
+
+  (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
+
+    (define No-NT (length nonterms))
+
+    (define (encode x)
+      (let ((PosInNT (pos-in-list x nonterms)))
+	(if PosInNT
+	    PosInNT
+	    (let ((PosInT (pos-in-list x terms)))
+	      (if PosInT
+		  (+ No-NT PosInT)
+		  (lalr-error "undefined symbol _ " x))))))
+
+    (define (process-prec-directive rhs ruleno)
+      (let loop ((l rhs))
+	(if (null? l)
+	    '()
+	    (let ((first (car l))
+		  (rest  (cdr l)))
+	      (cond
+	       ((or (member first terms) (member first nonterms))
+		(cons first (loop rest)))
+	       ((and (pair? first)
+		     (eq? (car first) 'prec_))
+		(if (and (pair? (cdr first))
+			 (null? (cddr first))
+			 (member (cadr first) terms))
+		    (if (null? rest)
+			(begin
+			  (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
+			  (loop rest))
+			(lalr-error "prec_ directive should be at end of rule_ " rhs))
+		    (lalr-error "Invalid prec_ directive_ " first)))
+	       (else
+		(lalr-error "Invalid terminal or nonterminal_ " first)))))))
+
+    (define (check-error-production rhs)
+      (let loop ((rhs rhs))
+	(if (pair? rhs)
+	    (begin
+	      (if (and (eq? (car rhs) 'error)
+		       (or (null? (cdr rhs))
+			   (not (member (cadr rhs) terms))
+			   (not (null? (cddr rhs)))))
+		  (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token._" rhs))
+	      (loop (cdr rhs))))))
+
+
+    (if (not (pair? (cdr nonterm-def)))
+	(lalr-error "At least one production needed for nonterminal_" (car nonterm-def))
+	(let ((name (symbol->string (car nonterm-def))))
+	  (let loop1 ((lst (cdr nonterm-def))
+		      (i 1)
+		      (rev-productions-and-actions '()))
+	    (if (not (pair? lst))
+		(reverse rev-productions-and-actions)
+		(let* ((rhs  (process-prec-directive (car lst) (+ ruleno i -1)))
+		       (rest (cdr lst))
+		       (prod (map encode (cons (car nonterm-def) rhs))))
+		  ;; -- check for undefined tokens
+		  (for-each (lambda (x)
+			      (if (not (or (member x terms) (member x nonterms)))
+				  (lalr-error "Invalid terminal or nonterminal_" x)))
+			    rhs)
+		  ;; -- check 'error' productions
+		  (check-error-production rhs)
+
+		  (if (and (pair? rest)
+			   (eq? (car rest) '_)
+			   (pair? (cdr rest)))
+		      (loop1 (cddr rest)
+			     (+ i 1)
+			     (cons (cons prod (cadr rest))
+				   rev-productions-and-actions))
+		      (let* ((rhs-length (length rhs))
+			     (action
+			      (cons 'vector
+				    (cons (list 'quote (string->symbol
+							(string-append
+							 name
+							 "-"
+							 (number->string i))))
+					  (let loop-j ((j 1))
+					    (if (> j rhs-length)
+						'()
+						(cons (string->symbol
+						       (string-append
+							"$"
+							(number->string j)))
+						      (loop-j (+ j 1)))))))))
+			(loop1 rest
+			       (+ i 1)
+			       (cons (cons prod action)
+				     rev-productions-and-actions))))))))))
+
+  (define (valid-nonterminal? x)
+    (symbol? x))
+
+  (define (valid-terminal? x)
+    (symbol? x))			; DB 
+
+  ;; ----------------------------------------------------------------------
+  ;; Miscellaneous
+  ;; ----------------------------------------------------------------------
+  (define (pos-in-list x lst)
+    (let loop ((lst lst) (i 0))
+      (cond ((not (pair? lst))    #f)
+	    ((equal? (car lst) x) i)
+	    (else                 (loop (cdr lst) (+ i 1))))))
+
+  (define (sunion lst1 lst2)		; union of sorted lists
+    (let loop ((L1 lst1)
+	       (L2 lst2))
+      (cond ((null? L1)    L2)
+	    ((null? L2)    L1)
+	    (else
+	     (let ((x (car L1)) (y (car L2)))
+	       (cond
+		((> x y)
+		 (cons y (loop L1 (cdr L2))))
+		((< x y)
+		 (cons x (loop (cdr L1) L2)))
+		(else
+		 (loop (cdr L1) L2))
+		))))))
+
+  (define (sinsert elem lst)
+    (let loop ((l1 lst))
+      (if (null? l1)
+	  (cons elem l1)
+	  (let ((x (car l1)))
+	    (cond ((< elem x)
+		   (cons elem l1))
+		  ((> elem x)
+		   (cons x (loop (cdr l1))))
+		  (else
+		   l1))))))
+
+  (define (lalr-filter p lst)
+    (let loop ((l lst))
+      (if (null? l)
+	  '()
+	  (let ((x (car l)) (y (cdr l)))
+	    (if (p x)
+		(cons x (loop y))
+		(loop y))))))
+      
+  ;; ----------------------------------------------------------------------
+  ;; Debugging tools ...
+  ;; ----------------------------------------------------------------------
+  (define the-terminals #f)		; names of terminal symbols
+  (define the-nonterminals #f)		; non-terminals
+
+  (define (print-item item-no)
+    (let loop ((i item-no))
+      (let ((v (vector-ref ritem i)))
+	(if (>= v 0)
+	    (loop (+ i 1))
+	    (let* ((rlno    (- v))
+		   (nt      (vector-ref rlhs rlno)))
+	      (display (vector-ref the-nonterminals nt)) (display " --> ")
+	      (let loop ((i (vector-ref rrhs rlno)))
+		(let ((v (vector-ref ritem i)))
+		  (if (= i item-no)
+		      (display ". "))
+		  (if (>= v 0)
+		      (begin
+			(display (get-symbol v))
+			(display " ")
+			(loop (+ i 1)))
+		      (begin
+			(display "   (rule ")
+			(display (- v))
+			(display ")")
+			(newline))))))))))
+
+  (define (get-symbol n)
+    (if (>= n nvars)
+	(vector-ref the-terminals (- n nvars))
+	(vector-ref the-nonterminals n)))
+
+
+  (define (print-states)
+    (define (print-action act)
+      (cond
+       ((eq? act '*error*)
+	(display " _ Error"))
+       ((eq? act 'accept)
+	(display " _ Accept input"))
+       ((< act 0)
+	(display " _ reduce using rule ")
+	(display (- act)))
+       (else
+	(display " _ shift and goto state ")
+	(display act)))
+      (newline)
+      #t)
+
+    (define (print-actions acts)
+      (let loop ((l acts))
+	(if (null? l)
+	    #t
+	    (let ((sym (caar l))
+		  (act (cadar l)))
+	      (display "   ")
+	      (cond
+	       ((eq? sym 'default)
+		(display "default action"))
+	       (else
+		(if (number? sym)
+		    (display (get-symbol (+ sym nvars)))
+		    (display sym))))
+	      (print-action act)
+	      (loop (cdr l))))))
+
+    (if (not action-table)
+	(begin
+	  (display "No generated parser available!")
+	  (newline)
+	  #f)
+	(begin
+	  (display "State table") (newline)
+	  (display "-----------") (newline) (newline)
+
+	  (let loop ((l first-state))
+	    (if (null? l)
+		#t
+		(let* ((core  (car l))
+		       (i     (core-number core))
+		       (items (core-items core))
+		       (actions (vector-ref action-table i)))
+		  (display "state ") (display i) (newline)
+		  (newline)
+		  (for-each (lambda (x) (display "   ") (print-item x))
+			    items)
+		  (newline)
+		  (print-actions actions)
+		  (newline)
+		  (loop (cdr l))))))))
+
+
+
+  ;; ----------------------------------------------------------------------
+      
+  (define build-goto-table
+    (lambda ()
+      `(vector
+	,@(map
+	   (lambda (shifts)
+	     (list 'quote
+		   (if shifts
+		       (let loop ((l (shift-shifts shifts)))
+			 (if (null? l)
+			     '()
+			     (let* ((state  (car l))
+				    (symbol (vector-ref acces-symbol state)))
+			       (if (< symbol nvars)
+				   (cons `(,symbol . ,state)
+					 (loop (cdr l)))
+				   (loop (cdr l))))))
+		       '())))
+	   (vector->list shift-table)))))
+
+
+  (define build-reduction-table
+    (lambda (gram/actions)
+      `(vector
+	'()
+	,@(map
+	   (lambda (p)
+	     (let ((act (cdr p)))
+	       `(lambda ,(if (eq? driver-name 'lr-driver)
+			     '(___stack ___sp ___goto-table ___push yypushback)
+			     '(___sp ___goto-table ___push))
+		  ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
+		     `(let* (,@(if act
+				   (let loop ((i 1) (l rhs))
+				     (if (pair? l)
+					 (let ((rest (cdr l))
+                                               (ns (number->string (+ (- n i) 1))))
+                                           (cons
+                                            `(tok ,(if (eq? driver-name 'lr-driver)
+                                                       `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
+                                                       `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
+                                            (cons
+                                             `(,(string->symbol (string-append "$" ns))
+                                               (if (lexical-token? tok) (lexical-token-value tok) tok))
+                                             (cons
+                                              `(,(string->symbol (string-append "@" ns))
+                                                (if (lexical-token? tok) (lexical-token-source tok) tok))
+                                              (loop (+ i 1) rest)))))
+					 '()))
+				   '()))
+			,(if (= nt 0)
+			     '$1
+			     `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) 
+                                       ,(if (eq? driver-name 'lr-driver)
+                                            `(vector-ref ___stack (- ___sp ,(length rhs)))
+                                            `(list-ref ___sp ,(length rhs))))))))))
+
+	   gram/actions))))
+
+
+
+  ;; Options
+
+  (define *valid-options*
+    (list
+     (cons 'out-table_
+	   (lambda (option)
+	     (and (list? option)
+		  (= (length option) 2)
+		  (string? (cadr option)))))
+     (cons 'output_
+	   (lambda (option)
+	     (and (list? option)
+		  (= (length option) 3)
+		  (symbol? (cadr option))
+		  (string? (caddr option)))))
+     (cons 'expect_
+	   (lambda (option)
+	     (and (list? option)
+		  (= (length option) 2)
+		  (integer? (cadr option))
+		  (>= (cadr option) 0))))
+
+     (cons 'driver_
+	   (lambda (option)
+	     (and (list? option)
+		  (= (length option) 2)
+		  (symbol? (cadr option))
+		  (memq (cadr option) '(lr glr)))))))
+
+
+  (define (validate-options options)
+    (for-each
+     (lambda (option)
+       (let ((p (assoc (car option) *valid-options*)))
+	 (if (or (not p)
+		 (not ((cdr p) option)))
+	     (lalr-error "Invalid option_" option))))
+     options))
+
+
+  (define (output-parser! options code)
+    (let ((option (assq 'output_ options)))
+      (if option
+	  (let ((parser-name (cadr option))
+		(file-name   (caddr option)))
+	    (with-output-to-file file-name
+	      (lambda ()
+		(pprint `(define ,parser-name ,code))
+		(newline)))))))
+
+
+  (define (output-table! options)
+    (let ((option (assq 'out-table_ options)))
+      (if option
+	  (let ((file-name (cadr option)))
+	    (with-output-to-file file-name print-states)))))
+
+
+  (define (set-expected-conflicts! options)
+    (let ((option (assq 'expect_ options)))
+      (set! expected-conflicts (if option (cadr option) 0))))
+
+  (define (set-driver-name! options)
+    (let ((option (assq 'driver_ options)))
+      (if option
+	  (let ((driver-type (cadr option)))
+	    (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
+
+
+  ;; -- arguments
+
+  (define (extract-arguments lst proc)
+    (let loop ((options '())
+	       (tokens  '())
+	       (rules   '())
+	       (lst     lst))
+      (if (pair? lst)
+	  (let ((p (car lst)))
+	    (cond
+	     ((and (pair? p)
+		   (lalr-keyword? (car p))
+		   (assq (car p) *valid-options*))
+	      (loop (cons p options) tokens rules (cdr lst)))
+	     (else
+	      (proc options p (cdr lst)))))
+	  (lalr-error "Malformed lalr-parser form" lst))))
+
+
+  (define (build-driver options tokens rules)
+    (validate-options options)
+    (set-expected-conflicts! options)
+    (set-driver-name! options)
+    (let* ((gram/actions (gen-tables! tokens rules))
+	   (code         `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
+    
+      (output-table! options)
+      (output-parser! options code)
+      code))
+
+  (extract-arguments arguments build-driver))
+   
+
+
+;;;
+;;;; --
+;;;; Implementation of the lr-driver
+;;;
+
+
+(cond-expand
+ (gambit
+  (declare
+   (standard-bindings)
+   (fixnum)
+   (block)
+   (not safe)))
+ (chicken
+  (declare
+   (uses extras)
+   (usual-integrations)
+   (fixnum)
+   (not safe)))
+ (else))
+
+
+;;;
+;;;; Source location utilities
+;;;
+
+
+;; This function assumes that src-location-1 and src-location-2 are source-locations
+;; Returns #f if they are not locations for the same input 
+(define (combine-locations src-location-1 src-location-2)
+  (let ((offset-1 (source-location-offset src-location-1))
+        (offset-2 (source-location-offset src-location-2))
+        (length-1 (source-location-length src-location-1))
+        (length-2 (source-location-length src-location-2)))
+
+    (cond ((not (equal? (source-location-input src-location-1)
+                        (source-location-input src-location-2)))
+           #f)
+          ((or (not (number? offset-1)) (not (number? offset-2))
+               (not (number? length-1)) (not (number? length-2))
+               (< offset-1 0) (< offset-2 0)
+               (< length-1 0) (< length-2 0))
+           (make-source-location (source-location-input src-location-1)
+                                 (source-location-line src-location-1)
+                                 (source-location-column src-location-1)
+                                 -1 -1))
+          ((<= offset-1 offset-2)
+           (make-source-location (source-location-input src-location-1)
+                                 (source-location-line src-location-1)
+                                 (source-location-column src-location-1)
+                                 offset-1
+                                 (- (+ offset-2 length-2) offset-1)))
+          (else
+           (make-source-location (source-location-input src-location-1)
+                                 (source-location-line src-location-1)
+                                 (source-location-column src-location-1)
+                                 offset-2
+                                 (- (+ offset-1 length-1) offset-2))))))
+
+
+;;;
+;;;;  LR-driver
+;;;
+
+
+(define *max-stack-size* 500)
+
+(define (lr-driver action-table goto-table reduction-table)
+  (define ___atable action-table)
+  (define ___gtable goto-table)
+  (define ___rtable reduction-table)
+
+  (define ___lexerp #f)
+  (define ___errorp #f)
+  
+  (define ___stack  #f)
+  (define ___sp     0)
+  
+  (define ___curr-input #f)
+  (define ___reuse-input #f)
+  
+  (define ___input #f)
+  (define (___consume)
+    (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
+    (set! ___reuse-input #f)
+    (set! ___curr-input ___input))
+  
+  (define (___pushback)
+    (set! ___reuse-input #t))
+  
+  (define (___initstack)
+    (set! ___stack (make-vector *max-stack-size* 0))
+    (set! ___sp 0))
+  
+  (define (___growstack)
+    (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
+      (let loop ((i (- (vector-length ___stack) 1)))
+        (if (>= i 0)
+	    (begin
+	      (vector-set! new-stack i (vector-ref ___stack i))
+	      (loop (- i 1)))))
+      (set! ___stack new-stack)))
+  
+  (define (___checkstack)
+    (if (>= ___sp (vector-length ___stack))
+        (___growstack)))
+  
+  (define (___push delta new-category lvalue tok)
+    (set! ___sp (- ___sp (* delta 2)))
+    (let* ((state     (vector-ref ___stack ___sp))
+           (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
+      (set! ___sp (+ ___sp 2))
+      (___checkstack)
+      (vector-set! ___stack ___sp new-state)
+      (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
+  
+  (define (___reduce st)
+    ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
+  
+  (define (___shift token attribute)
+    (set! ___sp (+ ___sp 2))
+    (___checkstack)
+    (vector-set! ___stack (- ___sp 1) attribute)
+    (vector-set! ___stack ___sp token))
+  
+  (define (___action x l)
+    (let ((y (assoc x l)))
+      (if y (cadr y) (cadar l))))
+  
+  (define (___recover tok)
+    (let find-state ((sp ___sp))
+      (if (< sp 0)
+          (set! ___sp sp)
+          (let* ((state (vector-ref ___stack sp))
+                 (act   (assoc 'error (vector-ref ___atable state))))
+            (if act
+                (begin
+                  (set! ___sp sp)
+                  (___sync (cadr act) tok))
+                (find-state (- sp 2)))))))
+  
+  (define (___sync state tok)
+    (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
+      (set! ___sp (+ ___sp 4))
+      (___checkstack)
+      (vector-set! ___stack (- ___sp 3) #f)
+      (vector-set! ___stack (- ___sp 2) state)
+      (let skip ()
+        (let ((i (___category ___input)))
+          (if (eq? i '*eoi*)
+              (set! ___sp -1)
+              (if (memq i sync-set)
+                  (let ((act (assoc i (vector-ref ___atable state))))
+                    (vector-set! ___stack (- ___sp 1) #f)
+                    (vector-set! ___stack ___sp (cadr act)))
+                  (begin
+                    (___consume)
+                    (skip))))))))
+  
+  (define (___category tok)
+    (if (lexical-token? tok)
+        (lexical-token-category tok)
+        tok))
+
+  (define (___run)
+    (let loop ()
+      (if ___input
+          (let* ((state (vector-ref ___stack ___sp))
+                 (i     (___category ___input))
+                 (act   (___action i (vector-ref ___atable state))))
+            
+            (cond ((not (symbol? i))
+                   (___errorp "Syntax error_ invalid token_ " ___input)
+                   #f)
+             
+                  ;; Input succesfully parsed
+                  ((eq? act 'accept)
+                   (vector-ref ___stack 1))
+                  
+                  ;; Syntax error in input
+                  ((eq? act '*error*)
+                   (if (eq? i '*eoi*)
+                       (begin
+                         (___errorp "Syntax error_ unexpected end of input")
+                         #f)
+                       (begin
+                         (___errorp "Syntax error_ unexpected token _ " ___input)
+                         (___recover i)
+                         (if (>= ___sp 0)
+                             (set! ___input #f)
+                             (begin
+                               (set! ___sp 0)
+                               (set! ___input '*eoi*)))
+                         (loop))))
+             
+                  ;; Shift current token on top of the stack
+                  ((>= act 0)
+                   (___shift act ___input)
+                   (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
+                   (loop))
+             
+                  ;; Reduce by rule (- act)
+                  (else
+                   (___reduce (- act))
+                   (loop))))
+          
+          ;; no lookahead, so check if there is a default action
+          ;; that does not require the lookahead
+          (let* ((state  (vector-ref ___stack ___sp))
+                 (acts   (vector-ref ___atable state))
+                 (defact (if (pair? acts) (cadar acts) #f)))
+            (if (and (= 1 (length acts)) (< defact 0))
+                (___reduce (- defact))
+                (___consume))
+            (loop)))))
+  
+
+  (lambda (lexerp errorp)
+    (set! ___errorp errorp)
+    (set! ___lexerp lexerp)
+    (___initstack)
+    (___run)))
+
+
+;;;
+;;;;  Simple-minded GLR-driver
+;;;
+
+
+(define (glr-driver action-table goto-table reduction-table)
+  (define ___atable action-table)
+  (define ___gtable goto-table)
+  (define ___rtable reduction-table)
+
+  (define ___lexerp #f)
+  (define ___errorp #f)
+  
+  ;; -- Input handling 
+  
+  (define *input* #f)
+  (define (initialize-lexer lexer)
+    (set! ___lexerp lexer)
+    (set! *input* #f))
+  (define (consume)
+    (set! *input* (___lexerp)))
+  
+  (define (token-category tok)
+    (if (lexical-token? tok)
+        (lexical-token-category tok)
+        tok))
+
+  (define (token-attribute tok)
+    (if (lexical-token? tok)
+        (lexical-token-value tok)
+        tok))
+
+  ;; -- Processes (stacks) handling
+  
+  (define *processes* '())
+  
+  (define (initialize-processes)
+    (set! *processes* '()))
+  (define (add-process process)
+    (set! *processes* (cons process *processes*)))
+  (define (get-processes)
+    (reverse *processes*))
+  
+  (define (for-all-processes proc)
+    (let ((processes (get-processes)))
+      (initialize-processes)
+      (for-each proc processes)))
+  
+  ;; -- parses
+  (define *parses* '())
+  (define (get-parses)
+    *parses*)
+  (define (initialize-parses)
+    (set! *parses* '()))
+  (define (add-parse parse)
+    (set! *parses* (cons parse *parses*)))
+    
+
+  (define (push delta new-category lvalue stack tok)
+    (let* ((stack     (drop stack (* delta 2)))
+           (state     (car stack))
+           (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
+        (cons new-state (cons (note-source-location lvalue tok) stack))))
+  
+  (define (reduce state stack)
+    ((vector-ref ___rtable state) stack ___gtable push))
+  
+  (define (shift state symbol stack)
+    (cons state (cons symbol stack)))
+  
+  (define (get-actions token action-list)
+    (let ((pair (assoc token action-list)))
+      (if pair 
+          (cdr pair)
+          (cdar action-list)))) ;; get the default action
+  
+
+  (define (run)
+    (let loop-tokens ()
+      (consume)
+      (let ((symbol (token-category *input*)))
+        (for-all-processes
+         (lambda (process)
+           (let loop ((stacks (list process)) (active-stacks '()))
+             (cond ((pair? stacks)
+                    (let* ((stack   (car stacks))
+                           (state   (car stack)))
+                      (let actions-loop ((actions      (get-actions symbol (vector-ref ___atable state)))
+                                         (active-stacks active-stacks))
+                        (if (pair? actions)
+                            (let ((action        (car actions))
+                                  (other-actions (cdr actions)))
+                              (cond ((eq? action '*error*)
+                                     (actions-loop other-actions active-stacks))
+                                    ((eq? action 'accept)
+                                     (add-parse (car (take-right stack 2)))
+                                     (actions-loop other-actions active-stacks))
+                                    ((>= action 0)
+                                     (let ((new-stack (shift action *input* stack)))
+                                       (add-process new-stack))
+                                     (actions-loop other-actions active-stacks))
+                                    (else
+                                     (let ((new-stack (reduce (- action) stack)))
+                                      (actions-loop other-actions (cons new-stack active-stacks))))))
+                            (loop (cdr stacks) active-stacks)))))
+                   ((pair? active-stacks)
+                    (loop (reverse active-stacks) '())))))))
+      (if (pair? (get-processes))
+          (loop-tokens))))
+
+  
+  (lambda (lexerp errorp)
+    (set! ___errorp errorp)
+    (initialize-lexer lexerp)
+    (initialize-processes)
+    (initialize-parses)
+    (add-process '(0))
+    (run)
+    (get-parses)))
+
+
+(define (drop l n)
+  (cond ((and (> n 0) (pair? l))
+	 (drop (cdr l) (- n 1)))
+	(else
+	 l)))
+
+(define (take-right l n)
+  (drop l (- (length l) n)));;; Multi-language support
+
+;; Copyright (C) 2001, 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
+
+;;; Code_
+
+(define-module (system base language)
+  #\use-module (system base syntax)
+  #\export (define-language language? lookup-language make-language
+            language-name language-title language-reader
+            language-printer language-parser 
+            language-compilers language-decompilers language-evaluator
+            language-joiner language-for-humans?
+            language-make-default-environment
+
+            lookup-compilation-order lookup-decompilation-order
+            invalidate-compilation-cache! default-environment
+
+            *current-language*)
+
+  #\re-export (current-language))
+
+
+;;;
+;;; Language class
+;;;
+
+(define-record/keywords <language>
+  name
+  title
+  reader
+  printer
+  (parser #f)
+  (compilers '())
+  (decompilers '())
+  (evaluator #f)
+  (joiner #f)
+  (for-humans? #t)
+  (make-default-environment make-fresh-user-module))
+
+(define-macro (define-language name . spec)
+  `(begin
+     (invalidate-compilation-cache!)
+     (define ,name (make-language #\name ',name ,@spec))))
+
+(define (lookup-language name)
+  (let ((m (resolve-module `(language ,name spec))))
+    (if (module-bound? m name)
+	(module-ref m name)
+	(error "no such language" name))))
+
+(define *compilation-cache* '())
+(define *decompilation-cache* '())
+
+(define (invalidate-compilation-cache!)
+  (set! *decompilation-cache* '())
+  (set! *compilation-cache* '()))
+
+(define (compute-translation-order from to language-translators)
+  (cond
+   ((not (language? to))
+    (compute-translation-order from (lookup-language to) language-translators))
+   (else
+    (let lp ((from from) (seen '()))
+      (cond
+       ((not (language? from))
+        (lp (lookup-language from) seen))
+       ((eq? from to) (reverse! seen))
+       ((memq from seen) #f)
+       (else (or-map (lambda (pair)
+                       (lp (car pair) (acons from (cdr pair) seen)))
+                     (language-translators from))))))))
+
+(define (lookup-compilation-order from to)
+  (let ((key (cons from to)))
+    (or (assoc-ref *compilation-cache* key)
+        (let ((order (compute-translation-order from to language-compilers)))
+          (set! *compilation-cache*
+                (acons key order *compilation-cache*))
+          order))))
+
+(define (lookup-decompilation-order from to)
+  (let ((key (cons from to)))
+    (or (assoc-ref *decompilation-cache* key)
+        ;; trickery!
+        (let ((order (and=>
+                      (compute-translation-order to from language-decompilers)
+                      reverse!)))
+          (set! *decompilation-cache* (acons key order *decompilation-cache*))
+          order))))
+
+(define (default-environment lang)
+  "Return the default compilation environment for source language LANG."
+  ((language-make-default-environment
+    (if (language? lang) lang (lookup-language lang)))))
+
+
+
+;;;
+;;; Current language
+;;;
+
+;; Deprecated; use current-language instead.
+(define *current-language* (parameter-fluid current-language))
+;;; User interface messages
+
+;; Copyright (C) 2009, 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
+
+;;; Commentary_
+;;;
+;;; This module provide a simple interface to send messages to the user.
+;;; TODO_ Internationalize messages.
+;;;
+;;; Code_
+
+(define-module (system base message)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (ice-9 match)
+  #\export (*current-warning-port*
+            *current-warning-prefix*
+            warning
+
+            warning-type? warning-type-name warning-type-description
+            warning-type-printer lookup-warning-type
+
+            %warning-types))
+
+
+;;;
+;;; Source location
+;;;
+
+(define (location-string loc)
+  (if (pair? loc)
+      (format #f "~a_~a_~a"
+              (or (assoc-ref loc 'filename) "<stdin>")
+              (1+ (assoc-ref loc 'line))
+              (assoc-ref loc 'column))
+      "<unknown-location>"))
+
+
+;;;
+;;; Warnings
+;;;
+
+;; This name existed before %current-warning-port was introduced, but
+;; otherwise it is a deprecated binding.
+(define *current-warning-port*
+  ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as
+  ;; other modules might depend on this being a normal binding and not a
+  ;; syntax binding.
+  (parameter-fluid current-warning-port))
+
+(define *current-warning-prefix*
+  ;; Prefix string when emitting a warning.
+  (make-fluid ";;; "))
+
+
+(define-record-type <warning-type>
+  (make-warning-type name description printer)
+  warning-type?
+  (name         warning-type-name)
+  (description  warning-type-description)
+  (printer      warning-type-printer))
+
+(define %warning-types
+  ;; List of known warning types.
+  (map (lambda (args)
+         (apply make-warning-type args))
+
+       (let-syntax ((emit
+                     (lambda (s)
+                       (syntax-case s ()
+                         ((_ port fmt args ...)
+                          (string? (syntax->datum #'fmt))
+                          (with-syntax ((fmt
+                                         (string-append "~a"
+                                                        (syntax->datum
+                                                         #'fmt))))
+                            #'(format port fmt
+                                      (fluid-ref *current-warning-prefix*)
+                                      args ...)))))))
+         `((unsupported-warning ;; a "meta warning"
+            "warn about unknown warning types"
+            ,(lambda (port unused name)
+               (emit port "warning_ unknown warning type `~A'~%"
+                     name)))
+
+           (unused-variable
+            "report unused variables"
+            ,(lambda (port loc name)
+               (emit port "~A_ warning_ unused variable `~A'~%"
+                     loc name)))
+
+           (unused-toplevel
+            "report unused local top-level variables"
+            ,(lambda (port loc name)
+               (emit port "~A_ warning_ possibly unused local top-level variable `~A'~%"
+                     loc name)))
+
+           (unbound-variable
+            "report possibly unbound variables"
+            ,(lambda (port loc name)
+               (emit port "~A_ warning_ possibly unbound variable `~A'~%"
+                     loc name)))
+
+           (arity-mismatch
+            "report procedure arity mismatches (wrong number of arguments)"
+            ,(lambda (port loc name certain?)
+               (if certain?
+                   (emit port
+                         "~A_ warning_ wrong number of arguments to `~A'~%"
+                         loc name)
+                   (emit port
+                         "~A_ warning_ possibly wrong number of arguments to `~A'~%"
+                         loc name))))
+
+           (duplicate-case-datum
+            "report a duplicate datum in a case expression"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                     "~A_ warning_ duplicate datum ~S in clause ~S of case expression ~S~%"
+                     loc datum clause case-expr)))
+
+           (bad-case-datum
+            "report a case datum that cannot be meaningfully compared using `eqv?'"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                     "~A_ warning_ datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
+                     loc datum clause case-expr)))
+
+           (format
+            "report wrong number of arguments to `format'"
+            ,(lambda (port loc . rest)
+               (define (escape-newlines str)
+                 (list->string
+                  (string-fold-right (lambda (c r)
+                                       (if (eq? c #\newline)
+                                           (append '(#\\ #\n) r)
+                                           (cons c r)))
+                                     '()
+                                     str)))
+
+               (define (range min max)
+                 (cond ((eq? min 'any)
+                        (if (eq? max 'any)
+                            "any number" ;; can't happen
+                            (emit #f "up to ~a" max)))
+                       ((eq? max 'any)
+                        (emit #f "at least ~a" min))
+                       ((= min max) (number->string min))
+                       (else
+                        (emit #f "~a to ~a" min max))))
+
+               (match rest
+                 (('simple-format fmt opt)
+                  (emit port
+                        "~A_ warning_ ~S_ unsupported format option ~~~A, use (ice-9 format) instead~%"
+                        loc (escape-newlines fmt) opt))
+                 (('wrong-format-arg-count fmt min max actual)
+                  (emit port
+                        "~A_ warning_ ~S_ wrong number of `format' arguments_ expected ~A, got ~A~%"
+                        loc (escape-newlines fmt)
+                        (range min max) actual))
+                 (('syntax-error 'unterminated-iteration fmt)
+                  (emit port "~A_ warning_ ~S_ unterminated iteration~%"
+                        loc (escape-newlines fmt)))
+                 (('syntax-error 'unterminated-conditional fmt)
+                  (emit port "~A_ warning_ ~S_ unterminated conditional~%"
+                        loc (escape-newlines fmt)))
+                 (('syntax-error 'unexpected-semicolon fmt)
+                  (emit port "~A_ warning_ ~S_ unexpected `~~;'~%"
+                        loc (escape-newlines fmt)))
+                 (('syntax-error 'unexpected-conditional-termination fmt)
+                  (emit port "~A_ warning_ ~S_ unexpected `~~]'~%"
+                        loc (escape-newlines fmt)))
+                 (('wrong-port wrong-port)
+                  (emit port
+                        "~A_ warning_ ~S_ wrong port argument~%"
+                        loc wrong-port))
+                 (('wrong-format-string fmt)
+                  (emit port
+                        "~A_ warning_ ~S_ wrong format string~%"
+                        loc fmt))
+                 (('non-literal-format-string)
+                  (emit port
+                        "~A_ warning_ non-literal format string~%"
+                        loc))
+                 (('wrong-num-args count)
+                  (emit port
+                        "~A_ warning_ wrong number of arguments to `format'~%"
+                        loc))
+                 (else
+                  (emit port "~A_ `format' warning~%" loc)))))))))
+
+(define (lookup-warning-type name)
+  "Return the warning type NAME or `#f' if not found."
+  (find (lambda (wt)
+          (eq? name (warning-type-name wt)))
+        %warning-types))
+
+(define (warning type location . args)
+  "Emit a warning of type TYPE for source location LOCATION (a source
+property alist) using the data in ARGS."
+  (let ((wt   (lookup-warning-type type))
+        (port (current-warning-port)))
+    (if (warning-type? wt)
+        (apply (warning-type-printer wt)
+               port (location-string location)
+               args)
+        (format port "~A_ unknown warning type `~A'_ ~A~%"
+                (location-string location) type args))))
+
+;;; message.scm ends here
+;;; pmatch, a simple matcher
+
+;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
+;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
+;;; Copyright (C) 2007 Daniel P. Friedman
+;;;
+;;; 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
+
+;;; Originally written by Oleg Kiselyov for LeanTAP in Kanren, which is
+;;; available under the MIT license.
+;;;
+;;; http_//kanren.cvs.sourceforge.net/viewvc/kanren/kanren/mini/leanTAP.scm?view=log
+;;;
+;;; This version taken from_
+;;; αKanren_ A Fresh Name in Nominal Logic Programming
+;;; by William E. Byrd and Daniel P. Friedman
+;;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;;; Université Laval Technical Report DIUL-RT-0701
+
+;;; To be clear_ the original code is MIT-licensed, and the modifications
+;;; made to it by Guile are under Guile's license (currently LGPL v3+).
+
+;;; Code_
+
+(define-module (system base pmatch)
+  #\export-syntax (pmatch))
+
+(define-syntax-rule (pmatch e cs ...)
+  (let ((v e)) (pmatch1 v cs ...)))
+
+(define-syntax pmatch1
+  (syntax-rules (else guard)
+    ((_ v) (if #f #f))
+    ((_ v (else e0 e ...)) (let () e0 e ...))
+    ((_ v (pat (guard g ...) e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch1 v cs ...))))
+       (ppat v pat
+             (if (and g ...) (let () e0 e ...) (fk))
+             (fk))))
+    ((_ v (pat e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch1 v cs ...))))
+       (ppat v pat (let () e0 e ...) (fk))))))
+
+(define-syntax ppat
+  (syntax-rules (_ quote unquote)
+    ((_ v _ kt kf) kt)
+    ((_ v () kt kf) (if (null? v) kt kf))
+    ((_ v (quote lit) kt kf)
+     (if (equal? v (quote lit)) kt kf))
+    ((_ v (unquote var) kt kf) (let ((var v)) kt))
+    ((_ v (x . y) kt kf)
+     (if (pair? v)
+         (let ((vx (car v)) (vy (cdr v)))
+           (ppat vx x (ppat vy y kt kf) kf))
+         kf))
+    ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
+;;; Guile VM specific syntaxes and utilities
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code_
+
+(define-module (system base syntax)
+  #\export (%compute-initargs)
+  #\export-syntax (define-type define-record define-record/keywords
+                   record-case transform-record))
+
+(define (symbol-trim-both sym pred)
+  (string->symbol (string-trim-both (symbol->string sym) pred)))
+(define (trim-brackets sym)
+  (symbol-trim-both sym (list->char-set '(#\< #\>))))
+
+
+;;;
+;;; Type
+;;;
+
+(define-macro (define-type name . rest)
+  (let ((name (if (pair? name) (car name) name))
+        (opts (if (pair? name) (cdr name) '())))
+    (let ((printer (kw-arg-ref opts #\printer))
+          (common-slots (or (kw-arg-ref opts #\common-slots) '())))
+      `(begin ,@(map (lambda (def)
+                       `(define-record ,(if printer
+                                            `(,(car def) ,printer)
+                                            (car def))
+                          ,@common-slots
+                          ,@(cdr def)))
+                     rest)
+              ,@(map (lambda (common-slot i)
+                       `(define ,(symbol-append (trim-brackets name)
+                                                '- common-slot)
+                          (make-procedure-with-setter
+                           (lambda (x) (struct-ref x ,i))
+                           (lambda (x v) (struct-set! x ,i v)))))
+                     common-slots (iota (length common-slots)))))))
+
+
+;;;
+;;; Record
+;;;
+
+(define-macro (define-record name-form . slots)
+  (let* ((name (if (pair? name-form) (car name-form) name-form))
+         (printer (and (pair? name-form) (cadr name-form)))
+         (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+                          slots))
+         (stem (trim-brackets name)))
+    `(begin
+       (define ,name (make-record-type ,(symbol->string name) ',slot-names
+                                       ,@(if printer (list printer) '())))
+       ,(let* ((reqs (let lp ((slots slots))
+                       (if (or (null? slots) (not (symbol? (car slots))))
+                           '()
+                           (cons (car slots) (lp (cdr slots))))))
+               (opts (list-tail slots (length reqs)))
+               (tail (module-gensym "defrec")))
+          `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
+             (let ,(map (lambda (o)
+                          `(,(car o) (cond ((null? ,tail) ,(cadr o))
+                                           (else (let ((_x (car ,tail)))
+                                                   (set! ,tail (cdr ,tail))
+                                                   _x)))))
+                        opts)
+               (make-struct ,name 0 ,@slot-names))))
+       (define ,(symbol-append stem '?) (record-predicate ,name))
+       ,@(map (lambda (sname)
+                `(define ,(symbol-append stem '- sname)
+                   (make-procedure-with-setter
+                    (record-accessor ,name ',sname)
+                    (record-modifier ,name ',sname))))
+              slot-names))))
+
+;; like the former, but accepting keyword arguments in addition to
+;; optional arguments
+(define-macro (define-record/keywords name-form . slots)
+  (let* ((name (if (pair? name-form) (car name-form) name-form))
+         (printer (and (pair? name-form) (cadr name-form)))
+         (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+                          slots))
+         (stem (trim-brackets name)))
+    `(begin
+       (define ,name (make-record-type ,(symbol->string name) ',slot-names
+                                       ,@(if printer (list printer) '())))
+       (define ,(symbol-append 'make- stem)
+         (let ((slots (list ,@(map (lambda (slot)
+                                     (if (pair? slot)
+                                         `(cons ',(car slot) ,(cadr slot))
+                                         `',slot))
+                                   slots)))
+               (constructor (record-constructor ,name)))
+           (lambda args
+             (apply constructor (%compute-initargs args slots)))))
+       (define ,(symbol-append stem '?) (record-predicate ,name))
+       ,@(map (lambda (sname)
+                `(define ,(symbol-append stem '- sname)
+                   (make-procedure-with-setter
+                    (record-accessor ,name ',sname)
+                    (record-modifier ,name ',sname))))
+              slot-names))))
+
+(define (%compute-initargs args slots)
+  (define (finish out)
+    (map (lambda (slot)
+           (let ((name (if (pair? slot) (car slot) slot)))
+             (cond ((assq name out) => cdr)
+                   ((pair? slot) (cdr slot))
+                   (else (error "unbound slot" args slots name)))))
+         slots))
+  (let lp ((in args) (positional slots) (out '()))
+    (cond
+     ((null? in)
+      (finish out))
+     ((keyword? (car in))
+      (let ((sym (keyword->symbol (car in))))
+        (cond
+         ((and (not (memq sym slots))
+               (not (assq sym (filter pair? slots))))
+          (error "unknown slot" sym))
+         ((assq sym out) (error "slot already set" sym out))
+         (else (lp (cddr in) '() (acons sym (cadr in) out))))))
+     ((null? positional)
+      (error "too many initargs" args slots))
+     (else
+      (lp (cdr in) (cdr positional)
+          (let ((slot (car positional)))
+            (acons (if (pair? slot) (car slot) slot)
+                   (car in)
+                   out)))))))
+
+;; So, dear reader. It is pleasant indeed around this fire or at this
+;; cafe or in this room, is it not? I think so too.
+;;
+;; This macro used to generate code that looked like this_
+;;
+;;  `(((record-predicate ,record-type) ,r)
+;;    (let ,(map (lambda (slot)
+;;                 (if (pair? slot)
+;;                     `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+;;                     `(,slot ((record-accessor ,record-type ',slot) ,r))))
+;;               slots)
+;;      ,@body)))))
+;;
+;; But this was a hot spot, so computing all those predicates and
+;; accessors all the time was getting expensive, so we did a terrible
+;; thing_ we decided that since above we're already defining accessors
+;; and predicates with computed names, we might as well just rely on that fact here.
+;;
+;; It's a bit nasty, I agree. But it is fast.
+;;
+;;scheme@(guile-user)> (with-statprof #\hz 1000 #\full-stacks? #t (resolve-module '(oop goops)))%     cumulative   self             
+;; time   seconds     seconds      name
+;;   8.82      0.03      0.01  glil->assembly
+;;   8.82      0.01      0.01  record-type-fields
+;;   5.88      0.01      0.01  %compute-initargs
+;;   5.88      0.01      0.01  list-index
+
+
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+  (lambda (x)
+    (syntax-case x ()
+      ((_ record clause ...)
+       (let ((r (syntax r))
+             (rtd (syntax rtd)))
+         (define (process-clause tag fields exprs)
+           (let ((infix (trim-brackets (syntax->datum tag))))
+             (with-syntax ((tag tag)
+                           (((f . accessor) ...)
+                            (let lp ((fields fields))
+                              (syntax-case fields ()
+                                (() (syntax ()))
+                                (((v0 f0) f1 ...)
+                                 (acons (syntax v0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...)))))
+                                ((f0 f1 ...)
+                                 (acons (syntax f0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...))))))))
+                           ((e0 e1 ...)
+                            (syntax-case exprs ()
+                              (() (syntax (#t)))
+                              ((e0 e1 ...) (syntax (e0 e1 ...))))))
+               (syntax
+                ((eq? rtd tag)
+                 (let ((f (accessor r))
+                       ...)
+                   e0 e1 ...))))))
+         (with-syntax
+             ((r r)
+              (rtd rtd)
+              ((processed ...)
+               (let lp ((clauses (syntax (clause ...)))
+                        (out '()))
+                 (syntax-case clauses (else)
+                   (()
+                    (reverse! (cons (syntax
+                                     (else (error "unhandled record" r)))
+                                    out)))
+                   (((else e0 e1 ...))
+                    (reverse! (cons (syntax (else e0 e1 ...)) out)))
+                   (((else e0 e1 ...) . rest)
+                    (syntax-violation 'record-case
+                                      "bad else clause placement"
+                                      (syntax x)
+                                      (syntax (else e0 e1 ...))))
+                   ((((<foo> f0 ...) e0 ...) . rest)
+                    (lp (syntax rest)
+                        (cons (process-clause (syntax <foo>)
+                                              (syntax (f0 ...))
+                                              (syntax (e0 ...)))
+                              out)))))))
+           (syntax
+            (let* ((r record)
+                   (rtd (struct-vtable r)))
+              (cond processed ...)))))))))
+
+
+;; Here we take the terrorism to another level. Nasty, but the client
+;; code looks good.
+
+(define-macro (transform-record type-and-common record . clauses)
+  (let ((r (module-gensym "rec"))
+        (rtd (module-gensym "rtd"))
+        (type-stem (trim-brackets (car type-and-common))))
+    (define (make-stem s)
+      (symbol-append type-stem '- s))
+    (define (further-predicates x record-stem slots)
+      (define (access slot)
+        `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+      (let lp ((in slots) (out '()))
+        (cond ((null? in) out)
+              ((pair? (car in))
+               (let ((slot (caar in))
+                     (arg (cadar in)))
+                 (cond ((symbol? arg)
+                        (lp (cdr in) out))
+                       ((pair? arg)
+                        (lp (cdr in)
+                            (append (further-predicates (access slot)
+                                                        (car arg)
+                                                        (cdr arg))
+                                    out)))
+                       (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg)
+                                                out))))))
+              (else (lp (cdr in) out)))))
+    (define (let-clauses x record-stem slots)
+      (define (access slot)
+        `(,(symbol-append (make-stem record-stem) '- slot) ,x))
+      (let lp ((in slots) (out '()))
+        (cond ((null? in) out)
+              ((pair? (car in))
+               (let ((slot (caar in))
+                     (arg (cadar in)))
+                 (cond ((symbol? arg)
+                        (lp (cdr in)
+                            (cons `(,arg ,(access slot)) out)))
+                       ((pair? arg)
+                        (lp (cdr in)
+                            (append (let-clauses (access slot)
+                                                 (car arg)
+                                                 (cdr arg))
+                                    out)))
+                       (else
+                        (lp (cdr in) out)))))
+              (else
+               (lp (cdr in)
+                   (cons `(,(car in) ,(access (car in))) out))))))
+    (define (transform-expr x)
+      (cond ((not (pair? x)) x)
+            ((eq? (car x) '->)
+             (if (= (length x) 2)
+                 (let ((form (cadr x)))
+                   `(,(symbol-append 'make- (make-stem (car form)))
+                     ,@(cdr type-and-common)
+                     ,@(map (lambda (y)
+                              (if (and (pair? y) (eq? (car y) 'unquote))
+                                  (transform-expr (cadr y))
+                                  y))
+                            (cdr form))))
+                 (error "bad -> form" x)))
+            (else (cons (car x) (map transform-expr (cdr x))))))
+    (define (process-clause clause)
+      (if (eq? (car clause) 'else)
+          clause
+          (let ((stem (caar clause))
+                (slots (cdar clause))
+                (body (cdr clause)))
+            (let ((record-type (symbol-append '< (make-stem stem) '>)))
+              `((and (eq? ,rtd ,record-type)
+                     ,@(reverse (further-predicates r stem slots)))
+                (let ,(reverse (let-clauses r stem slots))
+                  ,@(if (pair? body)
+                        (map transform-expr body)
+                        '((if #f #f)))))))))
+    `(let* ((,r ,record)
+            (,rtd (struct-vtable ,r))
+            ,@(map (lambda (slot)
+                     `(,slot (,(make-stem slot) ,r)))
+                   (cdr type-and-common)))
+       (cond ,@(let ((clauses (map process-clause clauses)))
+                 (if (assq 'else clauses)
+                     clauses
+                     (append clauses `((else (error "unhandled record" ,r))))))))))
+;;; Compilation targets
+
+;; Copyright (C) 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
+
+;;; Code_
+
+(define-module (system base target)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 regex)
+  #\export (target-type with-target
+
+            target-cpu target-vendor target-os
+
+            target-endianness target-word-size))
+
+
+
+;;;
+;;; Target types
+;;;
+
+(define %native-word-size
+  ;; The native word size.  Note_ don't use `word-size' from
+  ;; (system vm objcode) to avoid a circular dependency.
+  ((@ (system foreign) sizeof) '*))
+
+(define %target-type (make-fluid %host-type))
+(define %target-endianness (make-fluid (native-endianness)))
+(define %target-word-size (make-fluid %native-word-size))
+
+(define (validate-target target)
+  (if (or (not (string? target))
+          (let ((parts (string-split target #\-)))
+            (or (< (length parts) 3)
+                (or-map string-null? parts))))
+      (error "invalid target" target)))
+
+(define (with-target target thunk)
+  (validate-target target)
+  (let ((cpu (triplet-cpu target)))
+    (with-fluids ((%target-type target)
+                  (%target-endianness (cpu-endianness cpu))
+                  (%target-word-size (triplet-pointer-size target)))
+      (thunk))))
+
+(define (cpu-endianness cpu)
+  "Return the endianness for CPU."
+  (if (string=? cpu (triplet-cpu %host-type))
+      (native-endianness)
+      (cond ((string-match "^i[0-9]86$" cpu)
+             (endianness little))
+            ((member cpu '("x86_64" "ia64"
+                           "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh3" "sh4" "alpha"))
+             (endianness little))
+            ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu"
+                           "mips" "mips64" "m68k" "s390x"))
+             (endianness big))
+            ((string-match "^arm.*el" cpu)
+             (endianness little))
+            ((string-match "^arm.*eb" cpu)
+             (endianness big))
+            ((string-prefix? "arm" cpu)          ;ARMs are LE by default
+             (endianness little))
+            ((string-match "^aarch64.*be" cpu)
+             (endianness big))
+            ((string=? "aarch64" cpu)
+             (endianness little))
+            (else
+             (error "unknown CPU endianness" cpu)))))
+
+(define (triplet-pointer-size triplet)
+  "Return the size of pointers in bytes for TRIPLET."
+  (let ((cpu (triplet-cpu triplet)))
+    (cond ((and (string=? cpu (triplet-cpu %host-type))
+                (string=? (triplet-os triplet) (triplet-os %host-type)))
+           %native-word-size)
+
+          ((string-match "^i[0-9]86$" cpu) 4)
+
+          ;; Although GNU config.guess doesn't yet recognize them,
+          ;; Debian (ab)uses the OS part to denote the specific ABI
+          ;; being used_ <http_//wiki.debian.org/Multiarch/Tuples>.
+          ;; See <http_//www.linux-mips.org/wiki/WhatsWrongWithO32N32N64>
+          ;; for details on the MIPS ABIs.
+          ((string-match "^mips64.*-gnuabi64" triplet) 8) ; n64 ABI
+          ((string-match "^mips64" cpu) 4)                ; n32 or o32
+
+          ((string-match "^x86_64-.*-gnux32" triplet) 4)  ; x32
+
+          ((string-match "64$" cpu) 8)
+          ((string-match "64_?[lbe][lbe]$" cpu) 8)
+          ((member cpu '("sparc" "powerpc" "mips" "mipsel" "nios2" "m68k" "sh3" "sh4")) 4)
+          ((member cpu '("s390x" "alpha")) 8)
+          ((string-match "^arm.*" cpu) 4)
+          (else (error "unknown CPU word size" cpu)))))
+
+(define (triplet-cpu t)
+  (substring t 0 (string-index t #\-)))
+
+(define (triplet-vendor t)
+  (let ((start (1+ (string-index t #\-))))
+    (substring t start (string-index t #\- start))))
+
+(define (triplet-os t)
+  (let ((start (1+ (string-index t #\- (1+ (string-index t #\-))))))
+    (substring t start)))
+
+
+(define (target-type)
+  "Return the GNU configuration triplet of the target platform."
+  (fluid-ref %target-type))
+
+(define (target-cpu)
+  "Return the CPU name of the target platform."
+  (triplet-cpu (target-type)))
+
+(define (target-vendor)
+  "Return the vendor name of the target platform."
+  (triplet-vendor (target-type)))
+
+(define (target-os)
+  "Return the operating system name of the target platform."
+  (triplet-os (target-type)))
+
+(define (target-endianness)
+  "Return the endianness object of the target platform."
+  (fluid-ref %target-endianness))
+
+(define (target-word-size)
+  "Return the word size, in bytes, of the target platform."
+  (fluid-ref %target-word-size))
+;;; 'SCM' type tag decoding.
+;;; Copyright (C) 2014, 2015 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 program.  If not, see <http_//www.gnu.org/licenses/>.
+
+(define-module (system base types)
+  #\use-module (rnrs bytevectors)
+  #\use-module (rnrs io ports)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\use-module (srfi srfi-60)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 iconv)
+  #\use-module (ice-9 format)
+  #\use-module (ice-9 vlist)
+  #\use-module (system foreign)
+  #\export (%word-size
+
+            memory-backend
+            memory-backend?
+            %ffi-memory-backend
+            dereference-word
+            memory-port
+            type-number->name
+
+            inferior-object?
+            inferior-object-kind
+            inferior-object-sub-kind
+            inferior-object-address
+
+            inferior-fluid?
+            inferior-fluid-number
+
+            inferior-struct?
+            inferior-struct-name
+            inferior-struct-fields
+
+            scm->object))
+
+;;; Commentary_
+;;;
+;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB.
+;;;
+;;; Code_
+
+
+;;;
+;;; Memory back-ends.
+;;;
+
+(define %word-size
+  ;; The pointer size.
+  (sizeof '*))
+
+(define-record-type <memory-backend>
+  (memory-backend peek open type-name)
+  memory-backend?
+  (peek      memory-backend-peek)
+  (open      memory-backend-open)
+  (type-name memory-backend-type-name))           ; for SMOBs and ports
+
+(define %ffi-memory-backend
+  ;; The FFI back-end to access the current process's memory.  The main
+  ;; purpose of this back-end is to allow testing.
+  (let ()
+    (define (dereference-word address)
+      (let* ((ptr (make-pointer address))
+             (bv  (pointer->bytevector ptr %word-size)))
+        (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
+
+    (define (open address size)
+      (define current-address address)
+
+      (define (read-memory! bv index count)
+        (let* ((ptr   (make-pointer current-address))
+               (mem   (pointer->bytevector ptr count)))
+          (bytevector-copy! mem 0 bv index count)
+          (set! current-address (+ current-address count))
+          count))
+
+      (if size
+          (let* ((ptr (make-pointer address))
+                 (bv  (pointer->bytevector ptr size)))
+            (open-bytevector-input-port bv))
+          (let ((port (make-custom-binary-input-port "ffi-memory"
+                                                     read-memory!
+                                                     #f #f #f)))
+            (setvbuf port _IONBF)
+            port)))
+
+    (memory-backend dereference-word open #f)))
+
+(define-inlinable (dereference-word backend address)
+  "Return the word at ADDRESS, using BACKEND."
+  (let ((peek (memory-backend-peek backend)))
+    (peek address)))
+
+(define-syntax memory-port
+  (syntax-rules ()
+    "Return an input port to the SIZE bytes at ADDRESS, using BACKEND.  When
+SIZE is omitted, return an unbounded port to the memory at ADDRESS."
+    ((_ backend address)
+     (let ((open (memory-backend-open backend)))
+       (open address #f)))
+    ((_ backend address size)
+     (if (zero? size)
+         ;; GDB's 'open-memory' raises an error when size
+         ;; is zero, so we must handle that case specially.
+         (open-bytevector-input-port '#vu8())
+         (let ((open (memory-backend-open backend)))
+           (open address size))))))
+
+(define (get-word port)
+  "Read a word from PORT and return it as an integer."
+  (let ((bv (get-bytevector-n port %word-size)))
+    (bytevector-uint-ref bv 0 (native-endianness) %word-size)))
+
+(define-inlinable (type-number->name backend kind number)
+  "Return the name of the type NUMBER of KIND, where KIND is one of
+'smob or 'port, or #f if the information is unavailable."
+  (let ((proc (memory-backend-type-name backend)))
+    (and proc (proc kind number))))
+
+
+;;;
+;;; Matching bit patterns and cells.
+;;;
+
+(define-syntax match-cell-words
+  (syntax-rules (bytevector)
+    ((_ port ((bytevector name len) rest ...) body)
+     (let ((name      (get-bytevector-n port len))
+           (remainder (modulo len %word-size)))
+       (unless (zero? remainder)
+         (get-bytevector-n port (- %word-size remainder)))
+       (match-cell-words port (rest ...) body)))
+    ((_ port (name rest ...) body)
+     (let ((name (get-word port)))
+       (match-cell-words port (rest ...) body)))
+    ((_ port () body)
+     body)))
+
+(define-syntax match-bit-pattern
+  (syntax-rules (& !! = _)
+    ((match-bit-pattern bits ((a !! b) & n = c) consequent alternate)
+     (let ((tag (logand bits n)))
+       (if (= tag c)
+           (let ((b tag)
+                 (a (logand bits (bitwise-not n))))
+             consequent)
+           alternate)))
+    ((match-bit-pattern bits (x & n = c) consequent alternate)
+     (let ((tag (logand bits n)))
+       (if (= tag c)
+           (let ((x bits))
+             consequent)
+           alternate)))
+    ((match-bit-pattern bits (_ & n = c) consequent alternate)
+     (let ((tag (logand bits n)))
+       (if (= tag c)
+           consequent
+           alternate)))
+    ((match-bit-pattern bits ((a << n) !! c) consequent alternate)
+     (let ((tag (bitwise-and bits (- (expt 2 n) 1))))
+       (if (= tag c)
+           (let ((a (arithmetic-shift bits (- n))))
+             consequent)
+           alternate)))))
+
+(define-syntax match-cell-clauses
+  (syntax-rules ()
+    ((_ port tag (((tag-pattern thing ...) body) rest ...))
+     (match-bit-pattern tag tag-pattern
+                        (match-cell-words port (thing ...) body)
+                        (match-cell-clauses port tag (rest ...))))
+    ((_ port tag ())
+     (inferior-object 'unmatched-tag tag))))
+
+(define-syntax match-cell
+  (syntax-rules ()
+    "Match a cell---i.e., a non-immediate value other than a pair.  The
+cell's contents are read from PORT."
+    ((_ port (pattern body ...) ...)
+     (let ((port* port)
+           (tag   (get-word port)))
+       (match-cell-clauses port* tag
+                           ((pattern (begin body ...))
+                            ...))))))
+
+(define-syntax match-scm-clauses
+  (syntax-rules ()
+    ((_ bits
+        (bit-pattern body ...)
+        rest ...)
+     (match-bit-pattern bits bit-pattern
+                        (begin body ...)
+                        (match-scm-clauses bits rest ...)))
+    ((_ bits)
+     'unmatched-scm)))
+
+(define-syntax match-scm
+  (syntax-rules ()
+    "Match BITS, an integer representation of an 'SCM' value, against
+CLAUSES.  Each clause must have the form_
+
+  (PATTERN BODY ...)
+
+PATTERN is a bit pattern that may specify bitwise operations on BITS to
+determine if it matches.  TEMPLATE specify the name of the variable to bind
+the matching bits, possibly with bitwise operations to extract it from BITS."
+    ((_ bits clauses ...)
+     (let ((bits* bits))
+       (match-scm-clauses bits* clauses ...)))))
+
+
+;;;
+;;; Tags---keep in sync with libguile/tags.h!
+;;;
+
+;; Immediate values.
+(define %tc2-int 2)
+(define %tc3-imm24 4)
+
+(define %tc3-cons 0)
+(define %tc3-int1 %tc2-int)
+(define %tc3-int2 (+ %tc2-int 4))
+
+(define %tc8-char (+ 8 %tc3-imm24))
+(define %tc8-flag (+ %tc3-imm24 0))
+
+;; Cell types.
+(define %tc3-struct 1)
+(define %tc7-symbol 5)
+(define %tc7-variable 7)
+(define %tc7-vector 13)
+(define %tc7-wvect 15)
+(define %tc7-string 21)
+(define %tc7-number 23)
+(define %tc7-hashtable 29)
+(define %tc7-pointer 31)
+(define %tc7-fluid 37)
+(define %tc7-stringbuf 39)
+(define %tc7-dynamic-state 45)
+(define %tc7-frame 47)
+(define %tc7-objcode 53)
+(define %tc7-vm 55)
+(define %tc7-vm-continuation 71)
+(define %tc7-bytevector 77)
+(define %tc7-program 79)
+(define %tc7-array 85)
+(define %tc7-bitvector 87)
+(define %tc7-port 125)
+(define %tc7-smob 127)
+
+(define %tc16-bignum (+ %tc7-number (* 1 256)))
+(define %tc16-real (+ %tc7-number (* 2 256)))
+(define %tc16-complex (+ %tc7-number (* 3 256)))
+(define %tc16-fraction (+ %tc7-number (* 4 256)))
+
+
+;; "Stringbufs".
+(define-record-type <stringbuf>
+  (stringbuf string)
+  stringbuf?
+  (string stringbuf-contents))
+
+(set-record-type-printer! <stringbuf>
+                          (lambda (stringbuf port)
+                            (display "#<stringbuf " port)
+                            (write (stringbuf-contents stringbuf) port)
+                            (display "#>" port)))
+
+;; Structs.
+(define-record-type <inferior-struct>
+  (inferior-struct name fields)
+  inferior-struct?
+  (name   inferior-struct-name)
+  (fields inferior-struct-fields set-inferior-struct-fields!))
+
+(define print-inferior-struct
+  (let ((%printed-struct (make-parameter vlist-null)))
+    (lambda (struct port)
+      (if (vhash-assq struct (%printed-struct))
+          (format port "#-1#")
+          (begin
+            (format port "#<struct ~a"
+                    (inferior-struct-name struct))
+            (parameterize ((%printed-struct
+                            (vhash-consq struct #t (%printed-struct))))
+              (for-each (lambda (field)
+                          (if (eq? field struct)
+                              (display " #0#" port)
+                              (format port " ~s" field)))
+                        (inferior-struct-fields struct)))
+            (format port " ~x>" (object-address struct)))))))
+
+(set-record-type-printer! <inferior-struct> print-inferior-struct)
+
+;; Fluids.
+(define-record-type <inferior-fluid>
+  (inferior-fluid number value)
+  inferior-fluid?
+  (number inferior-fluid-number)
+  (value  inferior-fluid-value))
+
+(set-record-type-printer! <inferior-fluid>
+                          (lambda (fluid port)
+                            (match fluid
+                              (($ <inferior-fluid> number)
+                               (format port "#<fluid ~a ~x>"
+                                       number
+                                       (object-address fluid))))))
+
+;; Object type to represent complex objects from the inferior process that
+;; cannot be really converted to usable Scheme objects in the current
+;; process.
+(define-record-type <inferior-object>
+  (%inferior-object kind sub-kind address)
+  inferior-object?
+  (kind     inferior-object-kind)
+  (sub-kind inferior-object-sub-kind)
+  (address  inferior-object-address))
+
+(define inferior-object
+  (case-lambda
+    "Return an object representing an inferior object at ADDRESS, of type
+KIND/SUB-KIND."
+    ((kind address)
+     (%inferior-object kind #f address))
+    ((kind sub-kind address)
+     (%inferior-object kind sub-kind address))))
+
+(set-record-type-printer! <inferior-object>
+                          (lambda (io port)
+                            (match io
+                              (($ <inferior-object> kind sub-kind address)
+                               (format port "#<~a ~_[~*~;~a ~]~x>"
+                                       kind sub-kind sub-kind
+                                       address)))))
+
+(define (inferior-smob backend type-number address)
+  "Return an object representing the SMOB at ADDRESS whose type is
+TYPE-NUMBER."
+  (inferior-object 'smob
+                   (or (type-number->name backend 'smob type-number)
+                       type-number)
+                   address))
+
+(define (inferior-port backend type-number address)
+  "Return an object representing the port at ADDRESS whose type is
+TYPE-NUMBER."
+  (inferior-object 'port
+                   (or (type-number->name backend 'port type-number)
+                       type-number)
+                   address))
+
+(define %visited-cells
+  ;; Vhash of mapping addresses of already visited cells to the
+  ;; corresponding inferior object.  This is used to detect and represent
+  ;; cycles.
+  (make-parameter vlist-null))
+
+(define-syntax visited
+  (syntax-rules (->)
+    ((_ (address -> object) body ...)
+     (parameterize ((%visited-cells (vhash-consv address object
+                                                 (%visited-cells))))
+       body ...))))
+
+(define (address->inferior-struct address vtable-data-address backend)
+  "Read the struct at ADDRESS using BACKEND.  Return an 'inferior-struct'
+object representing it."
+  (define %vtable-layout-index 0)
+  (define %vtable-name-index 5)
+
+  (let* ((layout-address (+ vtable-data-address
+                            (* %vtable-layout-index %word-size)))
+         (layout-bits    (dereference-word backend layout-address))
+         (layout         (scm->object layout-bits backend))
+         (name-address   (+ vtable-data-address
+                            (* %vtable-name-index %word-size)))
+         (name-bits      (dereference-word backend name-address))
+         (name           (scm->object name-bits backend)))
+    (if (symbol? layout)
+        (let* ((layout (symbol->string layout))
+               (len    (/ (string-length layout) 2))
+               (slots  (dereference-word backend (+ address %word-size)))
+               (port   (memory-port backend slots (* len %word-size)))
+               (fields (get-bytevector-n port (* len %word-size)))
+               (result (inferior-struct name #f)))
+
+          ;; Keep track of RESULT so callees can refer to it if we are
+          ;; decoding a circular struct.
+          (visited (address -> result)
+            (let ((values (map (cut scm->object <> backend)
+                               (bytevector->uint-list fields
+                                                      (native-endianness)
+                                                      %word-size))))
+              (set-inferior-struct-fields! result values)
+              result)))
+        (inferior-object 'invalid-struct address))))
+
+(define* (cell->object address #\optional (backend %ffi-memory-backend))
+  "Return an object representing the object at ADDRESS, reading from memory
+using BACKEND."
+  (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
+      (let ((port (memory-port backend address)))
+        (match-cell port
+          (((vtable-data-address & 7 = %tc3-struct))
+           (address->inferior-struct address
+                                     (- vtable-data-address %tc3-struct)
+                                     backend))
+          (((_ & #x7f = %tc7-symbol) buf hash props)
+           (match (cell->object buf backend)
+             (($ <stringbuf> string)
+              (string->symbol string))))
+          (((_ & #x7f = %tc7-variable) obj)
+           (inferior-object 'variable address))
+          (((_ & #x7f = %tc7-string) buf start len)
+           (match (cell->object buf backend)
+             (($ <stringbuf> string)
+              (substring string start (+ start len)))))
+          (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
+           (stringbuf (bytevector->string buf "ISO-8859-1")))
+          (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
+            len (bytevector buf (* 4 len)))
+           (stringbuf (bytevector->string buf (match (native-endianness)
+                                                ('little "UTF-32LE")
+                                                ('big "UTF-32BE")))))
+          (((_ & #x7f = %tc7-bytevector) len address)
+           (let ((bv-port (memory-port backend address len)))
+             (get-bytevector-n bv-port len)))
+          ((((len << 7) !! %tc7-vector) weakv-data)
+           (let* ((len    (arithmetic-shift len -1))
+                  (words  (get-bytevector-n port (* len %word-size)))
+                  (vector (make-vector len)))
+             (visited (address -> vector)
+               (fold (lambda (element index)
+                       (vector-set! vector index element)
+                       (+ 1 index))
+                     0
+                     (map (cut scm->object <> backend)
+                          (bytevector->uint-list words (native-endianness)
+                                                 %word-size)))
+               vector)))
+          (((_ & #x7f = %tc7-wvect))
+           (inferior-object 'weak-vector address))   ; TODO_ show elements
+          ((((n << 8) !! %tc7-fluid) init-value)
+           (inferior-fluid n #f))                    ; TODO_ show current value
+          (((_ & #x7f = %tc7-dynamic-state))
+           (inferior-object 'dynamic-state address))
+          ((((flags+type << 8) !! %tc7-port))
+           (inferior-port backend (logand flags+type #xff) address))
+          (((_ & #x7f = %tc7-program))
+           (inferior-object 'program address))
+          (((_ & #xffff = %tc16-bignum))
+           (inferior-object 'bignum address))
+          (((_ & #xffff = %tc16-real) pad)
+           (let* ((address (+ address (* 2 %word-size)))
+                  (port    (memory-port backend address (sizeof double)))
+                  (words   (get-bytevector-n port (sizeof double))))
+             (bytevector-ieee-double-ref words 0 (native-endianness))))
+          (((_ & #x7f = %tc7-number) mpi)
+           (inferior-object 'number address))
+          (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
+           (inferior-object 'hash-table address))
+          (((_ & #x7f = %tc7-pointer) address)
+           (make-pointer address))
+          (((_ & #x7f = %tc7-objcode))
+           (inferior-object 'objcode address))
+          (((_ & #x7f = %tc7-vm))
+           (inferior-object 'vm address))
+          (((_ & #x7f = %tc7-vm-continuation))
+           (inferior-object 'vm-continuation address))
+          (((_ & #x7f = %tc7-array))
+           (inferior-object 'array address))
+          (((_ & #x7f = %tc7-bitvector))
+           (inferior-object 'bitvector address))
+          ((((smob-type << 8) !! %tc7-smob) word1)
+           (inferior-smob backend smob-type address))))))
+
+
+(define* (scm->object bits #\optional (backend %ffi-memory-backend))
+  "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
+object."
+  (match-scm bits
+    (((integer << 2) !! %tc2-int)
+     integer)
+    ((address & 6 = %tc3-cons)
+     (let* ((type  (dereference-word backend address))
+            (pair? (not (bit-set? 0 type))))
+       (if pair?
+           (or (and=> (vhash-assv address (%visited-cells)) cdr)
+               (let ((car    type)
+                     (cdrloc (+ address %word-size))
+                     (pair   (cons *unspecified* *unspecified*)))
+                 (visited (address -> pair)
+                   (set-car! pair (scm->object car backend))
+                   (set-cdr! pair
+                             (scm->object (dereference-word backend cdrloc)
+                                          backend))
+                   pair)))
+           (cell->object address backend))))
+    (((char << 8) !! %tc8-char)
+     (integer->char char))
+    (((flag << 8) !! %tc8-flag)
+     (case flag
+       ((0)  #f)
+       ((1)  #nil)
+       ((3)  '())
+       ((4)  #t)
+       ((8)  (if #f #f))
+       ((9)  (inferior-object 'undefined bits))
+       ((10) (eof-object))
+       ((11) (inferior-object 'unbound bits))))))
+
+;;; Local Variables_
+;;; eval_ (put 'match-scm 'scheme-indent-function 1)
+;;; eval_ (put 'match-cell 'scheme-indent-function 1)
+;;; eval_ (put 'visited 'scheme-indent-function 1)
+;;; End_
+
+;;; types.scm ends here
+;;;; 	Copyright (C) 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 2.1 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 (system foreign)
+  #\use-module (rnrs bytevectors)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\export (void
+            float double
+            short
+            unsigned-short
+            int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
+            int8 uint8
+            uint16 int16
+            uint32 int32
+            uint64 int64
+
+            sizeof alignof
+
+            %null-pointer
+            null-pointer?
+            pointer?
+            make-pointer
+            pointer->scm
+            scm->pointer
+            pointer-address
+
+            pointer->bytevector
+            bytevector->pointer
+            set-pointer-finalizer!
+
+            dereference-pointer
+            string->pointer
+            pointer->string
+
+            pointer->procedure
+            ;; procedure->pointer (see below)
+            make-c-struct parse-c-struct
+
+            define-wrapped-pointer-type))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_foreign"))
+
+
+;;;
+;;; Pointers.
+;;;
+
+(define (null-pointer? pointer)
+  "Return true if POINTER is the null pointer."
+  (= (pointer-address pointer) 0))
+
+(if (defined? 'procedure->pointer)
+    (export procedure->pointer))
+
+
+;;;
+;;; Structures.
+;;;
+
+(define bytevector-pointer-ref
+  (case (sizeof '*)
+    ((8) (lambda (bv offset)
+           (make-pointer (bytevector-u64-native-ref bv offset))))
+    ((4) (lambda (bv offset)
+           (make-pointer (bytevector-u32-native-ref bv offset))))
+    (else (error "what machine is this?"))))
+
+(define bytevector-pointer-set!
+  (case (sizeof '*)
+    ((8) (lambda (bv offset ptr)
+           (bytevector-u64-native-set! bv offset (pointer-address ptr))))
+    ((4) (lambda (bv offset ptr)
+           (bytevector-u32-native-set! bv offset (pointer-address ptr))))
+    (else (error "what machine is this?"))))
+
+(define *writers*
+  `((,float . ,bytevector-ieee-single-native-set!)
+    (,double . ,bytevector-ieee-double-native-set!)
+    (,int8 . ,bytevector-s8-set!)
+    (,uint8 . ,bytevector-u8-set!)
+    (,int16 . ,bytevector-s16-native-set!)
+    (,uint16 . ,bytevector-u16-native-set!)
+    (,int32 . ,bytevector-s32-native-set!)
+    (,uint32 . ,bytevector-u32-native-set!)
+    (,int64 . ,bytevector-s64-native-set!)
+    (,uint64 . ,bytevector-u64-native-set!)
+    (* . ,bytevector-pointer-set!)))
+
+(define *readers*
+  `((,float . ,bytevector-ieee-single-native-ref)
+    (,double . ,bytevector-ieee-double-native-ref)
+    (,int8 . ,bytevector-s8-ref)
+    (,uint8 . ,bytevector-u8-ref)
+    (,int16 . ,bytevector-s16-native-ref)
+    (,uint16 . ,bytevector-u16-native-ref)
+    (,int32 . ,bytevector-s32-native-ref)
+    (,uint32 . ,bytevector-u32-native-ref)
+    (,int64 . ,bytevector-s64-native-ref)
+    (,uint64 . ,bytevector-u64-native-ref)
+    (* . ,bytevector-pointer-ref)))
+
+
+(define (align off alignment)
+  (1+ (logior (1- off) (1- alignment))))
+
+(define (write-c-struct bv offset types vals)
+  (let lp ((offset offset) (types types) (vals vals))
+    (cond
+     ((not (pair? types))
+      (or (null? vals)
+          (error "too many values" vals)))
+     ((not (pair? vals))
+      (error "too few values" types))
+     (else
+      ;; alignof will error-check
+      (let* ((type (car types))
+             (offset (align offset (alignof type))))
+        (if (pair? type)
+            (write-c-struct bv offset (car types) (car vals))
+            ((assv-ref *writers* type) bv offset (car vals)))
+        (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
+
+(define (read-c-struct bv offset types)
+  (let lp ((offset offset) (types types) (vals '()))
+    (cond
+     ((not (pair? types))
+      (reverse vals))
+     (else
+      ;; alignof will error-check
+      (let* ((type (car types))
+             (offset (align offset (alignof type))))
+        (lp (+ offset (sizeof type)) (cdr types)
+            (cons (if (pair? type)
+                      (read-c-struct bv offset (car types))
+                      ((assv-ref *readers* type) bv offset))
+                  vals)))))))
+
+(define (make-c-struct types vals)
+  (let ((bv (make-bytevector (sizeof types) 0)))
+    (write-c-struct bv 0 types vals)
+    (bytevector->pointer bv)))
+
+(define (parse-c-struct foreign types)
+  (let ((size (fold (lambda (type total)
+                      (+ (sizeof type)
+                         (align total (alignof type))))
+                    0
+                    types)))
+    (read-c-struct (pointer->bytevector foreign size) 0 types)))
+
+
+;;;
+;;; Wrapped pointer types.
+;;;
+
+(define-syntax define-wrapped-pointer-type
+  (lambda (stx)
+    "Define helper procedures to wrap pointer objects into Scheme
+objects with a disjoint type.  Specifically, this macro defines PRED, a
+predicate for the new Scheme type, WRAP, a procedure that takes a
+pointer object and returns an object that satisfies PRED, and UNWRAP
+which does the reverse.  PRINT must name a user-defined object printer."
+    (syntax-case stx ()
+      ((_ type-name pred wrap unwrap print)
+       (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
+         #'(begin
+             (define-record-type type-name
+               (%wrap pointer)
+               pred
+               (pointer unwrap))
+             (define wrap
+               ;; Use a weak hash table to preserve pointer identity, i.e.,
+               ;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
+               (let ((ptr->obj (make-weak-value-hash-table 3000)))
+                 (lambda (ptr)
+                   ;; XXX_ We can't use `hash-create-handle!' +
+                   ;; `set-cdr!' here because the former would create a
+                   ;; weak-cdr pair but the latter wouldn't register a
+                   ;; disappearing link (see `scm_hash_fn_set_x'.)
+                   (or (hash-ref ptr->obj ptr)
+                       (let ((o (%wrap ptr)))
+                         (hash-set! ptr->obj ptr o)
+                         o)))))
+             (set-record-type-printer! type-name print)))))))
+;;; Repl commands
+
+;; Copyright (C) 2001, 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
+
+;;; Code_
+
+(define-module (system repl command)
+  #\use-module (system base syntax)
+  #\use-module (system base pmatch)
+  #\use-module (system base compile)
+  #\use-module (system repl common)
+  #\use-module (system repl debug)
+  #\use-module (system vm objcode)
+  #\use-module (system vm program)
+  #\use-module (system vm trap-state)
+  #\use-module (system vm vm)
+  #\use-module ((system vm frame) #\select (frame-return-values))
+  #\autoload (system base language) (lookup-language language-reader)
+  #\autoload (system vm trace) (call-with-trace)
+  #\use-module (ice-9 format)
+  #\use-module (ice-9 session)
+  #\use-module (ice-9 documentation)
+  #\use-module (ice-9 and-let-star)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 control)
+  #\use-module ((ice-9 pretty-print) #\select ((pretty-print . pp)))
+  #\use-module ((system vm inspect) #\select ((inspect . %inspect)))
+  #\use-module (statprof)
+  #\export (meta-command define-meta-command))
+
+
+;;;
+;;; Meta command interface
+;;;
+
+(define *command-table*
+  '((help     (help h) (show) (apropos a) (describe d))
+    (module   (module m) (import use) (load l) (reload re) (binding b) (in))
+    (language (language L))
+    (compile  (compile c) (compile-file cc)
+              (expand exp) (optimize opt)
+	      (disassemble x) (disassemble-file xx))
+    (profile  (time t) (profile pr) (trace tr))
+    (debug    (backtrace bt) (up) (down) (frame fr)
+              (procedure proc) (locals) (error-message error)
+              (break br bp) (break-at-source break-at bs)
+              (step s) (step-instruction si)
+              (next n) (next-instruction ni)
+              (finish)
+              (tracepoint tp)
+              (traps) (delete del) (disable) (enable)
+              (registers regs))
+    (inspect  (inspect i) (pretty-print pp))
+    (system   (gc) (statistics stat) (option o)
+              (quit q continue cont))))
+
+(define *show-table*
+  '((show (warranty w) (copying c) (version v))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+(define *command-infos* (make-hash-table))
+(define (command-name c) (car c))
+(define (command-abbrevs c) (cdr c))
+(define (command-info c) (hashq-ref *command-infos* (command-name c)))
+(define (command-procedure c) (command-info-procedure (command-info c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (make-command-info proc arguments-reader)
+  (cons proc arguments-reader))
+
+(define (command-info-procedure info)
+  (car info))
+
+(define (command-info-arguments-reader info)
+  (cdr info))
+
+(define (command-usage c)
+  (let ((doc (command-doc c)))
+    (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+  (let* ((doc (command-doc c))
+	 (start (1+ (string-index doc #\newline))))
+    (cond ((string-index doc #\newline start)
+	   => (lambda (end) (substring doc start end)))
+	  (else (substring doc start)))))
+
+(define (lookup-group name)
+  (assq name *command-table*))
+
+(define* (lookup-command key #\optional (table *command-table*))
+  (let loop ((groups table) (commands '()))
+    (cond ((and (null? groups) (null? commands)) #f)
+	  ((null? commands)
+	   (loop (cdr groups) (cdar groups)))
+	  ((memq key (car commands)) (car commands))
+	  (else (loop groups (cdr commands))))))
+
+(define* (display-group group #\optional (abbrev? #t))
+  (format #t "~_(~A~) Commands~_[~; [abbrev]~]_~2%" (group-name group) abbrev?)
+  (for-each (lambda (c)
+	      (display-summary (command-usage c)
+			       (if abbrev? (command-abbrevs c) '())
+			       (command-summary c)))
+	    (group-commands group))
+  (newline))
+
+(define (display-command command)
+  (display "Usage_ ")
+  (display (command-doc command))
+  (newline))
+
+(define (display-summary usage abbrevs summary)
+  (let* ((usage-len (string-length usage))
+         (abbrevs (if (pair? abbrevs)
+                      (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
+                      ""))
+         (abbrevs-len (string-length abbrevs)))
+    (format #t " ,~A~A~A - ~A\n"
+            usage
+            (cond
+             ((> abbrevs-len 32)
+              (error "abbrevs too long" abbrevs))
+             ((> (+ usage-len abbrevs-len) 32)
+              (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
+             (else
+              (format #f "~v_" (- 32 abbrevs-len usage-len))))
+            abbrevs
+            summary)))
+
+(define (read-command repl)
+  (catch #t
+    (lambda () (read))
+    (lambda (key . args)
+      (pmatch args
+        ((,subr ,msg ,args . ,rest)
+         (format #t "Throw to key `~a' while reading command_\n" key)
+         (display-error #f (current-output-port) subr msg args rest))
+        (else
+         (format #t "Throw to key `~a' with args `~s' while reading command.\n"
+                 key args)))
+      (force-output)
+      *unspecified*)))
+
+(define (read-command-arguments c repl)
+  ((command-info-arguments-reader (command-info c)) repl))
+
+(define (meta-command repl)
+  (let ((command (read-command repl)))
+    (cond
+     ((eq? command *unspecified*)) ; read error, already signalled; pass.
+     ((not (symbol? command))
+      (format #t "Meta-command not a symbol_ ~s~%" command))
+     ((lookup-command command)
+      => (lambda (c)
+           (and=> (read-command-arguments c repl)
+                  (lambda (args) (apply (command-procedure c) repl args)))))
+     (else
+      (format #t "Unknown meta command_ ~A~%" command)))))
+
+(define (add-meta-command! name category proc argument-reader)
+  (hashq-set! *command-infos* name (make-command-info proc argument-reader))
+  (if category
+      (let ((entry (assq category *command-table*)))
+        (if entry
+            (set-cdr! entry (append (cdr entry) (list (list name))))
+            (set! *command-table*
+                  (append *command-table*
+                          (list (list category (list name)))))))))
+
+(define-syntax define-meta-command
+  (syntax-rules ()
+    ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...)
+     (add-meta-command!
+      'name
+      'category
+      (lambda* (repl expression0 ... . datums)
+        docstring
+        b0 b1 ...)
+      (lambda (repl)
+        (define (handle-read-error form-name key args)
+          (pmatch args
+            ((,subr ,msg ,args . ,rest)
+             (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A'_\n"
+                     key form-name 'name)
+             (display-error #f (current-output-port) subr msg args rest))
+            (else
+             (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
+                     key args form-name 'name)))
+          (abort))
+        (% (let* ((expression0
+                   (catch #t
+                          (lambda ()
+                            (repl-reader
+                             ""
+                             (lambda* (#\optional (port (current-input-port)))
+                               ((language-reader (repl-language repl))
+                                port (current-module)))))
+                          (lambda (k . args)
+                            (handle-read-error 'expression0 k args))))
+                  ...)
+             (append
+              (list expression0 ...)
+              (catch #t
+                     (lambda ()
+                       (let ((port (open-input-string (read-line))))
+                         (let lp ((out '()))
+                           (let ((x (read port)))
+                             (if (eof-object? x)
+                                 (reverse out)
+                                 (lp (cons x out)))))))
+                     (lambda (k . args)
+                       (handle-read-error #f k args)))))
+           (lambda (k) #f)))))           ; the abort handler
+
+    ((_ ((name category) repl . datums) docstring b0 b1 ...)
+     (define-meta-command ((name category) repl () . datums)
+       docstring b0 b1 ...))
+
+    ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
+     (define-meta-command ((name #f) repl (expression0 ...) . datums)
+       docstring b0 b1 ...))
+
+    ((_ (name repl . datums) docstring b0 b1 ...)
+     (define-meta-command ((name #f) repl () . datums)
+       docstring b0 b1 ...))))
+
+
+
+;;;
+;;; Help commands
+;;;
+
+(define-meta-command (help repl . args)
+  "help [all | GROUP | [-c] COMMAND]
+Show help.
+
+With one argument, tries to look up the argument as a group name, giving
+help on that group if successful. Otherwise tries to look up the
+argument as a command, giving help on the command.
+
+If there is a command whose name is also a group name, use the ,help
+-c COMMAND form to give help on the command instead of the group.
+
+Without any argument, a list of help commands and command groups
+are displayed."
+  (pmatch args
+    (()
+     (display-group (lookup-group 'help))
+     (display "Command Groups_\n\n")
+     (display-summary "help all" #f "List all commands")
+     (for-each (lambda (g)
+		 (let* ((name (symbol->string (group-name g)))
+			(usage (string-append "help " name))
+			(header (string-append "List " name " commands")))
+		   (display-summary usage #f header)))
+	       (cdr *command-table*))
+     (newline)
+     (display
+      "Type `,help -c COMMAND' to show documentation of a particular command.")
+     (newline))
+    ((all)
+     (for-each display-group *command-table*))
+    ((,group) (guard (lookup-group group))
+     (display-group (lookup-group group)))
+    ((,command) (guard (lookup-command command))
+     (display-command (lookup-command command)))
+    ((-c ,command) (guard (lookup-command command))
+     (display-command (lookup-command command)))
+    ((,command)
+     (format #t "Unknown command or group_ ~A~%" command))
+    ((-c ,command)
+     (format #t "Unknown command_ ~A~%" command))
+    (else
+     (format #t "Bad arguments_ ~A~%" args))))
+
+(define-meta-command (show repl . args)
+  "show [TOPIC]
+Gives information about Guile.
+
+With one argument, tries to show a particular piece of information;
+
+currently supported topics are `warranty' (or `w'), `copying' (or `c'),
+and `version' (or `v').
+
+Without any argument, a list of topics is displayed."
+  (pmatch args
+    (()
+     (display-group (car *show-table*) #f)
+     (newline))
+    ((,topic) (guard (lookup-command topic *show-table*))
+     ((command-procedure (lookup-command topic *show-table*)) repl))
+    ((,command)
+     (format #t "Unknown topic_ ~A~%" command))
+    (else
+     (format #t "Bad arguments_ ~A~%" args))))
+
+;;; `warranty', `copying' and `version' are "hidden" meta-commands, only
+;;; accessible via `show'. They have an entry in *command-infos* but not
+;;; in *command-table*.
+
+(define-meta-command (warranty repl)
+  "show warranty
+Details on the lack of warranty."
+  (display *warranty*)
+  (newline))
+
+(define-meta-command (copying repl)
+  "show copying
+Show the LGPLv3."
+  (display *copying*)
+  (newline))
+
+(define-meta-command (version repl)
+  "show version
+Version information."
+  (display *version*)
+  (newline))
+
+(define-meta-command (apropos repl regexp)
+  "apropos REGEXP
+Find bindings/modules/packages."
+  (apropos (->string regexp)))
+
+(define-meta-command (describe repl (form))
+  "describe OBJ
+Show description/documentation."
+  (display
+    (object-documentation
+      (let ((input (repl-parse repl form)))
+        (if (symbol? input)
+            (module-ref (current-module) input)
+            (repl-eval repl input)))))
+  (newline))
+
+(define-meta-command (option repl . args)
+  "option [NAME] [EXP]
+List/show/set options."
+  (pmatch args
+    (()
+     (for-each (lambda (spec)
+		 (format #t "  ~A~24t~A\n" (car spec) (cadr spec)))
+	       (repl-options repl)))
+    ((,name)
+     (display (repl-option-ref repl name))
+     (newline))
+    ((,name ,exp)
+     ;; Would be nice to evaluate in the current language, but the REPL
+     ;; option parser doesn't permit that, currently.
+     (repl-option-set! repl name (eval exp (current-module))))))
+
+(define-meta-command (quit repl)
+  "quit
+Quit this session."
+  (throw 'quit))
+
+
+;;;
+;;; Module commands
+;;;
+
+(define-meta-command (module repl . args)
+  "module [MODULE]
+Change modules / Show current module."
+  (pmatch args
+    (() (puts (module-name (current-module))))
+    ((,mod-name) (guard (list? mod-name))
+     (set-current-module (resolve-module mod-name)))
+    (,mod-name (set-current-module (resolve-module mod-name)))))
+
+(define-meta-command (import repl . args)
+  "import [MODULE ...]
+Import modules / List those imported."
+  (let ()
+    (define (use name)
+      (let ((mod (resolve-interface name)))
+        (if mod
+            (module-use! (current-module) mod)
+            (format #t "No such module_ ~A~%" name))))
+    (if (null? args)
+        (for-each puts (map module-name (module-uses (current-module))))
+        (for-each use args))))
+
+(define-meta-command (load repl file)
+  "load FILE
+Load a file in the current module."
+  (load (->string file)))
+
+(define-meta-command (reload repl . args)
+  "reload [MODULE]
+Reload the given module, or the current module if none was given."
+  (pmatch args
+    (() (reload-module (current-module)))
+    ((,mod-name) (guard (list? mod-name))
+     (reload-module (resolve-module mod-name)))
+    (,mod-name (reload-module (resolve-module mod-name)))))
+
+(define-meta-command (binding repl)
+  "binding
+List current bindings."
+  (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
+                   (current-module)))
+
+(define-meta-command (in repl module command-or-expression . args)
+  "in MODULE COMMAND-OR-EXPRESSION
+Evaluate an expression or command in the context of module."
+  (let ((m (resolve-module module #\ensure #f)))
+    (if m
+        (pmatch command-or-expression
+          (('unquote ,command) (guard (lookup-command command))
+           (save-module-excursion
+            (lambda ()
+              (set-current-module m)
+              (apply (command-procedure (lookup-command command)) repl args))))
+          (,expression
+           (guard (null? args))
+           (repl-print repl (eval expression m)))
+          (else
+           (format #t "Invalid arguments to `in'_ expected a single expression or a command.\n")))
+        (format #t "No such module_ ~s\n" module))))
+
+
+;;;
+;;; Language commands
+;;;
+
+(define-meta-command (language repl name)
+  "language LANGUAGE
+Change languages."
+  (let ((lang (lookup-language name))
+        (cur (repl-language repl)))
+    (format #t "Happy hacking with ~a!  To switch back, type `,L ~a'.\n"
+            (language-title lang) (language-name cur))
+    (current-language lang)
+    (set! (repl-language repl) lang)))
+
+
+;;;
+;;; Compile commands
+;;;
+
+(define-meta-command (compile repl (form))
+  "compile EXP
+Generate compiled code."
+  (let ((x (repl-compile repl (repl-parse repl form))))
+    (cond ((objcode? x) (guile_disassemble x))
+          (else (repl-print repl x)))))
+
+(define-meta-command (compile-file repl file . opts)
+  "compile-file FILE
+Compile a file."
+  (compile-file (->string file) #\opts opts))
+
+(define-meta-command (expand repl (form))
+  "expand EXP
+Expand any macros in a form."
+  (let ((x (repl-expand repl (repl-parse repl form))))
+    (run-hook before-print-hook x)
+    (pp x)))
+
+(define-meta-command (optimize repl (form))
+  "optimize EXP
+Run the optimizer on a piece of code and print the result."
+  (let ((x (repl-optimize repl (repl-parse repl form))))
+    (run-hook before-print-hook x)
+    (pp x)))
+
+(define (guile_disassemble x)
+  ((@ (language assembly disassemble) disassemble) x))
+
+(define-meta-command (disassemble repl (form))
+  "disassemble EXP
+Disassemble a compiled procedure."
+  (let ((obj (repl-eval repl (repl-parse repl form))))
+    (if (or (program? obj) (objcode? obj))
+        (guile_disassemble obj)
+        (format #t "Argument to ,disassemble not a procedure or objcode_ ~a~%"
+                obj))))
+
+(define-meta-command (disassemble-file repl file)
+  "disassemble-file FILE
+Disassemble a file."
+  (guile_disassemble (load-objcode (->string file))))
+
+
+;;;
+;;; Profile commands
+;;;
+
+(define-meta-command (time repl (form))
+  "time EXP
+Time execution."
+  (let* ((gc-start (gc-run-time))
+	 (real-start (get-internal-real-time))
+	 (run-start (get-internal-run-time))
+	 (result (repl-eval repl (repl-parse repl form)))
+	 (run-end (get-internal-run-time))
+	 (real-end (get-internal-real-time))
+	 (gc-end (gc-run-time)))
+    (define (diff start end)
+      (/ (- end start) 1.0 internal-time-units-per-second))
+    (repl-print repl result)
+    (format #t ";; ~,6Fs real time, ~,6Fs run time.  ~,6Fs spent in GC.\n"
+            (diff real-start real-end)
+            (diff run-start run-end)
+            (diff gc-start gc-end))
+    result))
+
+(define-meta-command (profile repl (form) . opts)
+  "profile EXP
+Profile execution."
+  ;; FIXME opts
+  (apply statprof
+         (repl-prepare-eval-thunk repl (repl-parse repl form))
+         opts))
+
+(define-meta-command (trace repl (form) . opts)
+  "trace EXP
+Trace execution."
+  ;; FIXME_ doc options, or somehow deal with them better
+  (apply call-with-trace
+         (repl-prepare-eval-thunk repl (repl-parse repl form))
+         (cons* #\width (terminal-width) opts)))
+
+
+;;;
+;;; Debug commands
+;;;
+
+(define-syntax define-stack-command
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (name repl . args) docstring body body* ...)
+       #`(define-meta-command (name repl . args)
+           docstring
+           (let ((debug (repl-debug repl)))
+             (if debug
+                 (letrec-syntax
+                     ((#,(datum->syntax #'repl 'frames)
+                       (identifier-syntax (debug-frames debug)))
+                      (#,(datum->syntax #'repl 'message)
+                       (identifier-syntax (debug-error-message debug)))
+                      (#,(datum->syntax #'repl 'for-trap?)
+                       (identifier-syntax (debug-for-trap? debug)))
+                      (#,(datum->syntax #'repl 'index)
+                       (identifier-syntax
+                        (id (debug-index debug))
+                        ((set! id exp) (set! (debug-index debug) exp))))
+                      (#,(datum->syntax #'repl 'cur)
+                       (identifier-syntax
+                        (vector-ref #,(datum->syntax #'repl 'frames)
+                                    #,(datum->syntax #'repl 'index)))))
+                   body body* ...)
+                 (format #t "Nothing to debug.~%"))))))))
+
+(define-stack-command (backtrace repl #\optional count
+                                 #\key (width (terminal-width)) full?)
+  "backtrace [COUNT] [#:width W] [#full? F]
+Print a backtrace.
+
+Print a backtrace of all stack frames, or innermost COUNT frames.
+If COUNT is negative, the last COUNT frames will be shown."
+  (print-frames frames
+                #\count count
+                #\width width
+                #\full? full?
+                #\for-trap? for-trap?))
+
+(define-stack-command (up repl #\optional (count 1))
+  "up [COUNT]
+Select a calling stack frame.
+
+Select and print stack frames that called this one.
+An argument says how many frames up to go."
+  (cond
+   ((or (not (integer? count)) (<= count 0))
+    (format #t "Invalid argument to `up'_ expected a positive integer for COUNT.~%"))
+   ((>= (+ count index) (vector-length frames))
+    (cond
+     ((= index (1- (vector-length frames)))
+      (format #t "Already at outermost frame.\n"))
+     (else
+      (set! index (1- (vector-length frames)))
+      (print-frame cur #\index index
+                   #\next-source? (and (zero? index) for-trap?)))))
+   (else
+    (set! index (+ count index))
+    (print-frame cur #\index index
+                 #\next-source? (and (zero? index) for-trap?)))))
+
+(define-stack-command (down repl #\optional (count 1))
+  "down [COUNT]
+Select a called stack frame.
+
+Select and print stack frames called by this one.
+An argument says how many frames down to go."
+  (cond
+   ((or (not (integer? count)) (<= count 0))
+    (format #t "Invalid argument to `down'_ expected a positive integer for COUNT.~%"))
+   ((< (- index count) 0)
+    (cond
+     ((zero? index)
+      (format #t "Already at innermost frame.\n"))
+     (else
+      (set! index 0)
+      (print-frame cur #\index index #\next-source? for-trap?))))
+   (else
+    (set! index (- index count))
+    (print-frame cur #\index index
+                 #\next-source? (and (zero? index) for-trap?)))))
+
+(define-stack-command (frame repl #\optional idx)
+  "frame [IDX]
+Show a frame.
+
+Show the selected frame.
+With an argument, select a frame by index, then show it."
+  (cond
+   (idx
+    (cond
+     ((or (not (integer? idx)) (< idx 0))
+      (format #t "Invalid argument to `frame'_ expected a non-negative integer for IDX.~%"))
+     ((< idx (vector-length frames))
+      (set! index idx)
+      (print-frame cur #\index index
+                   #\next-source? (and (zero? index) for-trap?)))
+     (else
+      (format #t "No such frame.~%"))))
+   (else (print-frame cur #\index index
+                      #\next-source? (and (zero? index) for-trap?)))))
+
+(define-stack-command (procedure repl)
+  "procedure
+Print the procedure for the selected frame."
+  (repl-print repl (frame-procedure cur)))
+
+(define-stack-command (locals repl #\key (width (terminal-width)))
+  "locals
+Show local variables.
+
+Show locally-bound variables in the selected frame."
+  (print-locals cur #\width width))
+
+(define-stack-command (error-message repl)
+  "error-message
+Show error message.
+
+Display the message associated with the error that started the current
+debugging REPL."
+  (format #t "~a~%" (if (string? message) message "No error message")))
+
+(define-meta-command (break repl (form))
+  "break PROCEDURE
+Break on calls to PROCEDURE.
+
+Starts a recursive prompt when PROCEDURE is called."
+  (let ((proc (repl-eval repl (repl-parse repl form))))
+    (if (not (procedure? proc))
+        (error "Not a procedure_ ~a" proc)
+        (let ((idx (add-trap-at-procedure-call! proc)))
+          (format #t "Trap ~a_ ~a.~%" idx (trap-name idx))))))
+
+(define-meta-command (break-at-source repl file line)
+  "break-at-source FILE LINE
+Break when control reaches the given source location.
+
+Starts a recursive prompt when control reaches line LINE of file FILE.
+Note that the given source location must be inside a procedure."
+  (let ((file (if (symbol? file) (symbol->string file) file)))
+    (let ((idx (add-trap-at-source-location! file line)))
+      (format #t "Trap ~a_ ~a.~%" idx (trap-name idx)))))
+
+(define (repl-pop-continuation-resumer repl msg)
+  ;; Capture the dynamic environment with this prompt thing. The
+  ;; result is a procedure that takes a frame.
+  (% (call-with-values
+         (lambda ()
+           (abort
+            (lambda (k)
+              ;; Call frame->stack-vector before reinstating the
+              ;; continuation, so that we catch the %stacks fluid at
+              ;; the time of capture.
+              (lambda (frame)
+                (k frame
+                   (frame->stack-vector
+                    (frame-previous frame)))))))
+       (lambda (from stack)
+         (format #t "~a~%" msg)
+         (let ((vals (frame-return-values from)))
+           (if (null? vals)
+               (format #t "No return values.~%")
+               (begin
+                 (format #t "Return values_~%")
+                 (for-each (lambda (x) (repl-print repl x)) vals))))
+         ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
+          #\debug (make-debug stack 0 msg #t))))))
+
+(define-stack-command (finish repl)
+  "finish
+Run until the current frame finishes.
+
+Resume execution, breaking when the current frame finishes."
+  (let ((handler (repl-pop-continuation-resumer
+                  repl (format #f "Return from ~a" cur))))
+    (add-ephemeral-trap-at-frame-finish! cur handler)
+    (throw 'quit)))
+
+(define (repl-next-resumer msg)
+  ;; Capture the dynamic environment with this prompt thing. The
+  ;; result is a procedure that takes a frame.
+  (% (let ((stack (abort
+                   (lambda (k)
+                     ;; Call frame->stack-vector before reinstating the
+                     ;; continuation, so that we catch the %stacks fluid
+                     ;; at the time of capture.
+                     (lambda (frame)
+                       (k (frame->stack-vector frame)))))))
+       (format #t "~a~%" msg)
+       ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
+        #\debug (make-debug stack 0 msg #t)))))
+
+(define-stack-command (step repl)
+  "step
+Step until control reaches a different source location.
+
+Step until control reaches a different source location."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #\into? #t #\instruction? #f)
+    (throw 'quit)))
+
+(define-stack-command (step-instruction repl)
+  "step-instruction
+Step until control reaches a different instruction.
+
+Step until control reaches a different VM instruction."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #\into? #t #\instruction? #t)
+    (throw 'quit)))
+
+(define-stack-command (next repl)
+  "next
+Step until control reaches a different source location in the current frame.
+
+Step until control reaches a different source location in the current frame."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #\into? #f #\instruction? #f)
+    (throw 'quit)))
+
+(define-stack-command (next-instruction repl)
+  "next-instruction
+Step until control reaches a different instruction in the current frame.
+
+Step until control reaches a different VM instruction in the current frame."
+  (let ((msg (format #f "Step into ~a" cur)))
+    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
+                                  #\into? #f #\instruction? #t)
+    (throw 'quit)))
+
+(define-meta-command (tracepoint repl (form))
+  "tracepoint PROCEDURE
+Add a tracepoint to PROCEDURE.
+
+A tracepoint will print out the procedure and its arguments, when it is
+called, and its return value(s) when it returns."
+  (let ((proc (repl-eval repl (repl-parse repl form))))
+    (if (not (procedure? proc))
+        (error "Not a procedure_ ~a" proc)
+        (let ((idx (add-trace-at-procedure-call! proc)))
+          (format #t "Trap ~a_ ~a.~%" idx (trap-name idx))))))
+
+(define-meta-command (traps repl)
+  "traps
+Show the set of currently attached traps.
+
+Show the set of currently attached traps (breakpoints and tracepoints)."
+  (let ((traps (list-traps)))
+    (if (null? traps)
+        (format #t "No traps set.~%")
+        (for-each (lambda (idx)
+                    (format #t "  ~a_ ~a~a~%"
+                            idx (trap-name idx)
+                            (if (trap-enabled? idx) "" " (disabled)")))
+                  traps))))
+
+(define-meta-command (delete repl idx)
+  "delete IDX
+Delete a trap.
+
+Delete a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (delete-trap! idx)))
+
+(define-meta-command (disable repl idx)
+  "disable IDX
+Disable a trap.
+
+Disable a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (disable-trap! idx)))
+
+(define-meta-command (enable repl idx)
+  "enable IDX
+Enable a trap.
+
+Enable a trap."
+  (if (not (integer? idx))
+      (error "expected a trap index (a non-negative integer)" idx)
+      (enable-trap! idx)))
+
+(define-stack-command (registers repl)
+  "registers
+Print registers.
+
+Print the registers of the current frame."
+  (print-registers cur))
+
+(define-meta-command (width repl #\optional x)
+  "width [X]
+Set debug output width.
+
+Set the number of screen columns in the output from `backtrace' and
+`locals'."
+  (terminal-width x)
+  (format #t "Set screen width to ~a columns.~%" (terminal-width)))
+
+
+
+;;;
+;;; Inspection commands
+;;;
+
+(define-meta-command (inspect repl (form))
+  "inspect EXP
+Inspect the result(s) of evaluating EXP."
+  (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
+    (lambda args
+      (for-each %inspect args))))
+
+(define-meta-command (pretty-print repl (form))
+  "pretty-print EXP
+Pretty-print the result(s) of evaluating EXP."
+  (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
+    (lambda args
+      (for-each
+       (lambda (x)
+         (run-hook before-print-hook x)
+         (pp x))
+       args))))
+
+
+;;;
+;;; System commands
+;;;
+
+(define-meta-command (gc repl)
+  "gc
+Garbage collection."
+  (gc))
+
+(define-meta-command (statistics repl)
+  "statistics
+Display statistics."
+  (let ((this-tms (times))
+	(this-gcs (gc-stats))
+	(last-tms (repl-tm-stats repl))
+	(last-gcs (repl-gc-stats repl)))
+    ;; GC times
+    (let ((this-times  (assq-ref this-gcs 'gc-times))
+	  (last-times  (assq-ref last-gcs 'gc-times)))
+      (display-diff-stat "GC times_" #t this-times last-times "times")
+      (newline))
+    ;; Memory size
+    (let ((this-heap  (assq-ref this-gcs 'heap-size))
+	  (this-free   (assq-ref this-gcs 'heap-free-size)))
+      (display-stat-title "Memory size_" "current" "limit")
+      (display-stat "heap" #f (- this-heap this-free) this-heap "bytes")
+      (newline))
+    ;; Cells collected
+    (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated))
+	  (last-alloc (assq-ref last-gcs 'heap-total-allocated)))
+      (display-stat-title "Bytes allocated_" "diff" "total")
+      (display-diff-stat "allocated" #f this-alloc last-alloc "bytes")
+      (newline))
+    ;; GC time taken
+    (let ((this-total (assq-ref this-gcs 'gc-time-taken))
+	  (last-total (assq-ref last-gcs 'gc-time-taken)))
+      (display-stat-title "GC time taken_" "diff" "total")
+      (display-time-stat "total" this-total last-total)
+      (newline))
+    ;; Process time spent
+    (let ((this-utime  (tms_utime this-tms))
+	  (last-utime  (tms_utime last-tms))
+	  (this-stime  (tms_stime this-tms))
+	  (last-stime  (tms_stime last-tms))
+	  (this-cutime (tms_cutime this-tms))
+	  (last-cutime (tms_cutime last-tms))
+	  (this-cstime (tms_cstime this-tms))
+	  (last-cstime (tms_cstime last-tms)))
+      (display-stat-title "Process time spent_" "diff" "total")
+      (display-time-stat "user" this-utime last-utime)
+      (display-time-stat "system" this-stime last-stime)
+      (display-time-stat "child user" this-cutime last-cutime)
+      (display-time-stat "child system" this-cstime last-cstime)
+      (newline))
+    ;; Save statistics
+    ;; Save statistics
+    (set! (repl-tm-stats repl) this-tms)
+    (set! (repl-gc-stats repl) this-gcs)))
+
+(define (display-stat title flag field1 field2 unit)
+  (let ((fmt (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+    (format #t fmt title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+  (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+  (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+  (define (conv num)
+    (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
+  (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+  (define (mips time clock)
+    (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
+  (display-stat title #f
+		(mips (- this-time last-time) (- this-clock last-clock))
+		(mips this-time this-clock) "mips"))
+;;; Repl common routines
+
+;; Copyright (C) 2001, 2008-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
+
+;;; Code_
+
+(define-module (system repl common)
+  #\use-module (system base syntax)
+  #\use-module (system base compile)
+  #\use-module (system base language)
+  #\use-module (system base message)
+  #\use-module (system vm program)
+  #\autoload (language tree-il optimize) (optimize!)
+  #\use-module (ice-9 control)
+  #\use-module (ice-9 history)
+  #\export (<repl> make-repl repl-language repl-options
+            repl-tm-stats repl-gc-stats repl-debug
+            repl-welcome repl-prompt
+            repl-read repl-compile repl-prepare-eval-thunk repl-eval
+            repl-expand repl-optimize
+            repl-parse repl-print repl-option-ref repl-option-set!
+            repl-default-option-set! repl-default-prompt-set!
+            puts ->string user-error
+            *warranty* *copying* *version*))
+
+(define *version*
+  (format #f "GNU Guile ~A
+Copyright (C) 1995-2016 Free Software Foundation, Inc.
+
+Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
+This program is free software, and you are welcome to redistribute it
+under certain conditions; type `,show c' for details." (version)))
+
+(define *copying*
+"Guile 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.
+
+Guile 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 program. If not, see
+<http_//www.gnu.org/licenses/lgpl.html>.")
+
+(define *warranty*
+"Guile is distributed WITHOUT ANY WARRANTY. The following
+sections from the GNU General Public License, version 3, should
+make that clear.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+See <http_//www.gnu.org/licenses/lgpl.html>, for more details.")
+
+
+;;;
+;;; Repl type
+;;;
+
+(define-record/keywords <repl>
+  language options tm-stats gc-stats debug)
+
+(define repl-default-options
+  (copy-tree
+   `((compile-options ,%auto-compilation-options #f)
+     (trace #f #f)
+     (interp #f #f)
+     (prompt #f ,(lambda (prompt)
+                   (cond
+                    ((not prompt) #f)
+                    ((string? prompt) (lambda (repl) prompt))
+                    ((thunk? prompt) (lambda (repl) (prompt)))
+                    ((procedure? prompt) prompt)
+                    (else (error "Invalid prompt" prompt)))))
+     (print #f ,(lambda (print)
+                  (cond
+                   ((not print) #f)
+                   ((procedure? print) print)
+                   (else (error "Invalid print procedure" print)))))
+     (value-history
+      ,(value-history-enabled?)
+      ,(lambda (x)
+         (if x (enable-value-history!) (disable-value-history!))
+         (->bool x)))
+     (on-error
+      debug
+      ,(let ((vals '(debug backtrace report pass)))
+         (lambda (x)
+           (if (memq x vals)
+               x
+               (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
+
+(define %make-repl make-repl)
+(define* (make-repl lang #\optional debug)
+  (%make-repl #\language (if (language? lang)
+                             lang
+                             (lookup-language lang))
+              #\options (copy-tree repl-default-options)
+              #\tm-stats (times)
+              #\gc-stats (gc-stats)
+              #\debug debug))
+
+(define (repl-welcome repl)
+  (display *version*)
+  (newline)
+  (newline)
+  (display "Enter `,help' for help.\n"))
+
+(define (repl-prompt repl)
+  (cond
+   ((repl-option-ref repl 'prompt)
+    => (lambda (prompt) (prompt repl)))
+   (else
+    (format #f "~A@~A~A> " (language-name (repl-language repl))
+            (module-name (current-module))
+            (let ((level (length (cond
+                                  ((fluid-ref *repl-stack*) => cdr)
+                                  (else '())))))
+              (if (zero? level) "" (format #f " [~a]" level)))))))
+
+(define (repl-read repl)
+  (let ((reader (language-reader (repl-language repl))))
+    (reader (current-input-port) (current-module))))
+
+(define (repl-compile-options repl)
+  (repl-option-ref repl 'compile-options))
+
+(define (repl-compile repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (compile form #\from from #\to 'objcode #\opts opts
+             #\env (current-module))))
+
+(define (repl-expand repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (decompile (compile form #\from from #\to 'tree-il #\opts opts
+                        #\env (current-module))
+               #\from 'tree-il #\to from)))
+
+(define (repl-optimize repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (decompile (optimize! (compile form #\from from #\to 'tree-il #\opts opts
+                                   #\env (current-module))
+                          (current-module)
+                          opts)
+               #\from 'tree-il #\to from)))
+
+(define (repl-parse repl form)
+  (let ((parser (language-parser (repl-language repl))))
+    (if parser (parser form) form)))
+
+(define (repl-prepare-eval-thunk repl form)
+  (let* ((eval (language-evaluator (repl-language repl))))
+    (if (and eval
+             (or (null? (language-compilers (repl-language repl)))
+                 (repl-option-ref repl 'interp)))
+        (lambda () (eval form (current-module)))
+        (make-program (repl-compile repl form)))))
+
+(define (repl-eval repl form)
+  (let ((thunk (repl-prepare-eval-thunk repl form)))
+    (% (thunk))))
+
+(define (repl-print repl val)
+  (if (not (eq? val *unspecified*))
+      (begin
+        (run-hook before-print-hook val)
+        (cond
+         ((repl-option-ref repl 'print)
+          => (lambda (print) (print repl val)))
+         (else
+          ;; The result of an evaluation is representable in scheme, and
+          ;; should be printed with the generic printer, `write'. The
+          ;; language-printer is something else_ it prints expressions of
+          ;; a given language, not the result of evaluation.
+          (write val)
+          (newline))))))
+
+(define (repl-option-ref repl key)
+  (cadr (or (assq key (repl-options repl))
+            (error "unknown repl option" key))))
+
+(define (repl-option-set! repl key val)
+  (let ((spec (or (assq key (repl-options repl))
+                  (error "unknown repl option" key))))
+    (set-car! (cdr spec)
+              (if (procedure? (caddr spec))
+                  ((caddr spec) val)
+                  val))))
+
+(define (repl-default-option-set! key val)
+  (let ((spec (or (assq key repl-default-options)
+                  (error "unknown repl option" key))))
+    (set-car! (cdr spec)
+              (if (procedure? (caddr spec))
+                  ((caddr spec) val)
+                  val))))
+
+(define (repl-default-prompt-set! prompt)
+  (repl-default-option-set! 'prompt prompt))
+
+
+;;;
+;;; Utilities
+;;;
+
+(define (puts x) (display x) (newline))
+
+(define (->string x)
+  (object->string x display))
+
+(define (user-error msg . args)
+  (throw 'user-error #f msg args #f))
+;;; Cooperative REPL server
+
+;; Copyright (C) 2014, 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
+
+;;; Code_
+
+(define-module (system repl coop-server)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 receive)
+  #\use-module (ice-9 threads)
+  #\use-module (ice-9 q)
+  #\use-module (srfi srfi-9)
+  #\use-module ((system repl repl)
+                #\select (start-repl* prompting-meta-read))
+  #\use-module ((system repl server)
+                #\select (run-server* make-tcp-server-socket
+                                      add-open-socket! close-socket!
+                                      guard-against-http-request))
+  #\export (spawn-coop-repl-server
+            poll-coop-repl-server))
+
+(define-record-type <coop-repl-server>
+  (%make-coop-repl-server mutex queue)
+  coop-repl-server?
+  (mutex coop-repl-server-mutex)
+  (queue coop-repl-server-queue))
+
+(define (make-coop-repl-server)
+  (%make-coop-repl-server (make-mutex) (make-q)))
+
+(define (coop-repl-server-eval coop-server opcode . args)
+  "Queue a new instruction with the symbolic name OPCODE and an arbitrary
+number of arguments, to be processed the next time COOP-SERVER is polled."
+  (with-mutex (coop-repl-server-mutex coop-server)
+    (enq! (coop-repl-server-queue coop-server)
+          (cons opcode args))))
+
+(define-record-type <coop-repl>
+  (%make-coop-repl mutex condvar thunk cont)
+  coop-repl?
+  (mutex coop-repl-mutex)
+  (condvar coop-repl-condvar)  ; signaled when thunk becomes non-#f
+  (thunk coop-repl-read-thunk set-coop-repl-read-thunk!)
+  (cont coop-repl-cont set-coop-repl-cont!))
+
+(define (make-coop-repl)
+  (%make-coop-repl (make-mutex) (make-condition-variable) #f #f))
+
+(define (coop-repl-read coop-repl)
+  "Read an expression via the thunk stored in COOP-REPL."
+  (let ((thunk
+         (with-mutex (coop-repl-mutex coop-repl)
+           (unless (coop-repl-read-thunk coop-repl)
+             (wait-condition-variable (coop-repl-condvar coop-repl)
+                                      (coop-repl-mutex coop-repl)))
+           (let ((thunk (coop-repl-read-thunk coop-repl)))
+             (unless thunk
+               (error "coop-repl-read_ condvar signaled, but thunk is #f!"))
+             (set-coop-repl-read-thunk! coop-repl #f)
+             thunk))))
+    (thunk)))
+
+(define (store-repl-cont cont coop-repl)
+  "Save the partial continuation CONT within COOP-REPL."
+  (set-coop-repl-cont! coop-repl
+                       (lambda (exp)
+                         (coop-repl-prompt
+                          (lambda () (cont exp))))))
+
+(define (coop-repl-prompt thunk)
+  "Apply THUNK within a prompt for cooperative REPLs."
+  (call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
+
+(define (make-coop-reader coop-repl)
+  "Return a new procedure for reading user input from COOP-REPL.  The
+generated procedure passes the responsibility of reading input to
+another thread and aborts the cooperative REPL prompt."
+  (lambda (repl)
+    (let ((read-thunk
+           ;; Need to preserve the REPL stack and current module across
+           ;; threads.
+           (let ((stack (fluid-ref *repl-stack*))
+                 (module (current-module)))
+             (lambda ()
+               (with-fluids ((*repl-stack* stack))
+                 (set-current-module module)
+                 (prompting-meta-read repl))))))
+      (with-mutex (coop-repl-mutex coop-repl)
+        (when (coop-repl-read-thunk coop-repl)
+          (error "coop-reader_ read-thunk is not #f!"))
+        (set-coop-repl-read-thunk! coop-repl read-thunk)
+        (signal-condition-variable (coop-repl-condvar coop-repl))))
+    (abort-to-prompt 'coop-repl-prompt coop-repl)))
+
+(define (reader-loop coop-server coop-repl)
+  "Run an unbounded loop that reads an expression for COOP-REPL and
+stores the expression within COOP-SERVER for later evaluation."
+  (coop-repl-server-eval coop-server 'eval coop-repl
+                         (coop-repl-read coop-repl))
+  (reader-loop coop-server coop-repl))
+
+(define (poll-coop-repl-server coop-server)
+  "Poll the cooperative REPL server COOP-SERVER and apply a pending
+operation if there is one, such as evaluating an expression typed at the
+REPL prompt.  This procedure must be called from the same thread that
+called spawn-coop-repl-server."
+  (let ((op (with-mutex (coop-repl-server-mutex coop-server)
+              (let ((queue (coop-repl-server-queue coop-server)))
+                (and (not (q-empty? queue))
+                     (deq! queue))))))
+    (when op
+      (match op
+        (('new-repl client)
+         (start-repl-client coop-server client))
+        (('eval coop-repl exp)
+         ((coop-repl-cont coop-repl) exp))))
+    *unspecified*))
+
+(define (start-coop-repl coop-server)
+  "Start a new cooperative REPL process for COOP-SERVER."
+  ;; Calling stop-server-and-clients! from a REPL will cause an
+  ;; exception to be thrown when trying to read from the socket that has
+  ;; been closed, so we catch that here.
+  (false-if-exception
+   (let ((coop-repl (make-coop-repl)))
+     (make-thread reader-loop coop-server coop-repl)
+     (start-repl* (current-language) #f (make-coop-reader coop-repl)))))
+
+(define (run-coop-repl-server coop-server server-socket)
+  "Start the cooperative REPL server for COOP-SERVER using the socket
+SERVER-SOCKET."
+  (run-server* server-socket (make-coop-client-proc coop-server)))
+
+(define* (spawn-coop-repl-server
+          #\optional (server-socket (make-tcp-server-socket)))
+  "Create and return a new cooperative REPL server object, and spawn a
+new thread to listen for connections on SERVER-SOCKET.  Proper
+functioning of the REPL server requires that poll-coop-repl-server be
+called periodically on the returned server object."
+  (let ((coop-server (make-coop-repl-server)))
+    (make-thread run-coop-repl-server
+                 coop-server
+                 server-socket)
+    coop-server))
+
+(define (make-coop-client-proc coop-server)
+  "Return a new procedure that is used to schedule the creation of a new
+cooperative REPL for COOP-SERVER."
+  (lambda (client addr)
+    (coop-repl-server-eval coop-server 'new-repl client)))
+
+(define (start-repl-client coop-server client)
+  "Run a cooperative REPL for COOP-SERVER within a prompt.  All input
+and output is sent over the socket CLIENT."
+
+  ;; Add the client to the list of open sockets, with a 'force-close'
+  ;; procedure that closes the underlying file descriptor.  We do it
+  ;; this way because we cannot close the port itself safely from
+  ;; another thread.
+  (add-open-socket! client (lambda () (close-fdes (fileno client))))
+
+  (guard-against-http-request client)
+
+  (with-continuation-barrier
+   (lambda ()
+     (coop-repl-prompt
+      (lambda ()
+        (parameterize ((current-input-port client)
+                       (current-output-port client)
+                       (current-error-port client)
+                       (current-warning-port client))
+          (with-fluids ((*repl-stack* '()))
+            (save-module-excursion
+             (lambda ()
+               (start-coop-repl coop-server)))))
+
+        ;; This may fail if 'stop-server-and-clients!' is called,
+        ;; because the 'force-close' procedure above closes the
+        ;; underlying file descriptor instead of the port itself.
+        (false-if-exception
+         (close-socket! client)))))))
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code_
+
+(define-module (system repl debug)
+  #\use-module (system base pmatch)
+  #\use-module (system base syntax)
+  #\use-module (system base language)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 pretty-print)
+  #\use-module (ice-9 format)
+  #\use-module ((system vm inspect) #\select ((inspect . %inspect)))
+  #\use-module (system vm program)
+  #\export (<debug>
+            make-debug debug?
+            debug-frames debug-index debug-error-message debug-for-trap?
+            terminal-width
+            print-registers print-locals print-frame print-frames frame->module
+            stack->vector narrow-stack->vector
+            frame->stack-vector))
+
+;; TODO_
+;;
+;; eval expression in context of frame
+;; set local variable in frame
+;; step until greater source line
+;; watch expression
+;; set printing width
+;; disassemble the current function
+;; inspect any object
+
+;;;
+;;; Debugger
+;;;
+;;; The actual interaction loop of the debugger is run by the repl. This module
+;;; simply exports a data structure to hold the debugger state, along with its
+;;; accessors, and provides some helper functions.
+;;;
+
+(define-record <debug> frames index error-message for-trap?)
+
+
+
+;; A fluid, because terminals are usually implicitly associated with
+;; threads.
+;;
+(define terminal-width
+  (let ((set-width (make-fluid)))
+    (case-lambda
+      (()
+       (or (fluid-ref set-width)
+           (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
+             (and (integer? w) (exact? w) (> w 0) w))
+           72))
+      ((w)
+       (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
+           (fluid-set! set-width w)
+           (error "Expected a column number (a positive integer)" w))))))
+
+
+
+
+(define (reverse-hashq h)
+  (let ((ret (make-hash-table)))
+    (hash-for-each
+     (lambda (k v)
+       (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+     h)
+    ret))
+
+(define* (print-registers frame #\optional (port (current-output-port))
+                          #\key (per-line-prefix "  "))
+  (define (print fmt val)
+    (display per-line-prefix port)
+    (run-hook before-print-hook val)
+    (format port fmt val))
+  
+  (format port "~aRegisters_~%" per-line-prefix)
+  (print "ip = ~d\n" (frame-instruction-pointer frame))
+  (print "sp = #x~x\n" (frame-stack-pointer frame))
+  (print "fp = #x~x\n" (frame-address frame)))
+
+(define* (print-locals frame #\optional (port (current-output-port))
+                       #\key (width (terminal-width)) (per-line-prefix "  "))
+  (let ((bindings (frame-bindings frame)))
+    (cond
+     ((null? bindings)
+      (format port "~aNo local variables.~%" per-line-prefix))
+     (else
+      (format port "~aLocal variables_~%" per-line-prefix)
+      (for-each
+       (lambda (binding)
+         (let ((v (let ((x (frame-local-ref frame (binding_index binding))))
+                    (if (binding_boxed? binding)
+                        (variable-ref x)
+                        x))))
+           (display per-line-prefix port)
+           (run-hook before-print-hook v)
+           (format port "~a~_[~; (boxed)~] = ~v_@y\n"
+                   (binding_name binding) (binding_boxed? binding) width v)))
+       (frame-bindings frame))))))
+
+(define* (print-frame frame #\optional (port (current-output-port))
+                      #\key index (width (terminal-width)) (full? #f)
+                      (last-source #f) next-source?)
+  (define (source_pretty-file source)
+    (if source
+        (or (source_file source) "current input")
+        "unknown file"))
+  (let* ((source ((if next-source? frame-next-source frame-source) frame))
+         (file (source_pretty-file source))
+         (line (and=> source source_line-for-user))
+         (col (and=> source source_column)))
+    (if (and file (not (equal? file (source_pretty-file last-source))))
+        (format port "~&In ~a_~&" file))
+    (format port "~9@a~_[~*~3_~;~3d~] ~v_@y~%"
+            (if line (format #f "~a_~a" line col) "")
+            index index width (frame-call-representation frame))
+    (if full?
+        (print-locals frame #\width width
+                      #\per-line-prefix "     "))))
+
+(define* (print-frames frames
+                       #\optional (port (current-output-port))
+                       #\key (width (terminal-width)) (full? #f)
+                       (forward? #f) count for-trap?)
+  (let* ((len (vector-length frames))
+         (lower-idx (if (or (not count) (positive? count))
+                        0
+                        (max 0 (+ len count))))
+         (upper-idx (if (and count (negative? count))
+                        (1- len)
+                        (1- (if count (min count len) len))))
+         (inc (if forward? 1 -1)))
+    (let lp ((i (if forward? lower-idx upper-idx))
+             (last-source #f))
+      (if (<= lower-idx i upper-idx)
+          (let* ((frame (vector-ref frames i)))
+            (print-frame frame port #\index i #\width width #\full? full?
+                         #\last-source last-source
+                         #\next-source? (and (zero? i) for-trap?))
+            (lp (+ i inc)
+                (if (and (zero? i) for-trap?)
+                    (frame-next-source frame)
+                    (frame-source frame))))))))
+
+;; Ideally here we would have something much more syntactic, in that a set! to a
+;; local var that is not settable would raise an error, and export etc forms
+;; would modify the module in question_ but alack, this is what we have now.
+;; Patches welcome!
+(define (frame->module frame)
+  (let ((proc (frame-procedure frame)))
+    (if (program? proc)
+        (let* ((mod (or (program-module proc) (current-module)))
+               (mod* (make-module)))
+          (module-use! mod* mod)
+          (for-each
+           (lambda (binding)
+             (let* ((x (frame-local-ref frame (binding_index binding)))
+                    (var (if (binding_boxed? binding) x (make-variable x))))
+               (format #t
+                       "~_[Read-only~;Mutable~] local variable ~a = ~70_@y\n"
+                       (binding_boxed? binding)
+                       (binding_name binding)
+                       (if (variable-bound? var) (variable-ref var) var))
+               (module-add! mod* (binding_name binding) var)))
+           (frame-bindings frame))
+          mod*)
+        (current-module))))
+
+
+(define (stack->vector stack)
+  (let* ((len (stack-length stack))
+         (v (make-vector len)))
+    (if (positive? len)
+        (let lp ((i 0) (frame (stack-ref stack 0)))
+          (if (< i len)
+              (begin
+                (vector-set! v i frame)
+                (lp (1+ i) (frame-previous frame))))))
+    v))
+
+(define (narrow-stack->vector stack . args)
+  (let ((narrowed (apply make-stack (stack-ref stack 0) args)))
+    (if narrowed
+        (stack->vector narrowed)
+        #()))) ; ? Can be the case for a tail-call to `throw' tho
+
+(define (frame->stack-vector frame)
+  (let ((tag (and (pair? (fluid-ref %stacks))
+                  (cdar (fluid-ref %stacks)))))
+    (narrow-stack->vector
+     (make-stack frame)
+     ;; Take the stack from the given frame, cutting 0
+     ;; frames.
+     0
+     ;; Narrow the end of the stack to the most recent
+     ;; start-stack.
+     tag
+     ;; And one more frame, because %start-stack
+     ;; invoking the start-stack thunk has its own frame
+     ;; too.
+     0 (and tag 1))))
+
+;; (define (debug)
+;;   (run-debugger
+;;    (narrow-stack->vector
+;;     (make-stack #t)
+;;     ;; Narrow the `make-stack' frame and the `debug' frame
+;;     2
+;;     ;; Narrow the end of the stack to the most recent start-stack.
+;;     (and (pair? (fluid-ref %stacks))
+;;          (cdar (fluid-ref %stacks))))))
+
+;;; Describe objects
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code_
+
+(define-module (system repl describe)
+  #\use-module (oop goops)
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 format)
+  #\use-module (ice-9 and-let-star)
+  #\export (describe))
+
+(define-method (describe (symbol <symbol>))
+  (format #t "`~s' is " symbol)
+  (if (not (defined? symbol))
+      (display "not defined in the current module.\n")
+      (describe-object (module-ref (current-module) symbol))))
+
+
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+  (if (slot-bound? class 'name)
+      (class-name class)
+      class))
+
+(define-method (display-class class . args)
+  (let* ((name (safe-class-name class))
+	 (desc (if (pair? args) (car args) name)))
+    (if (eq? *describe-format* 'tag)
+	(format #t "@class{~a}{~a}" name desc)
+	(format #t "~a" desc))))
+
+(define (display-list title list)
+  (if title (begin (display title) (display "_\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each display-summary list)))
+
+(define (display-slot-list title instance list)
+  (if title (begin (display title) (display "_\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each (lambda (slot)
+		  (let ((name (slot-definition-name slot)))
+		    (display "Slot_ ")
+		    (display name)
+		    (if (and instance (slot-bound? instance name))
+			(begin
+			  (display " = ")
+			  (display (slot-ref instance name))))
+		    (newline)))
+		list)))
+
+(define (display-file location)
+  (display "Defined in ")
+  (if (eq? *describe-format* 'tag)
+      (format #t "@location{~a}.\n" location)
+      (format #t "`~a'.\n" location)))
+
+(define (format-documentation doc)
+  (with-current-buffer (make-buffer #\text doc)
+    (lambda ()
+      (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
+	(do-while (match (re-search-forward regexp))
+	  (let ((key (string->symbol (match_substring match 1)))
+		(value (match_substring match 3)))
+	    (case key
+	      ((deffnx)
+	       (delete-region! (match_start match)
+			       (begin (forward-line) (point))))
+	      ((var)
+	       (replace-match! match 0 (string-upcase value)))
+	      ((code)
+	       (replace-match! match 0 (string-append "`" value "'")))))))
+      (display (string (current-buffer)))
+      (newline))))
+
+
+;;;
+;;; Top
+;;;
+
+(define description-table
+  (list
+   (cons <boolean>   "a boolean")
+   (cons <null>      "an empty list")
+   (cons <integer>   "an integer")
+   (cons <real>      "a real number")
+   (cons <complex>   "a complex number")
+   (cons <char>      "a character")
+   (cons <symbol>    "a symbol")
+   (cons <keyword>   "a keyword")
+   (cons <promise>   "a promise")
+   (cons <hook>      "a hook")
+   (cons <fluid>     "a fluid")
+   (cons <stack>     "a stack")
+   (cons <variable>  "a variable")
+   (cons <regexp>    "a regexp object")
+   (cons <module>    "a module object")
+   (cons <unknown>   "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-value obj)
+  (newline)
+  (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+	display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+  (write obj))
+
+(define-method (display-summary (obj <top>))
+  (display "Value_ ")
+  (display-object obj)
+  (newline))
+
+(define-method (display-type (obj <top>))
+  (cond
+   ((eof-object? obj) (display "the end-of-file object"))
+   ((unspecified? obj) (display "unspecified"))
+   (else (let ((class (class-of obj)))
+	   (display-class class (or (assq-ref description-table class)
+				    (safe-class-name class))))))
+  (display ".\n"))
+
+(define-method (display-value (obj <top>))
+  (if (not (unspecified? obj))
+      (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+  *unspecified*)
+
+(define-method (display-description (obj <top>))
+  (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+	 (index (string-index doc #\newline)))
+    (display (substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+  (display "Not documented.\n"))
+
+
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+  (cond
+   ((list? obj) (display-class <list> "a list"))
+   ((pair? (cdr obj)) (display "an improper list"))
+   (else (display-class <pair> "a pair")))
+  (display ".\n"))
+
+
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+  (if (read-only-string? 'obj)
+      (display "a read-only string")
+      (display-class <string> "a string"))
+  (display ".\n"))
+
+
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+  (cond
+   ;; FIXME_ VM programs, ...
+   (else
+    ;; Primitive procedure.  Let's lookup the dictionary.
+    (and-let* ((entry (lookup-procedure obj)))
+      (let ((name (entry-property entry 'name))
+	    (print-arg (lambda (arg)
+			 (display " ")
+			 (display (string-upcase (symbol->string arg))))))
+	(display "(")
+	(display name)
+	(and-let* ((args (entry-property entry 'args)))
+	  (for-each print-arg args))
+	(and-let* ((opts (entry-property entry 'opts)))
+	  (display " &optional")
+	  (for-each print-arg opts))
+	(and-let* ((rest (entry-property entry 'rest)))
+	  (display " &rest")
+	  (print-arg rest))
+	(display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+  (display "Procedure_ ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+  (cond
+   ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+   ((procedure-with-setter? obj)
+    (display-class <procedure-with-setter> "a procedure with setter"))
+   (else (display-class <procedure> "a procedure")))
+  (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+  (and-let* ((entry (lookup-procedure obj)))
+    (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+  (cond ((or (procedure-documentation obj)
+             (and=> (lookup-procedure obj) entry-text))
+	 => format-documentation)
+	(else (next-method))))
+
+
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-documentation obj)
+  (newline)
+  (display-value obj))
+
+(define-method (display-summary (obj <class>))
+  (display "Class_ ")
+  (display-class obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <class>))
+  (display-class <class> "a class")
+  (if (not (eq? (class-of obj) <class>))
+      (begin (display " of ") (display-class (class-of obj))))
+  (display ".\n"))
+
+(define-method (display-value (obj <class>))
+  (display-list "Class precedence list" (class-precedence-list obj))
+  (newline)
+  (display-list "Direct superclasses" (class-direct-supers obj))
+  (newline)
+  (display-list "Direct subclasses" (class-direct-subclasses obj))
+  (newline)
+  (display-slot-list "Direct slots" #f (class-direct-slots obj))
+  (newline)
+  (display-list "Direct methods" (class-direct-methods obj)))
+
+
+;;;
+;;; Instances
+;;;
+
+(define-method (display-type (obj <object>))
+  (display-class <object> "an instance")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <object>))
+  (display-slot-list #f obj (class-slots (class-of obj))))
+
+
+;;;
+;;; Generic functions
+;;;
+
+(define-method (display-type (obj <generic>))
+  (display-class <generic> "a generic function")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <generic>))
+  (display-list #f (generic-function-methods obj)))
+
+
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+  (display "(")
+  (let ((gf (method-generic-function obj)))
+    (display (if gf (generic-function-name gf) "#<anonymous>")))
+  (let loop ((args (method-specializers obj)))
+    (cond
+     ((null? args))
+     ((pair? args)
+      (display " ")
+      (display-class (car args))
+      (loop (cdr args)))
+     (else (display " . ") (display-class args))))
+  (display ")"))
+
+(define-method (display-summary (obj <method>))
+  (display "Method_ ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <method>))
+  (display-class <method> "a method")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+  (let ((doc (procedure-documentation (method-procedure obj))))
+    (if doc (format-documentation doc) (next-method))))
+;;; Error handling in the REPL
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code_
+
+(define-module (system repl error-handling)
+  #\use-module (system base pmatch)
+  #\use-module (system vm trap-state)
+  #\use-module (system repl debug)
+  #\use-module (ice-9 format)
+  #\export (call-with-error-handling
+            with-error-handling))
+
+
+
+
+;;;
+;;; Error handling via repl debugging
+;;;
+
+(define (error-string stack key args)
+  (call-with-output-string
+   (lambda (port)
+     (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+       (print-exception port frame key args)))))
+                  
+(define* (call-with-error-handling thunk #\key
+                                   (on-error 'debug) (post-error 'catch)
+                                   (pass-keys '(quit)) (trap-handler 'debug))
+  (let ((in (current-input-port))
+        (out (current-output-port))
+        (err (current-error-port)))
+    (define (with-saved-ports thunk)
+      (with-input-from-port in
+        (lambda ()
+          (with-output-to-port out
+            (lambda ()
+              (with-error-to-port err
+                thunk))))))
+
+    (define (debug-trap-handler frame trap-idx trap-name)
+      (let* ((tag (and (pair? (fluid-ref %stacks))
+                       (cdar (fluid-ref %stacks))))
+             (stack (narrow-stack->vector
+                     (make-stack frame)
+                     ;; Take the stack from the given frame, cutting 0
+                     ;; frames.
+                     0
+                     ;; Narrow the end of the stack to the most recent
+                     ;; start-stack.
+                     tag
+                     ;; And one more frame, because %start-stack
+                     ;; invoking the start-stack thunk has its own frame
+                     ;; too.
+                     0 (and tag 1)))
+             (error-msg (if trap-idx
+                            (format #f "Trap ~d_ ~a" trap-idx trap-name)
+                            trap-name))
+             (debug (make-debug stack 0 error-msg #t)))
+        (with-saved-ports
+         (lambda ()
+           (if trap-idx
+               (begin
+                 (format #t "~a~%" error-msg)
+                 (format #t "Entering a new prompt.  ")
+                 (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")))
+           ((@ (system repl repl) start-repl) #\debug debug)))))
+
+    (define (null-trap-handler frame trap-idx trap-name)
+      #t)
+
+    (define le-trap-handler
+      (case trap-handler
+        ((debug) debug-trap-handler)
+        ((pass) null-trap-handler)
+        ((disabled) #f)
+        (else (error "Unknown trap-handler strategy" trap-handler))))
+
+    (catch #t
+      (lambda () 
+        (with-default-trap-handler le-trap-handler
+          (lambda () (%start-stack #t thunk))))
+
+      (case post-error
+        ((report)
+         (lambda (key . args)
+           (if (memq key pass-keys)
+               (apply throw key args)
+               (begin
+                 (with-saved-ports
+                   (lambda ()
+                     (run-hook before-error-hook)
+                     (print-exception err #f key args)
+                     (run-hook after-error-hook)
+                     (force-output err)))
+                 (if #f #f)))))
+        ((catch)
+         (lambda (key . args)
+           (if (memq key pass-keys)
+               (apply throw key args))))
+        (else
+         (if (procedure? post-error)
+             (lambda (k . args)
+               (apply (if (memq k pass-keys) throw post-error) k args))
+             (error "Unknown post-error strategy" post-error))))
+
+      (case on-error
+        ((debug)
+         (lambda (key . args)
+           (if (not (memq key pass-keys))
+               (let* ((tag (and (pair? (fluid-ref %stacks))
+                                (cdar (fluid-ref %stacks))))
+                      (stack (narrow-stack->vector
+                              (make-stack #t)
+                              ;; Cut three frames from the top of the stack_
+                              ;; make-stack, this one, and the throw handler.
+                              3
+                              ;; Narrow the end of the stack to the most recent
+                              ;; start-stack.
+                              tag
+                              ;; And one more frame, because %start-stack invoking
+                              ;; the start-stack thunk has its own frame too.
+                              0 (and tag 1)))
+                      (error-msg (error-string stack key args))
+                      (debug (make-debug stack 0 error-msg #f)))
+                 (with-saved-ports
+                  (lambda ()
+                    (format #t "~a~%" error-msg)
+                    (format #t "Entering a new prompt.  ")
+                    (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+                    ((@ (system repl repl) start-repl) #\debug debug)))))))
+        ((report)
+         (lambda (key . args)
+           (if (not (memq key pass-keys))
+               (begin
+                 (with-saved-ports
+                  (lambda ()
+                    (run-hook before-error-hook)
+                    (print-exception err #f key args)
+                    (run-hook after-error-hook)
+                    (force-output err)))
+                 (if #f #f)))))
+        ((backtrace)
+         (lambda (key . args)
+           (if (not (memq key pass-keys))
+               (let* ((tag (and (pair? (fluid-ref %stacks))
+                                (cdar (fluid-ref %stacks))))
+                      (frames (narrow-stack->vector
+                               (make-stack #t)
+                               ;; Narrow as above, for the debugging case.
+                               3 tag 0 (and tag 1))))
+                 (with-saved-ports
+                  (lambda ()
+                    (print-frames frames)
+                    (run-hook before-error-hook)
+                    (print-exception err #f key args)
+                    (run-hook after-error-hook)
+                    (force-output err)))
+                 (if #f #f)))))
+        ((pass)
+         (lambda (key . args)
+           ;; fall through to rethrow
+           #t))
+        (else
+         (if (procedure? on-error)
+             (lambda (k . args)
+               (apply (if (memq k pass-keys) throw on-error) k args))
+             (error "Unknown on-error strategy" on-error)))))))
+
+(define-syntax-rule (with-error-handling form)
+  (call-with-error-handling (lambda () form)))
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001, 2009, 2010, 2011, 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
+
+;;; Code_
+
+(define-module (system repl repl)
+  #\use-module (system base syntax)
+  #\use-module (system base pmatch)
+  #\use-module (system base compile)
+  #\use-module (system base language)
+  #\use-module (system vm vm)
+  #\use-module (system repl error-handling)
+  #\use-module (system repl common)
+  #\use-module (system repl command)
+  #\use-module (ice-9 control)
+  #\export (start-repl run-repl))
+
+
+;;;
+;;; Comments
+;;;
+;;; (You don't want a comment to force a continuation line.)
+;;;
+
+(define (read-scheme-line-comment port)
+  (let lp ()
+    (let ((ch (read-char port)))
+      (or (eof-object? ch)
+          (eqv? ch #\newline)
+          (lp)))))
+
+(define (read-scheme-datum-comment port)
+  (read port))
+
+;; ch is a peeked char
+(define (read-comment lang port ch)
+  (and (eq? (language-name lang) 'scheme)
+       (case ch
+         ((#\;)
+          (read-char port)
+          (read-scheme-line-comment port)
+          #t)
+         ((#\#)
+          (read-char port)
+          (case (peek-char port)
+            ((#\;)
+             (read-char port)
+             (read-scheme-datum-comment port)
+             #t)
+            ;; Not doing R6RS block comments because of the possibility
+            ;; of read-hash extensions.  Lame excuse.  Not doing scsh
+            ;; block comments either, because I don't feel like handling
+            ;; .
+            (else
+             (unread-char #\# port)
+             #f)))
+         (else
+          #f))))
+
+
+
+;;;
+;;; Meta commands
+;;;
+
+(define meta-command-token (cons 'meta 'command))
+
+(define (meta-reader lang env)
+  (lambda* (#\optional (port (current-input-port)))
+    (with-input-from-port port
+      (lambda ()
+        (let ((ch (flush-leading-whitespace)))
+          (cond ((eof-object? ch)
+                 (read-char))  ; consume the EOF and return it
+                ((eqv? ch #\,)
+                 (read-char)
+                 meta-command-token)
+                ((read-comment lang port ch)
+                 *unspecified*)
+                (else ((language-reader lang) port env))))))))
+        
+(define (flush-all-input)
+  (if (and (char-ready?)
+           (not (eof-object? (peek-char))))
+      (begin
+        (read-char)
+        (flush-all-input))))
+
+;; repl-reader is a function defined in boot-9.scm, and is replaced by
+;; something else if readline has been activated. much of this hoopla is
+;; to be able to re-use the existing readline machinery.
+;;
+;; Catches read errors, returning *unspecified* in that case.
+;;
+;; Note_ although not exported, this is used by (system repl coop-server)
+(define (prompting-meta-read repl)
+  (catch #t
+    (lambda ()
+      (repl-reader (lambda () (repl-prompt repl))
+                   (meta-reader (repl-language repl) (current-module))))
+    (lambda (key . args)
+      (case key
+        ((quit)
+         (apply throw key args))
+        (else
+         (format (current-output-port) "While reading expression_\n")
+         (print-exception (current-output-port) #f key args)
+         (flush-all-input)
+         *unspecified*)))))
+
+
+
+;;;
+;;; The repl
+;;;
+
+(define* (start-repl #\optional (lang (current-language)) #\key debug)
+  (start-repl* lang debug prompting-meta-read))
+
+;; Note_ although not exported, this is used by (system repl coop-server)
+(define (start-repl* lang debug prompting-meta-read)
+  ;; ,language at the REPL will update the current-language.  Make
+  ;; sure that it does so in a new dynamic scope.
+  (parameterize ((current-language lang))
+    (run-repl* (make-repl lang debug) prompting-meta-read)))
+
+;; (put 'abort-on-error 'scheme-indent-function 1)
+(define-syntax-rule (abort-on-error string exp)
+  (catch #t
+    (lambda () exp)
+    (lambda (key . args)
+      (format #t "While ~A_~%" string)
+      (print-exception (current-output-port) #f key args)
+      (abort))))
+
+(define (run-repl repl)
+  (run-repl* repl prompting-meta-read))
+
+(define (run-repl* repl prompting-meta-read)
+  (define (with-stack-and-prompt thunk)
+    (call-with-prompt (default-prompt-tag)
+                      (lambda () (start-stack #t (thunk)))
+                      (lambda (k proc)
+                        (with-stack-and-prompt (lambda () (proc k))))))
+  
+  (% (with-fluids ((*repl-stack*
+                    (cons repl (or (fluid-ref *repl-stack*) '()))))
+       (if (null? (cdr (fluid-ref *repl-stack*)))
+           (repl-welcome repl))
+       (let prompt-loop ()
+         (let ((exp (prompting-meta-read repl)))
+           (cond
+            ((eqv? exp *unspecified*))  ; read error or comment, pass
+            ((eq? exp meta-command-token)
+             (catch #t
+               (lambda ()
+                 (meta-command repl))
+               (lambda (k . args)
+                 (if (eq? k 'quit)
+                     (abort args)
+                     (begin
+                       (format #t "While executing meta-command_~%")
+                       (print-exception (current-output-port) #f k args))))))
+            ((eof-object? exp)
+             (newline)
+             (abort '()))
+            (else
+             ;; since the input port is line-buffered, consume up to the
+             ;; newline
+             (flush-to-newline)
+             (call-with-error-handling
+              (lambda ()
+                (catch 'quit
+                  (lambda ()
+                    (call-with-values
+                        (lambda ()
+                          (% (let ((thunk
+                                    (abort-on-error "compiling expression"
+                                      (repl-prepare-eval-thunk
+                                       repl
+                                       (abort-on-error "parsing expression"
+                                         (repl-parse repl exp))))))
+                               (run-hook before-eval-hook exp)
+                               (call-with-error-handling
+                                (lambda ()
+                                  (with-stack-and-prompt thunk))
+                                #\on-error (repl-option-ref repl 'on-error)))
+                             (lambda (k) (values))))
+                      (lambda l
+                        (for-each (lambda (v)
+                                    (repl-print repl v))
+                                  l))))
+                  (lambda (k . args)
+                    (abort args))))
+              #\on-error (repl-option-ref repl 'on-error)
+              #\trap-handler 'disabled)))
+           (flush-to-newline) ;; consume trailing whitespace
+           (prompt-loop))))
+     (lambda (k status)
+       status)))
+
+;; Returns first non-whitespace char.
+(define (flush-leading-whitespace)
+  (let ((ch (peek-char)))
+    (cond ((eof-object? ch) ch)
+          ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
+          (else ch))))
+
+(define (flush-to-newline) 
+  (if (char-ready?)
+      (let ((ch (peek-char)))
+        (if (and (not (eof-object? ch)) (char-whitespace? ch))
+            (begin
+              (read-char)
+              (if (not (char=? ch #\newline))
+                  (flush-to-newline)))))))
+;;; Repl server
+
+;; Copyright (C)  2003, 2010, 2011, 2014, 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
+
+;;; Code_
+
+(define-module (system repl server)
+  #\use-module (system repl repl)
+  #\use-module (ice-9 threads)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 iconv)
+  #\use-module (rnrs bytevectors)
+  #\use-module (rnrs io ports)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-26)           ; cut
+  #\export (make-tcp-server-socket
+            make-unix-domain-server-socket
+            run-server
+            spawn-server
+            stop-server-and-clients!))
+
+;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a
+;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down
+;; the socket.
+(define *open-sockets* '())
+
+(define sockets-lock (make-mutex))
+
+;; WARNING_ it is unsafe to call 'close-socket!' from another thread.
+;; Note_ although not exported, this is used by (system repl coop-server)
+(define (close-socket! s)
+  (with-mutex sockets-lock
+    (set! *open-sockets* (assq-remove! *open-sockets* s)))
+  ;; Close-port could block or raise an exception flushing buffered
+  ;; output.  Hmm.
+  (close-port s))
+
+;; Note_ although not exported, this is used by (system repl coop-server)
+(define (add-open-socket! s force-close)
+  (with-mutex sockets-lock
+    (set! *open-sockets* (acons s force-close *open-sockets*))))
+
+(define (stop-server-and-clients!)
+  (cond
+   ((with-mutex sockets-lock
+      (match *open-sockets*
+        (() #f)
+        (((s . force-close) . rest)
+         (set! *open-sockets* rest)
+         force-close)))
+    => (lambda (force-close)
+         (force-close)
+         (stop-server-and-clients!)))))
+
+(define* (make-tcp-server-socket #\key
+                          (host #f)
+                          (addr (if host (inet-aton host) INADDR_LOOPBACK))
+                          (port 37146))
+  (let ((sock (socket PF_INET SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock AF_INET addr port)
+    sock))
+
+(define* (make-unix-domain-server-socket #\key (path "/tmp/guile-socket"))
+  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock AF_UNIX path)
+    sock))
+
+;; List of errno values from 'select' or 'accept' that should lead to a
+;; retry in 'run-server'.
+(define errs-to-retry
+  (delete-duplicates
+   (filter-map (lambda (name)
+                 (and=> (module-variable the-root-module name)
+                        variable-ref))
+               '(EINTR EAGAIN EWOULDBLOCK))))
+
+(define* (run-server #\optional (server-socket (make-tcp-server-socket)))
+  (run-server* server-socket serve-client))
+
+;; Note_ although not exported, this is used by (system repl coop-server)
+(define (run-server* server-socket serve-client)
+  ;; We use a pipe to notify the server when it should shut down.
+  (define shutdown-pipes      (pipe))
+  (define shutdown-read-pipe  (car shutdown-pipes))
+  (define shutdown-write-pipe (cdr shutdown-pipes))
+
+  ;; 'shutdown-server' is called by 'stop-server-and-clients!'.
+  (define (shutdown-server)
+    (display #\!  shutdown-write-pipe)
+    (force-output shutdown-write-pipe))
+
+  (define monitored-ports
+    (list server-socket
+          shutdown-read-pipe))
+
+  (define (accept-new-client)
+    (catch #t
+      (lambda ()
+        (let ((ready-ports (car (select monitored-ports '() '()))))
+          ;; If we've been asked to shut down, return #f.
+          (and (not (memq shutdown-read-pipe ready-ports))
+               (accept server-socket))))
+      (lambda k-args
+        (let ((err (system-error-errno k-args)))
+          (cond
+           ((memv err errs-to-retry)
+            (accept-new-client))
+           (else
+            (warn "Error accepting client" k-args)
+            ;; Retry after a timeout.
+            (sleep 1)
+            (accept-new-client)))))))
+
+  ;; Put the socket into non-blocking mode.
+  (fcntl server-socket F_SETFL
+         (logior O_NONBLOCK
+                 (fcntl server-socket F_GETFL)))
+
+  (sigaction SIGPIPE SIG_IGN)
+  (add-open-socket! server-socket shutdown-server)
+  (listen server-socket 5)
+  (let lp ((client (accept-new-client)))
+    ;; If client is false, we are shutting down.
+    (if client
+        (let ((client-socket (car client))
+              (client-addr (cdr client)))
+          (make-thread serve-client client-socket client-addr)
+          (lp (accept-new-client)))
+        (begin (close shutdown-write-pipe)
+               (close shutdown-read-pipe)
+               (close server-socket)))))
+
+(define* (spawn-server #\optional (server-socket (make-tcp-server-socket)))
+  (make-thread run-server server-socket))
+
+(define (serve-client client addr)
+
+  (let ((thread (current-thread)))
+    ;; Close the socket when this thread exits, even if canceled.
+    (set-thread-cleanup! thread (lambda () (close-socket! client)))
+    ;; Arrange to cancel this thread to forcefully shut down the socket.
+    (add-open-socket! client (lambda () (cancel-thread thread))))
+
+  (guard-against-http-request client)
+
+  (with-continuation-barrier
+   (lambda ()
+     (parameterize ((current-input-port client)
+                    (current-output-port client)
+                    (current-error-port client)
+                    (current-warning-port client))
+       (with-fluids ((*repl-stack* '()))
+         (start-repl))))))
+
+
+;;;
+;;; The following code adds protection to Guile's REPL servers against
+;;; HTTP inter-protocol exploitation attacks, a scenario whereby an
+;;; attacker can, via an HTML page, cause a web browser to send data to
+;;; TCP servers listening on a loopback interface or private network.
+;;; See <https_//en.wikipedia.org/wiki/Inter-protocol_exploitation> and
+;;; <https_//www.jochentopf.com/hfpa/hfpa.pdf>, The HTML Form Protocol
+;;; Attack (2001) by Tochen Topf <jochen@remote.org>.
+;;;
+;;; Here we add a procedure to 'before-read-hook' that looks for a possible
+;;; HTTP request-line in the first line of input from the client socket.  If
+;;; present, the socket is drained and closed, and a loud warning is written
+;;; to stderr (POSIX file descriptor 2).
+;;;
+
+(define (with-temporary-port-encoding port encoding thunk)
+  "Call THUNK in a dynamic environment in which the encoding of PORT is
+temporarily set to ENCODING."
+  (let ((saved-encoding #f))
+    (dynamic-wind
+      (lambda ()
+        (unless (port-closed? port)
+          (set! saved-encoding (port-encoding port))
+          (set-port-encoding! port encoding)))
+      thunk
+      (lambda ()
+        (unless (port-closed? port)
+          (set! encoding (port-encoding port))
+          (set-port-encoding! port saved-encoding))))))
+
+(define (with-saved-port-line+column port thunk)
+  "Save the line and column of PORT before entering THUNK, and restore
+their previous values upon normal or non-local exit from THUNK."
+  (let ((saved-line #f) (saved-column #f))
+    (dynamic-wind
+      (lambda ()
+        (unless (port-closed? port)
+          (set! saved-line   (port-line   port))
+          (set! saved-column (port-column port))))
+      thunk
+      (lambda ()
+        (unless (port-closed? port)
+          (set-port-line!   port saved-line)
+          (set-port-column! port saved-column))))))
+
+(define (drain-input-and-close socket)
+  "Drain input from SOCKET using ISO-8859-1 encoding until it would block,
+and then close it.  Return the drained input as a string."
+  (dynamic-wind
+    (lambda ()
+      ;; Enable full buffering mode on the socket to allow
+      ;; 'get-bytevector-some' to return non-trivial chunks.
+      (setvbuf socket _IOFBF))
+    (lambda ()
+      (let loop ((chunks '()))
+        (let ((result (and (char-ready? socket)
+                           (get-bytevector-some socket))))
+          (if (bytevector? result)
+              (loop (cons (bytevector->string result "ISO-8859-1")
+                          chunks))
+              (string-concatenate-reverse chunks)))))
+    (lambda ()
+      ;; Close the socket even in case of an exception.
+      (close-port socket))))
+
+(define permissive-http-request-line?
+  ;; This predicate is deliberately permissive
+  ;; when checking the Request-URI component.
+  (let ((cs (ucs-range->char-set #x20 #x7E))
+        (rx (make-regexp
+             (string-append
+              "^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT) "
+              "[^ ]+ "
+              "HTTP/[0-9]+.[0-9]+$"))))
+    (lambda (line)
+      "Return true if LINE might plausibly be an HTTP request-line,
+otherwise return #f."
+      ;; We cannot simplify this to a simple 'regexp-exec', because
+      ;; 'regexp-exec' cannot cope with NUL bytes.
+      (and (string-every cs line)
+           (regexp-exec  rx line)))))
+
+(define (check-for-http-request socket)
+  "Check for a possible HTTP request in the initial input from SOCKET.
+If one is found, close the socket and print a report to STDERR (fdes 2).
+Otherwise, put back the bytes."
+  ;; Temporarily set the port encoding to ISO-8859-1 to allow lossless
+  ;; reading and unreading of the first line, regardless of what bytes
+  ;; are present.  Note that a valid HTTP request-line contains only
+  ;; ASCII characters.
+  (with-temporary-port-encoding socket "ISO-8859-1"
+    (lambda ()
+      ;; Save the port 'line' and 'column' counters and later restore
+      ;; them, since unreading what we read is not sufficient to do so.
+      (with-saved-port-line+column socket
+        (lambda ()
+          ;; Read up to (but not including) the first CR or LF.
+          ;; Although HTTP mandates CRLF line endings, we are permissive
+          ;; here to guard against the possibility that in some
+          ;; environments CRLF might be converted to LF before it
+          ;; reaches us.
+          (match (read-delimited "\r\n" socket 'peek)
+            ((? eof-object?)
+             ;; We found EOF before any input.  Nothing to do.
+             'done)
+
+            ((? permissive-http-request-line? request-line)
+             ;; The input from the socket began with a plausible HTTP
+             ;; request-line, which is unlikely to be legitimate and may
+             ;; indicate an possible break-in attempt.
+
+             ;; First, set the current port parameters to a void-port,
+             ;; to avoid sending any more data over the socket, to cause
+             ;; the REPL reader to see EOF, and to swallow any remaining
+             ;; output gracefully.
+             (let ((void-port (%make-void-port "rw")))
+               (current-input-port   void-port)
+               (current-output-port  void-port)
+               (current-error-port   void-port)
+               (current-warning-port void-port))
+
+             ;; Read from the socket until we would block,
+             ;; and then close it.
+             (let ((drained-input (drain-input-and-close socket)))
+
+               ;; Print a report to STDERR (POSIX file descriptor 2).
+               ;; XXX Can we do better here?
+               (call-with-port (dup->port 2 "w")
+                 (cut format <> "
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+@@ POSSIBLE BREAK-IN ATTEMPT ON THE REPL SERVER                @@
+@@ BY AN HTTP INTER-PROTOCOL EXPLOITATION ATTACK.  See_        @@
+@@ <https_//en.wikipedia.org/wiki/Inter-protocol_exploitation> @@
+@@ Possible HTTP request received_ ~S
+@@ The associated socket has been closed.                      @@
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
+                      (string-append request-line
+                                     drained-input)))))
+
+            (start-line
+             ;; The HTTP request-line was not found, so
+             ;; 'unread' the characters that we have read.
+             (unread-string start-line socket))))))))
+
+(define (guard-against-http-request socket)
+  "Arrange for the Guile REPL to check for an HTTP request in the
+initial input from SOCKET, in which case the socket will be closed.
+This guards against HTTP inter-protocol exploitation attacks, a scenario
+whereby an attacker can, via an HTML page, cause a web browser to send
+data to TCP servers listening on a loopback interface or private
+network."
+  (%set-port-property! socket 'guard-against-http-request? #t))
+
+(define* (maybe-check-for-http-request
+          #\optional (socket (current-input-port)))
+  "Apply check-for-http-request to SOCKET if previously requested by
+guard-against-http-request.  This procedure is intended to be added to
+before-read-hook."
+  (when (%port-property socket 'guard-against-http-request?)
+    (check-for-http-request socket)
+    (unless (port-closed? socket)
+      (%set-port-property! socket 'guard-against-http-request? #f))))
+
+;; Install the hook.
+(add-hook! before-read-hook
+           maybe-check-for-http-request)
+
+;;; Local Variables_
+;;; eval_ (put 'with-temporary-port-encoding 'scheme-indent-function 2)
+;;; eval_ (put 'with-saved-port-line+column  'scheme-indent-function 1)
+;;; End_
+;;; -*- mode_ scheme; coding_ utf-8; -*-
+;;;
+;;; Copyright (C) 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 (system vm coverage)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module (system vm program)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-26)
+  #\export (with-code-coverage
+            coverage-data?
+            instrumented-source-files
+            instrumented/executed-lines
+            line-execution-counts
+            procedure-execution-count
+            coverage-data->lcov))
+
+;;; Author_ Ludovic Courtès
+;;;
+;;; Commentary_
+;;;
+;;; This module provides support to gather code coverage data by instrumenting
+;;; the VM.
+;;;
+;;; Code_
+
+
+;;;
+;;; Gathering coverage data.
+;;;
+
+(define (hashq-proc proc n)
+  ;; Return the hash of PROC's objcode.
+  (hashq (program-objcode proc) n))
+
+(define (assq-proc proc alist)
+  ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
+  ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
+  ;; are taken as an arbitrary representative of all the procedures (closures)
+  ;; sharing that objcode.  This can significantly reduce memory consumption.
+  (let ((code (program-objcode proc)))
+    (find (lambda (pair)
+            (eq? code (program-objcode (car pair))))
+          alist)))
+
+(define (with-code-coverage vm thunk)
+  "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
+coverage data.  Return code coverage data and the values returned by THUNK."
+
+  (define procedure->ip-counts
+    ;; Mapping from procedures to hash tables; said hash tables map instruction
+    ;; pointers to the number of times they were executed.
+    (make-hash-table 500))
+
+  (define (collect! frame)
+    ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
+    (let* ((proc       (frame-procedure frame))
+           (ip         (frame-instruction-pointer frame))
+           (proc-entry (hashx-create-handle! hashq-proc assq-proc
+                                             procedure->ip-counts proc #f)))
+      (let loop ()
+        (define ip-counts (cdr proc-entry))
+        (if ip-counts
+            (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
+              (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
+            (begin
+              (set-cdr! proc-entry (make-hash-table))
+              (loop))))))
+
+  ;; FIXME_ It's unclear what the dynamic-wind is for, given that if the
+  ;; VM is different from the current one, continuations will not be
+  ;; resumable.
+  (call-with-values (lambda ()
+                      (let ((level   (vm-trace-level vm))
+                            (hook    (vm-next-hook vm)))
+                        (dynamic-wind
+                          (lambda ()
+                            (set-vm-trace-level! vm (+ level 1))
+                            (add-hook! hook collect!))
+                          (lambda ()
+                            (call-with-vm vm thunk))
+                          (lambda ()
+                            (set-vm-trace-level! vm level)
+                            (remove-hook! hook collect!)))))
+    (lambda args
+      (apply values (make-coverage-data procedure->ip-counts) args))))
+
+
+;;;
+;;; Coverage data summary.
+;;;
+
+(define-record-type <coverage-data>
+  (%make-coverage-data procedure->ip-counts
+                       procedure->sources
+                       file->procedures
+                       file->line-counts)
+  coverage-data?
+
+  ;; Mapping from procedures to hash tables; said hash tables map instruction
+  ;; pointers to the number of times they were executed.
+  (procedure->ip-counts data-procedure->ip-counts)
+
+  ;; Mapping from procedures to the result of `program-sources'.
+  (procedure->sources   data-procedure->sources)
+
+  ;; Mapping from source file names to lists of procedures defined in the file.
+  (file->procedures     data-file->procedures)
+
+  ;; Mapping from file names to hash tables, which in turn map from line numbers
+  ;; to execution counts.
+  (file->line-counts    data-file->line-counts))
+
+
+(define (make-coverage-data procedure->ip-counts)
+  ;; Return a `coverage-data' object based on the coverage data available in
+  ;; PROCEDURE->IP-COUNTS.  Precompute the other hash tables that make up
+  ;; `coverage-data' objects.
+  (let* ((procedure->sources (make-hash-table 500))
+         (file->procedures   (make-hash-table 100))
+         (file->line-counts  (make-hash-table 100))
+         (data               (%make-coverage-data procedure->ip-counts
+                                                  procedure->sources
+                                                  file->procedures
+                                                  file->line-counts)))
+    (define (increment-execution-count! file line count)
+      ;; Make the execution count of FILE_LINE the maximum of its current value
+      ;; and COUNT.  This is so that LINE's execution count is correct when
+      ;; several instruction pointers map to LINE.
+      (let ((file-entry (hash-create-handle! file->line-counts file #f)))
+        (if (not (cdr file-entry))
+            (set-cdr! file-entry (make-hash-table 500)))
+        (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
+          (set-cdr! line-entry (max (cdr line-entry) count)))))
+
+    ;; Update execution counts for procs that were executed.
+    (hash-for-each (lambda (proc ip-counts)
+                     (let* ((sources (program-sources* data proc))
+                            (file    (and (pair? sources)
+                                          (source_file (car sources)))))
+                       (and file
+                            (begin
+                              ;; Add a zero count for all IPs in SOURCES and in
+                              ;; the sources of procedures closed over by PROC.
+                              (for-each
+                               (lambda (source)
+                                 (let ((file (source_file source))
+                                       (line (source_line source)))
+                                   (increment-execution-count! file line 0)))
+                               (append-map (cut program-sources* data <>)
+                                           (closed-over-procedures proc)))
+
+                              ;; Add the actual execution count collected.
+                              (hash-for-each
+                               (lambda (ip count)
+                                 (let ((line (closest-source-line sources ip)))
+                                   (increment-execution-count! file line count)))
+                               ip-counts)))))
+                   procedure->ip-counts)
+
+    ;; Set the execution count to zero for procedures loaded and not executed.
+    ;; FIXME_ Traversing thousands of procedures here is inefficient.
+    (for-each (lambda (proc)
+                (and (not (hashq-ref procedure->sources proc))
+                     (for-each (lambda (proc)
+                                 (let* ((sources (program-sources* data proc))
+                                        (file    (and (pair? sources)
+                                                      (source_file (car sources)))))
+                                   (and file
+                                        (for-each
+                                         (lambda (ip)
+                                           (let ((line (closest-source-line sources ip)))
+                                             (increment-execution-count! file line 0)))
+                                         (map source_addr sources)))))
+                               (closed-over-procedures proc))))
+              (append-map module-procedures (loaded-modules)))
+
+    data))
+
+(define (procedure-execution-count data proc)
+  "Return the number of times PROC's code was executed, according to DATA, or #f
+if PROC was not executed.  When PROC is a closure, the number of times its code
+was executed is returned, not the number of times this code associated with this
+particular closure was executed."
+  (let ((sources (program-sources* data proc)))
+    (and (pair? sources)
+         (and=> (hashx-ref hashq-proc assq-proc
+                           (data-procedure->ip-counts data) proc)
+                (lambda (ip-counts)
+                  ;; FIXME_ broken with lambda*
+                  (let ((entry-ip (source_addr (car sources))))
+                    (hashv-ref ip-counts entry-ip 0)))))))
+
+(define (program-sources* data proc)
+  ;; A memoizing version of `program-sources'.
+  (or (hashq-ref (data-procedure->sources data) proc)
+      (and (program? proc)
+           (let ((sources (program-sources proc))
+                 (p->s    (data-procedure->sources data))
+                 (f->p    (data-file->procedures data)))
+             (if (pair? sources)
+                 (let* ((file  (source_file (car sources)))
+                        (entry (hash-create-handle! f->p file '())))
+                   (hashq-set! p->s proc sources)
+                   (set-cdr! entry (cons proc (cdr entry)))
+                   sources)
+                 sources)))))
+
+(define (file-procedures data file)
+  ;; Return the list of globally bound procedures defined in FILE.
+  (hash-ref (data-file->procedures data) file '()))
+
+(define (instrumented/executed-lines data file)
+  "Return the number of instrumented and the number of executed source lines in
+FILE according to DATA."
+  (define instr+exec
+    (and=> (hash-ref (data-file->line-counts data) file)
+           (lambda (line-counts)
+             (hash-fold (lambda (line count instr+exec)
+                          (let ((instr (car instr+exec))
+                                (exec  (cdr instr+exec)))
+                            (cons (+ 1 instr)
+                                  (if (> count 0)
+                                      (+ 1 exec)
+                                      exec))))
+                        '(0 . 0)
+                        line-counts))))
+
+  (values (car instr+exec) (cdr instr+exec)))
+
+(define (line-execution-counts data file)
+  "Return a list of line number/execution count pairs for FILE, or #f if FILE
+is not among the files covered by DATA."
+  (and=> (hash-ref (data-file->line-counts data) file)
+         (lambda (line-counts)
+           (hash-fold alist-cons '() line-counts))))
+
+(define (instrumented-source-files data)
+  "Return the list of `instrumented' source files, i.e., source files whose code
+was loaded at the time DATA was collected."
+  (hash-fold (lambda (file counts files)
+               (cons file files))
+             '()
+             (data-file->line-counts data)))
+
+
+;;;
+;;; Helpers.
+;;;
+
+(define (loaded-modules)
+  ;; Return the list of all the modules currently loaded.
+  (define seen (make-hash-table))
+
+  (let loop ((modules (module-submodules (resolve-module '() #f)))
+             (result  '()))
+    (hash-fold (lambda (name module result)
+                 (if (hashq-ref seen module)
+                     result
+                     (begin
+                       (hashq-set! seen module #t)
+                       (loop (module-submodules module)
+                             (cons module result)))))
+               result
+               modules)))
+
+(define (module-procedures module)
+  ;; Return the list of procedures bound globally in MODULE.
+  (hash-fold (lambda (binding var result)
+               (if (variable-bound? var)
+                   (let ((value (variable-ref var)))
+                     (if (procedure? value)
+                         (cons value result)
+                         result))
+                   result))
+             '()
+             (module-obarray module)))
+
+(define (closest-source-line sources ip)
+  ;; Given SOURCES, as returned by `program-sources' for a given procedure,
+  ;; return the source line of code that is the closest to IP.  This is similar
+  ;; to what `program-source' does.
+  (let loop ((sources sources)
+             (line    (and (pair? sources) (source_line (car sources)))))
+    (if (null? sources)
+        line
+        (let ((source (car sources)))
+          (if (> (source_addr source) ip)
+              line
+              (loop (cdr sources) (source_line source)))))))
+
+(define (closed-over-procedures proc)
+  ;; Return the list of procedures PROC closes over, PROC included.
+  (let loop ((proc   proc)
+             (result '()))
+    (if (and (program? proc) (not (memq proc result)))
+        (fold loop (cons proc result)
+              (append (vector->list (or (program-objects proc) #()))
+                      (program-free-variables proc)))
+        result)))
+
+
+;;;
+;;; LCOV output.
+;;;
+
+(define* (coverage-data->lcov data port)
+  "Traverse code coverage information DATA, as obtained with
+`with-code-coverage', and write coverage information in the LCOV format to PORT.
+The report will include all the modules loaded at the time coverage data was
+gathered, even if their code was not executed."
+
+  (define (dump-function proc)
+    ;; Dump source location and basic coverage data for PROC.
+    (and (program? proc)
+         (let ((sources (program-sources* data proc)))
+           (and (pair? sources)
+                (let* ((line (source_line-for-user (car sources)))
+                       (name (or (procedure-name proc)
+                                 (format #f "anonymous-l~a" line))))
+                  (format port "FN_~A,~A~%" line name)
+                  (and=> (procedure-execution-count data proc)
+                         (lambda (count)
+                           (format port "FNDA_~A,~A~%" count name))))))))
+
+  ;; Output per-file coverage data.
+  (format port "TN_~%")
+  (for-each (lambda (file)
+              (let ((procs (file-procedures data file))
+                    (path  (search-path %load-path file)))
+                (if (string? path)
+                    (begin
+                      (format port "SF_~A~%" path)
+                      (for-each dump-function procs)
+                      (for-each (lambda (line+count)
+                                  (let ((line  (car line+count))
+                                        (count (cdr line+count)))
+                                    (format port "DA_~A,~A~%"
+                                            (+ 1 line) count)))
+                                (line-execution-counts data file))
+                      (let-values (((instr exec)
+                                    (instrumented/executed-lines data file)))
+                        (format port "LH_ ~A~%" exec)
+                        (format port "LF_ ~A~%" instr))
+                      (format port "end_of_record~%"))
+                    (begin
+                      (format (current-error-port)
+                              "skipping unknown source file_ ~a~%"
+                              file)))))
+            (instrumented-source-files data)))
+;;; Guile VM frame functions
+
+;;; Copyright (C) 2001, 2005, 2009, 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
+
+;;; Code_
+
+(define-module (system vm frame)
+  #\use-module (system base pmatch)
+  #\use-module (system vm program)
+  #\use-module (system vm instruction)
+  #\use-module (system vm objcode)
+  #\export (frame-bindings
+            frame-lookup-binding
+            frame-binding-ref frame-binding-set!
+            frame-next-source frame-call-representation
+            frame-environment
+            frame-object-binding frame-object-name
+            frame-return-values))
+
+(define (frame-bindings frame)
+  (let ((p (frame-procedure frame)))
+    (if (program? p)
+        (program-bindings-for-ip p (frame-instruction-pointer frame))
+        '())))
+
+(define (frame-lookup-binding frame var)
+  (let lp ((bindings (frame-bindings frame)))
+    (cond ((null? bindings)
+           #f)
+          ((eq? (binding_name (car bindings)) var)
+           (car bindings))
+          (else
+           (lp (cdr bindings))))))
+
+(define (frame-binding-set! frame var val)
+  (frame-local-set! frame
+                    (binding_index
+                     (or (frame-lookup-binding frame var)
+                         (error "variable not bound in frame" var frame)))
+                    val))
+
+(define (frame-binding-ref frame var)
+  (frame-local-ref frame
+                   (binding_index
+                    (or (frame-lookup-binding frame var)
+                        (error "variable not bound in frame" var frame)))))
+
+
+;; This function is always called to get some sort of representation of the
+;; frame to present to the user, so let's do the logical thing and dispatch to
+;; frame-call-representation.
+(define (frame-arguments frame)
+  (cdr (frame-call-representation frame)))
+
+
+
+;;;
+;;; Pretty printing
+;;;
+
+(define (frame-next-source frame)
+  (let ((proc (frame-procedure frame)))
+    (if (program? proc)
+        (program-source proc
+                        (frame-instruction-pointer frame)
+                        (program-sources-pre-retire proc))
+        '())))
+
+
+;; Basically there are two cases to deal with here_
+;;
+;;   1. We've already parsed the arguments, and bound them to local
+;;      variables. In a standard (lambda (a b c) ...) call, this doesn't
+;;      involve any argument shuffling; but with rest, optional, or
+;;      keyword arguments, the arguments as given to the procedure may
+;;      not correspond to what's on the stack. We reconstruct the
+;;      arguments using e.g. for the case above_ `(,a ,b ,c). This works
+;;      for rest arguments too_ (a b . c) => `(,a ,b . ,c)
+;;
+;;   2. We have failed to parse the arguments. Perhaps it's the wrong
+;;      number of arguments, or perhaps we're doing a typed dispatch and
+;;      the types don't match. In that case the arguments are all on the
+;;      stack, and nothing else is on the stack.
+
+(define (frame-call-representation frame)
+  (let ((p (frame-procedure frame)))
+    (cons
+     (or (false-if-exception (procedure-name p)) p)
+     (cond
+      ((and (program? p)
+            (program-arguments-alist p (frame-instruction-pointer frame)))
+       ;; case 1
+       => (lambda (arguments)
+            (define (binding-ref sym i)
+              (cond
+               ((frame-lookup-binding frame sym)
+                => (lambda (b) (frame-local-ref frame (binding_index b))))
+               ((< i (frame-num-locals frame))
+                (frame-local-ref frame i))
+               (else
+                ;; let's not error here, as we are called during backtraces...
+                '???)))
+            (let lp ((req (or (assq-ref arguments 'required) '()))
+                     (opt (or (assq-ref arguments 'optional) '()))
+                     (key (or (assq-ref arguments 'keyword) '()))
+                     (rest (or (assq-ref arguments 'rest) #f))
+                     (i 0))
+              (cond
+               ((pair? req)
+                (cons (binding-ref (car req) i)
+                      (lp (cdr req) opt key rest (1+ i))))
+               ((pair? opt)
+                (cons (binding-ref (car opt) i)
+                      (lp req (cdr opt) key rest (1+ i))))
+               ((pair? key)
+                (cons* (caar key)
+                       (frame-local-ref frame (cdar key))
+                       (lp req opt (cdr key) rest (1+ i))))
+               (rest
+                (binding-ref rest i))
+               (else
+                '())))))
+      (else
+       ;; case 2
+       (map (lambda (i)
+              (frame-local-ref frame i))
+            (iota (frame-num-locals frame))))))))
+
+
+
+;;; Misc
+;;;
+
+(define (frame-environment frame)
+  (map (lambda (binding)
+	 (cons (binding_name binding) (frame-binding-ref frame binding)))
+       (frame-bindings frame)))
+
+(define (frame-object-binding frame obj)
+  (do ((bs (frame-bindings frame) (cdr bs)))
+      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+       (and (pair? bs) (car bs)))))
+
+(define (frame-object-name frame obj)
+  (cond ((frame-object-binding frame obj) => binding_name)
+	(else #f)))
+
+;; Nota bene, only if frame is in a return context (i.e. in a
+;; pop-continuation hook dispatch).
+(define (frame-return-values frame)
+  (let* ((len (frame-num-locals frame))
+         (nvalues (frame-local-ref frame (1- len))))
+    (map (lambda (i)
+           (frame-local-ref frame (+ (- len nvalues 1) i)))
+         (iota nvalues))))
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code_
+
+(define-module (system vm inspect)
+  #\use-module (system base pmatch)
+  #\use-module (system base syntax)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module ((language assembly disassemble)
+                #\select ((disassemble . %disassemble)))
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 pretty-print)
+  #\use-module (ice-9 format)
+  #\use-module (system vm program)
+  #\export (inspect))
+
+
+(define (reverse-hashq h)
+  (let ((ret (make-hash-table)))
+    (hash-for-each
+     (lambda (k v)
+       (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+     h)
+    ret))
+
+(define (catch-bad-arguments thunk bad-args-thunk)
+  (catch 'wrong-number-of-args
+    (lambda ()
+      (catch 'keyword-argument-error
+        thunk
+        (lambda (k . args)
+          (bad-args-thunk))))
+    (lambda (k . args)
+      (bad-args-thunk))))
+
+(define (read-args prompt)
+  (define (read* reader)
+    (repl-reader prompt reader))
+  (define (next)
+    (read* read-char))
+  (define (cmd chr)
+    (cond
+     ((eof-object? chr) (list chr))
+     ((char=? chr #\newline) (cmd (next)))
+     ((char-whitespace? chr) (cmd (next)))
+     (else
+      (unread-char chr)
+      (let ((tok (read* read)))
+        (args (list tok) (next))))))
+  (define (args out chr)
+    (cond
+     ((eof-object? chr) (reverse out))
+     ((char=? chr #\newline) (reverse out))
+     ((char-whitespace? chr) (args out (next)))
+     (else
+      (unread-char chr)
+      (let ((tok (read* read)))
+        (args (cons tok out) (next))))))
+  (cmd (next)))
+
+
+;;;
+;;; Inspector
+;;;
+
+(define (inspect x)
+  (define-syntax-rule (define-command ((mod cname alias ...) . args)
+                        body ...)
+    (define cname
+      (let ((c (lambda* args body ...)))
+        (set-procedure-property! c 'name 'cname)
+        (module-define! mod 'cname c)
+        (module-add! mod 'alias (module-local-variable mod 'cname))
+        ...
+        c)))
+
+  (let ((commands (make-module)))
+    (define (prompt)
+      (format #f "~20@y inspect> " x))
+      
+    (define-command ((commands quit q continue cont c))
+      "Quit the inspector."
+      (throw 'quit))
+      
+    (define-command ((commands print p))
+      "Print the current object using `pretty-print'."
+      (pretty-print x))
+      
+    (define-command ((commands write w))
+      "Print the current object using `write'."
+      (write x))
+      
+    (define-command ((commands display d))
+      "Print the current object using `display'."
+      (display x))
+      
+    (define-command ((commands disassemble x))
+      "Disassemble the current object, which should be objcode or a procedure."
+      (catch #t
+        (lambda ()
+          (%disassemble x))
+        (lambda args
+          (format #t "Error disassembling object_ ~a\n" args))))
+    
+    (define-command ((commands help h ?) #\optional cmd)
+      "Show this help message."
+      (let ((rhash (reverse-hashq (module-obarray commands))))
+        (define (help-cmd cmd)
+          (let* ((v (module-local-variable commands cmd))
+                 (p (variable-ref v))
+                 (canonical-name (procedure-name p)))
+            ;; la la la
+            (format #t "~a~{ ~_@(~a~)~}~?~%~a~&~%"
+                    canonical-name (program-lambda-list p)
+                    "~#[~_;~40t(aliases_ ~@{~a~^, ~})~]"
+                    (delq canonical-name (hashq-ref rhash v))
+                    (procedure-documentation p))))
+        (cond
+         (cmd
+          (cond
+           ((and (symbol? cmd) (module-local-variable commands cmd))
+            (help-cmd cmd))
+           (else
+            (format #t "Invalid command ~s.~%" cmd)
+            (format #t "Try `help' for a list of commands~%"))))
+         (else
+          (let ((names (sort
+                        (hash-map->list
+                         (lambda (k v)
+                           (procedure-name (variable-ref k)))
+                         rhash)
+                        (lambda (x y)
+                          (string<? (symbol->string x)
+                                    (symbol->string y))))))
+            (format #t "Available commands_~%~%")
+            (for-each help-cmd names))))))
+
+    (define (handle cmd . args)
+      (cond
+       ((and (symbol? cmd)
+             (module-local-variable commands cmd))
+        => (lambda (var)
+             (let ((proc (variable-ref var)))
+               (catch-bad-arguments
+                (lambda ()
+                  (apply (variable-ref var) args))
+                (lambda ()
+                  (format (current-error-port)
+                          "Invalid arguments to ~a. Try `help ~a'.~%"
+                          (procedure-name proc) (procedure-name proc)))))))
+       ; ((and (integer? cmd) (exact? cmd))
+       ;  (nth cmd))
+       ((eof-object? cmd)
+        (newline)
+        (throw 'quit))
+       (else
+        (format (current-error-port)
+                "~&Unknown command_ ~a. Try `help'.~%" cmd)
+        *unspecified*)))
+
+    (catch 'quit
+      (lambda ()
+        (let loop ()
+          (apply
+           handle
+           (save-module-excursion
+            (lambda ()
+              (set-current-module commands)
+              (read-args prompt))))
+          (loop)))
+      (lambda (k . args)
+        (apply values args)))))
+;;; Guile VM instructions
+
+;; Copyright (C) 2001, 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
+
+;;; Code_
+
+(define-module (system vm instruction)
+  #\export (instruction-list
+           instruction? instruction-length
+           instruction-pops instruction-pushes
+           instruction->opcode opcode->instruction))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_instructions")
+;;; Guile VM object code
+
+;; Copyright (C) 2001, 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
+
+;;; Code_
+
+(define-module (system vm objcode)
+  #\export (objcode? objcode-meta
+            bytecode->objcode objcode->bytecode
+            load-objcode write-objcode
+            word-size byte-order))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_objcodes")
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code_
+
+(define-module (system vm program)
+  #\use-module (system base pmatch)
+  #\use-module (system vm instruction)
+  #\use-module (system vm objcode)
+  #\use-module (rnrs bytevectors)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-26)
+  #\export (make-program
+
+            make-binding binding_name binding_boxed? binding_index
+            binding_start binding_end
+
+            source_addr source_line source_column source_file
+            source_line-for-user
+            program-sources program-sources-pre-retire program-source
+
+            program-bindings program-bindings-by-index program-bindings-for-ip
+            program-arities program-arity arity_start arity_end
+
+            arity_nreq arity_nopt arity_rest? arity_kw arity_allow-other-keys?
+
+            program-arguments-alist program-lambda-list
+
+            program-meta
+            program-objcode program? program-objects
+            program-module program-base
+            program-free-variables
+            program-num-free-variables
+            program-free-variable-ref program-free-variable-set!))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_programs")
+
+(define (make-binding name boxed? index start end)
+  (list name boxed? index start end))
+(define (binding_name b) (list-ref b 0))
+(define (binding_boxed? b) (list-ref b 1))
+(define (binding_index b) (list-ref b 2))
+(define (binding_start b) (list-ref b 3))
+(define (binding_end b) (list-ref b 4))
+
+(define (source_addr source)
+  (car source))
+(define (source_file source)
+  (cadr source))
+(define (source_line source)
+  (caddr source))
+(define (source_column source)
+  (cdddr source))
+
+;; Lines are zero-indexed inside Guile, but users expect them to be
+;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
+;; figure.
+(define (source_line-for-user source)
+  (1+ (source_line source)))
+
+;; FIXME_ pull this definition from elsewhere.
+(define *bytecode-header-len* 8)
+
+;; We could decompile the program to get this, but that seems like a
+;; waste.
+(define (bytecode-instruction-length bytecode ip)
+  (let* ((idx (+ ip *bytecode-header-len*))
+         (inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
+    ;; 1+ for the instruction itself.
+    (1+ (cond
+         ((eq? inst 'load-program)
+          (+ (bytevector-u32-native-ref bytecode (+ idx 1))
+             (bytevector-u32-native-ref bytecode (+ idx 5))))
+         ((< (instruction-length inst) 0)
+          ;; variable length instruction -- the length is encoded in the
+          ;; instruction stream.
+          (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
+             (ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
+             (bytevector-u8-ref bytecode (+ idx 3))))
+         (else
+          ;; fixed length
+          (instruction-length inst))))))
+
+;; Source information could in theory be correlated with the ip of the
+;; instruction, or the ip just after the instruction is retired. Guile
+;; does the latter, to make backtraces easy -- an error produced while
+;; running an opcode always happens after it has retired its arguments.
+;;
+;; But for breakpoints and such, we need the ip before the instruction
+;; is retired -- before it has had a chance to do anything. So here we
+;; change from the post-retire addresses given by program-sources to
+;; pre-retire addresses.
+;;
+(define (program-sources-pre-retire proc)
+  (let ((bv (objcode->bytecode (program-objcode proc))))
+    (let lp ((in (program-sources proc))
+             (out '())
+             (ip 0))
+      (cond
+       ((null? in)
+        (reverse out))
+       (else
+        (pmatch (car in)
+          ((,post-ip . ,source)
+           (let lp2 ((ip ip)
+                     (next ip))
+             (if (< next post-ip)
+                 (lp2 next (+ next (bytecode-instruction-length bv next)))
+                 (lp (cdr in)
+                     (acons ip source out)
+                     next))))
+          (else
+           (error "unexpected"))))))))
+
+(define (collapse-locals locs)
+  (let lp ((ret '()) (locs locs))
+    (if (null? locs)
+        (map cdr (sort! ret 
+                        (lambda (x y) (< (car x) (car y)))))
+        (let ((b (car locs)))
+          (cond
+           ((assv-ref ret (binding_index b))
+            => (lambda (bindings)
+                 (append! bindings (list b))
+                 (lp ret (cdr locs))))
+           (else
+            (lp (acons (binding_index b) (list b) ret)
+                (cdr locs))))))))
+
+;; returns list of list of bindings
+;; (list-ref ret N) == bindings bound to the Nth local slot
+(define (program-bindings-by-index prog)
+  (cond ((program-bindings prog) => collapse-locals)
+        (else '())))
+
+(define (program-bindings-for-ip prog ip)
+  (let lp ((in (program-bindings-by-index prog)) (out '()))
+    (if (null? in)
+        (reverse out)
+        (lp (cdr in)
+            (let inner ((binds (car in)))
+              (cond ((null? binds) out)
+                    ((<= (binding_start (car binds))
+                         ip
+                         (binding_end (car binds)))
+                     (cons (car binds) out))
+                    (else (inner (cdr binds)))))))))
+
+(define (arity_start a)
+  (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+(define (arity_end a)
+  (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+(define (arity_nreq a)
+  (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+(define (arity_nopt a)
+  (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity_rest? a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity_kw a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity_allow-other-keys? a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
+(define (program-arity prog ip)
+  (let ((arities (program-arities prog)))
+    (and arities
+         (let lp ((arities arities))
+           (cond ((null? arities) #f)
+                 ((not ip) (car arities)) ; take the first one
+                 ((and (< (arity_start (car arities)) ip)
+                       (<= ip (arity_end (car arities))))
+                  (car arities))
+                 (else (lp (cdr arities))))))))
+
+(define (arglist->arguments-alist arglist)
+  (pmatch arglist
+    ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+     `((required . ,req)
+       (optional . ,opt)
+       (keyword . ,keyword)
+       (allow-other-keys? . ,allow-other-keys?)
+       (rest . ,rest)
+       (extents . ,extents)))
+    (else #f)))
+
+(define* (arity->arguments-alist prog arity
+                                 #\optional
+                                 (make-placeholder
+                                  (lambda (i) (string->symbol "_"))))
+  (define var-by-index
+    (let ((rbinds (map (lambda (x)
+                         (cons (binding_index x) (binding_name x)))
+                       (program-bindings-for-ip prog
+                                                (arity_start arity)))))
+      (lambda (i)
+        (or (assv-ref rbinds i)
+            ;; if we don't know the name, return a placeholder
+            (make-placeholder i)))))
+
+  (let lp ((nreq (arity_nreq arity)) (req '())
+           (nopt (arity_nopt arity)) (opt '())
+           (rest? (arity_rest? arity)) (rest #f)
+           (n 0))
+    (cond
+     ((< 0 nreq)
+      (lp (1- nreq) (cons (var-by-index n) req)
+          nopt opt rest? rest (1+ n)))
+     ((< 0 nopt)
+      (lp nreq req
+          (1- nopt) (cons (var-by-index n) opt)
+          rest? rest (1+ n)))
+     (rest?
+      (lp nreq req nopt opt
+          #f (var-by-index (+ n (length (arity_kw arity))))
+          (1+ n)))
+     (else
+      `((required . ,(reverse req))
+        (optional . ,(reverse opt))
+        (keyword . ,(arity_kw arity))
+        (allow-other-keys? . ,(arity_allow-other-keys? arity))
+        (rest . ,rest))))))
+
+;; the name "program-arguments" is taken by features.c...
+(define* (program-arguments-alist prog #\optional ip)
+  "Returns the signature of the given procedure in the form of an association list."
+  (let ((arity (program-arity prog ip)))
+    (and arity
+         (arity->arguments-alist prog arity))))
+
+(define* (program-lambda-list prog #\optional ip)
+  "Returns the signature of the given procedure in the form of an argument list."
+  (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
+
+(define (arguments-alist->lambda-list arguments-alist)
+  (let ((req (or (assq-ref arguments-alist 'required) '()))
+        (opt (or (assq-ref arguments-alist 'optional) '()))
+        (key (map keyword->symbol
+                  (map car (or (assq-ref arguments-alist 'keyword) '()))))
+        (rest (or (assq-ref arguments-alist 'rest) '())))
+    `(,@req
+      ,@(if (pair? opt) (cons #\optional opt) '())
+      ,@(if (pair? key) (cons #\key key) '())
+      . ,rest)))
+
+(define (program-free-variables prog)
+  "Return the list of free variables of PROG."
+  (let ((count (program-num-free-variables prog)))
+    (unfold (lambda (i) (>= i count))
+            (cut program-free-variable-ref prog <>)
+            1+
+            0)))
+
+(define (write-program prog port)
+  (format port "#<procedure ~a~a>"
+          (or (procedure-name prog)
+              (and=> (program-source prog 0)
+                     (lambda (s)
+                       (format #f "~a at ~a_~a_~a"
+                               (number->string (object-address prog) 16)
+                               (or (source_file s)
+                                   (if s "<current input>" "<unknown port>"))
+                               (source_line-for-user s) (source_column s))))
+              (number->string (object-address prog) 16))
+          (let ((arities (program-arities prog)))
+            (if (or (not arities) (null? arities))
+                ""
+                (string-append
+                 " " (string-join (map (lambda (a)
+                                         (object->string
+                                          (arguments-alist->lambda-list
+                                           (arity->arguments-alist prog a))))
+                                       arities)
+                                  " | "))))))
+
+;;; Guile VM tracer
+
+;; Copyright (C) 2001, 2009, 2010, 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
+
+;;; Code_
+
+(define-module (system vm trace)
+  #\use-module (system base syntax)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module (system vm program)
+  #\use-module (system vm objcode)
+  #\use-module (system vm traps)
+  #\use-module (rnrs bytevectors)
+  #\use-module (system vm instruction)
+  #\use-module (ice-9 format)
+  #\export (trace-calls-in-procedure
+            trace-calls-to-procedure
+            trace-instructions-in-procedure
+            call-with-trace))
+
+;; FIXME_ this constant needs to go in system vm objcode
+(define *objcode-header-len* 8)
+
+(define (build-prefix prefix depth infix numeric-format max-indent)
+  (let lp ((indent "") (n 0))
+    (cond
+     ((= n depth)
+      (string-append prefix indent))
+     ((< (+ (string-length indent) (string-length infix)) max-indent)
+      (lp (string-append indent infix) (1+ n)))
+     (else
+      (string-append prefix indent (format #f numeric-format depth))))))
+
+(define (print-application frame depth width prefix max-indent)
+  (let ((prefix (build-prefix prefix depth "|  " "~d> " max-indent)))
+    (format (current-error-port) "~a~v_@y\n"
+            prefix
+            width
+            (frame-call-representation frame))))
+
+(define* (print-return frame depth width prefix max-indent)
+  (let* ((len (frame-num-locals frame))
+         (nvalues (frame-local-ref frame (1- len)))
+         (prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
+    (case nvalues
+      ((0)
+       (format (current-error-port) "~ano values\n" prefix))
+      ((1)
+       (format (current-error-port) "~a~v_@y\n"
+               prefix
+               width
+               (frame-local-ref frame (- len 2))))
+      (else
+       ;; this should work, but there appears to be a bug
+       ;; "~a~d values_~_{ ~v_@y~}\n"
+       (format (current-error-port) "~a~d values_~{ ~a~}\n"
+               prefix nvalues
+               (map (lambda (val)
+                      (format #f "~v_@y" width val))
+                    (frame-return-values frame)))))))
+  
+(define* (trace-calls-to-procedure proc #\key (width 80) (vm (the-vm))
+                                   (prefix "trace_ ")
+                                   (max-indent (- width 40)))
+  (define (apply-handler frame depth)
+    (print-application frame depth width prefix max-indent))
+  (define (return-handler frame depth)
+    (print-return frame depth width prefix max-indent))
+  (trap-calls-to-procedure proc apply-handler return-handler
+                           #\vm vm))
+
+(define* (trace-calls-in-procedure proc #\key (width 80) (vm (the-vm))
+                                   (prefix "trace_ ")
+                                   (max-indent (- width 40)))
+  (define (apply-handler frame depth)
+    (print-application frame depth width prefix max-indent))
+  (define (return-handler frame depth)
+    (print-return frame depth width prefix max-indent))
+  (trap-calls-in-dynamic-extent proc apply-handler return-handler
+                                #\vm vm))
+
+(define* (trace-instructions-in-procedure proc #\key (width 80) (vm (the-vm))
+                                          (max-indent (- width 40)))
+  (define (trace-next frame)
+    (let* ((ip (frame-instruction-pointer frame))
+           (objcode (program-objcode (frame-procedure frame)))
+           (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+                                      (+ ip *objcode-header-len*))))
+      (format #t "~8d_ ~a\n" ip (opcode->instruction opcode))))
+  
+  (trap-instructions-in-dynamic-extent proc trace-next
+                                       #\vm vm))
+
+;; Note that because this procedure manipulates the VM trace level
+;; directly, it doesn't compose well with traps at the REPL.
+;;
+(define* (call-with-trace thunk #\key (calls? #t) (instructions? #f) 
+                          (width 80) (vm (the-vm)) (max-indent (- width 40)))
+  (let ((call-trap #f)
+        (inst-trap #f))
+    (dynamic-wind
+      (lambda ()
+        (if calls?
+            (set! call-trap
+                  (trace-calls-in-procedure thunk #\vm vm #\width width
+                                            #\max-indent max-indent)))
+        (if instructions?
+            (set! inst-trap
+                  (trace-instructions-in-procedure thunk #\vm vm #\width width 
+                                                   #\max-indent max-indent)))
+        (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+      thunk
+      (lambda ()
+        (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+        (if call-trap (call-trap))
+        (if inst-trap (inst-trap))
+        (set! call-trap #f)
+        (set! inst-trap #f)))))
+;;; trap-state.scm_ a set of traps
+
+;; Copyright (C)  2010 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary_
+;;;
+;;; Code_
+
+(define-module (system vm trap-state)
+  #\use-module (system base syntax)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\use-module (system vm vm)
+  #\use-module (system vm traps)
+  #\use-module (system vm trace)
+  #\use-module (system vm frame)
+  #\use-module (system vm program)
+  #\export (add-trap!
+            list-traps
+            trap-enabled?
+            trap-name
+            enable-trap!
+            disable-trap!
+            delete-trap!
+            
+            with-default-trap-handler
+            install-trap-handler!
+
+            add-trap-at-procedure-call!
+            add-trace-at-procedure-call!
+            add-trap-at-source-location!
+            add-ephemeral-trap-at-frame-finish!
+            add-ephemeral-stepping-trap!))
+
+(define %default-trap-handler (make-fluid))
+
+(define (default-trap-handler frame idx trap-name)
+  (let ((default-handler (fluid-ref %default-trap-handler)))
+    (if default-handler
+        (default-handler frame idx trap-name)
+        (warn "Trap with no handler installed" frame idx trap-name))))
+
+(define-record <trap-wrapper>
+  index
+  enabled?
+  trap
+  name)
+
+(define-record <trap-state>
+  (handler default-trap-handler)
+  (next-idx 0)
+  (next-ephemeral-idx -1)
+  (wrappers '()))
+
+(define (trap-wrapper<? t1 t2)
+  (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
+
+;; The interface that a trap provides to the outside world is that of a
+;; procedure, which when called disables the trap, and returns a
+;; procedure to enable the trap. Perhaps this is a bit too odd and we
+;; should fix this.
+(define (enable-trap-wrapper! wrapper)
+  (if (trap-wrapper-enabled? wrapper)
+      (error "Trap already enabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #t))))
+
+(define (disable-trap-wrapper! wrapper)
+  (if (not (trap-wrapper-enabled? wrapper))
+      (error "Trap already disabled" (trap-wrapper-index wrapper))
+      (let ((trap (trap-wrapper-trap wrapper)))
+        (set! (trap-wrapper-trap wrapper) (trap))
+        (set! (trap-wrapper-enabled? wrapper) #f))))
+
+(define (add-trap-wrapper! trap-state wrapper)
+  (set! (trap-state-wrappers trap-state)
+        (append (trap-state-wrappers trap-state) (list wrapper)))
+  (trap-wrapper-index wrapper))
+
+(define (remove-trap-wrapper! trap-state wrapper)
+  (set! (trap-state-wrappers trap-state)
+        (delq wrapper (trap-state-wrappers trap-state))))
+
+(define (trap-state->trace-level trap-state)
+  (fold (lambda (wrapper level)
+          (if (trap-wrapper-enabled? wrapper)
+              (1+ level)
+              level))
+        0
+        (trap-state-wrappers trap-state)))
+
+(define (wrapper-at-index trap-state idx)
+  (let lp ((wrappers (trap-state-wrappers trap-state)))
+    (cond
+     ((null? wrappers)
+      (warn "no wrapper found with index in trap-state" idx)
+      #f)
+     ((eqv? (trap-wrapper-index (car wrappers)) idx)
+      (car wrappers))
+     (else
+      (lp (cdr wrappers))))))
+
+(define (next-index! trap-state)
+  (let ((idx (trap-state-next-idx trap-state)))
+    (set! (trap-state-next-idx trap-state) (1+ idx))
+    idx))
+
+(define (next-ephemeral-index! trap-state)
+  (let ((idx (trap-state-next-ephemeral-idx trap-state)))
+    (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
+    idx))
+
+(define (handler-for-index trap-state idx)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx))
+          (handler (trap-state-handler trap-state)))
+      (if wrapper
+          (handler frame
+                   (trap-wrapper-index wrapper)
+                   (trap-wrapper-name wrapper))))))
+
+(define (ephemeral-handler-for-index trap-state idx handler)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx)))
+      (if wrapper
+          (begin
+            (if (trap-wrapper-enabled? wrapper)
+                (disable-trap-wrapper! wrapper))
+            (remove-trap-wrapper! trap-state wrapper)
+            (handler frame))))))
+
+
+
+;;;
+;;; VM-local trap states
+;;;
+
+(define *trap-states* (make-weak-key-hash-table))
+
+(define (trap-state-for-vm vm)
+  (or (hashq-ref *trap-states* vm)
+      (let ((ts (make-trap-state)))
+        (hashq-set! *trap-states* vm ts)
+        (trap-state-for-vm vm))))
+
+(define (the-trap-state)
+  (trap-state-for-vm (the-vm)))
+
+
+
+;;;
+;;; API
+;;;
+
+(define* (with-default-trap-handler handler thunk
+                                    #\optional (trap-state (the-trap-state)))
+  (with-fluids ((%default-trap-handler handler))
+    (dynamic-wind
+      (lambda ()
+        ;; Don't enable hooks if the handler is #f.
+        (if handler
+            (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
+      thunk
+      (lambda ()
+        (if handler
+            (set-vm-trace-level! (the-vm) 0))))))
+
+(define* (list-traps #\optional (trap-state (the-trap-state)))
+  (map trap-wrapper-index (trap-state-wrappers trap-state)))
+
+(define* (trap-name idx #\optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         trap-wrapper-name))
+
+(define* (trap-enabled? idx #\optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         trap-wrapper-enabled?))
+
+(define* (enable-trap! idx #\optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         enable-trap-wrapper!))
+
+(define* (disable-trap! idx #\optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         disable-trap-wrapper!))
+
+(define* (delete-trap! idx #\optional (trap-state (the-trap-state)))
+  (and=> (wrapper-at-index trap-state idx)
+         (lambda (wrapper)
+           (if (trap-wrapper-enabled? wrapper)
+               (disable-trap-wrapper! wrapper))
+           (remove-trap-wrapper! trap-state wrapper))))
+
+(define* (install-trap-handler! handler #\optional (trap-state (the-trap-state)))
+  (set! (trap-state-handler trap-state) handler))
+
+(define* (add-trap-at-procedure-call! proc #\optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trap-at-procedure-call
+                proc
+                (handler-for-index trap-state idx))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Breakpoint at ~a" proc)))))
+
+(define* (add-trace-at-procedure-call! proc
+                                       #\optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trace-calls-to-procedure
+                proc
+                #\prefix (format #f "Trap ~a_ " idx))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Tracepoint at ~a" proc)))))
+
+(define* (add-trap-at-source-location! file user-line
+                                       #\optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trap-at-source-location file user-line
+                                        (handler-for-index trap-state idx))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Breakpoint at ~a_~a" file user-line)))))
+
+;; handler _= frame -> nothing
+(define* (add-ephemeral-trap-at-frame-finish! frame handler
+                                              #\optional (trap-state
+                                                          (the-trap-state)))
+  (let* ((idx (next-ephemeral-index! trap-state))
+         (trap (trap-frame-finish
+                frame
+                (ephemeral-handler-for-index trap-state idx handler)
+                (lambda (frame) (delete-trap! idx trap-state)))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Return from ~a" frame)))))
+
+(define (source-string source)
+  (if source
+      (format #f "~a_~a_~a" (or (source_file source) "unknown file")
+              (source_line-for-user source) (source_column source))
+      "unknown source location"))
+
+(define* (add-ephemeral-stepping-trap! frame handler
+                                       #\optional (trap-state
+                                                   (the-trap-state))
+                                       #\key (into? #t) (instruction? #f))
+  (define (wrap-predicate-according-to-into predicate)
+    (if into?
+        predicate
+        (let ((fp (frame-address frame)))
+          (lambda (f)
+            (and (<= (frame-address f) fp)
+                 (predicate f))))))
+  
+  (let* ((source (frame-next-source frame))
+         (idx (next-ephemeral-index! trap-state))
+         (trap (trap-matching-instructions
+                (wrap-predicate-according-to-into
+                 (if instruction?
+                     (lambda (f) #t)
+                     (lambda (f) (not (equal? (frame-next-source f) source)))))
+                (ephemeral-handler-for-index trap-state idx handler))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (if instruction?
+          (if into?
+              "Step to different instruction"
+              (format #f "Step to different instruction in ~a" frame))
+          (if into?
+              (format #f "Step into ~a" (source-string source)) 
+              (format #f "Step out of ~a" (source-string source))))))))
+
+(define* (add-trap! trap name #\optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state)))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper idx #t trap name))))
+;;; Traps_ stepping, breakpoints, and such.
+
+;; Copyright (C)  2010 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary_
+;;;
+;;; Guile's debugging capabilities come from the hooks that its VM
+;;; provides. For example, there is a hook that is fired when a function
+;;; is called, and even a hook that gets fired at every retired
+;;; instruction.
+;;;
+;;; But as the firing of these hooks is interleaved with the program
+;;; execution, if we want to debug a program, we have to write an
+;;; imperative program that mutates the state of these hooks, and to
+;;; dispatch the hooks to a more semantic context.
+;;;
+;;; For example if we have placed a breakpoint at foo.scm_38, and
+;;; determined that that location maps to the 18th instruction in
+;;; procedure `bar', then we will need per-instruction hooks within
+;;; `bar' -- but when running other procedures, we can have the
+;;; per-instruction hooks off.
+;;;
+;;; Our approach is to define "traps". The behavior of a trap is
+;;; specified when the trap is created. After creation, traps expose a
+;;; limited, uniform interface_ they are either on or off.
+;;;
+;;; To take our foo.scm_38 example again, we can define a trap that
+;;; calls a function when control transfers to that source line --
+;;; trap-at-source-location below. Calling the trap-at-source-location
+;;; function adds to the VM hooks in such at way that it can do its job.
+;;; The result of calling the function is a "disable-hook" closure that,
+;;; when called, will turn off that trap.
+;;;
+;;; The result of calling the "disable-hook" closure, in turn, is an
+;;; "enable-hook" closure, which when called turns the hook back on, and
+;;; returns a "disable-hook" closure.
+;;;
+;;; It's a little confusing. The summary is, call these functions to add
+;;; a trap; and call their return value to disable the trap.
+;;;
+;;; Code_
+
+(define-module (system vm traps)
+  #\use-module (system base pmatch)
+  #\use-module (system vm vm)
+  #\use-module (system vm frame)
+  #\use-module (system vm program)
+  #\use-module (system vm objcode)
+  #\use-module (system vm instruction)
+  #\use-module (system xref)
+  #\use-module (rnrs bytevectors)
+  #\export (trap-at-procedure-call
+            trap-in-procedure
+            trap-instructions-in-procedure
+            trap-at-procedure-ip-in-range
+            trap-at-source-location
+            trap-frame-finish
+            trap-in-dynamic-extent
+            trap-calls-in-dynamic-extent
+            trap-instructions-in-dynamic-extent
+            trap-calls-to-procedure
+            trap-matching-instructions))
+
+(define-syntax arg-check
+  (syntax-rules ()
+    ((_ arg predicate? message)
+     (if (not (predicate? arg))
+         (error "bad argument ~a_ ~a" 'arg message)))
+    ((_ arg predicate?)
+     (if (not (predicate? arg))
+         (error "bad argument ~a_ expected ~a" 'arg 'predicate?)))))
+
+(define (new-disabled-trap vm enable disable)
+  (let ((enabled? #f))
+    (define-syntax disabled?
+      (identifier-syntax
+       (disabled? (not enabled?))
+       ((set! disabled? val) (set! enabled? (not val)))))
+    
+    (define* (enable-trap #\optional frame)
+      (if enabled? (error "trap already enabled"))
+      (enable frame)
+      (set! enabled? #t)
+      disable-trap)
+    
+    (define* (disable-trap #\optional frame)
+      (if disabled? (error "trap already disabled"))
+      (disable frame)
+      (set! disabled? #t)
+      enable-trap)
+
+    enable-trap))
+
+(define (new-enabled-trap vm frame enable disable)
+  ((new-disabled-trap vm enable disable) frame))
+
+(define (frame-matcher proc match-objcode?)
+  (let ((proc (if (struct? proc)
+                  (procedure proc)
+                  proc)))
+    (if match-objcode?
+        (lambda (frame)
+          (let ((frame-proc (frame-procedure frame)))
+            (or (eq? frame-proc proc)
+                (and (program? frame-proc)
+                     (eq? (program-objcode frame-proc)
+                          (program-objcode proc))))))
+        (lambda (frame)
+          (eq? (frame-procedure frame) proc)))))
+
+;; A basic trap, fires when a procedure is called.
+;;
+(define* (trap-at-procedure-call proc handler #\key (vm (the-vm))
+                                 (closure? #f)
+                                 (our-frame? (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check handler procedure?)
+  (let ()
+    (define (apply-hook frame)
+      (if (our-frame? frame)
+          (handler frame)))
+
+    (new-enabled-trap
+     vm #f
+     (lambda (frame)
+       (add-hook! (vm-apply-hook vm) apply-hook))
+     (lambda (frame)
+       (remove-hook! (vm-apply-hook vm) apply-hook)))))
+
+;; A more complicated trap, traps when control enters a procedure.
+;;
+;; Control can enter a procedure via_
+;;  * A procedure call.
+;;  * A return to a procedure's frame on the stack.
+;;  * A continuation returning directly to an application of this
+;;    procedure.
+;;
+;; Control can leave a procedure via_
+;;  * A normal return from the procedure.
+;;  * An application of another procedure.
+;;  * An invocation of a continuation.
+;;  * An abort.
+;;
+(define* (trap-in-procedure proc enter-handler exit-handler
+                            #\key current-frame (vm (the-vm))
+                            (closure? #f)
+                            (our-frame? (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check enter-handler procedure?)
+  (arg-check exit-handler procedure?)
+  (let ((in-proc? #f))
+    (define (enter-proc frame)
+      (if in-proc?
+          (warn "already in proc" frame)
+          (begin
+            (enter-handler frame)
+            (set! in-proc? #t))))
+
+    (define (exit-proc frame)
+      (if in-proc?
+          (begin
+            (exit-handler frame)
+            (set! in-proc? #f))
+          (warn "not in proc" frame)))
+    
+    (define (apply-hook frame)
+      (if in-proc?
+          (exit-proc frame))
+      (if (our-frame? frame)
+          (enter-proc frame)))
+
+    (define (push-cont-hook frame)
+      (if in-proc?
+          (exit-proc frame)))
+    
+    (define (pop-cont-hook frame)
+      (if in-proc?
+          (exit-proc frame))
+      (if (our-frame? (frame-previous frame))
+          (enter-proc (frame-previous frame))))
+
+    (define (abort-hook frame)
+      (if in-proc?
+          (exit-proc frame))
+      (if (our-frame? frame)
+          (enter-proc frame)))
+
+    (define (restore-hook frame)
+      (if in-proc?
+          (exit-proc frame))
+      (if (our-frame? frame)
+          (enter-proc frame)))
+
+    (new-enabled-trap
+     vm current-frame
+     (lambda (frame)
+       (add-hook! (vm-apply-hook vm) apply-hook)
+       (add-hook! (vm-push-continuation-hook vm) push-cont-hook)
+       (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (add-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (add-hook! (vm-restore-continuation-hook vm) restore-hook)
+       (if (and frame (our-frame? frame))
+           (enter-proc frame)))
+     (lambda (frame)
+       (if in-proc?
+           (exit-proc frame))
+       (remove-hook! (vm-apply-hook vm) apply-hook)
+       (remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
+       (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
+
+;; Building on trap-in-procedure, we have trap-instructions-in-procedure
+;;
+(define* (trap-instructions-in-procedure proc next-handler exit-handler
+                                         #\key current-frame (vm (the-vm))
+                                         (closure? #f)
+                                         (our-frame?
+                                          (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check next-handler procedure?)
+  (arg-check exit-handler procedure?)
+  (let ()
+    (define (next-hook frame)
+      (if (our-frame? frame)
+          (next-handler frame)))
+    
+    (define (enter frame)
+      (add-hook! (vm-next-hook vm) next-hook)
+      (if frame (next-hook frame)))
+
+    (define (exit frame)
+      (exit-handler frame)
+      (remove-hook! (vm-next-hook vm) next-hook))
+
+    (trap-in-procedure proc enter exit
+                       #\current-frame current-frame #\vm vm
+                       #\our-frame? our-frame?)))
+
+(define (non-negative-integer? x)
+  (and (number? x) (integer? x) (exact? x) (not (negative? x))))
+
+(define (positive-integer? x)
+  (and (number? x) (integer? x) (exact? x) (positive? x)))
+
+(define (range? x)
+  (and (list? x)
+       (and-map (lambda (x)
+                  (and (pair? x)
+                       (non-negative-integer? (car x))
+                       (non-negative-integer? (cdr x))))
+                x)))
+
+(define (in-range? range i)
+  (or-map (lambda (bounds)
+            (and (<= (car bounds) i)
+                 (< i (cdr bounds))))
+          range))
+
+;; Building on trap-instructions-in-procedure, we have
+;; trap-at-procedure-ip-in-range.
+;;
+(define* (trap-at-procedure-ip-in-range proc range handler
+                                        #\key current-frame (vm (the-vm))
+                                        (closure? #f)
+                                        (our-frame?
+                                         (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check range range?)
+  (arg-check handler procedure?)
+  (let ((fp-stack '()))
+    (define (cull-frames! fp)
+      (let lp ((frames fp-stack))
+        (if (and (pair? frames) (< (car frames) fp))
+            (lp (cdr frames))
+            (set! fp-stack frames))))
+
+    (define (next-handler frame)
+      (let ((fp (frame-address frame))
+            (ip (frame-instruction-pointer frame)))
+        (cull-frames! fp)
+        (let ((now-in-range? (in-range? range ip))
+              (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
+          (cond
+           (was-in-range?
+            (if (not now-in-range?)
+                (set! fp-stack (cdr fp-stack))))
+           (now-in-range?
+            (set! fp-stack (cons fp fp-stack))
+            (handler frame))))))
+    
+    (define (exit-handler frame)
+      (if (and (pair? fp-stack)
+               (= (car fp-stack) (frame-address frame)))
+          (set! fp-stack (cdr fp-stack))))
+    
+    (trap-instructions-in-procedure proc next-handler exit-handler
+                                    #\current-frame current-frame #\vm vm
+                                    #\our-frame? our-frame?)))
+
+;; FIXME_ define this in objcode somehow. We are reffing the first
+;; uint32 in the objcode, which is the length of the program (without
+;; the meta).
+(define (program-last-ip prog)
+  (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
+
+(define (program-sources-by-line proc file)
+  (let lp ((sources (program-sources-pre-retire proc))
+           (out '()))
+    (if (pair? sources)
+        (lp (cdr sources)
+            (pmatch (car sources)
+              ((,start-ip ,start-file ,start-line . ,start-col)
+               (if (equal? start-file file)
+                   (cons (cons start-line
+                               (if (pair? (cdr sources))
+                                   (pmatch (cadr sources)
+                                     ((,end-ip . _)
+                                      (cons start-ip end-ip))
+                                     (else (error "unexpected")))
+                                   (cons start-ip (program-last-ip proc))))
+                         out)
+                   out))
+              (else (error "unexpected"))))
+        (let ((alist '()))
+          (for-each
+           (lambda (pair)
+             (set! alist
+                   (assv-set! alist (car pair)
+                              (cons (cdr pair)
+                                    (or (assv-ref alist (car pair))
+                                        '())))))
+           out)
+          (sort! alist (lambda (x y) (< (car x) (car y))))
+          alist))))
+
+(define (source->ip-range proc file line)
+  (or (or-map (lambda (line-and-ranges)
+                (cond
+                 ((= (car line-and-ranges) line)
+                  (cdr line-and-ranges))
+                 ((> (car line-and-ranges) line)
+                  (warn "no instructions found at" file "_" line
+                        "; using line" (car line-and-ranges) "instead")
+                  (cdr line-and-ranges))
+                 (else #f)))
+              (program-sources-by-line proc file))
+      (begin
+        (warn "no instructions found for" file "_" line)
+        '())))
+
+(define (source-closures-or-procedures file line)
+  (let ((closures (source-closures file line)))
+    (if (pair? closures)
+        (values closures #t)
+        (values (source-procedures file line) #f))))
+
+;; Building on trap-on-instructions-in-procedure, we have
+;; trap-at-source-location. The parameter `user-line' is one-indexed, as
+;; a user counts lines, instead of zero-indexed, as Guile counts lines.
+;;
+(define* (trap-at-source-location file user-line handler
+                                  #\key current-frame (vm (the-vm)))
+  (arg-check file string?)
+  (arg-check user-line positive-integer?)
+  (arg-check handler procedure?)
+  (let ((traps #f))
+    (call-with-values
+        (lambda () (source-closures-or-procedures file (1- user-line)))
+      (lambda (procs closures?)
+        (new-enabled-trap
+         vm current-frame
+         (lambda (frame)
+           (set! traps
+                 (map
+                  (lambda (proc)
+                    (let ((range (source->ip-range proc file (1- user-line))))
+                      (trap-at-procedure-ip-in-range proc range handler
+                                                     #\current-frame current-frame
+                                                     #\vm vm
+                                                     #\closure? closures?)))
+                  procs))
+           (if (null? traps)
+               (error "No procedures found at ~a_~a." file user-line)))
+         (lambda (frame)
+           (for-each (lambda (trap) (trap frame)) traps)
+           (set! traps #f)))))))
+
+
+
+;; On a different tack, now we're going to build up a set of traps that
+;; do useful things during the dynamic extent of a procedure's
+;; application. First, a trap for when a frame returns.
+;;
+(define* (trap-frame-finish frame return-handler abort-handler
+                            #\key (vm (the-vm)))
+  (arg-check frame frame?)
+  (arg-check return-handler procedure?)
+  (arg-check abort-handler procedure?)
+  (let ((fp (frame-address frame)))
+    (define (pop-cont-hook frame)
+      (if (and fp (eq? (frame-address frame) fp))
+          (begin
+            (set! fp #f)
+            (return-handler frame))))
+    
+    (define (abort-hook frame)
+      (if (and fp (< (frame-address frame) fp))
+          (begin
+            (set! fp #f)
+            (abort-handler frame))))
+    
+    (new-enabled-trap
+     vm frame
+     (lambda (frame)
+       (if (not fp)
+           (error "return-or-abort traps may only be enabled once"))
+       (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (add-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+     (lambda (frame)
+       (set! fp #f)
+       (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+
+;; A more traditional dynamic-wind trap. Perhaps this should not be
+;; based on the above trap-frame-finish?
+;;
+(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
+                                 #\key current-frame (vm (the-vm))
+                                 (closure? #f)
+                                 (our-frame? (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check enter-handler procedure?)
+  (arg-check return-handler procedure?)
+  (arg-check abort-handler procedure?)
+  (let ((exit-trap #f))
+    (define (return-hook frame)
+      (exit-trap frame) ; disable the return/abort trap.
+      (set! exit-trap #f)
+      (return-handler frame))
+    
+    (define (abort-hook frame)
+      (exit-trap frame) ; disable the return/abort trap.
+      (set! exit-trap #f)
+      (abort-handler frame))
+    
+    (define (apply-hook frame)
+      (if (and (not exit-trap) (our-frame? frame))
+          (begin
+            (enter-handler frame)
+            (set! exit-trap
+                  (trap-frame-finish frame return-hook abort-hook
+                                     #\vm vm)))))
+    
+    (new-enabled-trap
+     vm current-frame
+     (lambda (frame)
+       (add-hook! (vm-apply-hook vm) apply-hook))
+     (lambda (frame)
+       (if exit-trap
+           (abort-hook frame))
+       (set! exit-trap #f)
+       (remove-hook! (vm-apply-hook vm) apply-hook)))))
+
+;; Trapping all procedure calls within a dynamic extent, recording the
+;; depth of the call stack relative to the original procedure.
+;;
+(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
+                                       #\key current-frame (vm (the-vm))
+                                       (closure? #f)
+                                       (our-frame?
+                                        (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check apply-handler procedure?)
+  (arg-check return-handler procedure?)
+  (let ((*call-depth* 0))
+    (define (trace-push frame)
+      (set! *call-depth* (1+ *call-depth*)))
+  
+    (define (trace-pop frame)
+      (return-handler frame *call-depth*)
+      (set! *call-depth* (1- *call-depth*)))
+  
+    (define (trace-apply frame)
+      (apply-handler frame *call-depth*))
+  
+    ;; FIXME_ recalc depth on abort
+
+    (define (enter frame)
+      (add-hook! (vm-push-continuation-hook vm) trace-push)
+      (add-hook! (vm-pop-continuation-hook vm) trace-pop)
+      (add-hook! (vm-apply-hook vm) trace-apply))
+  
+    (define (leave frame)
+      (remove-hook! (vm-push-continuation-hook vm) trace-push)
+      (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
+      (remove-hook! (vm-apply-hook vm) trace-apply))
+  
+    (define (return frame)
+      (leave frame))
+  
+    (define (abort frame)
+      (leave frame))
+
+    (trap-in-dynamic-extent proc enter return abort
+                            #\current-frame current-frame #\vm vm
+                            #\our-frame? our-frame?)))
+
+;; Trapping all retired intructions within a dynamic extent.
+;;
+(define* (trap-instructions-in-dynamic-extent proc next-handler
+                                              #\key current-frame (vm (the-vm))
+                                              (closure? #f)
+                                              (our-frame?
+                                               (frame-matcher proc closure?)))
+  (arg-check proc procedure?)
+  (arg-check next-handler procedure?)
+  (let ()
+    (define (trace-next frame)
+      (next-handler frame))
+  
+    (define (enter frame)
+      (add-hook! (vm-next-hook vm) trace-next))
+  
+    (define (leave frame)
+      (remove-hook! (vm-next-hook vm) trace-next))
+  
+    (define (return frame)
+      (leave frame))
+  
+    (define (abort frame)
+      (leave frame))
+
+    (trap-in-dynamic-extent proc enter return abort
+                            #\current-frame current-frame #\vm vm
+                            #\our-frame? our-frame?)))
+
+;; Traps calls and returns for a given procedure, keeping track of the call depth.
+;;
+(define* (trap-calls-to-procedure proc apply-handler return-handler
+                                  #\key (vm (the-vm)))
+  (arg-check proc procedure?)
+  (arg-check apply-handler procedure?)
+  (arg-check return-handler procedure?)
+  (let ((pending-finish-traps '())
+        (last-fp #f))
+    (define (apply-hook frame)
+      (let ((depth (length pending-finish-traps)))
+
+        (apply-handler frame depth)
+
+        (if (not (eq? (frame-address frame) last-fp))
+            (let ((finish-trap #f))
+              (define (frame-finished frame)
+                (finish-trap frame) ;; disables the trap.
+                (set! pending-finish-traps
+                      (delq finish-trap pending-finish-traps))
+                (set! finish-trap #f))
+              
+              (define (return-hook frame)
+                (frame-finished frame)
+                (return-handler frame depth))
+        
+              ;; FIXME_ abort handler?
+              (define (abort-hook frame)
+                (frame-finished frame))
+        
+              (set! finish-trap
+                    (trap-frame-finish frame return-hook abort-hook #\vm vm))
+              (set! pending-finish-traps
+                    (cons finish-trap pending-finish-traps))))))
+
+    ;; The basic idea is that we install one trap that fires for calls,
+    ;; but that each call installs its own finish trap. Those finish
+    ;; traps remove themselves as their frames finish or abort.
+    ;;
+    ;; However since to the outside world we present the interface of
+    ;; just being one trap, disabling this calls-to-procedure trap
+    ;; should take care of disabling all of the pending finish traps. We
+    ;; keep track of pending traps through the pending-finish-traps
+    ;; list.
+    ;;
+    ;; So since we know that the trap-at-procedure will be enabled, and
+    ;; thus returning a disable closure, we make sure to wrap that
+    ;; closure in something that will disable pending finish traps.
+    (define (with-pending-finish-disablers trap)
+      (define (with-pending-finish-enablers trap)
+        (lambda* (#\optional frame)
+          (with-pending-finish-disablers (trap frame))))
+      
+      (lambda* (#\optional frame)
+        (for-each (lambda (disable) (disable frame))
+                  pending-finish-traps)
+        (set! pending-finish-traps '())
+        (with-pending-finish-enablers (trap frame))))
+
+    (with-pending-finish-disablers
+     (trap-at-procedure-call proc apply-hook #\vm vm))))
+
+;; Trap when the source location changes.
+;;
+(define* (trap-matching-instructions frame-pred handler
+                                     #\key (vm (the-vm)))
+  (arg-check frame-pred procedure?)
+  (arg-check handler procedure?)
+  (let ()
+    (define (next-hook frame)
+      (if (frame-pred frame)
+          (handler frame)))
+  
+    (new-enabled-trap
+     vm #f
+     (lambda (frame)
+       (add-hook! (vm-next-hook vm) next-hook))
+     (lambda (frame)
+       (remove-hook! (vm-next-hook vm) next-hook)))))
+;;; Guile VM core
+
+;;; Copyright (C) 2001, 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
+
+;;; Code_
+
+(define-module (system vm vm)
+  #\export (vm?
+            make-vm the-vm call-with-vm
+            vm_ip vm_sp vm_fp
+
+            vm-trace-level set-vm-trace-level!
+            vm-engine set-vm-engine! set-default-vm-engine!
+            vm-push-continuation-hook vm-pop-continuation-hook
+            vm-apply-hook
+            vm-next-hook
+            vm-abort-continuation-hook vm-restore-continuation-hook))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_vm")
+;;;; 	Copyright (C) 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 2.1 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 (system xref)
+  #\use-module (system base pmatch)
+  #\use-module (system base compile)
+  #\use-module (system vm program)
+  #\use-module (srfi srfi-1)
+  #\export (*xref-ignored-modules*
+            procedure-callees
+            procedure-callers
+            source-closures
+            source-procedures))
+
+;;;
+;;; The cross-reference database_ who calls whom.
+;;;
+
+(define (program-callee-rev-vars prog)
+  (define (cons-uniq x y)
+    (if (memq x y) y (cons x y)))
+  (cond
+   ((program-objects prog)
+    => (lambda (objects)
+          (let ((n (vector-length objects))
+                (progv (make-vector (vector-length objects) #f))
+                (asm (decompile (program-objcode prog) #\to 'assembly)))
+            (pmatch asm
+              ((load-program ,labels ,len . ,body)
+               (for-each
+                (lambda (x)
+                  (pmatch x
+                    ((toplevel-ref ,n) (vector-set! progv n #t))
+                    ((toplevel-set ,n) (vector-set! progv n #t))))
+                body)))
+            (let lp ((i 0) (out '()))
+              (cond
+               ((= i n) out)
+               ((program? (vector-ref objects i))
+                (lp (1+ i)
+                    (fold cons-uniq out
+                          (program-callee-rev-vars (vector-ref objects i)))))
+               ((vector-ref progv i)
+                (let ((obj (vector-ref objects i)))
+                  (if (variable? obj)
+                      (lp (1+ i) (cons-uniq obj out))
+                      ;; otherwise it's an unmemoized binding
+                      (pmatch obj
+                        (,sym (guard (symbol? sym))
+                         (let ((v (module-variable (or (program-module prog)
+                                                       the-root-module)
+                                                   sym)))
+                           (lp (1+ i) (if v (cons-uniq v out) out))))
+                        ((,mod ,sym ,public?)
+                         ;; hm, hacky.
+                         (let* ((m (nested-ref-module (resolve-module '() #f)
+                                                      mod))
+                                (v (and m
+                                        (module-variable
+                                         (if public?
+                                             (module-public-interface m)
+                                             m)
+                                         sym))))
+                           (lp (1+ i)
+                               (if v (cons-uniq v out) out))))))))
+               (else (lp (1+ i) out)))))))
+   (else '())))
+
+(define (procedure-callee-rev-vars proc)
+  (cond
+   ((program? proc) (program-callee-rev-vars proc))
+   (else '())))
+
+(define (procedure-callees prog)
+  "Evaluates to a list of the given program callees."
+  (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
+    (cond ((null? in) out)
+          ((variable-bound? (car in))
+           (lp (cdr in) (cons (variable-ref (car in)) out)))
+          (else (lp (cdr in) out)))))
+
+;; var -> ((module-name caller ...) ...)
+(define *callers-db* #f)
+;; module-name -> (callee ...)
+(define *module-callees-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-modules* '())
+
+(define *xref-ignored-modules* '((value-history)))
+(define (on-module-modified m)
+  (let ((name (module-name m)))
+    (if (and (not (member name *xref-ignored-modules*))
+             (not (member name *tainted-modules*))
+             (pair? name))
+        (set! *tainted-modules* (cons name *tainted-modules*)))))
+
+(define (add-caller callee caller mod-name)
+  (let ((all-callers (hashq-ref *callers-db* callee)))
+    (if (not all-callers)
+        (hashq-set! *callers-db* callee `((,mod-name ,caller)))
+        (let ((callers (assoc mod-name all-callers)))
+          (if callers
+              (if (not (member caller callers))
+                  (set-cdr! callers (cons caller (cdr callers))))
+              (hashq-set! *callers-db* callee
+                          (cons `(,mod-name ,caller) all-callers)))))))
+
+(define (forget-callers callee mod-name)
+  (hashq-set! *callers-db* callee
+             (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
+
+(define (add-callees callees mod-name)
+  (hash-set! *module-callees-db* mod-name
+             (append callees (hash-ref *module-callees-db* mod-name '()))))
+
+(define (untaint-modules)
+  (define (untaint m)
+    (for-each (lambda (callee) (forget-callers callee m))
+              (hash-ref *module-callees-db* m '()))
+    (ensure-callers-db m))
+  (ensure-callers-db #f)
+  (for-each untaint *tainted-modules*)
+  (set! *tainted-modules* '()))
+
+(define (ensure-callers-db mod-name)
+  (let ((mod (and mod-name (resolve-module mod-name)))
+        (visited #f))
+    (define (visit-variable var mod-name)
+      (if (variable-bound? var)
+          (let ((x (variable-ref var)))
+            (cond
+             ((and visited (hashq-ref visited x)))
+             ((procedure? x)
+              (if visited (hashq-set! visited x #t))
+              (let ((callees (filter variable-bound?
+                                     (procedure-callee-rev-vars x))))
+                (for-each (lambda (callee)
+                            (add-caller callee x mod-name))
+                          callees)
+                (add-callees callees mod-name)))))))
+
+    (define (visit-module mod)
+      (if visited (hashq-set! visited mod #t))
+      (if (not (memq on-module-modified (module-observers mod)))
+          (module-observe mod on-module-modified))
+      (let ((name (module-name mod)))
+        (module-for-each (lambda (sym var)
+                           (visit-variable var name))
+                         mod)))
+
+    (define (visit-submodules mod)
+      (hash-for-each
+       (lambda (name sub)
+         (if (not (and visited (hashq-ref visited sub)))
+             (begin
+               (visit-module sub)
+               (visit-submodules sub))))
+       (module-submodules mod)))
+
+    (cond ((and (not mod-name) (not *callers-db*))
+           (set! *callers-db* (make-hash-table 1000))
+           (set! visited (make-hash-table 1000))
+           (visit-submodules (resolve-module '() #f)))
+          (mod-name (visit-module mod)))))
+
+(define (procedure-callers var)
+  "Returns an association list, keyed by module name, of known callers
+of the given procedure. The latter can specified directly as a
+variable, a symbol (which gets resolved in the current module) or a
+pair of the form (module-name . variable-name), "
+  (let ((v (cond ((variable? var) var)
+                 ((symbol? var) (module-variable (current-module) var))
+                 (else
+                  (pmatch var
+                    ((,modname . ,sym)
+                     (module-variable (resolve-module modname) sym))
+                    (else
+                     (error "expected a variable, symbol, or (modname . sym)" var)))))))
+    (untaint-modules)
+    (hashq-ref *callers-db* v '())))
+
+
+
+;;;
+;;; The source database_ procedures defined at a given source location.
+;;;
+
+;; FIXME_ refactor to share code with the xref database.
+
+;; ((ip file line . col) ...)
+(define (procedure-sources proc)
+  (cond
+   ((program? proc) (program-sources proc))
+   (else '())))
+
+;; file -> line -> (proc ...)
+(define *closure-sources-db* #f)
+;; file -> line -> (proc ...)
+(define *sources-db* #f)
+;; module-name -> proc -> sources
+(define *module-sources-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-sources* '())
+
+(define (on-source-modified m)
+  (let ((name (module-name m)))
+    (if (and (not (member name *xref-ignored-modules*))
+             (not (member name *tainted-sources*))
+             (pair? name))
+        (set! *tainted-sources* (cons name *tainted-sources*)))))
+
+(define (add-source proc file line db)
+  (let ((file-table (or (hash-ref db file)
+                        (let ((table (make-hash-table)))
+                          (hash-set! db file table)
+                          table))))
+    (hashv-set! file-table
+                line
+                (cons proc (hashv-ref file-table line '())))))
+
+(define (forget-source proc file line db)
+  (let ((file-table (hash-ref db file)))
+    (if file-table
+        (let ((procs (delq proc (hashv-ref file-table line '()))))
+          (if (pair? procs)
+              (hashv-set! file-table line procs)
+              (hashv-remove! file-table line))))))
+
+(define (add-sources proc mod-name db)
+  (let ((sources (procedure-sources proc)))
+    (if (pair? sources)
+        (begin
+          ;; Add proc to *module-sources-db*, for book-keeping.
+          (hashq-set! (or (hash-ref *module-sources-db* mod-name)
+                          (let ((table (make-hash-table)))
+                            (hash-set! *module-sources-db* mod-name table)
+                            table))
+                      proc
+                      sources)
+          ;; Actually add the source entries.
+          (for-each (lambda (source)
+                      (pmatch source
+                        ((,ip ,file ,line . ,col)
+                         (add-source proc file line db))
+                        (else (error "unexpected source format" source))))
+                    sources)))
+    ;; Add source entries for nested procedures.
+    (for-each (lambda (obj)
+                (if (procedure? obj)
+                    (add-sources obj mod-name *closure-sources-db*)))
+              (or (and (program? proc)
+                       (and=> (program-objects proc) vector->list))
+                  '()))))
+
+(define (forget-sources proc mod-name db)
+  (let ((mod-table (hash-ref *module-sources-db* mod-name)))
+    (if mod-table
+        (begin
+          ;; Forget source entries.
+          (for-each (lambda (source)
+                      (pmatch source
+                        ((,ip ,file ,line . ,col)
+                         (forget-source proc file line db))
+                        (else (error "unexpected source format" source))))
+                    (hashq-ref mod-table proc '()))
+          ;; Forget the proc.
+          (hashq-remove! mod-table proc)
+          ;; Forget source entries for nested procedures.
+          (for-each (lambda (obj)
+                (if (procedure? obj)
+                    (forget-sources obj mod-name *closure-sources-db*)))
+              (or (and (program? proc)
+                       (and=> (program-objects proc) vector->list))
+                  '()))))))
+
+(define (untaint-sources)
+  (define (untaint m)
+    (for-each (lambda (proc) (forget-sources proc m *sources-db*))
+              (cond
+               ((hash-ref *module-sources-db* m)
+                => (lambda (table)
+                     (hash-for-each (lambda (proc sources) proc) table)))
+               (else '())))
+    (ensure-sources-db m))
+  (ensure-sources-db #f)
+  (for-each untaint *tainted-sources*)
+  (set! *tainted-sources* '()))
+
+(define (ensure-sources-db mod-name)
+  (define (visit-module mod)
+    (if (not (memq on-source-modified (module-observers mod)))
+        (module-observe mod on-source-modified))
+    (let ((name (module-name mod)))
+      (module-for-each
+       (lambda (sym var)
+         (if (variable-bound? var)
+             (let ((x (variable-ref var)))
+               (if (procedure? x)
+                   (add-sources x name *sources-db*)))))
+       mod)))
+
+  (define visit-submodules
+    (let ((visited #f))
+      (lambda (mod)
+        (if (not visited)
+            (set! visited (make-hash-table)))
+        (hash-for-each
+         (lambda (name sub)
+           (if (not (hashq-ref visited sub))
+               (begin
+                 (hashq-set! visited sub #t)
+                 (visit-module sub)
+                 (visit-submodules sub))))
+         (module-submodules mod)))))
+
+  (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*))
+         (set! *closure-sources-db* (make-hash-table 1000))
+         (set! *sources-db* (make-hash-table 1000))
+         (visit-submodules (resolve-module '() #f)))
+        (mod-name (visit-module (resolve-module mod-name)))))
+
+(define (lines->ranges file-table)
+  (let ((ranges (make-hash-table)))
+    (hash-for-each
+     (lambda (line procs)
+       (for-each
+        (lambda (proc)
+          (cond
+           ((hashq-ref ranges proc)
+            => (lambda (pair)
+                 (if (< line (car pair))
+                     (set-car! pair line))
+                 (if (> line (cdr pair))
+                     (set-cdr! pair line))))
+           (else
+            (hashq-set! ranges proc (cons line line)))))
+        procs))
+     file-table)
+    (sort! (hash-map->list cons ranges)
+           (lambda (x y) (< (cadr x) (cadr y))))))
+
+(define* (lookup-source-procedures canon-file line db)
+  (let ((file-table (hash-ref db canon-file)))
+    (let lp ((ranges (if file-table (lines->ranges file-table) '()))
+             (procs '()))
+      (cond
+       ((null? ranges) (reverse procs))
+       ((<= (cadar ranges) line (cddar ranges))
+        (lp (cdr ranges) (cons (caar ranges) procs)))
+       (else
+        (lp (cdr ranges) procs))))))
+
+(define* (source-closures file line #\key (canonicalization 'relative))
+  (ensure-sources-db #f)
+  (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+                 (false-if-exception (open-input-file file))))
+         (file (if port (port-filename port) file)))
+    (lookup-source-procedures file line *closure-sources-db*)))
+
+(define* (source-procedures file line #\key (canonicalization 'relative))
+  (ensure-sources-db #f)
+  (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+                 (false-if-exception (open-input-file file))))
+         (file (if port (port-filename port) file)))
+    (lookup-source-procedures file line *sources-db*)))
+;;;; (texinfo) -- parsing of texinfo into SXML
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;;;;    Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
+;;;;
+;;;; This file is based on SSAX's SSAX.scm.
+;;;; 
+;;;; 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_
+;;
+;; @subheading Texinfo processing in scheme
+;; 
+;; This module parses texinfo into SXML. TeX will always be the
+;; processor of choice for print output, of course. However, although
+;; @code{makeinfo} works well for info, its output in other formats is
+;; not very customizable, and the program is not extensible as a whole.
+;; This module aims to provide an extensible framework for texinfo
+;; processing that integrates texinfo into the constellation of SXML
+;; processing tools.
+;; 
+;; @subheading Notes on the SXML vocabulary
+;;
+;; Consider the following texinfo fragment_
+;; 
+;;@example
+;; @@deffn Primitive set-car! pair value
+;; This function...
+;; @@end deffn
+;;@end example
+;; 
+;; Logically, the category (Primitive), name (set-car!), and arguments
+;; (pair value) are ``attributes'' of the deffn, with the description as
+;; the content. However, texinfo allows for @@-commands within the
+;; arguments to an environment, like @code{@@deffn}, which means that
+;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand,
+;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are
+;; called ``arguments'', and are grouped under the special element, `%'.
+;;
+;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In
+;; the interests of interoperability, this module provides a conversion
+;; function to replace the `%' with `texinfo-arguments'.
+;; 
+;;; Code_
+
+;; Comparison to xml output of texinfo (which is rather undocumented)_
+;;  Doesn't conform to texinfo dtd
+;;  No DTD at all, in fact _-/
+;;  Actually outputs valid xml, after transforming %
+;;  Slower (although with caching the SXML that problem can go away)
+;;  Doesn't parse menus (although menus are shite)
+;;  Args go in a dedicated element, FBOFW
+;;  Definitions are handled a lot better
+;;  Does parse comments
+;;  Outputs only significant line breaks (a biggie!)
+;;  Nodes are treated as anchors, rather than content organizers (a biggie)
+;;    (more book-like, less info-like)
+
+;; TODO
+;; Integration_ help, indexing, plain text
+
+(define-module (texinfo)
+  #\use-module (sxml simple)
+  #\use-module (sxml transform)
+  #\use-module (sxml ssax input-parse)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-11)
+  #\use-module (srfi srfi-13)
+  #\export (call-with-file-and-dir
+            texi-command-specs
+            texi-command-depth
+            texi-fragment->stexi
+            texi->stexi
+            stexi->sxml))
+
+;; Some utilities
+
+(define (parser-error port message . rest)
+  (apply throw 'parser-error port message rest))
+
+(define (call-with-file-and-dir filename proc)
+  "Call the one-argument procedure @var{proc} with an input port that
+reads from @var{filename}. During the dynamic extent of @var{proc}'s
+execution, the current directory will be @code{(dirname
+@var{filename})}. This is useful for parsing documents that can include
+files by relative path name."
+  (let ((current-dir (getcwd)))
+    (dynamic-wind
+        (lambda () (chdir (dirname filename)))
+        (lambda ()
+          (call-with-input-file (basename filename) proc))
+        (lambda () (chdir current-dir)))))
+
+;;========================================================================
+;;            Reflection on the XML vocabulary
+
+(define texi-command-specs
+  ;~
+"A list of (@var{name} @var{content-model} . @var{args})
+
+@table @var
+@item name 
+The name of an @@-command, as a symbol.
+
+@item content-model
+A symbol indicating the syntactic type of the @@-command_
+@table @code
+@item EMPTY-COMMAND
+No content, and no @code{@@end} is coming
+@item EOL-ARGS
+Unparsed arguments until end of line
+@item EOL-TEXT
+Parsed arguments until end of line
+@item INLINE-ARGS
+Unparsed arguments ending with @code{#\\@}}
+@item INLINE-TEXT
+Parsed arguments ending with @code{#\\@}}
+@item INLINE-TEXT-ARGS
+Parsed arguments ending with @code{#\\@}}
+@item ENVIRON
+The tag is an environment tag, expect @code{@@end foo}.
+@item TABLE-ENVIRON
+Like ENVIRON, but with special parsing rules for its arguments.
+@item FRAGMENT
+For @code{*fragment*}, the command used for parsing fragments of
+texinfo documents.
+@end table
+
+@code{INLINE-TEXT} commands will receive their arguments within their
+bodies, whereas the @code{-ARGS} commands will receive them in their
+attribute list.
+
+@code{EOF-TEXT} receives its arguments in its body.
+
+@code{ENVIRON} commands have both_ parsed arguments until the end of
+line, received through their attribute list, and parsed text until the
+@code{@@end}, received in their bodies.
+
+@code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in
+@code{ENVIRON}.
+
+In addition, @code{ALIAS} can alias one command to another.  The alias
+will never be seen in parsed stexinfo.
+
+There are four @@-commands that are treated specially. @code{@@include}
+is a low-level token that will not be seen by higher-level parsers, so
+it has no content-model. @code{@@para} is the paragraph command, which
+is only implicit in the texinfo source. @code{@@item} has special
+syntax, as noted above, and @code{@@entry} is how this parser treats
+@code{@@item} commands within @code{@@table}, @code{@@ftable}, and
+@code{@@vtable}.
+
+Also, indexing commands (@code{@@cindex}, etc.) are treated specially.
+Their arguments are parsed, but they are needed before entering the
+element so that an anchor can be inserted into the text before the index
+entry.
+
+@item args
+Named arguments to the command, in the same format as the formals for a
+lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
+@code{INLINE-TEXT-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
+@end table"
+  '(;; Special commands
+    (include            #f) ;; this is a low-level token
+    (para               PARAGRAPH)
+    (item               ITEM)
+    (entry              ENTRY . heading)
+    (noindent           EMPTY-COMMAND)
+    (*fragment*         FRAGMENT)
+
+    ;; Inline text commands
+    (*braces*           INLINE-TEXT) ;; FIXME_ make me irrelevant
+    (bold               INLINE-TEXT)
+    (sample             INLINE-TEXT)
+    (samp               INLINE-TEXT)
+    (code               INLINE-TEXT)
+    (math               INLINE-TEXT)
+    (kbd                INLINE-TEXT)
+    (key                INLINE-TEXT)
+    (var                INLINE-TEXT)
+    (env                INLINE-TEXT)
+    (file               INLINE-TEXT)
+    (command            INLINE-TEXT)
+    (option             INLINE-TEXT)
+    (dfn                INLINE-TEXT)
+    (cite               INLINE-TEXT)
+    (acro               INLINE-TEXT)
+    (email              INLINE-TEXT)
+    (emph               INLINE-TEXT)
+    (strong             INLINE-TEXT)
+    (sample             INLINE-TEXT)
+    (sc                 INLINE-TEXT)
+    (titlefont          INLINE-TEXT)
+    (asis               INLINE-TEXT)
+    (b                  INLINE-TEXT)
+    (i                  INLINE-TEXT)
+    (r                  INLINE-TEXT)
+    (sansserif          INLINE-TEXT)
+    (slanted            INLINE-TEXT)
+    (t                  INLINE-TEXT)
+
+    ;; Inline args commands
+    (value              INLINE-ARGS . (key))
+    (ref                INLINE-ARGS . (node #\opt name section info-file manual))
+    (xref               INLINE-ARGS . (node #\opt name section info-file manual))
+    (pxref              INLINE-TEXT-ARGS
+                        . (node #\opt name section info-file manual))
+    (url                ALIAS       . uref)
+    (uref               INLINE-ARGS . (url #\opt title replacement))
+    (anchor             INLINE-ARGS . (name))
+    (dots               INLINE-ARGS . ())
+    (result             INLINE-ARGS . ())
+    (bullet             INLINE-ARGS . ())
+    (copyright          INLINE-ARGS . ())
+    (tie                INLINE-ARGS . ())
+    (image              INLINE-ARGS . (file #\opt width height alt-text extension))
+
+    ;; Inline parsed args commands
+    (acronym            INLINE-TEXT-ARGS . (acronym #\opt meaning))
+
+    ;; EOL args elements
+    (node               EOL-ARGS . (name #\opt next previous up))
+    (c                  EOL-ARGS . all)
+    (comment            EOL-ARGS . all)
+    (setchapternewpage  EOL-ARGS . all)
+    (sp                 EOL-ARGS . all)
+    (page               EOL-ARGS . ())
+    (vskip              EOL-ARGS . all)
+    (syncodeindex       EOL-ARGS . all)
+    (contents           EOL-ARGS . ())
+    (shortcontents      EOL-ARGS . ())
+    (summarycontents    EOL-ARGS . ())
+    (insertcopying      EOL-ARGS . ())
+    (dircategory        EOL-ARGS . (category))
+    (top		EOL-ARGS . (title))
+    (printindex		EOL-ARGS . (type))
+    (paragraphindent    EOL-ARGS . (indent))
+
+    ;; EOL text commands
+    (*ENVIRON-ARGS*     EOL-TEXT)
+    (itemx              EOL-TEXT)
+    (set                EOL-TEXT)
+    (center             EOL-TEXT)
+    (title              EOL-TEXT)
+    (subtitle           EOL-TEXT)
+    (author             EOL-TEXT)
+    (chapter            EOL-TEXT)
+    (section            EOL-TEXT)
+    (appendix           EOL-TEXT)
+    (appendixsec        EOL-TEXT)
+    (unnumbered         EOL-TEXT)
+    (unnumberedsec      EOL-TEXT)
+    (subsection         EOL-TEXT)
+    (subsubsection      EOL-TEXT)
+    (appendixsubsec     EOL-TEXT)
+    (appendixsubsubsec  EOL-TEXT)
+    (unnumberedsubsec   EOL-TEXT)
+    (unnumberedsubsubsec EOL-TEXT)
+    (chapheading        EOL-TEXT)
+    (majorheading       EOL-TEXT)
+    (heading            EOL-TEXT)
+    (subheading         EOL-TEXT)
+    (subsubheading      EOL-TEXT)
+
+    (deftpx             EOL-TEXT-ARGS . (category name . attributes))
+    (defcvx             EOL-TEXT-ARGS . (category class name))
+    (defivarx           EOL-TEXT-ARGS . (class name))
+    (deftypeivarx       EOL-TEXT-ARGS . (class data-type name))
+    (defopx             EOL-TEXT-ARGS . (category class name . arguments))
+    (deftypeopx         EOL-TEXT-ARGS . (category class data-type name . arguments))
+    (defmethodx         EOL-TEXT-ARGS . (class name . arguments))
+    (deftypemethodx     EOL-TEXT-ARGS . (class data-type name . arguments))
+    (defoptx            EOL-TEXT-ARGS . (name))
+    (defvrx             EOL-TEXT-ARGS . (category name))
+    (defvarx            EOL-TEXT-ARGS . (name))
+    (deftypevrx         EOL-TEXT-ARGS . (category data-type name))
+    (deftypevarx        EOL-TEXT-ARGS . (data-type name))
+    (deffnx             EOL-TEXT-ARGS . (category name . arguments))
+    (deftypefnx         EOL-TEXT-ARGS . (category data-type name . arguments))
+    (defspecx           EOL-TEXT-ARGS . (name . arguments))
+    (defmacx            EOL-TEXT-ARGS . (name . arguments))
+    (defunx             EOL-TEXT-ARGS . (name . arguments))
+    (deftypefunx        EOL-TEXT-ARGS . (data-type name . arguments))
+
+    ;; Indexing commands
+    (cindex             INDEX . entry)
+    (findex             INDEX . entry)
+    (vindex             INDEX . entry)
+    (kindex             INDEX . entry)
+    (pindex             INDEX . entry)
+    (tindex             INDEX . entry)
+
+    ;; Environment commands (those that need @end)
+    (texinfo            ENVIRON . title)
+    (ignore             ENVIRON . ())
+    (ifinfo             ENVIRON . ())
+    (iftex              ENVIRON . ())
+    (ifhtml             ENVIRON . ())
+    (ifxml              ENVIRON . ())
+    (ifplaintext        ENVIRON . ())
+    (ifnotinfo          ENVIRON . ())
+    (ifnottex           ENVIRON . ())
+    (ifnothtml          ENVIRON . ())
+    (ifnotxml           ENVIRON . ())
+    (ifnotplaintext     ENVIRON . ())
+    (titlepage          ENVIRON . ())
+    (menu               ENVIRON . ())
+    (direntry           ENVIRON . ())
+    (copying            ENVIRON . ())
+    (example            ENVIRON . ())
+    (smallexample       ENVIRON . ())
+    (display            ENVIRON . ())
+    (smalldisplay       ENVIRON . ())
+    (verbatim           ENVIRON . ())
+    (format             ENVIRON . ())
+    (smallformat        ENVIRON . ())
+    (lisp               ENVIRON . ())
+    (smalllisp          ENVIRON . ())
+    (cartouche          ENVIRON . ())
+    (quotation          ENVIRON . ())
+
+    (deftp              ENVIRON . (category name . attributes))
+    (defcv              ENVIRON . (category class name))
+    (defivar            ENVIRON . (class name))
+    (deftypeivar        ENVIRON . (class data-type name))
+    (defop              ENVIRON . (category class name . arguments))
+    (deftypeop          ENVIRON . (category class data-type name . arguments))
+    (defmethod          ENVIRON . (class name . arguments))
+    (deftypemethod      ENVIRON . (class data-type name . arguments))
+    (defopt             ENVIRON . (name))
+    (defvr              ENVIRON . (category name))
+    (defvar             ENVIRON . (name))
+    (deftypevr          ENVIRON . (category data-type name))
+    (deftypevar         ENVIRON . (data-type name))
+    (deffn              ENVIRON . (category name . arguments))
+    (deftypefn          ENVIRON . (category data-type name . arguments))
+    (defspec            ENVIRON . (name . arguments))
+    (defmac             ENVIRON . (name . arguments))
+    (defun              ENVIRON . (name . arguments))
+    (deftypefun         ENVIRON . (data-type name . arguments))
+
+    (table              TABLE-ENVIRON . (formatter))
+    (itemize            TABLE-ENVIRON . (formatter))
+    (enumerate          TABLE-ENVIRON . (start))
+    (ftable             TABLE-ENVIRON . (formatter))
+    (vtable             TABLE-ENVIRON . (formatter))))
+
+(define command-depths
+  '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4)
+    (top . 0) (unnumbered . 1) (unnumberedsec . 2)
+    (unnumberedsubsec . 3) (unnumberedsubsubsec . 4)
+    (appendix . 1) (appendixsec . 2) (appendixsection . 2)
+    (appendixsubsec . 3) (appendixsubsubsec . 4)))
+(define (texi-command-depth command max-depth)
+  "Given the texinfo command @var{command}, return its nesting level, or
+@code{#f} if it nests too deep for @var{max-depth}.
+
+Examples_
+@example
+ (texi-command-depth 'chapter 4)        @result{} 1
+ (texi-command-depth 'top 4)            @result{} 0
+ (texi-command-depth 'subsection 4)     @result{} 3
+ (texi-command-depth 'appendixsubsec 4) @result{} 3
+ (texi-command-depth 'subsection 2)     @result{} #f
+@end example"
+  (let ((depth (and=> (assq command command-depths) cdr)))
+    (and depth (<= depth max-depth) depth)))
+
+;; The % is for arguments
+(define (space-significant? command)
+  (memq command
+        '(example smallexample verbatim lisp smalllisp menu %)))
+
+;; Like a DTD for texinfo
+(define (command-spec command)
+  (let ((spec (assq command texi-command-specs)))
+    (cond
+     ((not spec)
+      (parser-error #f "Unknown command" command))
+     ((eq? (cadr spec) 'ALIAS)
+      (command-spec (cddr spec)))
+     (else
+      spec))))
+
+(define (inline-content? content)
+  (case content
+    ((INLINE-TEXT INLINE-ARGS INLINE-TEXT-ARGS) #t)
+    (else #f)))
+
+
+;;========================================================================
+;;		Lower-level parsers and scanners
+;;
+;; They deal with primitive lexical units (Names, whitespaces, tags) and
+;; with pieces of more generic productions. Most of these parsers must
+;; be called in appropriate context. For example, complete-start-command
+;; must be called only when the @-command start has been detected and
+;; its name token has been read.
+
+;; Test if a string is made of only whitespace
+;; An empty string is considered made of whitespace as well
+(define (string-whitespace? str)
+  (or (string-null? str)
+      (string-every char-whitespace? str)))
+
+;; Like read-text-line, but allows EOF.
+(define read-eof-breaks '(*eof* #\return #\newline))
+(define (read-eof-line port)
+  (if (eof-object? (peek-char port))
+      (peek-char port)
+      (let* ((line (next-token '() read-eof-breaks
+                               "reading a line" port))
+             (c (read-char port)))	; must be either \n or \r or EOF
+        (if (and (eq? c #\return) (eq? (peek-char port) #\newline))
+            (read-char port))		; skip \n that follows \r
+        line)))
+
+(define (skip-whitespace port)
+  (skip-while '(#\space #\tab #\return #\newline) port))
+
+(define (skip-horizontal-whitespace port)
+  (skip-while '(#\space #\tab) port))
+
+;; command __= Letter+
+
+;; procedure_   read-command PORT
+;;
+;; Read a command starting from the current position in the PORT and
+;; return it as a symbol.
+(define (read-command port)
+  (let ((first-char (peek-char port)))
+    (or (char-alphabetic? first-char)
+        (parser-error port "Nonalphabetic @-command char_ '" first-char "'")))
+  (string->symbol
+    (next-token-of
+      (lambda (c)
+        (cond
+          ((eof-object? c) #f)
+          ((char-alphabetic? c) c)
+          (else #f)))
+      port)))
+
+;; A token is a primitive lexical unit. It is a record with two fields,
+;; token-head and token-kind.
+;;
+;; Token types_
+;;      END     The end of a texinfo command. If the command is ended by },
+;;              token-head will be #f. Otherwise if the command is ended by
+;;              @end COMMAND, token-head will be COMMAND. As a special case,
+;;              @bye is the end of a special @texinfo command.
+;;      START   The start of a texinfo command. The token-head will be a
+;;              symbol of the @-command name.
+;;      INCLUDE An @include directive. The token-head will be empty -- the
+;;              caller is responsible for reading the include file name.
+;;      ITEM    @item commands have an irregular syntax. They end at the
+;;              next @item, or at the end of the environment. For that
+;;              read-command-token treats them specially.
+
+(define (make-token kind head) (cons kind head))
+(define token? pair?)
+(define token-kind car)
+(define token-head cdr)
+
+;; procedure_	read-command-token PORT
+;;
+;; This procedure starts parsing of a command token. The current
+;; position in the stream must be #\@. This procedure scans enough of
+;; the input stream to figure out what kind of a command token it is
+;; seeing. The procedure returns a token structure describing the token.
+
+(define (read-command-token port)
+  (assert-curr-char '(#\@) "start of the command" port)
+  (let ((peeked (peek-char port)))
+    (cond
+     ((memq peeked '(#\! #\_ #\. #\? #\@ #\\ #\{ #\}))
+      ;; @-commands that escape characters
+      (make-token 'STRING (string (read-char port))))
+     (else
+      (let ((name (read-command port)))
+        (case name
+          ((end)
+           ;; got an ending tag
+           (let ((command (string-trim-both
+                           (read-eof-line port))))
+             (or (and (not (string-null? command))
+                      (string-every char-alphabetic? command))
+                 (parser-error port "malformed @end" command))
+             (make-token 'END (string->symbol command))))
+          ((bye)
+           ;; the end of the top
+           (make-token 'END 'texinfo))
+          ((item)
+           (make-token 'ITEM 'item))
+          ((include)
+           (make-token 'INCLUDE #f))
+          (else
+           (make-token 'START name))))))))
+
+;; procedure+_ 	read-verbatim-body PORT STR-HANDLER SEED
+;;
+;; This procedure must be called after we have read a string
+;; "@verbatim\n" that begins a verbatim section. The current position
+;; must be the first position of the verbatim body. This function reads
+;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a
+;; character data consumer.
+;;
+;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED.
+;; The first STRING1 argument to STR-HANDLER never contains a newline.
+;; The second STRING2 argument often will. On the first invocation of the
+;; STR-HANDLER, the seed is the one passed to read-verbatim-body
+;; as the third argument. The result of this first invocation will be
+;; passed as the seed argument to the second invocation of the line
+;; consumer, and so on. The result of the last invocation of the
+;; STR-HANDLER is returned by the read-verbatim-body. Note a
+;; similarity to the fundamental 'fold' iterator.
+;;
+;; Within a verbatim section all characters are taken at their face
+;; value. It ends with "\n@end verbatim(\r)?\n".
+
+;; Must be called right after the newline after @verbatim.
+(define (read-verbatim-body port str-handler seed)
+  (let loop ((seed seed))
+    (let ((fragment (next-token '() '(#\newline)
+                                "reading verbatim" port)))
+      ;; We're reading the char after the 'fragment', which is
+      ;; #\newline.
+      (read-char port)
+      (if (string=? fragment "@end verbatim")
+          seed
+          (loop (str-handler fragment "\n" seed))))))
+
+;; procedure+_	read-arguments PORT
+;;
+;; This procedure reads and parses a production ArgumentList.
+;; ArgumentList __= S* Argument (S* , S* Argument)* S*
+;; Argument __= ([^@{},])*
+;;
+;; Arguments are the things in braces, i.e @ref{my node} has one
+;; argument, "my node". Most commands taking braces actually don't have
+;; arguments, they process text. For example, in
+;; @emph{@strong{emphasized}}, the emph takes text, because the parse
+;; continues into the braces.
+;;
+;; Any whitespace within Argument is replaced with a single space.
+;; Whitespace around an Argument is trimmed.
+;;
+;; The procedure returns a list of arguments. Afterwards the current
+;; character will be after the final #\}.
+
+(define (read-arguments port stop-char)
+  (define (split str)
+    (read-char port) ;; eat the delimiter
+    (let ((ret (map (lambda (x) (if (string-null? x) #f x))
+                    (map string-trim-both (string-split str #\,)))))
+      (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret)))
+          '()
+          ret)))
+  (split (next-token '() (list stop-char)
+                     "arguments of @-command" port)))
+
+;; procedure+_	complete-start-command COMMAND PORT
+;;
+;; This procedure is to complete parsing of an @-command. The procedure
+;; must be called after the command token has been read. COMMAND is a
+;; TAG-NAME.
+;;
+;; This procedure returns several values_
+;;  COMMAND_ a symbol.
+;;  ARGUMENTS_ command's arguments, as an alist.
+;;  CONTENT-MODEL_ the content model of the command.
+;;
+;; On exit, the current position in PORT will depend on the CONTENT-MODEL.
+;;
+;; Content model     Port position
+;; =============     =============
+;; INLINE-TEXT       One character after the #\{.
+;; INLINE-TEXT-ARGS  One character after the #\{.
+;; INLINE-ARGS       The first character after the #\}.
+;; EOL-TEXT          The first non-whitespace character after the command.
+;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT
+;;                   The first character on the next line.
+;; PARAGRAPH, ITEM, EMPTY-COMMAND
+;;                   The first character after the command.
+
+(define (arguments->attlist port args arg-names)
+  (let loop ((in args) (names arg-names) (opt? #f) (out '()))
+    (cond
+     ((symbol? names) ;; a rest arg
+      (reverse (if (null? in) out (acons names in out))))
+     ((and (not (null? names)) (eq? (car names) #\opt))
+      (loop in (cdr names) #t out))
+     ((null? in)
+      (if (or (null? names) opt?)
+          (reverse out)
+          (parser-error port "@-command expected more arguments_" 
+                        args arg-names names)))
+     ((null? names)
+      (parser-error port "@-command didn't expect more arguments_" in))
+     ((not (car in))
+      (or (and opt? (loop (cdr in) (cdr names) opt? out))
+          (parser-error "@-command missing required argument"
+                        (car names))))
+     (else
+      (loop (cdr in) (cdr names) opt?
+            (acons (car names)
+                   (if (list? (car in)) (car in) (list (car in)))
+                   out))))))
+
+(define (parse-table-args command port)
+  (let* ((line (string-trim-both (read-text-line port)))
+         (length (string-length line)))
+    (define (get-formatter)
+      (or (and (not (zero? length))
+               (eq? (string-ref line 0) #\@)
+               (let ((f (string->symbol (substring line 1))))
+                 (or (inline-content? (cadr (command-spec f)))
+                     (parser-error
+                      port "@item formatter must be INLINE" f))
+                 f))
+          (parser-error port "Invalid @item formatter" line)))
+    (case command
+      ((enumerate)
+       (if (zero? length)
+           '()
+           `((start
+              ,(if (or (and (eq? length 1)
+                            (char-alphabetic? (string-ref line 0)))
+                       (string-every char-numeric? line))
+                   line
+                   (parser-error
+                    port "Invalid enumerate start" line))))))
+      ((itemize)
+       `((bullet
+          ,(or (and (eq? length 1) line)
+               (and (string-null? line) '(bullet))
+               (list (get-formatter))))))
+      (else ;; tables of various varieties
+       `((formatter (,(get-formatter))))))))
+
+(define (complete-start-command command port)
+  (define (get-arguments type arg-names stop-char)
+    (arguments->attlist port (read-arguments port stop-char) arg-names))
+
+  (let* ((spec (command-spec command))
+         (command (car spec))
+         (type (cadr spec))
+         (arg-names (cddr spec)))
+    (case type
+      ((INLINE-TEXT)
+       (assert-curr-char '(#\{) "Inline element lacks {" port)
+       (values command '() type))
+      ((INLINE-ARGS)
+       (assert-curr-char '(#\{) "Inline element lacks {" port)
+       (values command (get-arguments type arg-names #\}) type))
+      ((INLINE-TEXT-ARGS)
+       (assert-curr-char '(#\{) "Inline element lacks {" port)
+       (values command '() type))
+      ((EOL-ARGS)
+       (values command (get-arguments type arg-names #\newline) type))
+      ((ENVIRON ENTRY INDEX)
+       (skip-horizontal-whitespace port)
+       (values command (parse-environment-args command port) type))
+      ((TABLE-ENVIRON)
+       (skip-horizontal-whitespace port)
+       (values command (parse-table-args command port) type))
+      ((EOL-TEXT)
+       (skip-horizontal-whitespace port)
+       (values command '() type))
+      ((EOL-TEXT-ARGS)
+       (skip-horizontal-whitespace port)
+       (values command (parse-eol-text-args command port) type))
+      ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT)
+       (values command '() type))
+      (else ;; INCLUDE shouldn't get here
+       (parser-error port "can't happen")))))
+
+;;-----------------------------------------------------------------------------
+;;			Higher-level parsers and scanners
+;;
+;; They parse productions corresponding entire @-commands.
+
+;; Only reads @settitle, leaves it to the command parser to finish
+;; reading the title.
+(define (take-until-settitle port)
+  (or (find-string-from-port? "\n@settitle " port)
+      (parser-error port "No \\n@settitle  found"))
+  (skip-horizontal-whitespace port)
+  (and (eq? (peek-char port) #\newline)
+       (parser-error port "You have a @settitle, but no title")))
+
+;; procedure+_	read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
+;;
+;; This procedure is to read the CharData of a texinfo document.
+;;
+;; text __= (CharData | Command)*
+;;
+;; The procedure reads CharData and stops at @-commands (or
+;; environments). It also stops at an open or close brace.
+;;
+;; port
+;;	a PORT to read
+;; expect-eof?
+;;	a boolean indicating if EOF is normal, i.e., the character
+;;	data may be terminated by the EOF. EOF is normal
+;;	while processing the main document.
+;; preserve-ws?
+;;	a boolean indicating if we are within a whitespace-preserving
+;;      environment. If #t, suppress paragraph detection.
+;; str-handler
+;;	a STR-HANDLER, see read-verbatim-body
+;; seed
+;;	an argument passed to the first invocation of STR-HANDLER.
+;;
+;; The procedure returns two results_ SEED and TOKEN. The SEED is the
+;; result of the last invocation of STR-HANDLER, or the original seed if
+;; STR-HANDLER was never called.
+;;
+;; TOKEN can be either an eof-object (this can happen only if expect-eof?
+;; was #t), or a texinfo token denoting the start or end of a tag.
+
+;; read-char-data port expect-eof? preserve-ws? str-handler seed
+(define read-char-data
+  (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline)))
+    (define (handle str-handler str1 str2 seed)
+      (if (and (string-null? str1) (string-null? str2))
+          seed
+          (str-handler str1 str2 seed)))
+
+    (lambda (port expect-eof? preserve-ws? str-handler seed)
+      (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof)))
+        (let loop ((seed seed))
+          (let* ((fragment (next-token '() end-chars "reading char data" port))
+                 (term-char (peek-char port))) ; one of end-chars
+            (cond
+             ((eof-object? term-char) ; only if expect-eof?
+              (values (handle str-handler fragment "" seed) term-char))
+             ((memq term-char '(#\@ #\{ #\}))
+              (values (handle str-handler fragment "" seed)
+                      (case term-char
+                        ((#\@) (read-command-token port))
+                        ((#\{) (make-token 'START '*braces*))
+                        ((#\}) (read-char port) (make-token 'END #f)))))
+             ((eq? term-char #\newline)
+              ;; Always significant, unless directly before an end token.
+              (let ((c (peek-next-char port)))
+                (cond
+                 ((eof-object? c)
+                  (or expect-eof?
+                      (parser-error port "EOF while reading char data"))
+                  (values (handle str-handler fragment "" seed) c))
+                 ((eq? c #\@)
+                  (let* ((token (read-command-token port))
+                         (end? (eq? (token-kind token) 'END)))
+                    (values
+                     (handle str-handler fragment
+                             (if end? "" (if preserve-ws? "\n" " "))
+                             seed)
+                     token)))
+                 ((and (not preserve-ws?) (eq? c #\newline))
+                  ;; paragraph-separator __= #\newline #\newline+
+                  (skip-while '(#\newline) port)
+                  (skip-horizontal-whitespace port)
+                  (values (handle str-handler fragment "" seed)
+                          (make-token 'PARA 'para)))
+                 (else
+                  (loop (handle str-handler fragment
+                                (if preserve-ws? "\n" " ") seed)))))))))))))
+
+; procedure+_	assert-token TOKEN KIND NAME
+; Make sure that TOKEN is of anticipated KIND and has anticipated NAME
+(define (assert-token token kind name)
+  (or (and (token? token)
+           (eq? kind (token-kind token))
+           (equal? name (token-head token)))
+      (parser-error #f "Expecting @end for " name ", got " token)))
+
+;;========================================================================
+;;		Highest-level parsers_ Texinfo to SXML
+
+;; These parsers are a set of syntactic forms to instantiate a SSAX
+;; parser. The user tells what to do with the parsed character and
+;; element data. These latter handlers determine if the parsing follows a
+;; SAX or a DOM model.
+
+;; syntax_ make-command-parser fdown fup str-handler
+
+;; Create a parser to parse and process one element, including its
+;; character content or children elements. The parser is typically
+;; applied to the root element of a document.
+
+;; fdown
+;;	procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED
+;;
+;;	This procedure is to generate the seed to be passed to handlers
+;;	that process the content of the element. This is the function
+;;	identified as 'fdown' in the denotational semantics of the XML
+;;	parser given in the title comments to (sxml ssax).
+;;
+;; fup
+;;	procedure COMMAND ARGUMENTS PARENT-SEED SEED
+;;
+;;	This procedure is called when parsing of COMMAND is finished.
+;;	The SEED is the result from the last content parser (or from
+;;	fdown if the element has the empty content). PARENT-SEED is the
+;;	same seed as was passed to fdown. The procedure is to generate a
+;;	seed that will be the result of the element parser. This is the
+;;	function identified as 'fup' in the denotational semantics of
+;;	the XML parser given in the title comments to (sxml ssax).
+;;
+;; str-handler
+;;	A STR-HANDLER, see read-verbatim-body
+;;
+
+;; The generated parser is a
+;;	procedure COMMAND PORT SEED
+;;
+;; The procedure must be called *after* the command token has been read.
+
+(define (read-include-file-name port)
+  (let ((x (string-trim-both (read-eof-line port))))
+    (if (string-null? x)
+        (error "no file listed")
+        x))) ;; fixme_ should expand @value{} references
+
+(define (sxml->node-name sxml)
+  "Turn some sxml string into a valid node name."
+  (let loop ((in (string->list (sxml->string sxml))) (out '()))
+    (if (null? in)
+        (apply string (reverse out))
+        (if (memq (car in) '(#\{ #\} #\@ #\,))
+            (loop (cdr in) out)
+            (loop (cdr in) (cons (car in) out))))))
+
+(define (index command arguments fdown fup parent-seed)
+  (case command
+    ((deftp defcv defivar deftypeivar defop deftypeop defmethod
+      deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+      deftypefn defspec defmac defun deftypefun)
+     (let ((args `((name ,(string-append (symbol->string command) "-"
+                                         (cadr (assq 'name arguments)))))))
+       (fup 'anchor args parent-seed
+            (fdown 'anchor args 'INLINE-ARGS '()))))
+    ((cindex findex vindex kindex pindex tindex)
+     (let ((args `((name ,(string-append (symbol->string command) "-"
+                                         (sxml->node-name
+                                          (assq 'entry arguments)))))))
+       (fup 'anchor args parent-seed
+            (fdown 'anchor args 'INLINE-ARGS '()))))
+    (else parent-seed)))
+
+(define (make-command-parser fdown fup str-handler)
+  (lambda (command port seed)
+    (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed))
+      (let*-values (((command arguments expected-content)
+                     (complete-start-command command port)))
+        (let* ((parent-seed (index command arguments fdown fup parent-seed))
+               (seed (fdown command arguments expected-content parent-seed))
+               (eof-closes? (or (memq command '(texinfo para *fragment*))
+                                (eq? expected-content 'EOL-TEXT)))
+               (sig-ws? (or sig-ws? (space-significant? command)))
+               (up (lambda (s) (fup command arguments parent-seed s)))
+               (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s)))
+               (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s)))))
+          
+          (define (port-for-content)
+            (if (eq? expected-content 'EOL-TEXT)
+                (call-with-input-string (read-text-line port) identity)
+                port))
+
+          (cond
+           ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX
+                                     EOL-TEXT-ARGS))
+            ;; empty or finished by complete-start-command
+            (up seed))
+           ((eq? command 'verbatim)
+            (up (read-verbatim-body port str-handler seed)))
+           (else
+            (let loop ((port (port-for-content))
+                       (expect-eof? eof-closes?)
+                       (end-para identity)
+                       (need-break? (and (not sig-ws?)
+                                         (memq expected-content
+                                               '(ENVIRON TABLE-ENVIRON
+                                                 ENTRY ITEM FRAGMENT))))
+                       (seed seed))
+              (cond
+               ((and need-break? (or sig-ws? (skip-whitespace port))
+                     (not (memq (peek-char port) '(#\@ #\})))
+                     (not (eof-object? (peek-char port))))
+                ;; Even if we have an @, it might be inline -- check
+                ;; that later
+                (let ((seed (end-para seed)))
+                  (loop port expect-eof? (make-end-para seed) #f
+                        (new-para seed))))
+               (else
+                (let*-values (((seed token)
+                               (read-char-data
+                                port expect-eof? sig-ws? str-handler seed)))
+                  (cond
+                   ((eof-object? token)
+                    (case expect-eof? 
+                      ((include #f) (end-para seed))
+                      (else (up (end-para seed)))))
+                   (else
+                    (case (token-kind token)
+                      ((STRING)
+                       ;; this is only @-commands that escape
+                       ;; characters_ @}, @@, @{ -- new para if need-break
+                       (let ((seed ((if need-break? end-para identity) seed)))
+                         (loop port expect-eof?
+                               (if need-break? (make-end-para seed) end-para) #f
+                               (str-handler (token-head token) ""
+                                            ((if need-break? new-para identity)
+                                             seed)))))
+                      ((END)
+                       ;; The end will only have a name if it's for an
+                       ;; environment
+                       (cond
+                        ((memq command '(item entry))
+                         (let ((spec (command-spec (token-head token))))
+                           (or (eq? (cadr spec) 'TABLE-ENVIRON)
+                               (parser-error
+                                port "@item not ended by @end table/enumerate/itemize"
+                                token))))
+                        ((eq? expected-content 'ENVIRON)
+                         (assert-token token 'END command)))
+                       (up (end-para seed)))
+                      ((ITEM)
+                       (cond
+                        ((memq command '(enumerate itemize))
+                         (up (visit 'item port sig-ws? (end-para seed))))
+                        ((eq? expected-content 'TABLE-ENVIRON)
+                         (up (visit 'entry port sig-ws? (end-para seed))))
+                        ((memq command '(item entry))
+                         (visit command port sig-ws? (up (end-para seed))))
+                        (else
+                         (parser-error
+                          port "@item must be within a table environment"
+                          command))))
+                      ((PARA)
+                       ;; examine valid paragraphs?
+                       (loop port expect-eof? end-para (not sig-ws?) seed))
+                      ((INCLUDE)
+                       ;; Recurse for include files
+                       (let ((seed (call-with-file-and-dir
+                                    (read-include-file-name port)
+                                    (lambda (port)
+                                      (loop port 'include end-para
+                                            need-break? seed)))))
+                         (loop port expect-eof? end-para need-break? seed)))
+                      ((START)          ; Start of an @-command
+                       (let* ((head (token-head token))
+                              (spec (command-spec head))
+                              (head (car spec))
+                              (type (cadr spec))
+                              (inline? (inline-content? type))
+                              (seed ((if (and inline? (not need-break?))
+                                         identity end-para) seed))
+                              (end-para (if inline?
+                                            (if need-break? (make-end-para seed)
+                                                end-para)
+                                            identity))
+                              (new-para (if (and inline? need-break?)
+                                            new-para identity)))
+                         (loop port expect-eof? end-para (not inline?)
+                               (visit head port sig-ws? (new-para seed)))))
+                      (else
+                       (parser-error port "Unknown token type" token))))))))))))))))
+
+;; procedure_ reverse-collect-str-drop-ws fragments
+;;
+;; Given the list of fragments (some of which are text strings), reverse
+;; the list and concatenate adjacent text strings. We also drop
+;; "unsignificant" whitespace, that is, whitespace in front, behind and
+;; between elements. The whitespace that is included in character data
+;; is not affected.
+(define (reverse-collect-str-drop-ws fragments)
+  (cond 
+   ((null? fragments)                   ; a shortcut
+    '())
+   ((and (string? (car fragments))	; another shortcut
+         (null? (cdr fragments))	; remove single ws-only string
+         (string-whitespace? (car fragments)))
+    '())
+   (else
+    (let loop ((fragments fragments) (result '()) (strs '())
+               (all-whitespace? #t))
+      (cond
+       ((null? fragments)
+        (if all-whitespace?
+            result                      ; remove leading ws
+            (cons (apply string-append strs) result)))
+       ((string? (car fragments))
+        (loop (cdr fragments) result (cons (car fragments) strs)
+              (and all-whitespace?
+                   (string-whitespace? (car fragments)))))
+       (else
+        (loop (cdr fragments)
+              (cons
+               (car fragments)
+               (cond
+                ((null? strs) result)
+                (all-whitespace?
+                 (if (null? result)
+                     result             ; remove trailing whitespace
+                     (cons " " result))); replace interstitial ws with
+					; one space
+                (else
+                 (cons (apply string-append strs) result))))
+              '() #t)))))))
+
+(define (parse-inline-text-args port spec text)
+  (let lp ((in text) (cur '()) (out '()))
+    (cond
+     ((null? in)
+      (if (and (pair? cur)
+               (string? (car cur))
+               (string-whitespace? (car cur)))
+          (lp in (cdr cur) out)
+          (let ((args (reverse (if (null? cur)
+                                   out
+                                   (cons (reverse cur) out)))))
+            (arguments->attlist port args (cddr spec)))))
+     ((pair? (car in))
+      (lp (cdr in) (cons (car in) cur) out))
+     ((string-index (car in) #\,)
+      (let* ((parts (string-split (car in) #\,))
+             (head (string-trim-right (car parts)))
+             (rev-tail (reverse (cdr parts)))
+             (last (string-trim (car rev-tail))))
+        (lp (cdr in)
+            (if (string-null? last) cur (cons last cur))
+            (append (cdr rev-tail)
+                    (cons (reverse (if (string-null? head) cur (cons head cur)))
+                          out)))))
+     (else
+      (lp (cdr in)
+          (cons (if (null? cur) (string-trim (car in)) (car in)) cur)
+          out)))))
+
+(define (make-dom-parser)
+  (make-command-parser
+   (lambda (command args content seed)      ; fdown
+     '())
+   (lambda (command args parent-seed seed)  ; fup
+     (let* ((seed (reverse-collect-str-drop-ws seed))
+            (spec (command-spec command))
+            (command (car spec)))
+       (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
+           (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
+                 parent-seed)
+           (acons command
+                  (if (null? args) seed (acons '% args seed))
+                  parent-seed))))
+   (lambda (string1 string2 seed)           ; str-handler
+     (if (string-null? string2)
+         (cons string1 seed)
+         (cons* string2 string1 seed)))))
+
+(define parse-environment-args
+  (let ((parser (make-dom-parser)))
+    ;; duplicate arguments->attlist to avoid unnecessary splitting
+    (lambda (command port)
+      (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+             (spec (command-spec command))
+             (command (car spec))
+             (arg-names (cddr spec)))
+        (cond
+         ((not arg-names)
+          (if (null? args) '()
+              (parser-error port "@-command doesn't take args" command)))
+         ((eq? arg-names #t)
+          (list (cons 'arguments args)))
+         (else
+          (let loop ((args args) (arg-names arg-names) (out '()))
+            (cond
+             ((null? arg-names)
+              (if (null? args) (reverse! out)
+                  (parser-error port "@-command didn't expect more args"
+                                command args)))
+             ((symbol? arg-names)
+              (reverse! (acons arg-names args out)))
+             ((null? args)
+              (parser-error port "@-command expects more args"
+                            command arg-names))
+             ((and (string? (car args)) (string-index (car args) #\space))
+              => (lambda (i)
+                   (let ((rest (substring/shared (car args) (1+ i))))
+                     (if (zero? i)
+                         (loop (cons rest (cdr args)) arg-names out)
+                         (loop (cons rest (cdr args)) (cdr arg-names)
+                               (cons (list (car arg-names)
+                                           (substring (car args) 0 i))
+                                     out))))))
+             (else
+              (loop (cdr args) (cdr arg-names)
+                    (if (and (pair? (car args)) (eq? (caar args) '*braces*))
+                        (acons (car arg-names) (cdar args) out)
+                        (cons (list (car arg-names) (car args)) out))))))))))))
+   
+(define (parse-eol-text-args command port)
+  ;; perhaps parse-environment-args should be named more
+  ;; generically.
+  (parse-environment-args command port))
+
+;; procedure_ texi-fragment->stexi STRING
+;;
+;; A DOM parser for a texinfo fragment STRING.
+;;
+;; The procedure returns an SXML tree headed by the special tag,
+;; *fragment*.
+
+(define (texi-fragment->stexi string-or-port)
+  "Parse the texinfo commands in @var{string-or-port}, and return the
+resultant stexi tree. The head of the tree will be the special command,
+@code{*fragment*}."
+  (define (parse port)
+    (postprocess (car ((make-dom-parser) '*fragment* port '()))))
+  (if (input-port? string-or-port)
+      (parse string-or-port)
+      (call-with-input-string string-or-port parse)))
+
+;; procedure_ texi->stexi PORT
+;;
+;; This is an instance of a SSAX parser above that returns an SXML
+;; representation of the texinfo document ready to be read at PORT.
+;;
+;; The procedure returns an SXML tree. The port points to the
+;; first character after the @bye, or to the end of the file.
+
+(define (texi->stexi port)
+  "Read a full texinfo document from @var{port} and return the parsed
+stexi tree. The parsing will start at the @code{@@settitle} and end at
+@code{@@bye} or EOF."
+  (let ((parser (make-dom-parser)))
+    (take-until-settitle port)
+    (postprocess (car (parser 'texinfo port '())))))
+
+(define (car-eq? x y) (and (pair? x) (eq? (car x) y)))
+(define (make-contents tree)
+  (define (lp in out depth)
+    (cond
+     ((null? in) (values in (cons 'enumerate (reverse! out))))
+     ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4))
+      => (lambda (new-depth)
+           (let ((node-name (and (car-eq? (car in) 'node)
+                                 (cadr (assq 'name (cdadar in))))))
+             (cond
+              ((< new-depth depth)
+               (values in (cons 'enumerate (reverse! out))))
+              ((> new-depth depth)
+               (let ((out-cdr (if (null? out) '() (cdr out)))
+                     (out-car (if (null? out) (list 'item) (car out))))
+                 (let*-values (((new-in new-out) (lp in '() (1+ depth))))
+                   (lp new-in
+                       (cons (append out-car (list new-out)) out-cdr)
+                       depth))))
+              (else ;; same depth
+               (lp (cddr in)
+                   (cons
+                    `(item (para
+                            ,@(if node-name
+                                  `((ref (% (node ,node-name))))
+                                  (cdadr in))))
+                    out)
+                   depth))))))
+     (else (lp (cdr in) out depth))))
+  (let*-values (((_ contents) (lp tree '() 1)))
+    `((chapheading "Table of Contents") ,contents)))
+
+(define (trim-whitespace str trim-left? trim-right?)
+  (let* ((left-space? (and (not trim-left?)
+                           (string-prefix? " " str)))
+         (right-space? (and (not trim-right?)
+                            (string-suffix? " " str)))
+         (tail (append! (string-tokenize str)
+                        (if right-space? '("") '()))))
+    (string-join (if left-space? (cons "" tail) tail))))
+
+(define (postprocess tree)
+  (define (loop in out state first? sig-ws?)
+    (cond
+     ((null? in)
+      (values (reverse! out) state))
+     ((string? (car in))
+      (loop (cdr in)
+            (cons (if sig-ws? (car in)
+                      (trim-whitespace (car in) first? (null? (cdr in))))
+                  out)
+            state #f sig-ws?))
+     ((pair? (car in))
+      (case (caar in)
+        ((set)
+         (if (null? (cdar in)) (error "@set missing arguments" in))
+         (if (string? (cadar in))
+             (let ((i (string-index (cadar in) #\space)))
+               (if i 
+                   (loop (cdr in) out
+                         (acons (substring (cadar in) 0 i)
+                                (cons (substring (cadar in) (1+ i)) (cddar in))
+                                state)
+                         #f sig-ws?)
+                   (loop (cdr in) out (acons (cadar in) (cddar in) state)
+                         #f sig-ws?)))
+             (error "expected a constant to define for @set" in)))
+        ((value)
+         (loop (fold-right cons (cdr in)
+                           (or (and=>
+                                (assoc (cadr (assq 'key (cdadar in))) state) cdr)
+                               (error "unknown value" (cdadar in) state)))
+               out
+               state #f sig-ws?))
+        ((copying)
+         (loop (cdr in) out (cons (car in) state) #f sig-ws?))
+        ((insertcopying)
+         (loop (fold-right cons (cdr in)
+                           (or (cdr (assoc 'copying state))
+                               (error "copying isn't set yet")))
+               out
+               state #f sig-ws?))
+        ((contents)
+         (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?))
+        (else
+         (let*-values (((kid-out state)
+                        (loop (car in) '() state #t
+                              (or sig-ws? (space-significant? (caar in))))))
+           (loop (cdr in) (cons kid-out out) state #f sig-ws?)))))
+     (else ; a symbol
+      (loop (cdr in) (cons (car in) out) state #t sig-ws?))))
+
+  (call-with-values
+      (lambda () (loop tree '() '() #t #f))
+    (lambda (out state) out)))
+
+;; Replace % with texinfo-arguments.
+(define (stexi->sxml tree)
+  "Transform the stexi tree @var{tree} into sxml. This involves
+replacing the @code{%} element that keeps the texinfo arguments with an
+element for each argument.
+
+FIXME_ right now it just changes % to @code{texinfo-arguments} -- that
+doesn't hang with the idea of making a dtd at some point"
+  (pre-post-order
+   tree
+   `((% . ,(lambda (x . t) (cons 'texinfo-arguments t)))
+     (*text* . ,(lambda (x t) t))
+     (*default* . ,(lambda (x . t) (cons x t))))))
+
+;;; arch-tag_ 73890afa-597c-4264-ae70-46fe7756ffb5
+;;; texinfo.scm ends here
+;;;; (texinfo docbook) -- translating sdocbook into stexinfo
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2012  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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_
+;;
+;; @c
+;; This module exports procedures for transforming a limited subset of
+;; the SXML representation of docbook into stexi. It is not complete by
+;; any means. The intention is to gather a number of routines and
+;; stylesheets so that external modules can parse specific subsets of
+;; docbook, for example that set generated by certain tools.
+;;
+;;; Code_
+
+(define-module (texinfo docbook)
+  #\use-module (sxml fold)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\export (*sdocbook->stexi-rules*
+            *sdocbook-block-commands*
+            sdocbook-flatten
+            filter-empty-elements
+            replace-titles))
+
+(define (identity . args)
+  args)
+
+(define (identity-deattr tag . body)
+  `(,tag ,@(if (and (pair? body) (pair? (car body))
+                    (eq? (caar body) '@))
+               (cdr body)
+               body)))
+
+(define (detag-one tag body)
+  body)
+
+(define tag-replacements
+  '((parameter var)
+    (replaceable var)
+    (type code)
+    (function code)
+    (literal samp)
+    (emphasis emph)
+    (simpara para)
+    (programlisting example)
+    (firstterm dfn)
+    (filename file)
+    (quote cite)
+    (application cite)
+    (symbol code)
+    (note cartouche)
+    (envar env)))
+
+(define ignore-list '())
+
+(define (stringify exp)
+  (with-output-to-string (lambda () (write exp))))
+
+(define *sdocbook->stexi-rules*
+  ;~
+  "A stylesheet for use with SSAX's @code{pre-post-order}, which defines
+a number of generic rules for transforming docbook into texinfo."
+  `((@ *preorder* . ,identity)
+    (% *preorder* . ,identity)
+    (para . ,identity-deattr)
+    (orderedlist ((listitem
+                   . ,(lambda (tag . body)
+                        `(item ,@body))))
+                 . ,(lambda (tag . body)
+                      `(enumerate ,@body)))
+    (itemizedlist ((listitem
+                    . ,(lambda (tag . body)
+                         `(item ,@body))))
+                  . ,(lambda (tag . body)
+                       `(itemize ,@body)))
+    (acronym . ,(lambda (tag . body)
+                  `(acronym (% (acronym . ,body)))))
+    (term . ,detag-one)
+    (informalexample . ,detag-one)
+    (section . ,identity)
+    (subsection . ,identity)
+    (subsubsection . ,identity)
+    (ulink . ,(lambda (tag attrs . body)
+                (cond
+                 ((assq 'url (cdr attrs))
+                  => (lambda (url)
+                       `(uref (% ,url (title ,@body)))))
+                 (else
+                  (car body)))))
+    (*text* . ,detag-one)
+    (*default* . ,(lambda (tag . body)
+                    (let ((subst (assq tag tag-replacements)))
+                      (cond
+                       (subst
+                        (if (and (pair? body) (pair? (car body)) (eq? (caar body) '@))
+                            (begin
+                              (warn "Ignoring" tag "attributes" (car body))
+                              (append (cdr subst) (cdr body)))
+                            (append (cdr subst) body)))
+                       ((memq tag ignore-list) #f)
+                       (else 
+                        (warn "Don't know how to convert" tag "to stexi")
+                        `(c (% (all ,(stringify (cons tag body))))))))))))
+
+;;     (variablelist
+;;      ((varlistentry
+;;        . ,(lambda (tag term . body)
+;;             `(entry (% (heading ,@(cdr term))) ,@body)))
+;;       (listitem
+;;        . ,(lambda (tag simpara)
+;;             simpara)))
+;;      . ,(lambda (tag attrs . body)
+;;           `(table (% (formatter (var))) ,@body)))
+
+(define *sdocbook-block-commands*
+  ;~
+  "The set of sdocbook element tags that should not be nested inside
+each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
+for more information." 
+  '(para programlisting informalexample indexterm variablelist
+    orderedlist refsect1 refsect2 refsect3 refsect4 title example
+    note itemizedlist informaltable))
+
+(define (inline-command? command)
+  (not (memq command *sdocbook-block-commands*)))
+
+(define (sdocbook-flatten sdocbook)
+  "\"Flatten\" a fragment of sdocbook so that block elements do not nest
+inside each other.
+
+Docbook is a nested format, where e.g. a @code{refsect2} normally
+appears inside a @code{refsect1}. Logical divisions in the document are
+represented via the tree topology; a @code{refsect2} element
+@emph{contains} all of the elements in its section.
+
+On the contrary, texinfo is a flat format, in which sections are marked
+off by standalone section headers like @code{@@chapter}, and block
+elements do not nest inside each other.
+
+This function takes a nested sdocbook fragment @var{sdocbook} and
+flattens all of the sections, such that e.g.
+@example
+ (refsect1 (refsect2 (para \"Hello\")))
+@end example
+becomes
+@example
+ ((refsect1) (refsect2) (para \"Hello\"))
+@end example
+
+Oftentimes (always?) sectioning elements have @code{<title>} as their
+first element child; users interested in processing the @code{refsect*}
+elements into proper sectioning elements like @code{chapter} might be
+interested in @code{replace-titles} and @code{filter-empty-elements}.
+@xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo
+docbook filter-empty-elements,,filter-empty-elements}.
+
+Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
+this function returns an untagged list of stexi elements."
+  (define (fhere str accum block cont)
+    (values (cons str accum)
+            block
+            cont))
+  (define (fdown node accum block cont)
+    (let ((command (car node))
+          (attrs (and (pair? (cdr node)) (pair? (cadr node))
+                      (eq? (caadr node) '%)
+                      (cadr node))))
+      (values (if attrs (cddr node) (cdr node))
+              '()
+              '()
+              (lambda (accum block)
+                (values
+                 `(,command ,@(if attrs (list attrs) '())
+                            ,@(reverse accum))
+                 block)))))
+  (define (fup node paccum pblock pcont kaccum kblock kcont)
+    (call-with-values (lambda () (kcont kaccum kblock))
+      (lambda (ret block)
+        (if (inline-command? (car ret))
+            (values (cons ret paccum) (append kblock pblock) pcont)
+            (values paccum (append kblock (cons ret pblock)) pcont)))))
+  (call-with-values
+      (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
+    (lambda (accum block cont)
+      (reverse block))))
+    
+(define (filter-empty-elements sdocbook)
+  "Filters out empty elements in an sdocbook nodeset. Mostly useful
+after running @code{sdocbook-flatten}."
+  (reverse
+   (fold
+    (lambda (x rest)
+      (if (and (pair? x) (null? (cdr x)))
+          rest
+          (cons x rest)))
+    '()
+    sdocbook)))
+
+(define (replace-titles sdocbook-fragment)
+  "Iterate over the sdocbook nodeset @var{sdocbook-fragment},
+transforming contiguous @code{refsect} and @code{title} elements into
+the appropriate texinfo sectioning command. Most useful after having run
+@code{sdocbook-flatten}.
+
+For example_
+@example
+ (replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\")))
+    @result{} '((chapter \"Foo\") (para \"Bar.\"))
+@end example
+"
+  (define sections '((refsect1 . chapter)
+                     (refsect2 . section)
+                     (refsect3 . subsection)
+                     (refsect4 . subsubsection)))
+  (let lp ((in sdocbook-fragment) (out '()))
+    (cond
+     ((null? in)
+      (reverse out))
+     ((and (pair? (car in)) (assq (caar in) sections))
+      ;; pull out the title
+      => (lambda (pair)
+           (lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out))))
+     (else
+      (lp (cdr in) (cons (car in) out))))))
+;;;; (texinfo html) -- translating stexinfo into shtml
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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 implements transformation from @code{stexi} to HTML. Note
+;;that the output of @code{stexi->shtml} is actually SXML with the HTML
+;;vocabulary. This means that the output can be further processed, and
+;;that it must eventually be serialized by
+;;@ref{sxml simple sxml->xml,sxml->xml}.
+;;        
+;;References (i.e., the @code{@@ref} family of commands) are resolved by
+;;a @dfn{ref-resolver}.
+;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more
+;;information.
+;;
+;;; Code_
+
+;; TODO_ nice ref resolving API, default CSS stylesheet (esp. to remove
+;; margin-top on dd > p)
+
+(define-module (texinfo html)
+  #\use-module (texinfo)
+  #\use-module (sxml transform)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-13)
+  #\export (stexi->shtml add-ref-resolver! urlify))
+
+;; The caller is responsible for carring the returned list.
+(define (arg-ref key %-args)
+  (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x)))))
+(define (arg-req key %-args)
+  (or (arg-ref key %-args)
+      (error "Missing argument_" key %-args)))
+(define (car* x) (and x (car x)))
+
+(define (urlify str)
+  (string-downcase
+   (string-map
+    (lambda (c)
+      (case c
+        ((#\space #\/ #\_) #\-)
+        (else c)))
+    str)))
+
+(define ref-resolvers 
+  (list
+   (lambda (node-name manual-name) ;; the default
+     (urlify (string-append (or manual-name "") "#" node-name)))))
+
+(define (add-ref-resolver! proc)
+  "Add @var{proc} to the head of the list of ref-resolvers. @var{proc}
+will be expected to take the name of a node and the name of a manual and
+return the URL of the referent, or @code{#f} to pass control to the next
+ref-resolver in the list.
+
+The default ref-resolver will return the concatenation of the manual
+name, @code{#}, and the node name."
+  (set! ref-resolvers (cons proc ref-resolvers)))
+
+(define (resolve-ref node manual)
+  (or (or-map (lambda (x) (x node manual)) ref-resolvers)
+      (error "Could not resolve reference" node manual)))
+
+(define (ref tag args)
+  (let* ((node (car (arg-req 'node args)))
+         (section (or (car* (arg-ref 'section args)) node))
+         (manual (car* (arg-ref 'manual args)))
+         (target (resolve-ref node manual)))
+    `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr)
+           (a (@ (href ,target)) ,section))))
+
+(define (uref tag args)
+  (let ((url (car (arg-req 'url args))))
+    `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url))))
+
+;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an
+;; empty string here to placate the reptile.
+(define (node tag args)
+  `(a (@ (name ,(urlify (car (arg-req 'name args))))) ""))
+
+(define (def tag args . body)
+  (define (code x) (and x (cons 'code x)))
+  (define (var x) (and x (cons 'var x)))
+  (define (b x) (and x (cons 'b x)))
+  (define (list/spaces . elts)
+    (let lp ((in elts) (out '()))
+      (cond ((null? in) (reverse! out))
+            ((null? (car in)) (lp (cdr in) out))
+            (else (lp (cdr in)
+                      (cons (car in)
+                            (if (null? out) out (cons " " out))))))))
+  (define (left-td-contents)
+    (list/spaces (code (arg-ref 'data-type args))
+                 (b (list (code (arg-ref 'class args)))) ;; is this right?
+                 (b (list (code (arg-ref 'name args))))
+                 (if (memq tag '(deftypeop deftypefn deftypefun))
+                     (code (arg-ref 'arguments args))
+                     (var (list (code (arg-ref 'arguments args)))))))
+
+  (let* ((category (case tag
+                     ((defun) "Function")
+                     ((defspec) "Special Form")
+                     ((defvar) "Variable")
+                     (else (car (arg-req 'category args))))))
+    `(div
+      (table
+       (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def"))
+       (tr (td ,@(left-td-contents))
+           (td (div (@ (class "right")) "[" ,category "]"))))
+      (div (@ (class "description")) ,@body))))
+
+(define (enumerate tag . elts)
+  (define (tonumber start)
+    (let ((c (string-ref start 0)))
+      (cond ((number? c) (string->number start))
+            (else (1+ (- (char->integer c)
+                         (char->integer (if (char-upper-case? c) #\A #\a))))))))
+  `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))
+             (cons `(@ (start ,@(tonumber (arg-req 'start (car elts)))))
+                       ;; (type ,(type (arg-ref 'start (car elts)))))
+                   (cdr elts))
+             elts)))
+
+(define (itemize tag . elts)
+  `(ul ,@(match elts
+           ;; Strip `bullet' attribute.
+           ((('% . attrs) . elts) elts)
+           (elts elts))))
+
+(define (acronym tag . elts)
+  (match elts
+    ;; FIXME_ Need attribute matcher that doesn't depend on attribute
+    ;; order.
+    ((('% ('acronym text) . _)) `(acronym ,text))))
+
+(define (table tag args . body)
+  (let ((formatter (caar (arg-req 'formatter args))))
+    (cons 'dl
+          (map (lambda (x)
+                 (cond ((and (pair? x) (eq? (car x) 'dt))
+                        (list (car x) (cons formatter (cdr x))))
+                       (else x)))
+               (apply append body)))))
+
+(define (entry tag args . body)
+  (let lp ((out `((dt ,@(arg-req 'heading args))))
+           (body body))
+    (if (and (pair? body) (pair? (car body)) (eq? (caar body) 'itemx))
+        (lp (append out `(dt ,@(map stexi->shtml (cdar body))))
+            (cdr body))
+        (append out `((dd ,@(map stexi->shtml body)))))))
+
+(define tag-replacements
+  '((titlepage    div (@ (class "titlepage")))
+    (title        h2  (@ (class "title")))
+    (subtitle     h3  (@ (class "subtitle")))
+    (author       h3  (@ (class "author")))
+    (example      pre)
+    (lisp         pre)
+    (smallexample pre (@ (class "smaller")))
+    (smalllisp    pre (@ (class "smaller")))
+    (cartouche    div (@ (class "cartouche")))
+    (verbatim     pre (@ (class "verbatim")))
+    (chapter      h2)
+    (section      h3)
+    (subsection   h4)
+    (subsubsection       h5)
+    (appendix     h2)
+    (appendixsec  h3)
+    (appendixsubsec      h4)
+    (appendixsubsubsec   h5)
+    (unnumbered   h2)
+    (unnumberedsec       h3)
+    (unnumberedsubsec    h4)
+    (unnumberedsubsubsec h5)
+    (majorheading h2)
+    (chapheading  h2)
+    (heading      h3)
+    (subheading   h4)
+    (subsubheading       h5)
+    (quotation    blockquote)
+    (item         li) ;; itemx ?
+    (para         p)
+    (*fragment*   div) ;; should be ok
+
+    (asis         span)
+    (bold         b)
+    (sample       samp)
+    (samp         samp)
+    (code         code)
+    (kbd          kbd)
+    (key          code (@ (class "key")))
+    (var          var)
+    (env          code (@ (class "env")))
+    (file         code (@ (class "file")))
+    (command      code (@ (class "command")))
+    (option       code (@ (class "option")))
+    (url          code (@ (class "url")))
+    (dfn          dfn)
+    (cite         cite)
+    (acro         acronym)
+    (email        code (@ (class "email")))
+    (emph         em)
+    (strong       strong)
+    (sc           span (@ (class "small-caps")))))
+
+(define ignore-list
+  '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
+    menu ignore syncodeindex comment c dircategory direntry top shortcontents
+    cindex printindex))
+
+(define rules
+  `((% *preorder* . ,(lambda args args)) ;; Keep these around...
+    (texinfo   . ,(lambda (tag args . body)
+                    (pre-post-order
+                     `(html
+                       (@ (xmlns "http_//www.w3.org/1999/xhtml"))
+                       (head (title ,(car (arg-req 'title args))))
+                       (body ,@body))
+                     `((% *preorder* . ,(lambda args #f)) ;; ... filter out.
+                       (*text*       . ,(lambda (tag x) x))
+                       (*default*    . ,(lambda (tag . body)
+                                          (cons tag body)))))))
+    (copyright . ,(lambda args '(*ENTITY* "copy")))
+    (result    . ,(lambda args '(*ENTITY* "rArr")))
+    (xref . ,ref) (ref . ,ref) (pxref . ,ref)
+    (uref . ,uref)
+    (node . ,node) (anchor . ,node)
+    (table . ,table)
+    (enumerate . ,enumerate)
+    (itemize . ,itemize)
+    (acronym . ,acronym)
+    (entry *preorder* . ,entry)
+
+    (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def)
+    (defop . ,def) (deftypeop . ,def) (defmethod . ,def)
+    (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def)
+    (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def) 
+    (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def)
+    (deftypefun . ,def)
+    (ifnottex . ,(lambda (tag . body) body))
+    (*text*    . ,(lambda (tag x) x))
+    (*default* . ,(lambda (tag . body)
+                    (let ((subst (assq tag tag-replacements)))
+                      (cond
+                       (subst (append (cdr subst) body))
+                       ((memq tag ignore-list) #f)
+                       (else 
+                        (warn "Don't know how to convert" tag "to HTML")
+                        body)))))))
+
+(define (stexi->shtml tree)
+  "Transform the stexi @var{tree} into shtml, resolving references via
+ref-resolvers. See the module commentary for more details."
+  (pre-post-order tree rules))
+
+;;; arch-tag_ ab05f3fe-9981-4a78-b64c-48efcd9983a6
+;;;; (texinfo indexing) -- indexing stexinfo
+;;;;
+;;;; 	Copyright (C) 2009, 2010  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003,2004,2009  Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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_
+;;
+;;@c texinfo formatting
+;;Given a piece of stexi, return an index of a specified variety.
+;;
+;;Note that currently, @code{stexi-extract-index} doesn't differentiate
+;;between different kinds of index entries. That's a bug ;)
+;;; Code_
+
+(define-module (texinfo indexing)
+  #\use-module (sxml simple)
+  #\use-module (srfi srfi-13)
+  #\export (stexi-extract-index))
+
+(define defines
+  '(deftp defcv defivar deftypeivar defop deftypeop defmethod
+    deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+    deftypefn defspec defmac defun deftypefun))
+
+(define indices
+  '(cindex findex vindex kindex pindex tindex))
+
+(define (stexi-extract-index tree manual-name kind)
+  "Given an stexi tree @var{tree}, index all of the entries of type
+@var{kind}. @var{kind} can be one of the predefined texinfo indices
+(@code{concept}, @code{variable}, @code{function}, @code{key},
+@code{program}, @code{type}) or one of the special symbols @code{auto} 
+or @code{all}. @code{auto} will scan the stext for a @code{(printindex)}
+statement, and @code{all} will generate an index from all entries,
+regardless of type.
+
+The returned index is a list of pairs, the @sc{car} of which is the
+entry (a string) and the @sc{cdr} of which is a node name (a string)."
+  (let loop ((in tree) (entries '()))
+    (cond
+     ((null? in)
+      entries)
+     ((pair? (car in))
+      (cond
+       ((and (pair? (cdr in)) (pair? (cadr in))
+             (eq? (caar in) 'anchor) (memq (caadr in) defines))
+        (loop (cddr in) (acons (cadr (assq 'name (cdr (cadadr in))))
+                               (cadr (assq 'name (cdadar in)))
+                               entries)))
+       ((and (pair? (cdr in)) (pair? (cadr in))
+             (eq? (caar in) 'anchor) (memq (caadr in) indices))
+        (loop (cddr in) (acons (sxml->string (cadr in))
+                               (cadr (assq 'name (cdadar in)))
+                               entries)))
+       (else
+        (loop (cdr in) (loop (car in) entries)))))
+     (else
+      (loop (cdr in) entries)))))
+
+;;; arch-tag_ 216d29d3-1ed9-433f-9c19-0dc4d6b439b6
+;;;; (texinfo plain-text) -- rendering stexinfo as plain text
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2011, 2013  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003,2004,2009  Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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_
+;;
+;;Transformation from stexi to plain-text. Strives to re-create the
+;;output from @code{info}; comes pretty damn close.
+;;        
+;;; Code_
+
+(define-module (texinfo plain-text)
+  #\use-module (texinfo)
+  #\use-module (texinfo string-utils)
+  #\use-module (sxml transform)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-13)
+  #\use-module (ice-9 match)
+  #\export (stexi->plain-text))
+
+;; The return value is a string.
+(define (arg-ref key %-args)
+  (and=> (and=> (assq key (cdr %-args)) cdr)
+         stexi->plain-text))
+(define (arg-req key %-args)
+  (or (arg-ref key %-args)
+      (error "Missing argument_" key %-args)))
+
+(define (make-ticker str)
+  (lambda () str))
+(define (make-enumerator n)
+  (lambda ()
+    (let ((last n))
+      (set! n (1+ n))
+      (format #f "~A. " last))))
+
+(define *indent* (make-fluid ""))
+(define *itemizer* (make-fluid (make-ticker "* ")))
+
+(define-macro (with-indent n . body)
+  `(with-fluids ((*indent* (string-append (fluid-ref *indent*)
+                                          (make-string ,n #\space))))
+     ,@body))
+
+(define (make-indenter n proc)
+  (lambda args (with-indent n (apply proc args))))
+
+(define (string-indent str)
+  (string-append (fluid-ref *indent*) str "\n"))
+
+(define-macro (with-itemizer itemizer . body)
+  `(with-fluids ((*itemizer* ,itemizer))
+     ,@body))
+
+(define (wrap* . strings)
+  (let ((indent (fluid-ref *indent*)))
+    (fill-string (string-concatenate strings)
+                 #\line-width 72 #\initial-indent indent
+                 #\subsequent-indent indent)))
+(define (wrap . strings)
+  (string-append (apply wrap* strings) "\n\n"))
+(define (wrap-heading . strings)
+  (string-append (apply wrap* strings) "\n"))
+
+(define (ref tag args)
+  (let* ((node (arg-req 'node args))
+         (name (or (arg-ref 'name args) node))
+         (manual (arg-ref 'manual args)))
+    (string-concatenate
+     (cons*
+      (or (and=> (assq tag '((xref "See ") (pxref "see "))) cadr) "")
+      name
+      (if manual `(" in manual " ,manual) '())))))
+
+(define (uref tag args)
+  (let ((url (arg-req 'url args))
+        (title (arg-ref 'title args)))
+    (if title
+        (string-append title " (" url ")")
+        (string-append "`" url "'"))))
+
+(define (def tag args . body)
+  (define (first-line)
+    (string-join
+     (filter identity
+             (map (lambda (x) (arg-ref x args))
+                  '(data-type class name arguments)))
+     " "))
+
+  (let* ((category (case tag
+                     ((defun) "Function")
+                     ((defspec) "Special Form")
+                     ((defvar) "Variable")
+                     (else (arg-req 'category args)))))
+    (string-append
+     (wrap-heading (string-append " - " category "_ " (first-line)))
+     (with-indent 5 (stexi->plain-text body)))))
+
+(define (enumerate tag . elts)
+  (define (tonumber start)
+    (let ((c (string-ref start 0)))
+      (cond ((number? c) (string->number start))
+            (else (1+ (- (char->integer c)
+                         (char->integer (if (char-upper-case? c) #\A #\a))))))))
+  (let* ((args? (and (pair? elts) (pair? (car elts))
+                     (eq? (caar elts) '%)))
+         (start (and args? (arg-ref 'start (car elts)))))
+    (with-itemizer (make-enumerator (if start (tonumber start) 1))
+      (with-indent 5
+        (stexi->plain-text (if start (cdr elts) elts))))))
+
+(define (itemize tag args . elts)
+  (with-itemizer (make-ticker "* ")
+    (with-indent 5
+      (stexi->plain-text elts))))
+
+(define (item tag . elts)
+  (let* ((ret (stexi->plain-text elts))
+         (tick ((fluid-ref *itemizer*)))
+         (tick-pos (- (string-length (fluid-ref *indent*))
+                      (string-length tick))))
+    (if (and (not (string-null? ret)) (not (negative? tick-pos)))
+        (string-copy! ret tick-pos tick))
+    ret))
+
+(define (table tag args . body)
+  (stexi->plain-text body))
+
+(define (entry tag args . body)
+  (let ((heading (wrap-heading
+                  (stexi->plain-text (arg-req 'heading args)))))
+    (string-append heading
+                   (with-indent 5 (stexi->plain-text body)))))
+
+(define (make-underliner char)
+  (lambda (tag . body)
+    (let ((str (stexi->plain-text body)))
+      (string-append
+       "\n"
+       (string-indent str)
+       (string-indent (make-string (string-length str) char))
+       "\n"))))
+
+(define chapter (make-underliner #\*))
+(define section (make-underliner #\=))
+(define subsection (make-underliner #\-))
+(define subsubsection (make-underliner #\.))
+
+(define (example tag . body)
+  (let ((ret (stexi->plain-text body)))
+    (string-append
+     (string-concatenate
+      (with-indent 5 (map string-indent (string-split ret #\newline))))
+     "\n")))
+
+(define (verbatim tag . body)
+  (let ((ret (stexi->plain-text body)))
+    (string-append
+     (string-concatenate
+      (map string-indent (string-split ret #\newline)))
+     "\n")))
+
+(define (fragment tag . body)
+  (string-concatenate (map-in-order stexi->plain-text body)))
+
+(define (para tag . body)
+  (wrap (stexi->plain-text body)))
+
+(define (make-surrounder str)
+  (lambda (tag . body)
+    (string-append str (stexi->plain-text body) str)))
+
+(define (code tag . body)
+  (string-append "`" (stexi->plain-text body) "'"))
+
+(define (key tag . body)
+  (string-append "<" (stexi->plain-text body) ">"))
+
+(define (var tag . body)
+  (string-upcase (stexi->plain-text body)))
+
+(define (passthrough tag . body)
+  (stexi->plain-text body))
+
+(define (texinfo tag args . body)
+  (let ((title (chapter 'foo (arg-req 'title args))))
+    (string-append title (stexi->plain-text body))))
+
+(define ignore-list
+  '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip
+    menu ignore syncodeindex comment c % node anchor))
+(define (ignored? tag)
+  (memq tag ignore-list))
+
+(define tag-handlers
+  `((title        ,chapter)
+    (chapter      ,chapter)
+    (section      ,section)
+    (subsection   ,subsection)
+    (subsubsection ,subsubsection)
+    (appendix     ,chapter)
+    (appendixsec  ,section)
+    (appendixsubsec ,subsection)
+    (appendixsubsubsec ,subsubsection)
+    (unnumbered   ,chapter)
+    (unnumberedsec ,section)
+    (unnumberedsubsec ,subsection)
+    (unnumberedsubsubsec ,subsubsection)
+    (majorheading ,chapter)
+    (chapheading  ,chapter)
+    (heading      ,section)
+    (subheading   ,subsection)
+    (subsubheading ,subsubsection)
+
+    (strong       ,(make-surrounder "*"))
+    (sample       ,code)
+    (samp         ,code)
+    (code         ,code)
+    (math         ,passthrough)
+    (kbd          ,code)
+    (key          ,key)
+    (var          ,var)
+    (env          ,code)
+    (file         ,code)
+    (command      ,code)
+    (option       ,code)
+    (url          ,code)
+    (dfn          ,(make-surrounder "\""))
+    (cite         ,(make-surrounder "\""))
+    (acro         ,passthrough)
+    (email        ,key)
+    (emph         ,(make-surrounder "_"))
+    (sc           ,var)
+    (copyright    ,(lambda args "(C)"))
+    (result       ,(lambda args "==>"))
+    (dots         ,(lambda args "..."))
+    (xref         ,ref)
+    (ref          ,ref)
+    (pxref        ,ref)
+    (uref         ,uref)
+
+    (texinfo      ,texinfo)
+    (quotation    ,(make-indenter 5 para))
+    (itemize      ,itemize)
+    (enumerate    ,enumerate)
+    (item         ,item)
+    (table        ,table)
+    (entry        ,entry)
+    (example      ,example)
+    (lisp         ,example)
+    (smallexample ,example)
+    (smalllisp    ,example)
+    (verbatim     ,verbatim)
+    (*fragment*   ,fragment)
+
+    (deftp        ,def)
+    (defcv        ,def)
+    (defivar      ,def)
+    (deftypeivar  ,def)
+    (defop        ,def)
+    (deftypeop    ,def)
+    (defmethod    ,def)
+    (deftypemethod  ,def)
+    (defopt       ,def)
+    (defvr        ,def)
+    (defvar       ,def)
+    (deftypevr    ,def)
+    (deftypevar   ,def)
+    (deffn        ,def) 
+    (deftypefn    ,def)
+    (defmac       ,def)
+    (defspec      ,def)
+    (defun        ,def)
+    (deftypefun   ,def)))
+
+(define (stexi->plain-text tree)
+  "Transform @var{tree} into plain text. Returns a string."
+  (match tree
+    (() "")
+    ((? string?) tree)
+    (((? symbol? tag) body ...)
+     (let ((handler (and (not (ignored? tag))
+                         (or (and=> (assq tag tag-handlers) cadr)
+                             para))))
+       (if handler
+           (apply handler tree)
+           "")))
+    ((tree ...)
+     (string-concatenate (map-in-order stexi->plain-text tree)))
+    (_ "")))
+
+;;; arch-tag_ f966c3f6-3b46-4790-bbf9-3ad27e4917c2
+;;;; (texinfo reflection) -- documenting Scheme as stexinfo
+;;;;
+;;;; 	Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003,2004,2009  Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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_
+;;
+;;Routines to generare @code{stexi} documentation for objects and
+;;modules.
+;;
+;;Note that in this context, an @dfn{object} is just a value associated
+;;with a location. It has nothing to do with GOOPS.
+;;
+;;; Code_
+
+(define-module (texinfo reflection)
+  #\use-module ((srfi srfi-1) #\select (append-map))
+  #\use-module (oop goops)
+  #\use-module (texinfo)
+  #\use-module (texinfo plain-text)
+  #\use-module (srfi srfi-13)
+  #\use-module (ice-9 session)
+  #\use-module (ice-9 documentation)
+  #\use-module (ice-9 optargs)
+  #\use-module ((sxml transform) #\select (pre-post-order))
+  #\export (module-stexi-documentation
+            script-stexi-documentation
+            object-stexi-documentation
+            package-stexi-standard-copying
+            package-stexi-standard-titlepage
+            package-stexi-generic-menu
+            package-stexi-standard-menu
+            package-stexi-extended-menu
+            package-stexi-standard-prologue
+            package-stexi-documentation
+            package-stexi-documentation-for-include))
+
+;; List for sorting the definitions in a module
+(define defs
+  '(deftp defcv defivar deftypeivar defop deftypeop defmethod
+    deftypemethod defopt defvr defvar deftypevr deftypevar deffn
+    deftypefn defmac defspec defun deftypefun))
+
+(define (sort-defs ordering a b)
+  (define (def x)
+    ;; a and b are lists of the form ((anchor ...) (def* ...)...)
+    (cadr x))
+  (define (name x)
+    (cadr (assq 'name (cdadr (def x)))))
+  (define (priority x)
+    (list-index defs (car (def x))))
+  (define (order x)
+    (or (list-index ordering (string->symbol (name x)))
+        ;; if the def is not in the list, a big number
+        1234567890))
+  (define (compare-in-order proc eq? < . args)
+    (if (not (eq? (proc a) (proc b)))
+        (< (proc a) (proc b))
+        (or (null? args)
+            (apply compare-in-order args))))
+  (compare-in-order order = <
+                    priority = <
+                    name string=? string<=?))
+
+(define (list*-join l infix restfix)
+  (let lp ((in l) (out '()))
+    (cond ((null? in) (reverse! out))
+          ((symbol? in) (reverse! (cons* in restfix out)))
+          (else (lp (cdr in) (if (null? out)
+                                 (list (car in))
+                                 (cons* (car in) infix out)))))))
+
+(define (process-args args)
+  (map (lambda (x) (if (string? x) x (object->string x)))
+       (list*-join (or args '())
+                   " " " . ")))
+
+(define (get-proc-args proc)
+  (cond
+   ((procedure-arguments proc)
+    => (lambda (args)
+         (let ((required-args (assq-ref args 'required))
+               (optional-args (assq-ref args 'optional))
+               (keyword-args  (assq-ref args 'keyword))
+               (rest-arg (assq-ref args 'rest)))
+           (process-args 
+            (append 
+             ;; start with the required args...
+             (map symbol->string required-args)
+
+             ;; add any optional args if needed...
+             (map (lambda (a)
+                    (if (list? a)
+                        (format #f "[~a = ~s]" (car a) (cadr a))
+                        (format #f "[~a]" a)))
+                  optional-args)
+                    
+             ;; now the keyword args..
+             (map (lambda (a)
+                    (if (pair? a)
+                        (format #f "[~a]" (car a))
+                        (format #f "[#:~a]" a)))
+                  keyword-args)
+                    
+             ;; now the rest arg...
+             (if rest-arg
+                 (list "." (symbol->string rest-arg))
+                 '()))))))))
+
+(define (macro-arguments name type transformer)
+  (process-args
+   (case type
+     ((syntax-rules)
+      (let ((patterns (procedure-property transformer 'patterns)))
+        (if (pair? patterns)
+            (car patterns)
+            '())))
+     ((identifier-syntax)
+      '())
+     ((defmacro)
+      (or (procedure-property transformer 'defmacro-args)
+          '()))
+     (else
+      ;; a procedural (syntax-case) macro. how to document these?
+      '()))))
+
+(define (macro-additional-stexi name type transformer)
+  (case type
+    ((syntax-rules)
+     (let ((patterns (procedure-property transformer 'patterns)))
+       (if (pair? patterns)
+           (map (lambda (x)
+                  `(defspecx (% (name ,name)
+                                (arguments ,@(process-args x)))))
+                (cdr patterns))
+           '())))
+    (else
+     '())))
+
+(define many-space? (make-regexp "[[_space_]][[_space_]][[_space_]]"))
+(define initial-space? (make-regexp "^[[_space_]]"))
+(define (string->stexi str)
+  (or (and (or (not str) (string-null? str))
+           '(*fragment*))
+      (and (or (string-index str #\@)
+               (and (not (regexp-exec many-space? str))
+                    (not (regexp-exec initial-space? str))))
+           (false-if-exception
+            (texi-fragment->stexi str)))
+      `(*fragment* (verbatim ,str))))
+
+(define method-formals
+  (and (defined? 'method-formals) method-formals))
+
+(define (method-stexi-arguments method)
+  (cond
+   (method-formals
+    (let lp ((formals (method-formals method))
+             (specializers (method-specializers method))
+             (out '()))
+      (define (arg-texinfo formal specializer)
+        `(" (" (var ,(symbol->string formal)) " "
+          (code ,(symbol->string (class-name specializer))) ")"))
+      (cond
+       ((null? formals) (reverse out))
+       ((pair? formals)
+        (lp (cdr formals) (cdr specializers)
+            (append (reverse (arg-texinfo (car formals) (car specializers)))
+                    out)))
+       (else
+        (append (reverse out) (arg-texinfo formals specializers)
+                (list "..."))))))
+   ((method-source method)
+    (let lp ((bindings (cadr (method-source method))) (out '()))
+      (define (arg-texinfo arg)
+        `(" (" (var ,(symbol->string (car arg))) " "
+          (code ,(symbol->string (cadr arg))) ")"))
+      (cond
+       ((null? bindings)
+        (reverse out))
+       ((not (pair? (car bindings)))
+        (append (reverse out) (arg-texinfo bindings) (list "...")))
+       (else
+        (lp (cdr bindings)
+            (append (reverse (arg-texinfo (car bindings))) out))))))
+   (else (warn method) '())))
+
+(define* (object-stexi-documentation object #\optional (name "[unknown]")
+                                     #\key (force #f))
+  (if (symbol? name)
+      (set! name (symbol->string name)))
+  (let ((stexi ((lambda (x)
+                  (cond ((string? x) (string->stexi x))
+                        ((and (pair? x) (eq? (car x) '*fragment*)) x)
+                        (force `(*fragment*))
+                        (else #f)))
+                (object-documentation
+                 (if (is-a? object <method>)
+                     (method-procedure object)
+                     object)))))
+    (define (make-def type args)
+      `(,type (% ,@args) ,@(cdr stexi)))
+    (cond
+     ((not stexi) #f)
+     ;; stexi is now a list, headed by *fragment*.
+     ((and (pair? (cdr stexi)) (pair? (cadr stexi))
+           (memq (caadr stexi) defs))
+      ;; it's already a deffoo.
+      stexi)
+     ((is-a? object <class>)
+      (make-def 'deftp `((name ,name)
+                         (category "Class"))))
+     ((is-a? object <macro>)
+      (let* ((proc (macro-transformer object))
+             (type (and proc (procedure-property proc 'macro-type))))
+        `(defspec (% (name ,name)
+                     (arguments ,@(macro-arguments name type proc)))
+           ,@(macro-additional-stexi name type proc)
+           ,@(cdr stexi))))
+     
+     ((is-a? object <procedure>)
+      (make-def 'defun `((name ,name)
+                         (arguments ,@(get-proc-args object)))))
+     ((is-a? object <method>)
+      (make-def 'deffn `((category "Method")
+                         (name ,name)
+                         (arguments ,@(method-stexi-arguments object)))))
+     ((is-a? object <generic>)
+      `(*fragment*
+        ,(make-def 'deffn `((name ,name)
+                            (category "Generic")))
+        ,@(map
+           (lambda (method)
+             (object-stexi-documentation method name #\force force))
+           (generic-function-methods object))))
+     (else
+      (make-def 'defvar `((name ,name)))))))
+
+(define (module-name->node-name sym-name)
+  (string-join (map symbol->string sym-name) " "))
+
+;; this copied from (ice-9 session); need to find a better way
+(define (module-filename name)
+  (let* ((name (map symbol->string name))
+         (reverse-name (reverse name))
+	 (leaf (car reverse-name))
+	 (dir-hint-module-name (reverse (cdr reverse-name)))
+	 (dir-hint (apply string-append
+                          (map (lambda (elt)
+                                 (string-append elt "/"))
+                               dir-hint-module-name))))
+    (%search-load-path (in-vicinity dir-hint leaf))))
+
+(define (read-module name)
+  (let ((filename (module-filename name)))
+    (if filename
+        (let ((port (open-input-file filename)))
+          (let lp ((out '()) (form (read port)))
+            (if (eof-object? form)
+                (reverse out)
+                (lp (cons form out) (read port)))))
+        '())))
+
+(define (module-export-list sym-name)
+  (define (module-form-export-list form)
+    (and (pair? form)
+         (eq? (car form) 'define-module)
+         (equal? (cadr form) sym-name)
+         (and=> (memq #\export (cddr form)) cadr)))
+  (let lp ((forms (read-module sym-name)))
+    (cond ((null? forms) '())
+          ((module-form-export-list (car forms)) => identity)
+          (else (lp (cdr forms))))))
+
+(define* (module-stexi-documentation sym-name
+                                     #\optional %docs-resolver
+                                     #\key (docs-resolver
+                                            (or %docs-resolver
+                                                (lambda (name def) def))))
+  "Return documentation for the module named @var{sym-name}. The
+documentation will be formatted as @code{stexi}
+ (@pxref{texinfo,texinfo})."
+  (if %docs-resolver
+      (issue-deprecation-warning
+       "module-stexi-documentation_ use #:docs-resolver instead of a positional argument."))
+  (let* ((commentary (and=> (module-commentary sym-name)
+                            (lambda (x) (string-trim-both x #\newline))))
+         (stexi (string->stexi commentary))
+         (node-name (module-name->node-name sym-name))
+         (name-str (with-output-to-string
+                     (lambda () (display sym-name))))
+         (module (resolve-interface sym-name))
+         (export-list (module-export-list sym-name)))
+    (define (anchor-name sym)
+      (string-append node-name " " (symbol->string sym)))
+    (define (make-defs)
+      (sort!
+       (module-map
+        (lambda (sym var)
+          `((anchor (% (name ,(anchor-name sym))))
+            ,@((lambda (x)
+                 (if (eq? (car x) '*fragment*)
+                     (cdr x)
+                     (list x)))
+               (if (variable-bound? var)
+                   (docs-resolver
+                    sym
+                    (object-stexi-documentation (variable-ref var) sym
+                                                #\force #t))
+                   (begin
+                     (warn "variable unbound!" sym)
+                     `(defvar (% (name ,(symbol->string sym)))
+                        "[unbound!]"))))))
+        module)
+       (lambda (a b) (sort-defs export-list a b))))
+
+    `(texinfo (% (title ,name-str))
+              (node (% (name ,node-name)))
+              (section "Overview")
+              ,@(cdr stexi)
+              (section "Usage")
+              ,@(apply append! (make-defs)))))
+
+(define (script-stexi-documentation scriptpath)
+  "Return documentation for given script. The documentation will be
+taken from the script's commentary, and will be returned in the
+@code{stexi} format (@pxref{texinfo,texinfo})."
+  (let ((commentary (file-commentary scriptpath)))
+    `(texinfo (% (title ,(basename scriptpath)))
+              (node (% (name ,(basename scriptpath))))
+              ,@(if commentary
+                    (cdr
+                     (string->stexi
+                      (string-trim-both commentary #\newline)))
+                    '()))))
+
+(cond
+ ((defined? 'add-value-help-handler!)
+  (add-value-help-handler! 
+   (lambda (name value)
+     (stexi->plain-text
+      (object-stexi-documentation value name #\force #t))))
+  (add-name-help-handler!
+   (lambda (name)
+    (and (list? name)
+         (and-map symbol? name)
+         (stexi->plain-text (module-stexi-documentation name)))))))
+
+;; we could be dealing with an old (ice-9 session); fondle it to get
+;; module-commentary
+(define module-commentary (@@ (ice-9 session) module-commentary))
+
+(define (package-stexi-standard-copying name version updated years
+                                        copyright-holder permissions)
+  "Create a standard texinfo @code{copying} section.
+
+@var{years} is a list of years (as integers) in which the modules
+being documented were released. All other arguments are strings."
+  `(copying
+    (para "This manual is for " ,name
+          " (version " ,version ", updated " ,updated ")")
+    (para "Copyright " ,(string-join (map number->string years) ",")
+          " " ,copyright-holder)
+    (quotation
+     (para ,permissions))))
+
+(define (package-stexi-standard-titlepage name version updated authors)
+  "Create a standard GNU title page.
+
+@var{authors} is a list of @code{(@var{name} . @var{email})}
+pairs. All other arguments are strings.
+
+Here is an example of the usage of this procedure_
+
+@smallexample
+ (package-stexi-standard-titlepage
+  \"Foolib\"
+  \"3.2\"
+  \"26 September 2006\"
+  '((\"Alyssa P Hacker\" . \"alyssa@@example.com\"))
+  '(2004 2005 2006)
+  \"Free Software Foundation, Inc.\"
+  \"Standard GPL permissions blurb goes here\")
+@end smallexample
+"
+  `(;(setchapternewpage (% (all "odd"))) makes manuals too long
+    (titlepage
+     (title ,name)
+     (subtitle "version " ,version ", updated " ,updated)
+     ,@(map (lambda (pair)
+              `(author ,(car pair)
+                       " (" (email ,(cdr pair)) ")"))
+            authors)
+     (page)
+     (vskip (% (all "0pt plus 1filll")))
+     (insertcopying))))
+
+(define (package-stexi-generic-menu name entries)
+  "Create a menu from a generic alist of entries, the car of which
+should be the node name, and the cdr the description. As an exception,
+an entry of @code{#f} will produce a separator."
+  (define (make-entry node description)
+    `("* " ,node "__"
+      ,(make-string (max (- 21 (string-length node)) 2) #\space)
+      ,@description "\n"))
+  `((ifnottex
+     (node (% (name "Top")))
+     (top (% (title ,name)))
+     (insertcopying)
+     (menu
+      ,@(apply
+         append
+         (map
+          (lambda (entry)
+            (if entry
+                (make-entry (car entry) (cdr entry))
+                '("\n")))
+          entries))))
+    (iftex
+     (shortcontents))))
+
+
+(define (package-stexi-standard-menu name modules module-descriptions
+                                     extra-entries)
+  "Create a standard top node and menu, suitable for processing
+by makeinfo."
+  (package-stexi-generic-menu
+   name
+   (let ((module-entries (map cons
+                              (map module-name->node-name modules)
+                              module-descriptions))
+         (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
+     `(,@module-entries
+       ,@(separate-sections extra-entries)))))
+
+(define (package-stexi-extended-menu name module-pairs script-pairs
+                                     extra-entries)
+  "Create an \"extended\" menu, like the standard menu but with a
+section for scripts."
+  (package-stexi-generic-menu
+   name
+   (let ((module-entries (map cons
+                              (map module-name->node-name
+                                   (map car module-pairs))
+                              (map cdr module-pairs)))
+         (script-entries (map cons
+                              (map basename (map car script-pairs))
+                              (map cdr script-pairs)))
+         (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
+     `(,@module-entries
+       ,@(separate-sections script-entries)
+       ,@(separate-sections extra-entries)))))
+
+(define (package-stexi-standard-prologue name filename category
+                                         description copying titlepage
+                                         menu)
+  "Create a standard prologue, suitable for later serialization
+to texinfo and .info creation with makeinfo.
+
+Returns a list of stexinfo forms suitable for passing to
+@code{package-stexi-documentation} as the prologue. @xref{texinfo
+reflection package-stexi-documentation}, @ref{texinfo reflection
+package-stexi-standard-titlepage,package-stexi-standard-titlepage},
+@ref{texinfo reflection
+package-stexi-standard-copying,package-stexi-standard-copying},
+and @ref{texinfo reflection
+package-stexi-standard-menu,package-stexi-standard-menu}."
+  `(,copying
+    (dircategory (% (category ,category)))
+    (direntry
+     "* " ,name "_ (" ,filename ").  " ,description ".")
+    ,@titlepage
+    ,@menu))
+
+(define (stexi->chapter stexi)
+  (pre-post-order
+   stexi
+   `((texinfo . ,(lambda (tag attrs node . body)
+                   `(,node
+                     (chapter ,@(assq-ref (cdr attrs) 'title))
+                     ,@body)))
+     (*text* . ,(lambda (tag text) text))
+     (*default* . ,(lambda args args)))))
+
+(define* (package-stexi-documentation modules name filename
+                                      prologue epilogue
+                                      #\key
+                                      (module-stexi-documentation-args
+                                       '())
+                                      (scripts '()))
+  "Create stexi documentation for a @dfn{package}, where a
+package is a set of modules that is released together.
+
+@var{modules} is expected to be a list of module names, where a
+module name is a list of symbols. The stexi that is returned will
+be titled @var{name} and a texinfo filename of @var{filename}.
+
+@var{prologue} and @var{epilogue} are lists of stexi forms that
+will be spliced into the output document before and after the
+generated modules documentation, respectively.
+@xref{texinfo reflection package-stexi-standard-prologue}, to
+create a conventional GNU texinfo prologue.
+
+@var{module-stexi-documentation-args} is an optional argument that, if
+given, will be added to the argument list when
+@code{module-texi-documentation} is called. For example, it might be
+useful to define a @code{#:docs-resolver} argument."
+  (define (verify-modules-list l)
+    (define (all pred l)
+      (and (pred (car l))
+           (or (null? (cdr l)) (all pred (cdr l)))))
+    (false-if-exception
+     (all (lambda (x) (all symbol? x)) modules)))
+  (if (not (verify-modules-list modules))
+      (error "expected modules to be a list of a list of symbols"
+             modules))
+
+  `(texinfo
+    (% (title ,name)
+       (filename ,filename))
+    ,@prologue
+    ,@(append-map (lambda (mod)
+                    (stexi->chapter
+                     (apply module-stexi-documentation
+                            mod module-stexi-documentation-args)))
+                  modules)
+    ,@(append-map (lambda (script)
+                    (stexi->chapter
+                     (script-stexi-documentation script)))
+                  scripts)
+    ,@epilogue))
+
+(define* (package-stexi-documentation-for-include modules module-descriptions
+                                                  #\key
+                                                  (module-stexi-documentation-args '()))
+  "Create stexi documentation for a @dfn{package}, where a
+package is a set of modules that is released together.
+
+@var{modules} is expected to be a list of module names, where a
+module name is a list of symbols. Returns an stexinfo fragment.
+
+Unlike @code{package-stexi-documentation}, this function simply produces
+a menu and the module documentations instead of producing a full texinfo
+document. This can be useful if you write part of your manual by hand,
+and just use @code{@@include} to pull in the automatically generated
+parts.
+
+@var{module-stexi-documentation-args} is an optional argument that, if
+given, will be added to the argument list when
+@code{module-texi-documentation} is called. For example, it might be
+useful to define a @code{#:docs-resolver} argument."
+  (define (make-entry node description)
+    `("* " ,node "__"
+      ,(make-string (max (- 21 (string-length node)) 2) #\space)
+      ,@description "\n"))
+  `(*fragment*
+    (menu
+     ,@(append-map (lambda (modname desc)
+                     (make-entry (module-name->node-name modname)
+                                 desc))
+                   modules
+                   module-descriptions))
+    ,@(append-map (lambda (modname)
+                    (stexi->chapter
+                     (apply module-stexi-documentation 
+                            modname
+                            module-stexi-documentation-args)))
+                  modules)))
+
+;;; arch-tag_ bbe2bc03-e16d-4a9e-87b9-55225dc9836c
+;;;; (texinfo serialize) -- rendering stexinfo as texinfo
+;;;;
+;;;; 	Copyright (C) 2009, 2012, 2013  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003,2004,2009  Andy Wingo <wingo at pobox dot com>
+;;;; 
+;;;; 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_
+;;
+;;Serialization of @code{stexi} to plain texinfo.
+;;
+;;; Code_
+
+(define-module (texinfo serialize)
+  #\use-module (texinfo)
+  #\use-module (texinfo string-utils)
+  #\use-module (sxml transform)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-13)
+  #\export (stexi->texi))
+
+(define (list-intersperse src-l elem)
+  (if (null? src-l) src-l
+      (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+        (if (null? l) (reverse dest)
+            (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
+;; converts improper lists to proper lists.
+(define (filter* pred l)
+  (let lp ((in l) (out '()))
+    (cond ((null? in)
+           (reverse! out))
+          ((pair? in)
+           (lp (cdr in) (if (pred (car in)) (cons (car in) out) out)))
+          (else
+           (lp '() (if (pred in) (cons in out) out))))))
+
+;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g)
+(define (list* . args)
+  (let* ((args (reverse args))
+         (tail (car args)))
+    (let lp ((in (cdr args)) (out tail))
+      (cond ((null? in) out)
+            ((pair? (car in)) (lp (cdr in) (append (car in) out)))
+            ((null? (car in)) (lp (cdr in) out))
+            (else (lp (cdr in) (cons (car in) out)))))))
+
+;; Why? Well, because syntax-case defines `include', and carps about its
+;; wrong usage below...
+(eval-when (expand load eval)
+  (define (include exp lp command type formals args accum)
+    (list* "\n"
+           (list-intersperse
+            args
+            " ")
+           " " command "@" accum)))
+
+(define (empty-command exp lp command type formals args accum)
+  (list* " " command "@" accum))
+
+(define (inline-text exp lp command type formals args accum)
+  (if (not (string=? command "*braces*")) ;; fixme _(
+      (list* "}"
+             (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+             "{" command "@" accum)
+      (list* "@}"
+             (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+             "@{" accum)))
+
+(define (inline-args exp lp command type formals args accum)
+  (list* "}"
+         (if (not args) ""
+             (list-intersperse
+              (map
+               (lambda (x)
+                 (cond ((not x) "")
+                       ((pair? x)
+                        (if (pair? (cdr x))
+                            (warn "Strange inline-args!" args))
+                        (car x))
+                       (else (error "Invalid inline-args" args))))
+               (drop-while not
+                           (map (lambda (x) (assq-ref args x))
+                                (reverse formals))))
+              ","))
+         "{" command "@" accum))
+
+(define (inline-text-args exp lp command type formals args accum)
+  (list* "}"
+         (if (not args) ""
+             (apply
+              append
+              (list-intersperse
+               (map
+                (lambda (x) (append-map (lambda (x) (lp x '())) (reverse x)))
+                (drop-while not
+                            (map (lambda (x) (assq-ref args x))
+                                 (reverse formals))))
+               '(","))))
+         "{" command "@" accum))
+
+(define (serialize-text-args lp formals args)
+  (apply
+   append
+   (list-intersperse
+    (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg))
+         (map
+          reverse
+          (drop-while
+           not (map (lambda (x) (assq-ref args x))
+                    (reverse formals)))))
+    '(" "))))
+
+(define (eol-text-args exp lp command type formals args accum)
+  (list* "\n"
+         (serialize-text-args lp formals args)
+         " " command "@" accum))
+
+(define (eol-text exp lp command type formals args accum)
+  (list* "\n"
+         (append-map (lambda (x) (lp x '()))
+                     (reverse (if args (cddr exp) (cdr exp))))
+         " " command "@" accum))
+
+(define (eol-args exp lp command type formals args accum)
+  (list* "\n"
+         (list-intersperse
+          (apply append
+                 (drop-while not
+                             (map (lambda (x) (assq-ref args x))
+                                  (reverse formals))))
+          ", ")
+         " " command "@" accum))
+
+(define (environ exp lp command type formals args accum)
+  (case (car exp)
+    ((texinfo)
+     (list* "@bye\n"
+            (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+            "\n@c %**end of header\n\n"
+            (reverse (assq-ref args 'title)) "@settitle "
+            (or (and=> (assq-ref args 'filename)
+                       (lambda (filename)
+                         (cons "\n" (reverse (cons "@setfilename " filename)))))
+                "")
+            "\\input texinfo   @c -*-texinfo-*-\n@c %**start of header\n"
+            accum))
+    (else
+     (list* "\n\n" command "@end "
+            (let ((body (append-map (lambda (x) (lp x '()))
+                                    (reverse (if args (cddr exp) (cdr exp))))))
+              (if (or (null? body)
+                      (eqv? (string-ref (car body)
+                                        (1- (string-length (car body))))
+                            #\newline))
+                  body
+                  (cons "\n" body)))
+            "\n"
+            (serialize-text-args lp formals args)
+            " " command "@" accum))))
+
+(define (table-environ exp lp command type formals args accum)
+  (list* "\n\n" command "@end "
+         (append-map (lambda (x) (lp x '()))
+                     (reverse (if args (cddr exp) (cdr exp))))
+         "\n"
+         (let* ((arg (if args (cadar args) ""))) ;; zero or one args
+           (if (pair? arg)
+               (list (symbol->string (car arg)) "@")
+               arg))
+         " " command "@" accum))
+
+(define (wrap strings)
+  (fill-string (string-concatenate strings)
+               #\line-width 72
+               #\break-long-words? #f))
+
+(define (paragraph exp lp command type formals args accum)
+  (list* "\n\n"
+         (wrap
+          (reverse
+           (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))))
+         accum))
+
+(define (item exp lp command type formals args accum)
+  (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+         "@item\n"
+         accum))
+
+(define (entry exp lp command type formals args accum)
+  (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp)))
+         "\n"
+         (append-map (lambda (x) (lp x '())) (reverse (cdar args)))
+         "@item "
+         accum))
+
+(define (fragment exp lp command type formals args accum)
+  (list* "\n@c %end of fragment\n"
+         (append-map (lambda (x) (lp x '())) (reverse (cdr exp)))
+         "\n@c %start of fragment\n\n"
+         accum))
+
+(define serializers
+  `((EMPTY-COMMAND . ,empty-command)
+    (INLINE-TEXT . ,inline-text)
+    (INLINE-ARGS . ,inline-args)
+    (INLINE-TEXT-ARGS . ,inline-text-args)
+    (EOL-TEXT . ,eol-text)
+    (EOL-TEXT-ARGS . ,eol-text-args)
+    (INDEX . ,eol-text-args)
+    (EOL-ARGS . ,eol-args)
+    (ENVIRON . ,environ)
+    (TABLE-ENVIRON . ,table-environ)
+    (ENTRY . ,entry)
+    (ITEM . ,item)
+    (PARAGRAPH . ,paragraph)
+    (FRAGMENT . ,fragment)
+    (#f . ,include))) ; support writing include statements
+
+(define (serialize exp lp command type formals args accum)
+  ((or (assq-ref serializers type)
+       (error "Unknown command type" exp type))
+   exp lp command type formals args accum))
+
+(define escaped-chars '(#\} #\{ #\@))
+(define (escape str)
+  "Escapes any illegal texinfo characters (currently @{, @}, and @@)."
+  (let loop ((in (string->list str)) (out '()))
+    (if (null? in)
+        (apply string (reverse out))
+        (if (memq (car in) escaped-chars)
+            (loop (cdr in) (cons* (car in) #\@ out))
+            (loop (cdr in) (cons (car in) out))))))
+
+(define (stexi->texi tree)
+  "Serialize the stexi @var{tree} into plain texinfo."
+  (string-concatenate-reverse
+   (let lp ((in tree) (out '()))
+     (cond
+      ((or (not in) (null? in)) out)
+      ((string? in) (cons (escape in) out))
+      ((pair? in)
+       (let ((command-spec (assq (car in) texi-command-specs)))
+         (if (not command-spec)
+             (begin
+               (warn "Unknown stexi command, not rendering" in)
+               out)
+             (serialize in
+                        lp
+                        (symbol->string (car in))
+                        (cadr command-spec)
+                        (filter* symbol? (cddr command-spec))
+                        (cond
+                         ((and (pair? (cdr in)) (pair? (cadr in))
+                               (eq? (caadr in) '%))
+                          (cdadr in))
+                         ((not (cadr command-spec))
+                          ;; include
+                          (cdr in))
+                         (else
+                          #f))
+                        out))))
+      (else
+       (error "Invalid stexi" in))))))
+
+;;; arch-tag_ d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5
+;;;; (texinfo string-utils) -- text filling and wrapping 
+;;;;
+;;;;    Copyright (C) 2009, 2013  Free Software Foundation, Inc.
+;;;;    Copyright (C) 2003  Richard Todd
+;;;; 
+;;;; 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_
+;; Module @samp{(texinfo string-utils)} provides various string-related
+;; functions useful to Guile's texinfo support.
+;;; Code_
+
+(define-module (texinfo string-utils)
+  #\use-module (srfi srfi-13)
+  #\use-module (srfi srfi-14)
+  #\export (escape-special-chars
+            transform-string
+            expand-tabs
+            center-string
+            left-justify-string
+            right-justify-string
+            collapse-repeated-chars
+            make-text-wrapper
+            fill-string
+            string->wrapped-lines))
+
+(define* (transform-string str match? replace #\optional (start #f) (end #f))
+"Uses @var{match?} against each character in @var{str}, and performs a
+replacement on each character for which matches are found.
+
+@var{match?} may either be a function, a character, a string, or
+@code{#t}.  If @var{match?}  is a function, then it takes a single
+character as input, and should return @samp{#t} for matches.
+@var{match?} is a character, it is compared to each string character
+using @code{char=?}.  If @var{match?} is a string, then any character
+in that string will be considered a match.  @code{#t} will cause 
+every character to be a match.
+
+If @var{replace} is a function, it is called with the matched
+character as an argument, and the returned value is sent to the output
+string via @samp{display}.  If @var{replace} is anything else, it is
+sent through the output string via @samp{display}.
+
+Note that te replacement for the matched characters does not need to
+be a single character.  That is what differentiates this function from
+@samp{string-map}, and what makes it useful for applications such as
+converting @samp{#\\&} to @samp{\"&amp;\"} in web page text.  Some other
+functions in this module are just wrappers around common uses of
+@samp{transform-string}.  Transformations not possible with this
+function should probably be done with regular expressions.
+
+If @var{start} and @var{end} are given, they control which portion
+of the string undergoes transformation.  The entire input string
+is still output, though.  So, if @var{start} is @samp{5}, then the
+first five characters of @var{str} will still appear in the returned
+string.
+
+@lisp
+; these two are equivalent...
+ (transform-string str #\\space #\\-) ; change all spaces to -'s
+ (transform-string str (lambda (c) (char=? #\\space c)) #\\-)
+@end lisp"
+  ;;  I had implemented this with string-fold, but it was
+  ;; slower...
+  (let* ((os (open-output-string))
+         (matcher (cond ((char? match?)
+                         (lambda (c) (char=? match? c)))
+                        ((procedure? match?)
+                         match?)
+                        ((string? match?)
+                         (lambda (c) (string-index match? c)))
+                        ((boolean? match?)
+                         (lambda (c) match?))
+                        (else (throw 'bad-type "expected #t, char, string, or procedure"))))
+         (replacer (if (procedure? replace)
+                       (lambda (c) (display (replace c) os))
+                       (lambda (c) (display replace os)))))
+
+    ;; put the first part in, un-transformed if they asked for it...
+    (if (and start (<= start (string-length str)))
+        (display (substring str 0 start) os))
+
+    ;; process the portion they want processed....
+    (string-for-each
+     (lambda (c)
+       (if (matcher c)
+           ;; we have a match! replace the char as directed...
+           (replacer c)
+
+           ;; not a match, just insert the character itself...
+           (write-char c os)))
+     str
+     (or start 0)
+     (or end (string-length str)))
+
+    ;; if there was any at the end, tack it on...
+    (if (and end (< end (string-length str)))
+        (display (substring str end) os))
+
+    (get-output-string os)))
+
+(define* (expand-tabs str #\optional (tab-size 8))
+"Returns a copy of @var{str} with all tabs expanded to spaces.  @var{tab-size} defaults to 8.
+
+Assuming tab size of 8, this is equivalent to_ @lisp
+ (transform-string str #\\tab \"        \")
+@end lisp"
+  (transform-string str 
+                    #\tab
+                    (make-string tab-size #\space)))
+
+(define (escape-special-chars str special-chars escape-char)
+"Returns a copy of @var{str} with all given special characters preceded
+by the given @var{escape-char}.
+
+@var{special-chars} can either be a single character, or a string consisting
+of all the special characters.
+
+@lisp
+;; make a string regexp-safe...
+ (escape-special-chars \"***(Example String)***\"  
+                      \"[]()/*.\" 
+                      #\\\\)
+=> \"\\\\*\\\\*\\\\*\\\\(Example String\\\\)\\\\*\\\\*\\\\*\"
+
+;; also can escape a singe char...
+ (escape-special-chars \"richardt@@vzavenue.net\"
+                      #\\@@
+                      #\\@@)
+=> \"richardt@@@@vzavenue.net\"
+@end lisp"
+  (transform-string str
+                    (if (char? special-chars)
+                        ;; if they gave us a char, use char=?
+                        (lambda (c) (char=? c special-chars))
+
+                        ;; if they gave us a string, see if our character is in it
+                        (lambda (c) (string-index special-chars c)))
+
+                    ;; replace matches with the character preceded by the escape character
+                    (lambda (c) (string escape-char c))))
+
+(define* (center-string str #\optional (width 80) (chr #\space) (rchr #f))
+"Returns a copy of @var{str} centered in a field of @var{width}
+characters.  Any needed padding is done by character @var{chr}, which
+defaults to @samp{#\\space}.  If @var{rchr} is provided, then the
+padding to the right will use it instead.  See the examples below.
+left and @var{rchr} on the right.  The default @var{width} is 80.  The
+default @var{chr} and @var{rchr} is @samp{#\\space}.  The string is
+never truncated.
+@lisp
+ (center-string \"Richard Todd\" 24)
+=> \"      Richard Todd      \"
+
+ (center-string \" Richard Todd \" 24 #\\=)
+=> \"===== Richard Todd =====\"
+
+ (center-string \" Richard Todd \" 24 #\\< #\\>)
+=> \"<<<<< Richard Todd >>>>>\"
+@end lisp"
+  (let* ((len (string-length str))
+         (lpad (make-string (max (quotient (- width len) 2) 0) chr))
+         ;; right-char == char unless it has been provided by the user
+         (right-chr (or rchr chr))
+         (rpad (if (char=? right-chr chr)
+                   lpad
+                   (make-string (max (quotient (- width len) 2) 0) right-chr))))
+    (if (>= len width)
+        str
+        (string-append lpad str rpad (if (odd? (- width len)) (string right-chr) "")))))
+
+(define* (left-justify-string str #\optional (width 80) (chr #\space))
+"@code{left-justify-string str [width chr]}.  
+Returns a copy of @var{str} padded with @var{chr} such that it is left
+justified in a field of @var{width} characters.  The default
+@var{width} is 80.  Unlike @samp{string-pad} from srfi-13, the string
+is never truncated."
+  (let* ((len (string-length str))
+         (pad (make-string (max (- width len) 0) chr)))
+    (if (>= len width)
+        str
+        (string-append str pad))))
+
+(define* (right-justify-string str #\optional (width 80) (chr #\space))
+"Returns a copy of @var{str} padded with @var{chr} such that it is
+right justified in a field of @var{width} characters.  The default
+@var{width} is 80.  The default @var{chr} is @samp{#\\space}.  Unlike
+@samp{string-pad} from srfi-13, the string is never truncated."
+  (let* ((len (string-length str))
+         (pad (make-string (max (- width len) 0) chr)))
+    (if (>= len width)
+        str
+        (string-append pad str))))
+
+ (define* (collapse-repeated-chars str #\optional (chr #\space) (num 1))
+"Returns a copy of @var{str} with all repeated instances of 
+@var{chr} collapsed down to at most @var{num} instances.
+The default value for @var{chr} is @samp{#\\space}, and 
+the default value for @var{num} is 1.
+
+@lisp
+ (collapse-repeated-chars \"H  e  l  l  o\")
+=> \"H e l l o\"
+ (collapse-repeated-chars \"H--e--l--l--o\" #\\-)
+=> \"H-e-l-l-o\"
+ (collapse-repeated-chars \"H-e--l---l----o\" #\\- 2)
+=> \"H-e--l--l--o\"
+@end lisp"
+   ;; define repeat-locator as a stateful match? function which remembers
+   ;; the last character it had seen.
+   (let ((repeat-locator
+          ;; initialize prev-chr to something other than what we're seeking...
+          (let ((prev-chr (if (char=? chr #\space) #\A #\space))
+                (match-count 0))
+            (lambda (c)
+              (if (and (char=? c prev-chr)
+                       (char=? prev-chr chr))
+                  ;; found enough duplicates if the match-count is high enough
+                  (begin
+                    (set! match-count (+ 1 match-count))
+                    (>= match-count num))
+
+                  ;; did not find a duplicate
+                  (begin (set! match-count 0) 
+                         (set! prev-chr c) 
+                         #f))))))
+
+     ;; transform the string with our stateful matcher...
+     ;; deleting matches...
+     (transform-string str repeat-locator "")))
+
+;; split a text string into segments that have the form...
+;;  <ws non-ws>  <ws non-ws> etc..
+(define (split-by-single-words str)
+  (let ((non-wschars (char-set-complement char-set_whitespace)))
+    (let loop ((ans '())
+               (index 0))
+      (let ((next-non-ws (string-index str non-wschars index)))
+        (if next-non-ws
+          ;; found non-ws...look for ws following...
+          (let ((next-ws (string-index str char-set_whitespace next-non-ws)))
+            (if next-ws
+                ;; found the ws following...
+                (loop (cons (substring str index next-ws) ans)
+                      next-ws)
+                ;; did not find ws...must be the end...
+                (reverse (cons (substring str index) ans))))
+          ;; did not find non-ws... only ws at end of the string...
+          (reverse ans))))))
+
+(define (end-of-sentence? str)
+  "Return #t when STR likely denotes the end of sentence."
+  (let ((len (string-length str)))
+    (and (> len 1)
+         (eqv? #\. (string-ref str (- len 1)))
+         (not (eqv? #\. (string-ref str (- len 2)))))))
+
+(define* (make-text-wrapper #\key
+                            (line-width 80)
+                            (expand-tabs? #t)
+                            (tab-width 8)
+                            (collapse-whitespace? #t)
+                            (subsequent-indent "")
+                            (initial-indent "")
+                            (break-long-words? #t))
+  "Returns a procedure that will split a string into lines according to the
+given parameters.
+
+@table @code
+@item #:line-width
+This is the target length used when deciding where to wrap lines.
+Default is 80.
+
+@item #:expand-tabs?
+Boolean describing whether tabs in the input should be expanded. Default
+is #t.
+
+@item #:tab-width
+If tabs are expanded, this will be the number of spaces to which they
+expand. Default is 8.
+
+@item #:collapse-whitespace?
+Boolean describing whether the whitespace inside the existing text
+should be removed or not.  Default is #t.
+
+If text is already well-formatted, and is just being wrapped to fit in a
+different width, then set this to @samp{#f}. This way, many common text
+conventions (such as two spaces between sentences) can be preserved if
+in the original text. If the input text spacing cannot be trusted, then
+leave this setting at the default, and all repeated whitespace will be
+collapsed down to a single space.
+
+@item #:initial-indent
+Defines a string that will be put in front of the first line of wrapped
+text. Default is the empty string, ``''.
+
+@item #:subsequent-indent
+Defines a string that will be put in front of all lines of wrapped
+text, except the first one.  Default is the empty string, ``''.
+
+@item #:break-long-words?
+If a single word is too big to fit on a line, this setting tells the
+wrapper what to do.  Defaults to #t, which will break up long words.
+When set to #f, the line will be allowed, even though it is longer
+than the defined @code{#:line-width}.
+@end table
+
+The return value is a procedure of one argument, the input string, which
+returns a list of strings, where each element of the list is one line."
+  (lambda (str)
+    ;; replace newlines with spaces
+    (set! str (transform-string str (lambda (c) (char=? c #\nl)) #\space))
+
+    ;; expand tabs if they wanted us to...
+    (if expand-tabs?
+        (set! str (expand-tabs str tab-width)))
+
+    ;; collapse whitespace if they wanted us to...
+    (if collapse-whitespace?
+        (set! str (collapse-repeated-chars str)))
+  
+    ;; drop any whitespace from the front...
+    (set! str (string-trim str))
+
+    ;; now start breaking the text into lines...
+    (let loop ((ans '())
+               (words (split-by-single-words str))
+               (line initial-indent)
+               (count 0))
+      (if (null? words)
+          ;; out of words? ...done!
+          (reverse (if (> count 0)
+                       (cons line ans)
+                       ans))
+        
+          ;; not out of words...keep going...
+          (let ((length-left (- line-width
+                                (string-length line)))
+                (next-word (if (= count 0)
+                               (string-trim (car words))
+                               (car words))))
+            (cond 
+             ;; does the next entry fit?
+             ((<= (string-length next-word)
+                  length-left)
+              (loop ans
+                    (cdr words)
+                    (if (and collapse-whitespace?
+                             (end-of-sentence? line))
+                        ;; Add an extra space after the period.
+                        (string-append line " " next-word)
+                        (string-append line next-word))
+                    (+ count 1)))
+
+             ;; ok, it didn't fit...is there already at least one word on the line?
+             ((> count 0)
+              ;; try to use it for the next line, then...
+              (loop (cons line ans)
+                    words
+                    subsequent-indent
+                    0))
+           
+             ;; ok, it didn't fit...and it's the first word. 
+             ;; were we told to break up long words?
+             (break-long-words?
+              ;; break the like at the limit, since the user wants us to...
+              (loop (cons (string-append line (substring next-word 0 length-left))
+                          ans)
+                    (cons (substring next-word length-left)
+                          (cdr words))
+                    subsequent-indent
+                    0))
+
+             ;; well, then is it the first word and we *shouldn't* break long words, then...
+             (else
+              (loop (cons (string-append line next-word)
+                          ans)
+                    (cdr words)
+                    subsequent-indent
+                    0))))))))
+
+(define (string->wrapped-lines str . kwargs)
+  "@code{string->wrapped-lines str keywds ...}. Wraps the text given in
+string @var{str} according to the parameters provided in @var{keywds},
+or the default setting if they are not given. Returns a list of strings
+representing the formatted lines. Valid keyword arguments are discussed
+in @code{make-text-wrapper}."
+  ((apply make-text-wrapper kwargs) str))
+
+(define (fill-string str . kwargs)
+  "Wraps the text given in string @var{str} according to the parameters
+provided in @var{kwargs}, or the default setting if they are not
+given.  Returns a single string with the wrapped text.  Valid keyword
+arguments are discussed in @code{make-text-wrapper}."
+  (string-join (apply string->wrapped-lines str kwargs)
+               "\n"
+               'infix))
+;;; Web client
+
+;; Copyright (C) 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_
+;;;
+;;; (web client) is a simple HTTP URL fetcher for Guile.
+;;;
+;;; In its current incarnation, (web client) is synchronous.  If you
+;;; want to fetch a number of URLs at once, probably the best thing to
+;;; do is to write an event-driven URL fetcher, similar in structure to
+;;; the web server.
+;;;
+;;; Another option, good but not as performant, would be to use threads,
+;;; possibly via a thread pool.
+;;;
+;;; Code_
+
+(define-module (web client)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\use-module (ice-9 iconv)
+  #\use-module (ice-9 rdelim)
+  #\use-module (web request)
+  #\use-module (web response)
+  #\use-module (web uri)
+  #\use-module (web http)
+  #\use-module (srfi srfi-1)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\export (current-http-proxy
+            open-socket-for-uri
+            http-get
+            http-get*
+            http-head
+            http-post
+            http-put
+            http-delete
+            http-trace
+            http-options))
+
+(define current-http-proxy
+  (make-parameter (let ((proxy (getenv "http_proxy")))
+                    (and (not (equal? proxy ""))
+                         proxy))))
+
+(define (ensure-uri uri-or-string)
+  (cond
+   ((string? uri-or-string) (string->uri uri-or-string))
+   ((uri? uri-or-string) uri-or-string)
+   (else (error "Invalid URI" uri-or-string))))
+
+(define (open-socket-for-uri uri-or-string)
+  "Return an open input/output port for a connection to URI."
+  (define http-proxy (current-http-proxy))
+  (define uri (ensure-uri (or http-proxy uri-or-string)))
+  (define addresses
+    (let ((port (uri-port uri)))
+      (delete-duplicates
+       (getaddrinfo (uri-host uri)
+                    (cond (port => number->string)
+                          (else (symbol->string (uri-scheme uri))))
+                    (if port
+                        AI_NUMERICSERV
+                        0))
+       (lambda (ai1 ai2)
+         (equal? (addrinfo_addr ai1) (addrinfo_addr ai2))))))
+
+  (let loop ((addresses addresses))
+    (let* ((ai (car addresses))
+           (s  (with-fluids ((%default-port-encoding #f))
+                 ;; Restrict ourselves to TCP.
+                 (socket (addrinfo_fam ai) SOCK_STREAM IPPROTO_IP))))
+      (catch 'system-error
+        (lambda ()
+          (connect s (addrinfo_addr ai))
+
+          ;; Buffer input and output on this port.
+          (setvbuf s _IOFBF)
+          ;; If we're using a proxy, make a note of that.
+          (when http-proxy (set-http-proxy-port?! s #t))
+          s)
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (close s)
+          (if (null? (cdr addresses))
+              (apply throw args)
+              (loop (cdr addresses))))))))
+
+(define (extend-request r k v . additional)
+  (let ((r (set-field r (request-headers)
+                      (assoc-set! (copy-tree (request-headers r))
+                                  k v))))
+    (if (null? additional)
+        r
+        (apply extend-request r additional))))
+
+;; -> request body
+(define (sanitize-request request body)
+  "\"Sanitize\" the given request and body, ensuring that they are
+complete and coherent.  This method is most useful for methods that send
+data to the server, like POST, but can be used for any method.  Return
+two values_ a request and a bytevector, possibly the same ones that were
+passed as arguments.
+
+If BODY is a string, encodes the string to a bytevector, in an encoding
+appropriate for REQUEST.  Adds a ‘content-length’ and ‘content-type’
+header, as necessary.
+
+If BODY is a procedure, it is called with a port as an argument, and the
+output collected as a bytevector.  In the future we might try to instead
+use a compressing, chunk-encoded port, and call this procedure later.
+Authors are advised not to rely on the procedure being called at any
+particular time.
+
+Note that we rely on the request itself already having been validated,
+as is the case by default with a request returned by `build-request'."
+  (cond
+   ((not body)
+    (let ((length (request-content-length request)))
+      (if length
+          ;; FIXME make this stricter_ content-length header should be
+          ;; prohibited if there's no body, even if the content-length
+          ;; is 0.
+          (unless (zero? length)
+            (error "content-length, but no body"))
+          (when (assq 'transfer-encoding (request-headers request))
+            (error "transfer-encoding not allowed with no body")))
+      (values request #vu8())))
+   ((string? body)
+    (let* ((type (request-content-type request '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-request
+       (if declared-charset
+           request
+           (extend-request request 'content-type
+                            `(,@type (charset . ,charset))))
+       (string->bytevector body charset))))
+   ((procedure? body)
+    (let* ((type (request-content-type request
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-request
+       (if declared-charset
+           request
+           (extend-request request 'content-type
+                            `(,@type (charset . ,charset))))
+       (call-with-encoded-output-string charset body))))
+   ((not (bytevector? body))
+    (error "unexpected body type"))
+   (else
+    (values (let ((rlen (request-content-length request))
+                  (blen (bytevector-length body)))
+              (cond
+               (rlen (if (= rlen blen)
+                         request
+                         (error "bad content-length" rlen blen)))
+               (else (extend-request request 'content-length blen))))
+            body))))
+
+(define (decode-response-body response body)
+  ;; `body' is either #f or a bytevector.
+  (cond
+   ((not body) body)
+   ((bytevector? body)
+    (let ((rlen (response-content-length response))
+          (blen (bytevector-length body)))
+      (cond
+       ((and rlen (not (= rlen blen)))
+        (error "bad content-length" rlen blen))
+       ((response-content-type response)
+        => (lambda (type)
+             (cond
+              ((text-content-type? (car type))
+               ;; RFC 2616 3.7.1_ "When no explicit charset parameter is
+               ;; provided by the sender, media subtypes of the "text"
+               ;; type are defined to have a default charset value of
+               ;; "ISO-8859-1" when received via HTTP."
+               (bytevector->string body (or (assq-ref (cdr type) 'charset)
+                                            "iso-8859-1")))
+              (else body))))
+       (else body))))
+   (else
+    (error "unexpected body type" body))))
+
+;; We could expose this to user code if there is demand.
+(define* (request uri #\key
+                  (body #f)
+                  (port (open-socket-for-uri uri))
+                  (method 'GET)
+                  (version '(1 . 1))
+                  (keep-alive? #f)
+                  (headers '())
+                  (decode-body? #t)
+                  (streaming? #f)
+                  (request
+                   (build-request
+                    (ensure-uri uri)
+                    #\method method
+                    #\version version
+                    #\headers (if keep-alive?
+                                  headers
+                                  (cons '(connection close) headers))
+                    #\port port)))
+  (call-with-values (lambda () (sanitize-request request body))
+    (lambda (request body)
+      (let ((request (write-request request port)))
+        (when body
+          (write-request-body request body))
+        (force-output (request-port request))
+        (let ((response (read-response port)))
+          (cond
+           ((eq? (request-method request) 'HEAD)
+            (unless keep-alive?
+              (close-port port))
+            (values response #f))
+           (streaming?
+            (values response
+                    (response-body-port response
+                                        #\keep-alive? keep-alive?
+                                        #\decode? decode-body?)))
+           (else
+            (let ((body (read-response-body response)))
+              (unless keep-alive?
+                (close-port port))
+              (values response
+                      (if decode-body?
+                          (decode-response-body response body)
+                          body))))))))))
+
+(define* (http-get uri #\key
+                   (body #f)
+                   (port (open-socket-for-uri uri))
+                   (version '(1 . 1)) (keep-alive? #f)
+                   ;; #\headers is the new name of #\extra-headers.
+                   (extra-headers #f) (headers (or extra-headers '()))
+                   (decode-body? #t) (streaming? #f))
+  "Connect to the server corresponding to URI and ask for the
+resource, using the ‘GET’ method.  If you already have a port open,
+pass it as PORT.  The port will be closed at the end of the
+request unless KEEP-ALIVE? is true.  Any extra headers in the
+alist HEADERS will be added to the request.
+
+If BODY is not ‘#f’, a message body will also be sent with the HTTP
+request.  If BODY is a string, it is encoded according to the
+content-type in HEADERS, defaulting to UTF-8.  Otherwise BODY should be
+a bytevector, or ‘#f’ for no body.  Although it's allowed to send a
+message body along with any request, usually only POST and PUT requests
+have bodies.  See ‘http-put’ and ‘http-post’ documentation, for more.
+
+If DECODE-BODY? is true, as is the default, the body of the
+response will be decoded to string, if it is a textual content-type.
+Otherwise it will be returned as a bytevector.
+
+However, if STREAMING? is true, instead of eagerly reading the response
+body from the server, this function only reads off the headers.  The
+response body will be returned as a port on which the data may be read.
+Unless KEEP-ALIVE? is true, the port will be closed after the full
+response body has been read.
+
+Returns two values_ the response read from the server, and the response
+body as a string, bytevector, #f value, or as a port (if STREAMING? is
+true)."
+  (when extra-headers
+    (issue-deprecation-warning
+     "The #\extra-headers argument to http-get has been renamed to #:headers. "
+     "Please update your code."))
+  (request uri #\method 'GET #\body body
+           #\port port #\version version #\keep-alive? keep-alive?
+           #\headers headers #\decode-body? decode-body?
+           #\streaming? streaming?))
+
+(define* (http-get* uri #\key
+                    (body #f)
+                    (port (open-socket-for-uri uri))
+                    (version '(1 . 1)) (keep-alive? #f)
+                    ;; #\headers is the new name of #\extra-headers.
+                    (extra-headers #f) (headers (or extra-headers '()))
+                    (decode-body? #t))
+  "Deprecated in favor of (http-get #:streaming? #t)."
+  (issue-deprecation-warning
+   "`http-get*' has been deprecated.  "
+   "Instead, use `http-get' with the #:streaming? #t keyword argument.")
+  (http-get uri #\body body
+            #\port port #\version version #\keep-alive? keep-alive?
+            #\headers headers #\decode-body? #t #\streaming? #t))
+
+(define-syntax-rule (define-http-verb http-verb method doc)
+  (define* (http-verb uri #\key
+                      (body #f)
+                      (port (open-socket-for-uri uri))
+                      (version '(1 . 1))
+                      (keep-alive? #f)
+                      (headers '())
+                      (decode-body? #t)
+                      (streaming? #f))
+    doc
+    (request uri
+             #\body body #\method method
+             #\port port #\version version #\keep-alive? keep-alive?
+             #\headers headers #\decode-body? decode-body?
+             #\streaming? streaming?)))
+
+(define-http-verb http-head
+  'HEAD
+  "Fetch message headers for the given URI using the HTTP \"HEAD\"
+method.
+
+This function is similar to ‘http-get’, except it uses the \"HEAD\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and ‘#f’.  Responses to HEAD
+requests do not have a body.  The second value is only returned so that
+other procedures can treat all of the http-foo verbs identically.")
+
+(define-http-verb http-post
+  'POST
+  "Post data to the given URI using the HTTP \"POST\" method.
+
+This function is similar to ‘http-get’, except it uses the \"POST\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and the response body.")
+
+(define-http-verb http-put
+  'PUT
+  "Put data at the given URI using the HTTP \"PUT\" method.
+
+This function is similar to ‘http-get’, except it uses the \"PUT\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and the response body.")
+
+(define-http-verb http-delete
+  'DELETE
+  "Delete data at the given URI using the HTTP \"DELETE\" method.
+
+This function is similar to ‘http-get’, except it uses the \"DELETE\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and the response body.")
+
+(define-http-verb http-trace
+  'TRACE
+  "Send an HTTP \"TRACE\" request.
+
+This function is similar to ‘http-get’, except it uses the \"TRACE\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and the response body.")
+
+(define-http-verb http-options
+  'OPTIONS
+  "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\"
+method.
+
+This function is similar to ‘http-get’, except it uses the \"OPTIONS\"
+method.  See ‘http-get’ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values_ the resulting response, and the response body.")
+;;; HTTP messages
+
+;; Copyright (C)  2010-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_
+;;;
+;;; This module has a number of routines to parse textual
+;;; representations of HTTP data into native Scheme data structures.
+;;;
+;;; It tries to follow RFCs fairly strictly---the road to perdition
+;;; being paved with compatibility hacks---though some allowances are
+;;; made for not-too-divergent texts (like a quality of .2 which should
+;;; be 0.2, etc).
+;;;
+;;; Code_
+
+(define-module (web http)
+  #\use-module ((srfi srfi-1) #\select (append-map! map!))
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-19)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 match)
+  #\use-module (ice-9 q)
+  #\use-module (ice-9 binary-ports)
+  #\use-module (rnrs bytevectors)
+  #\use-module (web uri)
+  #\export (string->header
+            header->string
+
+            declare-header!
+            declare-opaque-header!
+            known-header?
+            header-parser
+            header-validator
+            header-writer
+
+            read-header
+            parse-header
+            valid-header?
+            write-header
+
+            read-headers
+            write-headers
+
+            parse-http-method
+            parse-http-version
+            parse-request-uri
+
+            read-request-line
+            write-request-line
+            read-response-line
+            write-response-line
+
+            make-chunked-input-port
+            make-chunked-output-port
+
+            http-proxy-port?
+            set-http-proxy-port?!))
+
+
+(define (string->header name)
+  "Parse NAME to a symbolic header name."
+  (string->symbol (string-downcase name)))
+
+(define-record-type <header-decl>
+  (make-header-decl name parser validator writer multiple?)
+  header-decl?
+  (name header-decl-name)
+  (parser header-decl-parser)
+  (validator header-decl-validator)
+  (writer header-decl-writer)
+  (multiple? header-decl-multiple?))
+
+;; sym -> header
+(define *declared-headers* (make-hash-table))
+
+(define (lookup-header-decl sym)
+  (hashq-ref *declared-headers* sym))
+
+(define* (declare-header! name
+                          parser
+                          validator
+                          writer
+                          #\key multiple?)
+  "Declare a parser, validator, and writer for a given header."
+  (if (and (string? name) parser validator writer)
+      (let ((decl (make-header-decl name parser validator writer multiple?)))
+        (hashq-set! *declared-headers* (string->header name) decl)
+        decl)
+      (error "bad header decl" name parser validator writer multiple?)))
+
+(define (header->string sym)
+  "Return the string form for the header named SYM."
+  (let ((decl (lookup-header-decl sym)))
+    (if decl
+        (header-decl-name decl)
+        (string-titlecase (symbol->string sym)))))
+
+(define (known-header? sym)
+  "Return ‘#t’ iff SYM is a known header, with associated
+parsers and serialization procedures."
+  (and (lookup-header-decl sym) #t))
+
+(define (header-parser sym)
+  "Return the value parser for headers named SYM.  The result is a
+procedure that takes one argument, a string, and returns the parsed
+value.  If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged."
+  (let ((decl (lookup-header-decl sym)))
+    (if decl
+        (header-decl-parser decl)
+        (lambda (x) x))))
+
+(define (header-validator sym)
+  "Return a predicate which returns ‘#t’ if the given value is valid
+for headers named SYM.  The default validator for unknown headers
+is ‘string?’."
+  (let ((decl (lookup-header-decl sym)))
+    (if decl
+        (header-decl-validator decl)
+        string?)))
+
+(define (header-writer sym)
+  "Return a procedure that writes values for headers named SYM to a
+port.  The resulting procedure takes two arguments_ a value and a port.
+The default writer is ‘display’."
+  (let ((decl (lookup-header-decl sym)))
+    (if decl
+        (header-decl-writer decl)
+        display)))
+
+(define (read-header-line port)
+  "Read an HTTP header line and return it without its final CRLF or LF.
+Raise a 'bad-header' exception if the line does not end in CRLF or LF,
+or if EOF is reached."
+  (match (%read-line port)
+    (((? string? line) . #\newline)
+     ;; '%read-line' does not consider #\return a delimiter; so if it's
+     ;; there, remove it.  We are more tolerant than the RFC in that we
+     ;; tolerate LF-only endings.
+     (if (string-suffix? "\r" line)
+         (string-drop-right line 1)
+         line))
+    ((line . _)                                ;EOF or missing delimiter
+     (bad-header 'read-header-line line))))
+
+(define (read-continuation-line port val)
+  (if (or (eqv? (peek-char port) #\space)
+          (eqv? (peek-char port) #\tab))
+      (read-continuation-line port
+                              (string-append val
+                                             (read-header-line port)))
+      val))
+
+(define *eof* (call-with-input-string "" read))
+
+(define (read-header port)
+  "Read one HTTP header from PORT. Return two values_ the header
+name and the parsed Scheme value. May raise an exception if the header
+was known but the value was invalid.
+
+Returns the end-of-file object for both values if the end of the message
+body was reached (i.e., a blank line)."
+  (let ((line (read-header-line port)))
+    (if (or (string-null? line)
+            (string=? line "\r"))
+        (values *eof* *eof*)
+        (let* ((delim (or (string-index line #\_)
+                          (bad-header '%read line)))
+               (sym (string->header (substring line 0 delim))))
+          (values
+           sym
+           (parse-header
+            sym
+            (read-continuation-line
+             port
+             (string-trim-both line char-set_whitespace (1+ delim)))))))))
+
+(define (parse-header sym val)
+  "Parse VAL, a string, with the parser registered for the header
+named SYM.  Returns the parsed value."
+  ((header-parser sym) val))
+
+(define (valid-header? sym val)
+  "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."
+  (if (symbol? sym)
+      ((header-validator sym) val)
+      (error "header name not a symbol" sym)))
+
+(define (write-header sym val port)
+  "Write the given header name and value to PORT, using the writer
+from ‘header-writer’."
+  (display (header->string sym) port)
+  (display "_ " port)
+  ((header-writer sym) val port)
+  (display "\r\n" port))
+
+(define (read-headers port)
+  "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."
+  (let lp ((headers '()))
+    (call-with-values (lambda () (read-header port))
+      (lambda (k v)
+        (if (eof-object? k)
+            (reverse! headers)
+            (lp (acons k v headers)))))))
+
+(define (write-headers headers port)
+  "Write the given header alist to PORT.  Doesn't write the final
+‘\\r\\n’, as the user might want to add another header."
+  (let lp ((headers headers))
+    (if (pair? headers)
+        (begin
+          (write-header (caar headers) (cdar headers) port)
+          (lp (cdr headers))))))
+
+
+
+
+;;;
+;;; Utilities
+;;;
+
+(define (bad-header sym val)
+  (throw 'bad-header sym val))
+(define (bad-header-component sym val)
+  (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header_ ~a\n" (header->string sym) val))
+           (_ (default-printer)))
+         args))
+(define (bad-header-component-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header component_ ~a\n" sym val))
+           (_ (default-printer)))
+         args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
+
+(define (parse-opaque-string str)
+  str)
+(define (validate-opaque-string val)
+  (string? val))
+(define (write-opaque-string val port)
+  (display val port))
+
+(define separators-without-slash
+  (string->char-set "[^][()<>@,;_\\\"?= \t]"))
+(define (validate-media-type str)
+  (let ((idx (string-index str #\/)))
+    (and idx (= idx (string-rindex str #\/))
+         (not (string-index str separators-without-slash)))))
+(define (parse-media-type str)
+  (if (validate-media-type str)
+      (string->symbol str)
+      (bad-header-component 'media-type str)))
+
+(define* (skip-whitespace str #\optional (start 0) (end (string-length str)))
+  (let lp ((i start))
+    (if (and (< i end) (char-whitespace? (string-ref str i)))
+        (lp (1+ i))
+        i)))
+
+(define* (trim-whitespace str #\optional (start 0) (end (string-length str)))
+  (let lp ((i end))
+    (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
+        (lp (1- i))
+        i)))
+
+(define* (split-and-trim str #\optional (delim #\,)
+                         (start 0) (end (string-length str)))
+  (let lp ((i start))
+    (if (< i end)
+        (let* ((idx (string-index str delim i end))
+               (tok (string-trim-both str char-set_whitespace i (or idx end))))
+          (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
+        '())))
+
+(define (list-of-strings? val)
+  (list-of? val string?))
+
+(define (write-list-of-strings val port)
+  (write-list val port display ", "))
+
+(define (split-header-names str)
+  (map string->header (split-and-trim str)))
+
+(define (list-of-header-names? val)
+  (list-of? val symbol?))
+
+(define (write-header-list val port)
+  (write-list val port
+              (lambda (x port)
+                (display (header->string x) port))
+              ", "))
+
+(define (collect-escaped-string from start len escapes)
+  (let ((to (make-string len)))
+    (let lp ((start start) (i 0) (escapes escapes))
+      (if (null? escapes)
+          (begin
+            (substring-move! from start (+ start (- len i)) to i)
+            to)
+          (let* ((e (car escapes))
+                 (next-start (+ start (- e i) 2)))
+            (substring-move! from start (- next-start 2) to i)
+            (string-set! to e (string-ref from (- next-start 1)))
+            (lp next-start (1+ e) (cdr escapes)))))))
+
+;; in incremental mode, returns two values_ the string, and the index at
+;; which the string ended
+(define* (parse-qstring str #\optional
+                        (start 0) (end (trim-whitespace str start))
+                        #\key incremental?)
+  (if (and (< start end) (eqv? (string-ref str start) #\"))
+      (let lp ((i (1+ start)) (qi 0) (escapes '()))
+        (if (< i end)
+            (case (string-ref str i)
+              ((#\\)
+               (lp (+ i 2) (1+ qi) (cons qi escapes)))
+              ((#\")
+               (let ((out (collect-escaped-string str (1+ start) qi escapes)))
+                 (if incremental?
+                     (values out (1+ i))
+                     (if (= (1+ i) end)
+                         out
+                         (bad-header-component 'qstring str)))))
+              (else
+               (lp (1+ i) (1+ qi) escapes)))
+            (bad-header-component 'qstring str)))
+      (bad-header-component 'qstring str)))
+
+(define (write-list l port write-item delim)
+  (if (pair? l)
+      (let lp ((l l))
+        (write-item (car l) port)
+        (if (pair? (cdr l))
+            (begin
+              (display delim port)
+              (lp (cdr l)))))))
+
+(define (write-qstring str port)
+  (display #\" port)
+  (if (string-index str #\")
+      ;; optimize me
+      (write-list (string-split str #\") port display "\\\"")
+      (display str port))
+  (display #\" port))
+
+(define* (parse-quality str #\optional (start 0) (end (string-length str)))
+  (define (char->decimal c)
+    (let ((i (- (char->integer c) (char->integer #\0))))
+      (if (and (<= 0 i) (< i 10))
+          i
+          (bad-header-component 'quality str))))
+  (cond
+   ((not (< start end))
+    (bad-header-component 'quality str))
+   ((eqv? (string-ref str start) #\1)
+    (if (or (string= str "1" start end)
+            (string= str "1." start end)
+            (string= str "1.0" start end)
+            (string= str "1.00" start end)
+            (string= str "1.000" start end))
+        1000
+        (bad-header-component 'quality str)))
+   ((eqv? (string-ref str start) #\0)
+    (if (or (string= str "0" start end)
+            (string= str "0." start end))
+        0
+        (if (< 2 (- end start) 6)
+            (let lp ((place 1) (i (+ start 4)) (q 0))
+              (if (= i (1+ start))
+                  (if (eqv? (string-ref str (1+ start)) #\.)
+                      q
+                      (bad-header-component 'quality str))
+                  (lp (* 10 place) (1- i)
+                      (if (< i end)
+                          (+ q (* place (char->decimal (string-ref str i))))
+                          q))))
+            (bad-header-component 'quality str))))
+   ;; Allow the nonstandard .2 instead of 0.2.
+   ((and (eqv? (string-ref str start) #\.)
+         (< 1 (- end start) 5))
+    (let lp ((place 1) (i (+ start 3)) (q 0))
+      (if (= i start)
+          q
+          (lp (* 10 place) (1- i)
+              (if (< i end)
+                  (+ q (* place (char->decimal (string-ref str i))))
+                  q)))))
+   (else
+    (bad-header-component 'quality str))))
+
+(define (valid-quality? q)
+  (and (non-negative-integer? q) (<= q 1000)))
+
+(define (write-quality q port)
+  (define (digit->char d)
+    (integer->char (+ (char->integer #\0) d)))
+  (display (digit->char (modulo (quotient q 1000) 10)) port)
+  (display #\. port)
+  (display (digit->char (modulo (quotient q 100) 10)) port)
+  (display (digit->char (modulo (quotient q 10) 10)) port)
+  (display (digit->char (modulo q 10)) port))
+
+(define (list-of? val pred)
+  (or (null? val)
+      (and (pair? val)
+           (pred (car val))
+           (list-of? (cdr val) pred))))
+
+(define* (parse-quality-list str)
+  (map (lambda (part)
+         (cond
+          ((string-rindex part #\;)
+           => (lambda (idx)
+                (let ((qpart (string-trim-both part char-set_whitespace (1+ idx))))
+                  (if (string-prefix? "q=" qpart)
+                      (cons (parse-quality qpart 2)
+                            (string-trim-both part char-set_whitespace 0 idx))
+                      (bad-header-component 'quality qpart)))))
+          (else
+           (cons 1000 (string-trim-both part char-set_whitespace)))))
+       (string-split str #\,)))
+
+(define (validate-quality-list l)
+  (list-of? l
+            (lambda (elt)
+              (and (pair? elt)
+                   (valid-quality? (car elt))
+                   (string? (cdr elt))))))
+
+(define (write-quality-list l port)
+  (write-list l port
+              (lambda (x port)
+                (let ((q (car x))
+                      (str (cdr x)))
+                  (display str port)
+                  (if (< q 1000)
+                      (begin
+                        (display ";q=" port)
+                        (write-quality q port)))))
+              ","))
+
+(define* (parse-non-negative-integer val #\optional (start 0)
+                                     (end (string-length val)))
+  (define (char->decimal c)
+    (let ((i (- (char->integer c) (char->integer #\0))))
+      (if (and (<= 0 i) (< i 10))
+          i
+          (bad-header-component 'non-negative-integer val))))
+  (if (not (< start end))
+      (bad-header-component 'non-negative-integer val)
+      (let lp ((i start) (out 0))
+        (if (< i end)
+            (lp (1+ i)
+                (+ (* out 10) (char->decimal (string-ref val i))))
+            out))))
+
+(define (non-negative-integer? code)
+  (and (number? code) (>= code 0) (exact? code) (integer? code)))
+                                    
+(define (default-val-parser k val)
+  val)
+
+(define (default-val-validator k val)
+  (or (not val) (string? val)))
+
+(define (default-val-writer k val port)
+  (if (or (string-index val #\;)
+          (string-index val #\,)
+          (string-index val #\"))
+      (write-qstring val port)
+      (display val port)))
+
+(define* (parse-key-value-list str #\optional
+                               (val-parser default-val-parser)
+                               (start 0) (end (string-length str)))
+  (let lp ((i start) (out '()))
+    (if (not (< i end))
+        (reverse! out)
+        (let* ((i (skip-whitespace str i end))
+               (eq (string-index str #\= i end))
+               (comma (string-index str #\, i end))
+               (delim (min (or eq end) (or comma end)))
+               (k (string->symbol
+                   (substring str i (trim-whitespace str i delim)))))
+          (call-with-values
+              (lambda ()
+                (if (and eq (or (not comma) (< eq comma)))
+                    (let ((i (skip-whitespace str (1+ eq) end)))
+                      (if (and (< i end) (eqv? (string-ref str i) #\"))
+                          (parse-qstring str i end #\incremental? #t)
+                          (values (substring str i
+                                             (trim-whitespace str i
+                                                              (or comma end)))
+                                  (or comma end))))
+                    (values #f delim)))
+            (lambda (v-str next-i)
+              (let ((v (val-parser k v-str))
+                    (i (skip-whitespace str next-i end)))
+                (if (or (= i end) (eqv? (string-ref str i) #\,))
+                    (lp (1+ i) (cons (if v (cons k v) k) out))
+                    (bad-header-component 'key-value-list
+                                          (substring str start end))))))))))
+
+(define* (key-value-list? list #\optional
+                          (valid? default-val-validator))
+  (list-of? list
+            (lambda (elt)
+              (cond
+               ((pair? elt)
+                (let ((k (car elt))
+                      (v (cdr elt)))
+                  (and (symbol? k)
+                       (valid? k v))))
+               ((symbol? elt)
+                (valid? elt #f))
+               (else #f)))))
+
+(define* (write-key-value-list list port #\optional
+                               (val-writer default-val-writer) (delim ", "))
+  (write-list
+   list port
+   (lambda (x port)
+     (let ((k (if (pair? x) (car x) x))
+           (v (if (pair? x) (cdr x) #f)))
+       (display k port)
+       (if v
+           (begin
+             (display #\= port)
+             (val-writer k v port)))))
+   delim))
+
+;; param-component = token [ "=" (token | quoted-string) ] \
+;;    *(";" token [ "=" (token | quoted-string) ])
+;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set_whitespace #\, #\;))
+(define* (parse-param-component str #\optional
+                                (val-parser default-val-parser)
+                                (start 0) (end (string-length str)))
+  (let lp ((i start) (out '()))
+    (if (not (< i end))
+        (values (reverse! out) end)
+        (let ((delim (string-index str param-delimiters i)))
+          (let ((k (string->symbol
+                    (substring str i (trim-whitespace str i (or delim end)))))
+                (delimc (and delim (string-ref str delim))))
+            (case delimc
+              ((#\=)
+               (call-with-values
+                   (lambda ()
+                     (let ((i (skip-whitespace str (1+ delim) end)))
+                       (if (and (< i end) (eqv? (string-ref str i) #\"))
+                           (parse-qstring str i end #\incremental? #t)
+                           (let ((delim
+                                  (or (string-index str param-value-delimiters
+                                                    i end)
+                                      end)))
+                             (values (substring str i delim)
+                                     delim)))))
+                 (lambda (v-str next-i)
+                   (let* ((v (val-parser k v-str))
+                          (x (if v (cons k v) k))
+                          (i (skip-whitespace str next-i end)))
+                     (case (and (< i end) (string-ref str i))
+                       ((#f)
+                        (values (reverse! (cons x out)) end))
+                       ((#\;)
+                        (lp (skip-whitespace str (1+ i) end)
+                            (cons x out)))
+                       (else            ; including #\,
+                        (values (reverse! (cons x out)) i)))))))
+              ((#\;)
+               (let ((v (val-parser k #f)))
+                 (lp (skip-whitespace str (1+ delim) end)
+                     (cons (if v (cons k v) k) out))))
+             
+              (else ;; either the end of the string or a #\,
+               (let ((v (val-parser k #f)))
+                 (values (reverse! (cons (if v (cons k v) k) out))
+                         (or delim end))))))))))
+
+(define* (parse-param-list str #\optional
+                           (val-parser default-val-parser)
+                           (start 0) (end (string-length str)))
+  (let lp ((i start) (out '()))
+    (call-with-values
+        (lambda () (parse-param-component str val-parser i end))
+      (lambda (item i)
+        (if (< i end)
+            (if (eqv? (string-ref str i) #\,)
+                (lp (skip-whitespace str (1+ i) end)
+                    (cons item out))
+                (bad-header-component 'param-list str))
+            (reverse! (cons item out)))))))
+
+(define* (validate-param-list list #\optional
+                              (valid? default-val-validator))
+  (list-of? list
+            (lambda (elt)
+              (key-value-list? elt valid?))))
+
+(define* (write-param-list list port #\optional
+                           (val-writer default-val-writer))
+  (write-list
+   list port
+   (lambda (item port)
+     (write-key-value-list item port val-writer ";"))
+   ","))
+
+(define-syntax string-match?
+  (lambda (x)
+    (syntax-case x ()
+      ((_ str pat) (string? (syntax->datum #'pat))
+       (let ((p (syntax->datum #'pat)))
+         #`(let ((s str))
+             (and
+              (= (string-length s) #,(string-length p))
+              #,@(let lp ((i 0) (tests '()))
+                   (if (< i (string-length p))
+                       (let ((c (string-ref p i)))
+                         (lp (1+ i)
+                             (case c
+                               ((#\.)   ; Whatever.
+                                tests)
+                               ((#\d)   ; Digit.
+                                (cons #`(char-numeric? (string-ref s #,i))
+                                      tests))
+                               ((#\a)   ; Alphabetic.
+                                (cons #`(char-alphabetic? (string-ref s #,i))
+                                      tests))
+                               (else    ; Literal.
+                                (cons #`(eqv? (string-ref s #,i) #,c)
+                                      tests)))))
+                       tests)))))))))
+
+;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
+;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
+
+(define (parse-month str start end)
+  (define (bad)
+    (bad-header-component 'month (substring str start end)))
+  (if (not (= (- end start) 3))
+      (bad)
+      (let ((a (string-ref str (+ start 0)))
+            (b (string-ref str (+ start 1)))
+            (c (string-ref str (+ start 2))))
+        (case a
+          ((#\J)
+           (case b
+             ((#\a) (case c ((#\n) 1) (else (bad))))
+             ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
+             (else (bad))))
+          ((#\F)
+           (case b
+             ((#\e) (case c ((#\b) 2) (else (bad))))
+             (else (bad))))
+          ((#\M)
+           (case b
+             ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
+             (else (bad))))
+          ((#\A)
+           (case b
+             ((#\p) (case c ((#\r) 4) (else (bad))))
+             ((#\u) (case c ((#\g) 8) (else (bad))))
+             (else (bad))))
+          ((#\S)
+           (case b
+             ((#\e) (case c ((#\p) 9) (else (bad))))
+             (else (bad))))
+          ((#\O)
+           (case b
+             ((#\c) (case c ((#\t) 10) (else (bad))))
+             (else (bad))))
+          ((#\N)
+           (case b
+             ((#\o) (case c ((#\v) 11) (else (bad))))
+             (else (bad))))
+          ((#\D)
+           (case b
+             ((#\e) (case c ((#\c) 12) (else (bad))))
+             (else (bad))))
+          (else (bad))))))
+
+;; "GMT" | "+" 4DIGIT | "-" 4DIGIT
+;;
+;; RFC 2616 requires date values to use "GMT", but recommends accepting
+;; the others as they are commonly generated by e.g. RFC 822 sources.
+(define (parse-zone-offset str start)
+  (let ((s (substring str start)))
+    (define (bad)
+      (bad-header-component 'zone-offset s))
+    (cond
+     ((string=? s "GMT")
+      0)
+     ((string=? s "UTC")
+      0)
+     ((string-match? s ".dddd")
+      (let ((sign (case (string-ref s 0)
+                    ((#\+) +1)
+                    ((#\-) -1)
+                    (else (bad))))
+            (hours (parse-non-negative-integer s 1 3))
+            (minutes (parse-non-negative-integer s 3 5)))
+        (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich
+     (else (bad)))))
+
+;; RFC 822, updated by RFC 1123
+;; 
+;; Sun, 06 Nov 1994 08_49_37 GMT
+;; 01234567890123456789012345678
+;; 0         1         2
+(define (parse-rfc-822-date str space zone-offset)
+  ;; We could verify the day of the week but we don't.
+  (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd_dd_dd")
+         (let ((date (parse-non-negative-integer str 5 7))
+               (month (parse-month str 8 11))
+               (year (parse-non-negative-integer str 12 16))
+               (hour (parse-non-negative-integer str 17 19))
+               (minute (parse-non-negative-integer str 20 22))
+               (second (parse-non-negative-integer str 23 25)))
+           (make-date 0 second minute hour date month year zone-offset)))
+        ((string-match? (substring str 0 space) "aaa, d aaa dddd dd_dd_dd")
+         (let ((date (parse-non-negative-integer str 5 6))
+               (month (parse-month str 7 10))
+               (year (parse-non-negative-integer str 11 15))
+               (hour (parse-non-negative-integer str 16 18))
+               (minute (parse-non-negative-integer str 19 21))
+               (second (parse-non-negative-integer str 22 24)))
+           (make-date 0 second minute hour date month year zone-offset)))
+
+        ;; The next two clauses match dates that have a space instead of
+        ;; a leading zero for hours, like " 8_49_37".
+        ((string-match? (substring str 0 space) "aaa, dd aaa dddd  d_dd_dd")
+         (let ((date (parse-non-negative-integer str 5 7))
+               (month (parse-month str 8 11))
+               (year (parse-non-negative-integer str 12 16))
+               (hour (parse-non-negative-integer str 18 19))
+               (minute (parse-non-negative-integer str 20 22))
+               (second (parse-non-negative-integer str 23 25)))
+           (make-date 0 second minute hour date month year zone-offset)))
+        ((string-match? (substring str 0 space) "aaa, d aaa dddd  d_dd_dd")
+         (let ((date (parse-non-negative-integer str 5 6))
+               (month (parse-month str 7 10))
+               (year (parse-non-negative-integer str 11 15))
+               (hour (parse-non-negative-integer str 17 18))
+               (minute (parse-non-negative-integer str 19 21))
+               (second (parse-non-negative-integer str 22 24)))
+           (make-date 0 second minute hour date month year zone-offset)))
+
+        (else
+         (bad-header 'date str)         ; prevent tail call
+         #f)))
+
+;; RFC 850, updated by RFC 1036
+;; Sunday, 06-Nov-94 08_49_37 GMT
+;;        0123456789012345678901
+;;        0         1         2
+(define (parse-rfc-850-date str comma space zone-offset)
+  ;; We could verify the day of the week but we don't.
+  (let ((tail (substring str (1+ comma) space)))
+    (if (not (string-match? tail " dd-aaa-dd dd_dd_dd"))
+        (bad-header 'date str))
+    (let ((date (parse-non-negative-integer tail 1 3))
+          (month (parse-month tail 4 7))
+          (year (parse-non-negative-integer tail 8 10))
+          (hour (parse-non-negative-integer tail 11 13))
+          (minute (parse-non-negative-integer tail 14 16))
+          (second (parse-non-negative-integer tail 17 19)))
+      (make-date 0 second minute hour date month
+                 (let* ((now (date-year (current-date)))
+                        (then (+ now year (- (modulo now 100)))))
+                   (cond ((< (+ then 50) now) (+ then 100))
+                         ((< (+ now 50) then) (- then 100))
+                         (else then)))
+                 zone-offset))))
+
+;; ANSI C's asctime() format
+;; Sun Nov  6 08_49_37 1994
+;; 012345678901234567890123
+;; 0         1         2
+(define (parse-asctime-date str)
+  (if (not (string-match? str "aaa aaa .d dd_dd_dd dddd"))
+      (bad-header 'date str))
+  (let ((date (parse-non-negative-integer
+               str
+               (if (eqv? (string-ref str 8) #\space) 9 8)
+               10))
+        (month (parse-month str 4 7))
+        (year (parse-non-negative-integer str 20 24))
+        (hour (parse-non-negative-integer str 11 13))
+        (minute (parse-non-negative-integer str 14 16))
+        (second (parse-non-negative-integer str 17 19)))
+    (make-date 0 second minute hour date month year 0)))
+
+;; Convert all date values to GMT time zone, as per RFC 2616 appendix C.
+(define (normalize-date date)
+  (if (zero? (date-zone-offset date))
+      date
+      (time-utc->date (date->time-utc date) 0)))
+
+(define (parse-date str)
+  (let* ((space (string-rindex str #\space))
+         (zone-offset (and space (false-if-exception
+                                  (parse-zone-offset str (1+ space))))))
+    (normalize-date
+     (if zone-offset
+         (let ((comma (string-index str #\,)))
+           (cond ((not comma) (bad-header 'date str))
+                 ((= comma 3) (parse-rfc-822-date str space zone-offset))
+                 (else (parse-rfc-850-date str comma space zone-offset))))
+         (parse-asctime-date str)))))
+
+(define (write-date date port)
+  (define (display-digits n digits port)
+    (define zero (char->integer #\0))
+    (let lp ((tens (expt 10 (1- digits))))
+      (if (> tens 0)
+          (begin
+            (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
+                    port)
+            (lp (floor/ tens 10))))))
+  (let ((date (if (zero? (date-zone-offset date))
+                  date
+                  (time-tai->date (date->time-tai date) 0))))
+    (display (case (date-week-day date)
+               ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
+               ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
+               ((6) "Sat, ") (else (error "bad date" date)))
+             port)
+    (display-digits (date-day date) 2 port)
+    (display (case (date-month date)
+               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Mar ")
+               ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
+               ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
+               ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
+               (else (error "bad date" date)))
+             port)
+    (display-digits (date-year date) 4 port)
+    (display #\space port)
+    (display-digits (date-hour date) 2 port)
+    (display #\_ port)
+    (display-digits (date-minute date) 2 port)
+    (display #\_ port)
+    (display-digits (date-second date) 2 port)
+    (display " GMT" port)))
+
+;; Following https_//tools.ietf.org/html/rfc7232#section-2.3, an entity
+;; tag should really be a qstring.  However there are a number of
+;; servers that emit etags as unquoted strings.  Assume that if the
+;; value doesn't start with a quote, it's an unquoted strong etag.
+(define (parse-entity-tag val)
+  (cond
+   ((string-prefix? "W/" val) (cons (parse-qstring val 2) #f))
+   ((string-prefix? "\"" val) (cons (parse-qstring val) #t))
+   (else (cons val #t))))
+
+(define (entity-tag? val)
+  (and (pair? val)
+       (string? (car val))))
+
+(define (write-entity-tag val port)
+  (if (not (cdr val))
+      (display "W/" port))
+  (write-qstring (car val) port))
+
+(define* (parse-entity-tag-list val #\optional
+                                (start 0) (end (string-length val)))
+  (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
+    (call-with-values (lambda ()
+                        (parse-qstring val (if strong? start (+ start 2))
+                                       end #\incremental? #t))
+      (lambda (tag next)
+        (acons tag strong?
+               (let ((next (skip-whitespace val next end)))
+                  (if (< next end)
+                      (if (eqv? (string-ref val next) #\,)
+                          (parse-entity-tag-list
+                           val
+                           (skip-whitespace val (1+ next) end)
+                           end)
+                          (bad-header-component 'entity-tag-list val))
+                      '())))))))
+
+(define (entity-tag-list? val)
+  (list-of? val entity-tag?))
+
+(define (write-entity-tag-list val port)
+  (write-list val port write-entity-tag  ", "))
+
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
+;;
+;; That's what the spec says. In reality the Basic scheme doesn't have
+;; k-v pairs, just one auth token, so we give that token as a string.
+;;
+(define* (parse-credentials str #\optional (val-parser default-val-parser)
+                            (start 0) (end (string-length str)))
+  (let* ((start (skip-whitespace str start end))
+         (delim (or (string-index str char-set_whitespace start end) end)))
+    (if (= start end)
+        (bad-header-component 'authorization str))
+    (let ((scheme (string->symbol
+                   (string-downcase (substring str start (or delim end))))))
+      (case scheme
+        ((basic)
+         (let* ((start (skip-whitespace str delim end)))
+           (if (< start end)
+               (cons scheme (substring str start end))
+               (bad-header-component 'credentials str))))
+        (else
+         (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
+
+(define (validate-credentials val)
+  (and (pair? val) (symbol? (car val))
+       (case (car val)
+         ((basic) (string? (cdr val)))
+         (else (key-value-list? (cdr val))))))
+
+(define (write-credentials val port)
+  (display (car val) port)
+  (display #\space port)
+  (case (car val)
+    ((basic) (display (cdr val) port))
+    (else (write-key-value-list (cdr val) port))))
+
+;; challenges = 1#challenge
+;; challenge = auth-scheme 1*SP 1#auth-param
+;;
+;; A pain to parse, as both challenges and auth params are delimited by
+;; commas, and qstrings can contain anything. We rely on auth params
+;; necessarily having "=" in them.
+;;
+(define* (parse-challenge str #\optional
+                          (start 0) (end (string-length str)))
+  (let* ((start (skip-whitespace str start end))
+         (sp (string-index str #\space start end))
+         (scheme (if sp
+                     (string->symbol (string-downcase (substring str start sp)))
+                     (bad-header-component 'challenge str))))
+    (let lp ((i sp) (out (list scheme)))
+      (if (not (< i end))
+          (values (reverse! out) end)
+          (let* ((i (skip-whitespace str i end))
+                 (eq (string-index str #\= i end))
+                 (comma (string-index str #\, i end))
+                 (delim (min (or eq end) (or comma end)))
+                 (token-end (trim-whitespace str i delim)))
+            (if (string-index str #\space i token-end)
+                (values (reverse! out) i)
+                (let ((k (string->symbol (substring str i token-end))))
+                  (call-with-values
+                      (lambda ()
+                        (if (and eq (or (not comma) (< eq comma)))
+                            (let ((i (skip-whitespace str (1+ eq) end)))
+                              (if (and (< i end) (eqv? (string-ref str i) #\"))
+                                  (parse-qstring str i end #\incremental? #t)
+                                  (values (substring
+                                           str i
+                                           (trim-whitespace str i
+                                                            (or comma end)))
+                                          (or comma end))))
+                            (values #f delim)))
+                    (lambda (v next-i)
+                      (let ((i (skip-whitespace str next-i end)))
+                        (if (or (= i end) (eqv? (string-ref str i) #\,))
+                            (lp (1+ i) (cons (if v (cons k v) k) out))
+                            (bad-header-component
+                             'challenge
+                             (substring str start end)))))))))))))
+
+(define* (parse-challenges str #\optional (val-parser default-val-parser)
+                           (start 0) (end (string-length str)))
+  (let lp ((i start) (ret '()))
+    (let ((i (skip-whitespace str i end)))
+      (if (< i end)
+          (call-with-values (lambda () (parse-challenge str i end))
+            (lambda (challenge i)
+              (lp i (cons challenge ret))))
+          (reverse ret)))))
+
+(define (validate-challenges val)
+  (list-of? val (lambda (x)
+                  (and (pair? x) (symbol? (car x))
+                       (key-value-list? (cdr x))))))
+
+(define (write-challenge val port)
+  (display (car val) port)
+  (display #\space port)
+  (write-key-value-list (cdr val) port))
+
+(define (write-challenges val port)
+  (write-list val port write-challenge ", "))
+
+
+
+
+;;;
+;;; Request-Line and Response-Line
+;;;
+
+;; Hmm.
+(define (bad-request message . args)
+  (throw 'bad-request message args))
+(define (bad-response message . args)
+  (throw 'bad-response message args))
+
+(define *known-versions* '())
+
+(define* (parse-http-version str #\optional (start 0) (end (string-length str)))
+  "Parse an HTTP version from STR, returning it as a major–minor
+pair. For example, ‘HTTP/1.1’ parses as the pair of integers,
+‘(1 . 1)’."
+  (or (let lp ((known *known-versions*))
+        (and (pair? known)
+             (if (string= str (caar known) start end)
+                 (cdar known)
+                 (lp (cdr known)))))
+      (let ((dot-idx (string-index str #\. start end)))
+        (if (and (string-prefix? "HTTP/" str 0 5 start end)
+                 dot-idx
+                 (= dot-idx (string-rindex str #\. start end)))
+            (cons (parse-non-negative-integer str (+ start 5) dot-idx)
+                  (parse-non-negative-integer str (1+ dot-idx) end))
+            (bad-header-component 'http-version (substring str start end))))))
+
+(define (write-http-version val port)
+  "Write the given major-minor version pair to PORT."
+  (display "HTTP/" port)
+  (display (car val) port)
+  (display #\. port)
+  (display (cdr val) port))
+
+(for-each
+ (lambda (v)
+   (set! *known-versions*
+         (acons v (parse-http-version v 0 (string-length v))
+                *known-versions*)))
+ '("HTTP/1.0" "HTTP/1.1"))
+
+
+;; Request-URI = "*" | absoluteURI | abs_path | authority
+;;
+;; The `authority' form is only permissible for the CONNECT method, so
+;; because we don't expect people to implement CONNECT, we save
+;; ourselves the trouble of that case, and disallow the CONNECT method.
+;;
+(define* (parse-http-method str #\optional (start 0) (end (string-length str)))
+  "Parse an HTTP method from STR.  The result is an upper-case
+symbol, like ‘GET’."
+  (cond
+   ((string= str "GET" start end) 'GET)
+   ((string= str "HEAD" start end) 'HEAD)
+   ((string= str "POST" start end) 'POST)
+   ((string= str "PUT" start end) 'PUT)
+   ((string= str "DELETE" start end) 'DELETE)
+   ((string= str "OPTIONS" start end) 'OPTIONS)
+   ((string= str "TRACE" start end) 'TRACE)
+   (else (bad-request "Invalid method_ ~a" (substring str start end)))))
+
+(define* (parse-request-uri str #\optional (start 0) (end (string-length str)))
+  "Parse a URI from an HTTP request line.  Note that URIs in requests do
+not have to have a scheme or host name.  The result is a URI object."
+  (cond
+   ((= start end)
+    (bad-request "Missing Request-URI"))
+   ((string= str "*" start end)
+    #f)
+   ((eqv? (string-ref str start) #\/)
+    (let* ((q (string-index str #\? start end))
+           (f (string-index str #\# start end))
+           (q (and q (or (not f) (< q f)) q)))
+      (build-uri 'http
+                 #\path (substring str start (or q f end))
+                 #\query (and q (substring str (1+ q) (or f end)))
+                 #\fragment (and f (substring str (1+ f) end)))))
+   (else
+    (or (string->uri (substring str start end))
+        (bad-request "Invalid URI_ ~a" (substring str start end))))))
+
+(define (read-request-line port)
+  "Read the first line of an HTTP request from PORT, returning
+three values_ the method, the URI, and the version."
+  (let* ((line (read-header-line port))
+         (d0 (string-index line char-set_whitespace)) ; "delimiter zero"
+         (d1 (string-rindex line char-set_whitespace)))
+    (if (and d0 d1 (< d0 d1))
+        (values (parse-http-method line 0 d0)
+                (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
+                (parse-http-version line (1+ d1) (string-length line)))
+        (bad-request "Bad Request-Line_ ~s" line))))
+
+(define (write-uri uri port)
+  (if (uri-host uri)
+      (begin
+        (display (uri-scheme uri) port)
+        (display "_//" port)
+        (if (uri-userinfo uri)
+            (begin
+              (display (uri-userinfo uri) port)
+              (display #\@ port)))
+        (display (uri-host uri) port)
+        (let ((p (uri-port uri)))
+          (if (and p (not (eqv? p 80)))
+              (begin
+                (display #\_ port)
+                (display p port))))))
+  (let* ((path (uri-path uri))
+         (len (string-length path)))
+    (cond
+     ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
+      (bad-request "Non-absolute URI path_ ~s" path))
+     ((and (zero? len) (not (uri-host uri)))
+      (bad-request "Empty path and no host for URI_ ~s" uri))
+     (else
+      (display path port))))
+  (if (uri-query uri)
+      (begin
+        (display #\? port)
+        (display (uri-query uri) port))))
+
+(define (write-request-line method uri version port)
+  "Write the first line of an HTTP request to PORT."
+  (display method port)
+  (display #\space port)
+  (when (http-proxy-port? port)
+    (let ((scheme (uri-scheme uri))
+          (host (uri-host uri))
+          (host-port (uri-port uri)))
+      (when (and scheme host)
+        (display scheme port)
+        (display "_//" port)
+        (if (string-index host #\_)
+            (begin (display #\[ port)
+                   (display host port)
+                   (display #\] port))
+            (display host port))
+        (unless ((@@ (web uri) default-port?) scheme host-port)
+          (display #\_ port)
+          (display host-port port)))))
+  (let ((path (uri-path uri))
+        (query (uri-query uri)))
+    (if (string-null? path)
+        (display "/" port)
+        (display path port))
+    (if query
+        (begin
+          (display "?" port)
+          (display query port))))
+  (display #\space port)
+  (write-http-version version port)
+  (display "\r\n" port))
+
+(define (read-response-line port)
+  "Read the first line of an HTTP response from PORT, returning three
+values_ the HTTP version, the response code, and the (possibly empty)
+\"reason phrase\"."
+  (let* ((line (read-header-line port))
+         (d0 (string-index line char-set_whitespace)) ; "delimiter zero"
+         (d1 (and d0 (string-index line char-set_whitespace
+                                   (skip-whitespace line d0)))))
+    (if (and d0 d1)
+        (values (parse-http-version line 0 d0)
+                (parse-non-negative-integer line (skip-whitespace line d0 d1)
+                                            d1)
+                (string-trim-both line char-set_whitespace d1))
+        (bad-response "Bad Response-Line_ ~s" line))))
+
+(define (write-response-line version code reason-phrase port)
+  "Write the first line of an HTTP response to PORT."
+  (write-http-version version port)
+  (display #\space port)
+  (display code port)
+  (display #\space port)
+  (display reason-phrase port)
+  (display "\r\n" port))
+
+
+
+
+;;;
+;;; Helpers for declaring headers
+;;;
+
+;; emacs_ (put 'declare-header! 'scheme-indent-function 1)
+;; emacs_ (put 'declare-opaque!-header 'scheme-indent-function 1)
+(define (declare-opaque-header! name)
+  "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
+  (declare-header! name
+    parse-opaque-string validate-opaque-string write-opaque-string))
+
+;; emacs_ (put 'declare-date-header! 'scheme-indent-function 1)
+(define (declare-date-header! name)
+  (declare-header! name
+    parse-date date? write-date))
+
+;; emacs_ (put 'declare-string-list-header! 'scheme-indent-function 1)
+(define (declare-string-list-header! name)
+  (declare-header! name
+    split-and-trim list-of-strings? write-list-of-strings))
+
+;; emacs_ (put 'declare-symbol-list-header! 'scheme-indent-function 1)
+(define (declare-symbol-list-header! name)
+  (declare-header! name
+    (lambda (str)
+      (map string->symbol (split-and-trim str)))
+    (lambda (v)
+      (list-of? v symbol?))
+    (lambda (v port)
+      (write-list v port display ", "))))
+
+;; emacs_ (put 'declare-header-list-header! 'scheme-indent-function 1)
+(define (declare-header-list-header! name)
+  (declare-header! name
+    split-header-names list-of-header-names? write-header-list))
+
+;; emacs_ (put 'declare-integer-header! 'scheme-indent-function 1)
+(define (declare-integer-header! name)
+  (declare-header! name
+    parse-non-negative-integer non-negative-integer? display))
+
+;; emacs_ (put 'declare-uri-header! 'scheme-indent-function 1)
+(define (declare-uri-header! name)
+  (declare-header! name
+    (lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+    (@@ (web uri) absolute-uri?)
+    write-uri))
+
+;; emacs_ (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+  (declare-header! name
+    (lambda (str)
+      (or ((@@ (web uri) string->uri*) str)
+          (bad-header-component 'uri str)))
+    uri?
+    write-uri))
+
+;; emacs_ (put 'declare-quality-list-header! 'scheme-indent-function 1)
+(define (declare-quality-list-header! name)
+  (declare-header! name
+    parse-quality-list validate-quality-list write-quality-list))
+
+;; emacs_ (put 'declare-param-list-header! 'scheme-indent-function 1)
+(define* (declare-param-list-header! name #\optional
+                                     (val-parser default-val-parser)
+                                     (val-validator default-val-validator)
+                                     (val-writer default-val-writer))
+  (declare-header! name
+    (lambda (str) (parse-param-list str val-parser))
+    (lambda (val) (validate-param-list val val-validator))
+    (lambda (val port) (write-param-list val port val-writer))))
+
+;; emacs_ (put 'declare-key-value-list-header! 'scheme-indent-function 1)
+(define* (declare-key-value-list-header! name #\optional
+                                         (val-parser default-val-parser)
+                                         (val-validator default-val-validator)
+                                         (val-writer default-val-writer))
+  (declare-header! name
+    (lambda (str) (parse-key-value-list str val-parser))
+    (lambda (val) (key-value-list? val val-validator))
+    (lambda (val port) (write-key-value-list val port val-writer))))
+
+;; emacs_ (put 'declare-entity-tag-list-header! 'scheme-indent-function 1)
+(define (declare-entity-tag-list-header! name)
+  (declare-header! name
+    (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
+    (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
+    (lambda (val port)
+      (if (eq? val '*)
+          (display "*" port)
+          (write-entity-tag-list val port)))))
+
+;; emacs_ (put 'declare-credentials-header! 'scheme-indent-function 1)
+(define (declare-credentials-header! name)
+  (declare-header! name
+    parse-credentials validate-credentials write-credentials))
+
+;; emacs_ (put 'declare-challenge-list-header! 'scheme-indent-function 1)
+(define (declare-challenge-list-header! name)
+  (declare-header! name
+    parse-challenges validate-challenges write-challenges))
+
+
+
+
+;;;
+;;; General headers
+;;;
+
+;; Cache-Control   = 1#(cache-directive)
+;; cache-directive = cache-request-directive | cache-response-directive
+;; cache-request-directive =
+;;        "no-cache"                          ; Section 14.9.1
+;;      | "no-store"                          ; Section 14.9.2
+;;      | "max-age" "=" delta-seconds         ; Section 14.9.3, 14.9.4
+;;      | "max-stale" [ "=" delta-seconds ]   ; Section 14.9.3
+;;      | "min-fresh" "=" delta-seconds       ; Section 14.9.3
+;;      | "no-transform"                      ; Section 14.9.5
+;;      | "only-if-cached"                    ; Section 14.9.4
+;;      | cache-extension                     ; Section 14.9.6
+;;  cache-response-directive =
+;;        "public"                               ; Section 14.9.1
+;;      | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
+;;      | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
+;;      | "no-store"                             ; Section 14.9.2
+;;      | "no-transform"                         ; Section 14.9.5
+;;      | "must-revalidate"                      ; Section 14.9.4
+;;      | "proxy-revalidate"                     ; Section 14.9.4
+;;      | "max-age" "=" delta-seconds            ; Section 14.9.3
+;;      | "s-maxage" "=" delta-seconds           ; Section 14.9.3
+;;      | cache-extension                        ; Section 14.9.6
+;; cache-extension = token [ "=" ( token | quoted-string ) ]
+;;
+(declare-key-value-list-header! "Cache-Control"
+  (lambda (k v-str)
+    (case k
+      ((max-age min-fresh s-maxage)
+       (parse-non-negative-integer v-str))
+      ((max-stale)
+       (and v-str (parse-non-negative-integer v-str)))
+      ((private no-cache)
+       (and v-str (split-header-names v-str)))
+      (else v-str)))
+  (lambda (k v)
+    (case k
+      ((max-age min-fresh s-maxage)
+       (non-negative-integer? v))
+      ((max-stale)
+       (or (not v) (non-negative-integer? v)))
+      ((private no-cache)
+       (or (not v) (list-of-header-names? v)))
+      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+       (not v))
+      (else
+       (or (not v) (string? v)))))
+  (lambda (k v port)
+    (cond
+     ((string? v) (default-val-writer k v port))
+     ((pair? v)
+      (display #\" port)
+      (write-header-list v port)
+      (display #\" port))
+     ((integer? v)
+      (display v port))
+     (else
+      (bad-header-component 'cache-control v)))))
+
+;; Connection = "Connection" "_" 1#(connection-token)
+;; connection-token  = token
+;; e.g.
+;;     Connection_ close, Foo-Header
+;; 
+(declare-header! "Connection"
+  split-header-names
+  list-of-header-names?
+  (lambda (val port)
+    (write-list val port
+                (lambda (x port)
+                  (display (if (eq? x 'close)
+                               "close"
+                               (header->string x))
+                           port))
+                ", ")))
+
+;; Date  = "Date" "_" HTTP-date
+;; e.g.
+;;     Date_ Tue, 15 Nov 1994 08_12_31 GMT
+;;
+(declare-date-header! "Date")
+
+;; Pragma            = "Pragma" "_" 1#pragma-directive
+;; pragma-directive  = "no-cache" | extension-pragma
+;; extension-pragma  = token [ "=" ( token | quoted-string ) ]
+;;
+(declare-key-value-list-header! "Pragma")
+
+;; Trailer  = "Trailer" "_" 1#field-name
+;;
+(declare-header-list-header! "Trailer")
+
+;; Transfer-Encoding = "Transfer-Encoding" "_" 1#transfer-coding
+;;
+(declare-param-list-header! "Transfer-Encoding")
+
+;; Upgrade = "Upgrade" "_" 1#product
+;;
+(declare-string-list-header! "Upgrade")
+
+;; Via =  "Via" "_" 1#( received-protocol received-by [ comment ] )
+;; received-protocol = [ protocol-name "/" ] protocol-version
+;; protocol-name     = token
+;; protocol-version  = token
+;; received-by       = ( host [ "_" port ] ) | pseudonym
+;; pseudonym         = token
+;;
+(declare-header! "Via"
+  split-and-trim
+  list-of-strings?
+  write-list-of-strings
+  #\multiple? #t)
+
+;; Warning    = "Warning" "_" 1#warning-value
+;;
+;; warning-value = warn-code SP warn-agent SP warn-text
+;;                                       [SP warn-date]
+;;
+;; warn-code  = 3DIGIT
+;; warn-agent = ( host [ "_" port ] ) | pseudonym
+;;                 ; the name or pseudonym of the server adding
+;;                 ; the Warning header, for use in debugging
+;; warn-text  = quoted-string
+;; warn-date  = <"> HTTP-date <">
+(declare-header! "Warning"
+  (lambda (str)
+    (let ((len (string-length str)))
+      (let lp ((i (skip-whitespace str 0)))
+        (let* ((idx1 (string-index str #\space i))
+               (idx2 (string-index str #\space (1+ idx1))))
+          (if (and idx1 idx2)
+              (let ((code (parse-non-negative-integer str i idx1))
+                    (agent (substring str (1+ idx1) idx2)))
+                (call-with-values
+                    (lambda () (parse-qstring str (1+ idx2) #\incremental? #t))
+                  (lambda (text i)
+                    (call-with-values
+                        (lambda ()
+                          (let ((c (and (< i len) (string-ref str i))))
+                            (case c
+                              ((#\space)
+                               ;; we have a date.
+                               (call-with-values
+                                   (lambda () (parse-qstring str (1+ i)
+                                                             #\incremental? #t))
+                                 (lambda (date i)
+                                   (values text (parse-date date) i))))
+                              (else
+                               (values text #f i)))))
+                      (lambda (text date i)
+                        (let ((w (list code agent text date))
+                              (c (and (< i len) (string-ref str i))))
+                          (case c
+                            ((#f) (list w))
+                            ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
+                            (else (bad-header 'warning str))))))))))))))
+  (lambda (val)
+    (list-of? val
+              (lambda (elt)
+                (and (list? elt)
+                     (= (length elt) 4)
+                     (apply (lambda (code host text date)
+                              (and (non-negative-integer? code) (< code 1000)
+                                   (string? host)
+                                   (string? text)
+                                   (or (not date) (date? date))))
+                            elt)))))
+  (lambda (val port)
+    (write-list
+     val port
+     (lambda (w port)
+       (apply
+        (lambda (code host text date)
+          (display code port)
+          (display #\space port)
+          (display host port)
+          (display #\space port)
+          (write-qstring text port)
+          (if date
+              (begin
+                (display #\space port)
+                (write-date date port))))
+        w))
+     ", "))
+  #\multiple? #t)
+
+
+
+
+;;;
+;;; Entity headers
+;;;
+
+;; Allow = #Method
+;;
+(declare-symbol-list-header! "Allow")
+
+;; Content-Disposition = disposition-type *( ";" disposition-parm )
+;; disposition-type = "attachment" | disp-extension-token
+;; disposition-parm = filename-parm | disp-extension-parm
+;; filename-parm = "filename" "=" quoted-string
+;; disp-extension-token = token
+;; disp-extension-parm = token "=" ( token | quoted-string )
+;;
+(declare-header! "Content-Disposition"
+  (lambda (str)
+    (let ((disposition (parse-param-list str default-val-parser)))
+      ;; Lazily reuse the param list parser.
+      (unless (and (pair? disposition)
+                   (null? (cdr disposition)))
+        (bad-header-component 'content-disposition str))
+      (car disposition)))
+  (lambda (val)
+    (and (pair? val)
+         (symbol? (car val))
+         (list-of? (cdr val)
+                   (lambda (x)
+                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
+  (lambda (val port)
+    (write-param-list (list val) port)))
+
+;; Content-Encoding = 1#content-coding
+;;
+(declare-symbol-list-header! "Content-Encoding")
+
+;; Content-Language = 1#language-tag
+;;
+(declare-string-list-header! "Content-Language")
+
+;; Content-Length = 1*DIGIT
+;;
+(declare-integer-header! "Content-Length")
+
+;; Content-Location = ( absoluteURI | relativeURI )
+;;
+(declare-relative-uri-header! "Content-Location")
+
+;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
+;;
+(declare-opaque-header! "Content-MD5")
+
+;; Content-Range = content-range-spec
+;; content-range-spec      = byte-content-range-spec
+;; byte-content-range-spec = bytes-unit SP
+;;                           byte-range-resp-spec "/"
+;;                           ( instance-length | "*" )
+;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
+;;                                | "*"
+;; instance-length           = 1*DIGIT
+;;
+(declare-header! "Content-Range"
+  (lambda (str)
+    (let ((dash (string-index str #\-))
+          (slash (string-index str #\/)))
+      (if (and (string-prefix? "bytes " str) slash)
+          (list 'bytes
+                (cond
+                 (dash
+                  (cons
+                   (parse-non-negative-integer str 6 dash)
+                   (parse-non-negative-integer str (1+ dash) slash)))
+                 ((string= str "*" 6 slash)
+                  '*)
+                 (else
+                  (bad-header 'content-range str)))
+                (if (string= str "*" (1+ slash))
+                    '*
+                    (parse-non-negative-integer str (1+ slash))))
+          (bad-header 'content-range str))))
+  (lambda (val)
+    (and (list? val) (= (length val) 3)
+         (symbol? (car val))
+         (let ((x (cadr val)))
+           (or (eq? x '*)
+               (and (pair? x)
+                    (non-negative-integer? (car x))
+                    (non-negative-integer? (cdr x)))))
+         (let ((x (caddr val)))
+           (or (eq? x '*)
+               (non-negative-integer? x)))))
+  (lambda (val port)
+    (display (car val) port)
+    (display #\space port)
+    (if (eq? (cadr val) '*)
+        (display #\* port)
+        (begin
+          (display (caadr val) port)
+          (display #\- port)
+          (display (caadr val) port)))
+    (if (eq? (caddr val) '*)
+        (display #\* port)
+        (display (caddr val) port))))
+
+;; Content-Type = media-type
+;;
+(declare-header! "Content-Type"
+  (lambda (str)
+    (let ((parts (string-split str #\;)))
+      (cons (parse-media-type (car parts))
+            (map (lambda (x)
+                   (let ((eq (string-index x #\=)))
+                     (if (and eq (= eq (string-rindex x #\=)))
+                         (cons
+                          (string->symbol
+                           (string-trim x char-set_whitespace 0 eq))
+                          (string-trim-right x char-set_whitespace (1+ eq)))
+                         (bad-header 'content-type str))))
+                 (cdr parts)))))
+  (lambda (val)
+    (and (pair? val)
+         (symbol? (car val))
+         (list-of? (cdr val)
+                   (lambda (x)
+                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
+  (lambda (val port)
+    (display (car val) port)
+    (if (pair? (cdr val)) 
+       (begin
+          (display ";" port)
+          (write-list
+           (cdr val) port
+           (lambda (pair port)
+             (display (car pair) port)
+             (display #\= port)
+             (display (cdr pair) port))
+           ";")))))
+
+;; Expires = HTTP-date
+;;
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00_00_00 GMT"))
+
+(declare-header! "Expires"
+  (lambda (str)
+    (if (member str '("0" "-1"))
+        *date-in-the-past*
+        (parse-date str)))
+  date?
+  write-date)
+
+;; Last-Modified = HTTP-date
+;;
+(declare-date-header! "Last-Modified")
+
+
+
+
+;;;
+;;; Request headers
+;;;
+
+;; Accept = #( media-range [ accept-params ] )
+;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
+;;               *( ";" parameter )
+;; accept-params = ";" "q" "=" qvalue *( accept-extension )
+;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
+;;
+(declare-param-list-header! "Accept"
+  ;; -> (type/subtype (sym-prop . str-val) ...) ...)
+  ;;
+  ;; with the exception of prop `q', in which case the val will be a
+  ;; valid quality value
+  ;;
+  (lambda (k v)
+    (if (eq? k 'q) 
+        (parse-quality v)
+        v))
+  (lambda (k v)
+    (if (eq? k 'q)
+        (valid-quality? v)
+        (or (not v) (string? v))))
+  (lambda (k v port)
+    (if (eq? k 'q)
+        (write-quality v port)
+        (default-val-writer k v port))))
+
+;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
+;;
+(declare-quality-list-header! "Accept-Charset")
+
+;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
+;; codings = ( content-coding | "*" )
+;;
+(declare-quality-list-header! "Accept-Encoding")
+
+;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
+;; language-range  = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
+;;
+(declare-quality-list-header! "Accept-Language")
+
+;; Authorization = credentials
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
+;;
+(declare-credentials-header! "Authorization")
+
+;; Expect = 1#expectation
+;; expectation = "100-continue" | expectation-extension
+;; expectation-extension = token [ "=" ( token | quoted-string )
+;;                         *expect-params ]
+;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
+;;
+(declare-param-list-header! "Expect")
+
+;; From = mailbox
+;;
+;; Should be an email address; we just pass on the string as-is.
+;;
+(declare-opaque-header! "From")
+
+;; Host = host [ "_" port ]
+;; 
+(declare-header! "Host"
+  (lambda (str)
+    (let* ((rbracket (string-index str #\]))
+           (colon (string-index str #\_ (or rbracket 0)))
+           (host (cond
+                  (rbracket
+                   (unless (eqv? (string-ref str 0) #\[)
+                     (bad-header 'host str))
+                   (substring str 1 rbracket))
+                  (colon
+                   (substring str 0 colon))
+                  (else
+                   str)))
+           (port (and colon
+                      (parse-non-negative-integer str (1+ colon)))))
+      (cons host port)))
+  (lambda (val)
+    (and (pair? val)
+         (string? (car val))
+         (or (not (cdr val))
+             (non-negative-integer? (cdr val)))))
+  (lambda (val port)
+    (if (string-index (car val) #\_)
+        (begin
+          (display #\[ port)
+          (display (car val) port)
+          (display #\] port))
+        (display (car val) port))
+    (if (cdr val)
+        (begin
+          (display #\_ port)
+          (display (cdr val) port)))))
+
+;; If-Match = ( "*" | 1#entity-tag )
+;;
+(declare-entity-tag-list-header! "If-Match")
+
+;; If-Modified-Since = HTTP-date
+;;
+(declare-date-header! "If-Modified-Since")
+
+;; If-None-Match = ( "*" | 1#entity-tag )
+;;
+(declare-entity-tag-list-header! "If-None-Match")
+
+;; If-Range = ( entity-tag | HTTP-date )
+;;
+(declare-header! "If-Range"
+  (lambda (str)
+    (if (or (string-prefix? "\"" str)
+            (string-prefix? "W/" str))
+        (parse-entity-tag str)
+        (parse-date str)))
+  (lambda (val)
+    (or (date? val) (entity-tag? val)))
+  (lambda (val port)
+    (if (date? val)
+        (write-date val port)
+        (write-entity-tag val port))))
+
+;; If-Unmodified-Since = HTTP-date
+;;
+(declare-date-header! "If-Unmodified-Since")
+
+;; Max-Forwards = 1*DIGIT
+;;
+(declare-integer-header! "Max-Forwards")
+
+;; Proxy-Authorization = credentials
+;;
+(declare-credentials-header! "Proxy-Authorization")
+
+;; Range = "Range" "_" ranges-specifier
+;; ranges-specifier = byte-ranges-specifier
+;; byte-ranges-specifier = bytes-unit "=" byte-range-set
+;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
+;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
+;; first-byte-pos = 1*DIGIT
+;; last-byte-pos = 1*DIGIT
+;; suffix-byte-range-spec = "-" suffix-length
+;; suffix-length = 1*DIGIT
+;;
+(declare-header! "Range"
+  (lambda (str)
+    (if (string-prefix? "bytes=" str)
+        (cons
+         'bytes
+         (map (lambda (x)
+                (let ((dash (string-index x #\-)))
+                  (cond
+                   ((not dash)
+                    (bad-header 'range str))
+                   ((zero? dash)
+                    (cons #f (parse-non-negative-integer x 1)))
+                   ((= dash (1- (string-length x)))
+                    (cons (parse-non-negative-integer x 0 dash) #f))
+                   (else
+                    (cons (parse-non-negative-integer x 0 dash)
+                          (parse-non-negative-integer x (1+ dash)))))))
+              (string-split (substring str 6) #\,)))
+        (bad-header 'range str)))
+  (lambda (val)
+    (and (pair? val)
+         (symbol? (car val))
+         (list-of? (cdr val)
+                   (lambda (elt)
+                     (and (pair? elt)
+                          (let ((x (car elt)) (y (cdr elt)))
+                            (and (or x y)
+                                 (or (not x) (non-negative-integer? x))
+                                 (or (not y) (non-negative-integer? y)))))))))
+  (lambda (val port)
+    (display (car val) port)
+    (display #\= port)
+    (write-list
+     (cdr val) port
+     (lambda (pair port)
+       (if (car pair)
+           (display (car pair) port))
+       (display #\- port)
+       (if (cdr pair)
+           (display (cdr pair) port)))
+     ",")))
+
+;; Referer = ( absoluteURI | relativeURI )
+;;
+(declare-relative-uri-header! "Referer")
+
+;; TE = #( t-codings )
+;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
+;;
+(declare-param-list-header! "TE")
+
+;; User-Agent = 1*( product | comment )
+;;
+(declare-opaque-header! "User-Agent")
+
+
+
+
+;;;
+;;; Reponse headers
+;;;
+
+;; Accept-Ranges = acceptable-ranges
+;; acceptable-ranges = 1#range-unit | "none"
+;;
+(declare-symbol-list-header! "Accept-Ranges")
+
+;; Age = age-value
+;; age-value = delta-seconds
+;;
+(declare-integer-header! "Age")
+
+;; ETag = entity-tag
+;;
+(declare-header! "ETag"
+  parse-entity-tag
+  entity-tag?
+  write-entity-tag)
+
+;; Location = URI-reference
+;; 
+(declare-relative-uri-header! "Location")
+
+;; Proxy-Authenticate = 1#challenge
+;;
+(declare-challenge-list-header! "Proxy-Authenticate")
+
+;; Retry-After  = ( HTTP-date | delta-seconds )
+;;
+(declare-header! "Retry-After"
+  (lambda (str)
+    (if (and (not (string-null? str))
+             (char-numeric? (string-ref str 0)))
+        (parse-non-negative-integer str)
+        (parse-date str)))
+  (lambda (val)
+    (or (date? val) (non-negative-integer? val)))
+  (lambda (val port)
+    (if (date? val)
+        (write-date val port)
+        (display val port))))
+
+;; Server = 1*( product | comment )
+;;
+(declare-opaque-header! "Server")
+
+;; Vary = ( "*" | 1#field-name )
+;;
+(declare-header! "Vary"
+  (lambda (str)
+    (if (equal? str "*")
+        '*
+        (split-header-names str)))
+  (lambda (val)
+    (or (eq? val '*) (list-of-header-names? val)))
+  (lambda (val port)
+    (if (eq? val '*)
+        (display "*" port)
+        (write-header-list val port))))
+
+;; WWW-Authenticate = 1#challenge
+;;
+(declare-challenge-list-header! "WWW-Authenticate")
+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+  "Read a chunk header from PORT and return the size in bytes of the
+upcoming chunk."
+  (match (read-line port)
+    ((? eof-object?)
+     ;; Connection closed prematurely_ there's nothing left to read.
+     0)
+    (str
+     (let ((extension-start (string-index str
+                                          (lambda (c)
+                                            (or (char=? c #\;)
+                                                (char=? c #\return))))))
+       (string->number (if extension-start       ; unnecessary?
+                           (substring str 0 extension-start)
+                           str)
+                       16)))))
+
+(define* (make-chunked-input-port port #\key (keep-alive? #f))
+  "Returns a new port which translates HTTP chunked transfer encoded
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
+  (define (close)
+    (unless keep-alive?
+      (close-port port)))
+
+  (define chunk-size 0)     ;size of the current chunk
+  (define remaining 0)      ;number of bytes left from the current chunk
+  (define finished? #f)     ;did we get all the chunks?
+
+  (define (read! bv idx to-read)
+    (define (loop to-read num-read)
+      (cond ((or finished? (zero? to-read))
+             num-read)
+            ((zero? remaining)                    ;get a new chunk
+             (let ((size (read-chunk-header port)))
+               (set! chunk-size size)
+               (set! remaining size)
+               (if (zero? size)
+                   (begin
+                     (set! finished? #t)
+                     num-read)
+                   (loop to-read num-read))))
+            (else                           ;read from the current chunk
+             (let* ((ask-for (min to-read remaining))
+                    (read    (get-bytevector-n! port bv (+ idx num-read)
+                                                ask-for)))
+               (if (eof-object? read)
+                   (begin                         ;premature termination
+                     (set! finished? #t)
+                     num-read)
+                   (let ((left (- remaining read)))
+                     (set! remaining left)
+                     (when (zero? left)
+                       ;; We're done with this chunk; read CR and LF.
+                       (get-u8 port) (get-u8 port))
+                     (loop (- to-read read)
+                           (+ num-read read))))))))
+    (loop to-read 0))
+
+  (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #\key (keep-alive? #f))
+  "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to PORT. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close PORT, unless
+KEEP-ALIVE? is true."
+  (define (q-for-each f q)
+    (while (not (q-empty? q))
+      (f (deq! q))))
+  (define queue (make-q))
+  (define (put-char c)
+    (enq! queue c))
+  (define (put-string s)
+    (string-for-each (lambda (c) (enq! queue c))
+                     s))
+  (define (flush)
+    ;; It is important that we do _not_ write a chunk if the queue is
+    ;; empty, since it will be treated as the final chunk.
+    (unless (q-empty? queue)
+      (let ((len (q-length queue)))
+        (display (number->string len 16) port)
+        (display "\r\n" port)
+        (q-for-each (lambda (elem) (write-char elem port))
+                    queue)
+        (display "\r\n" port))))
+  (define (close)
+    (flush)
+    (display "0\r\n" port)
+    (force-output port)
+    (unless keep-alive?
+      (close-port port)))
+  (make-soft-port (vector put-char put-string flush #f close) "w"))
+
+(define %http-proxy-port? (make-object-property))
+(define (http-proxy-port? port) (%http-proxy-port? port))
+(define (set-http-proxy-port?! port flag)
+  (set! (%http-proxy-port? port) flag))
+;;; HTTP request objects
+
+;; 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
+
+;;; Code_
+
+(define-module (web request)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\use-module (ice-9 rdelim)
+  #\use-module (srfi srfi-9)
+  #\use-module (web uri)
+  #\use-module (web http)
+  #\export (request?
+            request-method
+            request-uri
+            request-version
+            request-headers
+            request-meta
+            request-port
+            
+            read-request
+            build-request
+            write-request
+
+            read-request-body
+            write-request-body
+
+            ;; General headers
+            ;;
+            request-cache-control
+            request-connection
+            request-date
+            request-pragma
+            request-trailer
+            request-transfer-encoding
+            request-upgrade
+            request-via
+            request-warning
+            
+            ;; Entity headers
+            ;;
+            request-allow
+            request-content-encoding
+            request-content-language
+            request-content-length
+            request-content-location
+            request-content-md5
+            request-content-range
+            request-content-type
+            request-expires
+            request-last-modified
+            
+            ;; Request headers
+            ;;
+            request-accept
+            request-accept-charset
+            request-accept-encoding
+            request-accept-language
+            request-authorization
+            request-expect
+            request-from
+            request-host
+            request-if-match
+            request-if-modified-since
+            request-if-none-match
+            request-if-range
+            request-if-unmodified-since
+            request-max-forwards
+            request-proxy-authorization
+            request-range
+            request-referer
+            request-te
+            request-user-agent
+
+            ;; Misc
+            request-absolute-uri))
+
+
+;;; {Character Encodings, Strings, and Bytevectors}
+;;; 
+;;; Requests are read from over the wire, and as such have to be treated
+;;; very carefully.
+;;;
+;;; The header portion of the message is defined to be in a subset of
+;;; ASCII, and may be processed either byte-wise (using bytevectors and
+;;; binary I/O) or as characters in a single-byte ASCII-compatible
+;;; encoding.
+;;;
+;;; We choose the latter, processing as strings in the latin-1
+;;; encoding. This allows us to use all the read-delimited machinery,
+;;; character sets, and regular expressions, shared substrings, etc.
+;;;
+;;; The characters in the header values may themselves encode other
+;;; bytes or characters -- basically each header has its own parser. We
+;;; leave that as a header-specific topic.
+;;;
+;;; The body is present if the content-length header is present. Its
+;;; format and, if textual, encoding is determined by the headers, but
+;;; its length is encoded in bytes. So we just slurp that number of
+;;; characters in latin-1, knowing that the number of characters
+;;; corresponds to the number of bytes, and then convert to a
+;;; bytevector, perhaps for later decoding.
+;;;
+
+(define-record-type <request>
+  (make-request method uri version headers meta port)
+  request?
+  (method request-method)
+  (uri request-uri)
+  (version request-version)
+  (headers request-headers)
+  (meta request-meta)
+  (port request-port))
+
+(define (bad-request message . args)
+  (throw 'bad-request message args))
+
+(define (bad-request-printer port key args default-printer)
+  (apply (case-lambda
+           ((msg args)
+            (display "Bad request_ " port)
+            (apply format port msg args)
+            (newline port))
+           (_ (default-printer)))
+         args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
+(define (non-negative-integer? n)
+  (and (number? n) (>= n 0) (exact? n) (integer? n)))
+                                    
+(define (validate-headers headers)
+  (if (pair? headers)
+      (let ((h (car headers)))
+        (if (pair? h)
+            (let ((k (car h)) (v (cdr h)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-request "Bad value for header ~a_ ~s" k v)))
+            (bad-request "Header not a pair_ ~a" h)))
+      (if (not (null? headers))
+          (bad-request "Headers not a list_ ~a" headers))))
+
+(define* (build-request uri #\key (method 'GET) (version '(1 . 1))
+                        (headers '()) port (meta '())
+                        (validate-headers? #t))
+  "Construct an HTTP request object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+  (let ((needs-host? (and (equal? version '(1 . 1))
+                          (not (assq-ref headers 'host)))))
+    (cond
+     ((not (and (pair? version)
+                (non-negative-integer? (car version))
+                (non-negative-integer? (cdr version))))
+      (bad-request "Bad version_ ~a" version))
+     ((not (uri? uri))
+      (bad-request "Bad uri_ ~a" uri))
+     ((and (not port) (memq method '(POST PUT)))
+      (bad-request "Missing port for message ~a" method))
+     ((not (list? meta))
+      (bad-request "Bad metadata alist" meta))
+     ((and needs-host? (not (uri-host uri)))
+      (bad-request "HTTP/1.1 request without Host header and no host in URI_ ~a"
+                   uri))
+     (else
+      (if validate-headers?
+          (validate-headers headers))))
+    (make-request method uri version
+                  (if needs-host?
+                      (acons 'host (cons (uri-host uri) (uri-port uri))
+                             headers)
+                      headers)
+                  meta port)))
+
+(define* (read-request port #\optional (meta '()))
+  "Read an HTTP request from PORT, optionally attaching the given
+metadata, META.
+
+As a side effect, sets the encoding on PORT to
+ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
+the discussion of character sets in \"HTTP Requests\" in the manual, for
+more information.
+
+Note that the body is not part of the request.  Once you have read a
+request, you may read the body separately, and likewise for writing
+requests."
+  (set-port-encoding! port "ISO-8859-1")
+  (call-with-values (lambda () (read-request-line port))
+    (lambda (method uri version)
+      (make-request method uri version (read-headers port) meta port))))
+
+;; FIXME_ really return a new request?
+(define (write-request r port)
+  "Write the given HTTP request to PORT.
+
+Return a new request, whose ‘request-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
+  (write-request-line (request-method r) (request-uri r)
+                      (request-version r) port)
+  (write-headers (request-headers r) port)
+  (display "\r\n" port)
+  (if (eq? port (request-port r))
+      r
+      (make-request (request-method r) (request-uri r) (request-version r)
+                    (request-headers r) (request-meta r) port)))
+
+(define (read-request-body r)
+  "Reads the request body from R, as a bytevector.  Return ‘#f’
+if there was no request body."
+  (let ((nbytes (request-content-length r)))
+    (and nbytes
+         (let ((bv (get-bytevector-n (request-port r) nbytes)))
+           (if (= (bytevector-length bv) nbytes)
+               bv
+               (bad-request "EOF while reading request body_ ~a bytes of ~a"
+                            (bytevector-length bv) nbytes))))))
+
+(define (write-request-body r bv)
+  "Write BV, a bytevector, to the port corresponding to the HTTP
+request R."
+  (put-bytevector (request-port r) bv))
+
+(define-syntax define-request-accessor
+  (lambda (x)
+    (syntax-case x ()
+      ((_ field)
+       #'(define-request-accessor field #f))
+      ((_ field def) (identifier? #'field)
+       #`(define* (#,(datum->syntax
+                      #'field
+                      (symbol-append 'request- (syntax->datum #'field)))
+                   request
+                   #\optional (default def))
+           (cond
+            ((assq 'field (request-headers request)) => cdr)
+            (else default)))))))
+
+;; General headers
+;;
+(define-request-accessor cache-control '())
+(define-request-accessor connection '())
+(define-request-accessor date #f)
+(define-request-accessor pragma '())
+(define-request-accessor trailer '())
+(define-request-accessor transfer-encoding '())
+(define-request-accessor upgrade '())
+(define-request-accessor via '())
+(define-request-accessor warning '())
+
+;; Entity headers
+;;
+(define-request-accessor allow '())
+(define-request-accessor content-encoding '())
+(define-request-accessor content-language '())
+(define-request-accessor content-length #f)
+(define-request-accessor content-location #f)
+(define-request-accessor content-md5 #f)
+(define-request-accessor content-range #f)
+(define-request-accessor content-type #f)
+(define-request-accessor expires #f)
+(define-request-accessor last-modified #f)
+
+;; Request headers
+;;
+(define-request-accessor accept '())
+(define-request-accessor accept-charset '())
+(define-request-accessor accept-encoding '())
+(define-request-accessor accept-language '())
+(define-request-accessor authorization #f)
+(define-request-accessor expect '())
+(define-request-accessor from #f)
+(define-request-accessor host #f)
+;; Absence of an if-directive appears to be different from `*'.
+(define-request-accessor if-match #f)
+(define-request-accessor if-modified-since #f)
+(define-request-accessor if-none-match #f)
+(define-request-accessor if-range #f)
+(define-request-accessor if-unmodified-since #f)
+(define-request-accessor max-forwards #f)
+(define-request-accessor proxy-authorization #f)
+(define-request-accessor range #f)
+(define-request-accessor referer #f)
+(define-request-accessor te '())
+(define-request-accessor user-agent #f)
+
+;; Misc accessors
+(define* (request-absolute-uri r #\optional default-host default-port)
+  "A helper routine to determine the absolute URI of a request, using the
+‘host’ header and the default host and port."
+  (let ((uri (request-uri r)))
+    (if (uri-host uri)
+        uri
+        (let ((host
+               (or (request-host r)
+                   (if default-host
+                       (cons default-host default-port)
+                       (bad-request
+                        "URI not absolute, no Host header, and no default_ ~s"
+                        uri)))))
+          (build-uri (uri-scheme uri)
+                     #\host (car host)
+                     #\port (cdr host)
+                     #\path (uri-path uri)
+                     #\query (uri-query uri)
+                     #\fragment (uri-fragment uri))))))
+;;; HTTP response objects
+
+;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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
+
+;;; Code_
+
+(define-module (web response)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 match)
+  #\use-module (srfi srfi-9)
+  #\use-module (web http)
+  #\export (response?
+            response-version
+            response-code
+            response-reason-phrase
+            response-headers
+            response-port
+            read-response
+            build-response
+            adapt-response-version
+            write-response
+
+            response-must-not-include-body?
+            response-body-port
+            read-response-body
+            write-response-body
+
+            ;; General headers
+            ;;
+            response-cache-control
+            response-connection
+            response-date
+            response-pragma
+            response-trailer
+            response-transfer-encoding
+            response-upgrade
+            response-via
+            response-warning
+
+            ;; Entity headers
+            ;;
+            response-allow
+            response-content-encoding
+            response-content-language
+            response-content-length
+            response-content-location
+            response-content-md5
+            response-content-range
+            response-content-type
+            text-content-type?
+            response-expires
+            response-last-modified
+
+            ;; Response headers
+            ;;
+            response-accept-ranges
+            response-age
+            response-etag
+            response-location
+            response-proxy-authenticate
+            response-retry-after
+            response-server
+            response-vary
+            response-www-authenticate))
+
+
+(define-record-type <response>
+  (make-response version code reason-phrase headers port)
+  response?
+  (version response-version)
+  (code response-code)
+  (reason-phrase %response-reason-phrase)
+  (headers response-headers)
+  (port response-port))
+
+(define (bad-response message . args)
+  (throw 'bad-response message args))
+
+(define (non-negative-integer? n)
+  (and (number? n) (>= n 0) (exact? n) (integer? n)))
+                                    
+(define (validate-headers headers)
+  (if (pair? headers)
+      (let ((h (car headers)))
+        (if (pair? h)
+            (let ((k (car h)) (v (cdr h)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-response "Bad value for header ~a_ ~s" k v)))
+            (bad-response "Header not a pair_ ~a" h)))
+      (if (not (null? headers))
+          (bad-response "Headers not a list_ ~a" headers))))
+
+(define* (build-response #\key (version '(1 . 1)) (code 200) reason-phrase
+                         (headers '()) port (validate-headers? #t))
+  "Construct an HTTP response object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+  (cond
+   ((not (and (pair? version)
+              (non-negative-integer? (car version))
+              (non-negative-integer? (cdr version))))
+    (bad-response "Bad version_ ~a" version))
+   ((not (and (non-negative-integer? code) (< code 600)))
+    (bad-response "Bad code_ ~a" code))
+   ((and reason-phrase (not (string? reason-phrase)))
+    (bad-response "Bad reason phrase" reason-phrase))
+   (else
+    (if validate-headers?
+        (validate-headers headers))))
+  (make-response version code reason-phrase headers port))
+
+(define *reason-phrases*
+  '((100 . "Continue")
+    (101 . "Switching Protocols")
+    (200 . "OK")
+    (201 . "Created")
+    (202 . "Accepted")
+    (203 . "Non-Authoritative Information")
+    (204 . "No Content")
+    (205 . "Reset Content")
+    (206 . "Partial Content")
+    (300 . "Multiple Choices")
+    (301 . "Moved Permanently")
+    (302 . "Found")
+    (303 . "See Other")
+    (304 . "Not Modified")
+    (305 . "Use Proxy")
+    (307 . "Temporary Redirect")
+    (400 . "Bad Request")
+    (401 . "Unauthorized")
+    (402 . "Payment Required")
+    (403 . "Forbidden")
+    (404 . "Not Found")
+    (405 . "Method Not Allowed")
+    (406 . "Not Acceptable")
+    (407 . "Proxy Authentication Required")
+    (408 . "Request Timeout")
+    (409 . "Conflict")
+    (410 . "Gone")
+    (411 . "Length Required")
+    (412 . "Precondition Failed")
+    (413 . "Request Entity Too Large")
+    (414 . "Request-URI Too Long")
+    (415 . "Unsupported Media Type")
+    (416 . "Requested Range Not Satisfiable")
+    (417 . "Expectation Failed")
+    (500 . "Internal Server Error")
+    (501 . "Not Implemented")
+    (502 . "Bad Gateway")
+    (503 . "Service Unavailable")
+    (504 . "Gateway Timeout")
+    (505 . "HTTP Version Not Supported")))
+
+(define (code->reason-phrase code)
+  (or (assv-ref *reason-phrases* code)
+      "(Unknown)"))
+
+(define (response-reason-phrase response)
+  "Return the reason phrase given in RESPONSE, or the standard
+reason phrase for the response's code."
+  (or (%response-reason-phrase response)
+      (code->reason-phrase (response-code response))))
+
+(define (text-content-type? type)
+  "Return #t if TYPE, a symbol as returned by `response-content-type',
+represents a textual type such as `text/plain'."
+  (let ((type (symbol->string type)))
+    (or (string-prefix? "text/" type)
+        (string-suffix? "/xml" type)
+        (string-suffix? "+xml" type))))
+
+(define (read-response port)
+  "Read an HTTP response from PORT.
+
+As a side effect, sets the encoding on PORT to
+ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
+the discussion of character sets in \"HTTP Responses\" in the manual,
+for more information."
+  (set-port-encoding! port "ISO-8859-1")
+  (call-with-values (lambda () (read-response-line port))
+    (lambda (version code reason-phrase)
+      (make-response version code reason-phrase (read-headers port) port))))
+
+(define (adapt-response-version response version)
+  "Adapt the given response to a different HTTP version.  Returns a new
+HTTP response.
+
+The idea is that many applications might just build a response for the
+default HTTP version, and this method could handle a number of
+programmatic transformations to respond to older HTTP versions (0.9 and
+1.0).  But currently this function is a bit heavy-handed, just updating
+the version field."
+  (build-response #\code (response-code response)
+                  #\version version
+                  #\headers (response-headers response)
+                  #\port (response-port response)))
+
+(define (write-response r port)
+  "Write the given HTTP response to PORT.
+
+Returns a new response, whose ‘response-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
+  (write-response-line (response-version r) (response-code r)
+                       (response-reason-phrase r) port)
+  (write-headers (response-headers r) port)
+  (display "\r\n" port)
+  (if (eq? port (response-port r))
+      r
+      (make-response (response-version r) (response-code r)
+                     (response-reason-phrase r) (response-headers r) port)))
+
+(define (response-must-not-include-body? r)
+  "Returns ‘#t’ if the response R is not permitted to have a body.
+
+This is true for some response types, like those with code 304."
+  ;; RFC 2616, section 4.3.
+  (or (<= 100 (response-code r) 199)
+      (= (response-code r) 204)
+      (= (response-code r) 304)))
+
+(define (make-delimited-input-port port len keep-alive?)
+  "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT.  Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+  (define bytes-read 0)
+
+  (define (fail)
+    (bad-response "EOF while reading response body_ ~a bytes of ~a"
+                  bytes-read len))
+
+  (define (read! bv start count)
+    ;; Read at most LEN bytes in total.  HTTP/1.1 doesn't say what to do
+    ;; when a server provides more than the Content-Length, but it seems
+    ;; wise to just stop reading at LEN.
+    (let ((count (min count (- len bytes-read))))
+      (let loop ((ret (get-bytevector-n! port bv start count)))
+        (cond ((eof-object? ret)
+               (if (= bytes-read len)
+                   0                              ; EOF
+                   (fail)))
+              ((and (zero? ret) (> count 0))
+               ;; Do not return zero since zero means EOF, so try again.
+               (loop (get-bytevector-n! port bv start count)))
+              (else
+               (set! bytes-read (+ bytes-read ret))
+               ret)))))
+
+  (define close
+    (and (not keep-alive?)
+         (lambda ()
+           (close-port port))))
+
+  (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+(define* (response-body-port r #\key (decode? #t) (keep-alive? #t))
+  "Return an input port from which the body of R can be read.  The
+encoding of the returned port is set according to R's ‘content-type’
+header, when it's textual, except if DECODE? is ‘#f’.  Return #f when
+no body is available.
+
+When KEEP-ALIVE? is ‘#f’, closing the returned port also closes R's
+response port."
+  (define port
+    (cond
+     ((member '(chunked) (response-transfer-encoding r))
+      (make-chunked-input-port (response-port r)
+                               #\keep-alive? keep-alive?))
+     ((response-content-length r)
+      => (lambda (len)
+           (make-delimited-input-port (response-port r)
+                                      len keep-alive?)))
+     ((response-must-not-include-body? r)
+      #f)
+     ((or (memq 'close (response-connection r))
+          (and (equal? (response-version r) '(1 . 0))
+               (not (memq 'keep-alive (response-connection r)))))
+      (response-port r))
+     (else
+      ;; Here we have a message with no transfer encoding, no
+      ;; content-length, and a response that won't necessarily be closed
+      ;; by the server.  Not much we can do; assume that the client
+      ;; knows how to handle it.
+      (response-port r))))
+
+  (when (and decode? port)
+    (match (response-content-type r)
+      (((? text-content-type?) . props)
+       (set-port-encoding! port
+                           (or (assq-ref props 'charset)
+                               "ISO-8859-1")))
+      (_ #f)))
+
+  port)
+
+(define (read-response-body r)
+  "Reads the response body from R, as a bytevector.  Returns
+‘#f’ if there was no response body."
+  (let ((body (and=> (response-body-port r #\decode? #f)
+                     get-bytevector-all)))
+    ;; Reading a body of length 0 will result in get-bytevector-all
+    ;; returning the EOF object.
+    (if (eof-object? body)
+        #vu8()
+        body)))
+
+(define (write-response-body r bv)
+  "Write BV, a bytevector, to the port corresponding to the HTTP
+response R."
+  (put-bytevector (response-port r) bv))
+
+(define-syntax define-response-accessor
+  (lambda (x)
+    (syntax-case x ()
+      ((_ field)
+       #'(define-response-accessor field #f))
+      ((_ field def) (identifier? #'field)
+       #`(define* (#,(datum->syntax
+                      #'field
+                      (symbol-append 'response- (syntax->datum #'field)))
+                   response
+                   #\optional (default def))
+           (cond
+            ((assq 'field (response-headers response)) => cdr)
+            (else default)))))))
+
+;; General headers
+;;
+(define-response-accessor cache-control '())
+(define-response-accessor connection '())
+(define-response-accessor date #f)
+(define-response-accessor pragma '())
+(define-response-accessor trailer '())
+(define-response-accessor transfer-encoding '())
+(define-response-accessor upgrade '())
+(define-response-accessor via '())
+(define-response-accessor warning '())
+
+;; Entity headers
+;;
+(define-response-accessor allow '())
+(define-response-accessor content-encoding '())
+(define-response-accessor content-language '())
+(define-response-accessor content-length #f)
+(define-response-accessor content-location #f)
+(define-response-accessor content-md5 #f)
+(define-response-accessor content-range #f)
+(define-response-accessor content-type #f)
+(define-response-accessor expires #f)
+(define-response-accessor last-modified #f)
+
+;; Response headers
+;;
+(define-response-accessor accept-ranges #f)
+(define-response-accessor age #f)
+(define-response-accessor etag #f)
+(define-response-accessor location #f)
+(define-response-accessor proxy-authenticate #f)
+(define-response-accessor retry-after #f)
+(define-response-accessor server #f)
+(define-response-accessor vary '())
+(define-response-accessor www-authenticate #f)
+;;; Web server
+
+;; Copyright (C)  2010, 2011, 2012, 2013, 2015 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_
+;;;
+;;; (web server) is a generic web server interface, along with a main
+;;; loop implementation for web servers controlled by Guile.
+;;;
+;;; The lowest layer is the <server-impl> object, which defines a set of
+;;; hooks to open a server, read a request from a client, write a
+;;; response to a client, and close a server.  These hooks -- open,
+;;; read, write, and close, respectively -- are bound together in a
+;;; <server-impl> object.  Procedures in this module take a
+;;; <server-impl> object, if needed.
+;;;
+;;; A <server-impl> may also be looked up by name.  If you pass the
+;;; `http' symbol to `run-server', Guile looks for a variable named
+;;; `http' in the `(web server http)' module, which should be bound to a
+;;; <server-impl> object.  Such a binding is made by instantiation of
+;;; the `define-server-impl' syntax.  In this way the run-server loop can
+;;; automatically load other backends if available.
+;;;
+;;; The life cycle of a server goes as follows_
+;;;
+;;;   * The `open' hook is called, to open the server. `open' takes 0 or
+;;;     more arguments, depending on the backend, and returns an opaque
+;;;     server socket object, or signals an error.
+;;;
+;;;   * The `read' hook is called, to read a request from a new client.
+;;;     The `read' hook takes one arguments, the server socket.  It
+;;;     should return three values_ an opaque client socket, the
+;;;     request, and the request body. The request should be a
+;;;     `<request>' object, from `(web request)'.  The body should be a
+;;;     string or a bytevector, or `#f' if there is no body.
+;;;
+;;;     If the read failed, the `read' hook may return #f for the client
+;;;     socket, request, and body.
+;;;
+;;;   * A user-provided handler procedure is called, with the request
+;;;     and body as its arguments.  The handler should return two
+;;;     values_ the response, as a `<response>' record from `(web
+;;;     response)', and the response body as a string, bytevector, or
+;;;     `#f' if not present.  We also allow the reponse to be simply an
+;;;     alist of headers, in which case a default response object is
+;;;     constructed with those headers.
+;;;
+;;;   * The `write' hook is called with three arguments_ the client
+;;;     socket, the response, and the body.  The `write' hook returns no
+;;;     values.
+;;;
+;;;   * At this point the request handling is complete. For a loop, we
+;;;     loop back and try to read a new request.
+;;;
+;;;   * If the user interrupts the loop, the `close' hook is called on
+;;;     the server socket.
+;;;
+;;; Code_
+
+(define-module (web server)
+  #\use-module (srfi srfi-9)
+  #\use-module (srfi srfi-9 gnu)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\use-module (web request)
+  #\use-module (web response)
+  #\use-module (system repl error-handling)
+  #\use-module (ice-9 control)
+  #\use-module (ice-9 iconv)
+  #\export (define-server-impl
+            lookup-server-impl
+
+            make-server-impl
+            server-impl?
+            server-impl-name
+            server-impl-open
+            server-impl-read
+            server-impl-write
+            server-impl-close
+
+            open-server
+            read-client
+            handle-request
+            sanitize-response
+            write-client
+            close-server
+            serve-one-client
+            run-server))
+
+(define *timer* (gettimeofday))
+(define (print-elapsed who)
+  (let ((t (gettimeofday)))
+    (pk who (+ (* (- (car t) (car *timer*)) 1000000)
+               (- (cdr t) (cdr *timer*))))
+    (set! *timer* t)))
+
+(eval-when (expand)
+  (define *time-debug?* #f))
+
+(define-syntax debug-elapsed
+  (lambda (x)
+    (syntax-case x ()
+      ((_ who)
+       (if *time-debug?*
+           #'(print-elapsed who)
+           #'*unspecified*)))))
+
+(define-record-type server-impl
+  (make-server-impl name open read write close)
+  server-impl?
+  (name server-impl-name)
+  (open server-impl-open)
+  (read server-impl-read)
+  (write server-impl-write)
+  (close server-impl-close))
+
+(define-syntax-rule (define-server-impl name open read write close)
+  (define name
+    (make-server-impl 'name open read write close)))
+
+(define (lookup-server-impl impl)
+  "Look up a server implementation.  If IMPL is a server
+implementation already, it is returned directly.  If it is a symbol, the
+binding named IMPL in the ‘(web server IMPL)’ module is
+looked up.  Otherwise an error is signaled.
+
+Currently a server implementation is a somewhat opaque type, useful only
+for passing to other procedures in this module, like
+‘read-client’."
+  (cond
+   ((server-impl? impl) impl)
+   ((symbol? impl)
+    (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
+      (if (server-impl? impl)
+          impl
+          (error "expected a server impl in module" `(web server ,impl)))))
+   (else
+    (error "expected a server-impl or a symbol" impl))))
+
+;; -> server
+(define (open-server impl open-params)
+  "Open a server for the given implementation.  Return one value, the
+new server object.  The implementation's ‘open’ procedure is
+applied to OPEN-PARAMS, which should be a list."
+  (apply (server-impl-open impl) open-params))
+
+;; -> (client request body | #f #f #f)
+(define (read-client impl server)
+  "Read a new client from SERVER, by applying the implementation's
+‘read’ procedure to the server.  If successful, return three
+values_ an object corresponding to the client, a request object, and the
+request body.  If any exception occurs, return ‘#f’ for all three
+values."
+  (call-with-error-handling
+   (lambda ()
+     ((server-impl-read impl) server))
+   #\pass-keys '(quit interrupt)
+   #\on-error (if (batch-mode?) 'backtrace 'debug)
+   #\post-error (lambda _ (values #f #f #f))))
+
+(define (extend-response r k v . additional)
+  (let ((r (set-field r (response-headers)
+                      (assoc-set! (copy-tree (response-headers r))
+                                  k v))))
+    (if (null? additional)
+        r
+        (apply extend-response r additional))))
+
+;; -> response body
+(define (sanitize-response request response body)
+  "\"Sanitize\" the given response and body, making them appropriate for
+the given request.
+
+As a convenience to web handler authors, RESPONSE may be given as
+an alist of headers, in which case it is used to construct a default
+response.  Ensures that the response version corresponds to the request
+version.  If BODY is a string, encodes the string to a bytevector,
+in an encoding appropriate for RESPONSE.  Adds a
+‘content-length’ and ‘content-type’ header, as necessary.
+
+If BODY is a procedure, it is called with a port as an argument,
+and the output collected as a bytevector.  In the future we might try to
+instead use a compressing, chunk-encoded port, and call this procedure
+later, in the write-client procedure.  Authors are advised not to rely
+on the procedure being called at any particular time."
+  (cond
+   ((list? response)
+    (sanitize-response request
+                       (build-response #\version (request-version request)
+                                       #\headers response)
+                       body))
+   ((not (equal? (request-version request) (response-version response)))
+    (sanitize-response request
+                       (adapt-response-version response
+                                               (request-version request))
+                       body))
+   ((not body)
+    (values response #vu8()))
+   ((string? body)
+    (let* ((type (response-content-type response
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-response
+       request
+       (if declared-charset
+           response
+           (extend-response response 'content-type
+                            `(,@type (charset . ,charset))))
+       (string->bytevector body charset))))
+   ((procedure? body)
+    (let* ((type (response-content-type response
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-response
+       request
+       (if declared-charset
+           response
+           (extend-response response 'content-type
+                            `(,@type (charset . ,charset))))
+       (call-with-encoded-output-string charset body))))
+   ((not (bytevector? body))
+    (error "unexpected body type"))
+   ((and (response-must-not-include-body? response)
+         body
+         ;; FIXME make this stricter_ even an empty body should be prohibited.
+         (not (zero? (bytevector-length body))))
+    (error "response with this status code must not include body" response))
+   (else
+    ;; check length; assert type; add other required fields?
+    (values (let ((rlen (response-content-length response))
+                  (blen (bytevector-length body)))
+              (cond
+               (rlen (if (= rlen blen)
+                         response
+                         (error "bad content-length" rlen blen)))
+               (else (extend-response response 'content-length blen))))
+            (if (eq? (request-method request) 'HEAD)
+                ;; Responses to HEAD requests must not include bodies.
+                ;; We could raise an error here, but it seems more
+                ;; appropriate to just do something sensible.
+                #f
+                body)))))
+
+;; -> response body state
+(define (handle-request handler request body state)
+  "Handle a given request, returning the response and body.
+
+The response and response body are produced by calling the given
+HANDLER with REQUEST and BODY as arguments.
+
+The elements of STATE are also passed to HANDLER as
+arguments, and may be returned as additional values.  The new
+STATE, collected from the HANDLER's return values, is then
+returned as a list.  The idea is that a server loop receives a handler
+from the user, along with whatever state values the user is interested
+in, allowing the user's handler to explicitly manage its state."
+  (call-with-error-handling
+   (lambda ()
+     (call-with-values (lambda ()
+                         (with-stack-and-prompt
+                          (lambda ()
+                            (apply handler request body state))))
+       (lambda (response body . state)
+         (call-with-values (lambda ()
+                             (debug-elapsed 'handler)
+                             (sanitize-response request response body))
+           (lambda (response body)
+             (debug-elapsed 'sanitize)
+             (values response body state))))))
+   #\pass-keys '(quit interrupt)
+   #\on-error (if (batch-mode?) 'backtrace 'debug)
+   #\post-error (lambda _
+                  (values (build-response #\code 500) #f state))))
+
+;; -> unspecified values
+(define (write-client impl server client response body)
+  "Write an HTTP response and body to CLIENT.  If the server and
+client support persistent connections, it is the implementation's
+responsibility to keep track of the client thereafter, presumably by
+attaching it to the SERVER argument somehow."
+  (call-with-error-handling
+   (lambda ()
+     ((server-impl-write impl) server client response body))
+   #\pass-keys '(quit interrupt)
+   #\on-error (if (batch-mode?) 'backtrace 'debug)
+   #\post-error (lambda _ (values))))
+
+;; -> unspecified values
+(define (close-server impl server)
+  "Release resources allocated by a previous invocation of
+‘open-server’."
+  ((server-impl-close impl) server))
+
+(define call-with-sigint
+  (if (not (provided? 'posix))
+      (lambda (thunk handler-thunk) (thunk))
+      (lambda (thunk handler-thunk)
+        (let ((handler #f))
+          (catch 'interrupt
+            (lambda ()
+              (dynamic-wind
+                (lambda ()
+                  (set! handler
+                        (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
+                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)))))
+            (lambda (k . _) (handler-thunk)))))))
+
+(define (with-stack-and-prompt thunk)
+  (call-with-prompt (default-prompt-tag)
+                    (lambda () (start-stack #t (thunk)))
+                    (lambda (k proc)
+                      (with-stack-and-prompt (lambda () (proc k))))))
+  
+;; -> new-state
+(define (serve-one-client handler impl server state)
+  "Read one request from SERVER, call HANDLER on the request
+and body, and write the response to the client.  Return the new state
+produced by the handler procedure."
+  (debug-elapsed 'serve-again)
+  (call-with-values
+      (lambda ()
+        (read-client impl server))
+    (lambda (client request body)
+      (debug-elapsed 'read-client)
+      (if client
+          (call-with-values
+              (lambda ()
+                (handle-request handler request body state))
+            (lambda (response body state)
+              (debug-elapsed 'handle-request)
+              (write-client impl server client response body)
+              (debug-elapsed 'write-client)
+              state))
+          state))))
+
+(define* (run-server handler #\optional (impl 'http) (open-params '())
+                     . state)
+  "Run Guile's built-in web server.
+
+HANDLER should be a procedure that takes two or more arguments,
+the HTTP request and request body, and returns two or more values, the
+response and response body.
+
+For example, here is a simple \"Hello, World!\" server_
+
+@example
+ (define (handler request body)
+   (values '((content-type . (text/plain)))
+           \"Hello, World!\"))
+ (run-server handler)
+@end example
+
+The response and body will be run through ‘sanitize-response’
+before sending back to the client.
+
+Additional arguments to HANDLER are taken from
+STATE.  Additional return values are accumulated into a new
+STATE, which will be used for subsequent requests.  In this way a
+handler can explicitly manage its state.
+
+The default server implementation is ‘http’, which accepts
+OPEN-PARAMS like ‘(#:port 8081)’, among others.  See \"Web
+Server\" in the manual, for more information."
+  (let* ((impl (lookup-server-impl impl))
+         (server (open-server impl open-params)))
+    (call-with-sigint
+     (lambda ()
+       (let lp ((state state))
+         (lp (serve-one-client handler impl server state))))
+     (lambda ()
+       (close-server impl server)
+       (values)))))
+;;; Web I/O_ HTTP
+
+;; Copyright (C)  2010, 2011, 2012, 2015 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 is the HTTP implementation of the (web server) interface.
+;;;
+;;; `read-request' sets the character encoding on the new port to
+;;; latin-1.  See the note in request.scm regarding character sets,
+;;; strings, and bytevectors for more information.
+;;;
+;;; Code_
+
+(define-module (web server http)
+  #\use-module ((srfi srfi-1) #\select (fold))
+  #\use-module (srfi srfi-9)
+  #\use-module (rnrs bytevectors)
+  #\use-module (web request)
+  #\use-module (web response)
+  #\use-module (web server)
+  #\use-module (ice-9 poll)
+  #\export (http))
+
+
+(define (make-default-socket family addr port)
+  (let ((sock (socket PF_INET SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock family addr port)
+    sock))
+
+(define-record-type <http-server>
+  (make-http-server socket poll-idx poll-set)
+  http-server?
+  (socket http-socket)
+  (poll-idx http-poll-idx set-http-poll-idx!)
+  (poll-set http-poll-set))
+
+(define *error-events* (logior POLLHUP POLLERR))
+(define *read-events* POLLIN)
+(define *events* (logior *error-events* *read-events*))
+
+;; -> server
+(define* (http-open #\key
+                    (host #f)
+                    (family AF_INET)
+                    (addr (if host
+                              (inet-pton family host)
+                              INADDR_LOOPBACK))
+                    (port 8080)
+                    (socket (make-default-socket family addr port)))
+  (listen socket 128)
+  (sigaction SIGPIPE SIG_IGN)
+  (let ((poll-set (make-empty-poll-set)))
+    (poll-set-add! poll-set socket *events*)
+    (make-http-server socket 0 poll-set)))
+
+(define (bad-request port)
+  (write-response (build-response #\version '(1 . 0) #\code 400
+                                  #\headers '((content-length . 0)))
+                  port))
+
+;; -> (client request body | #f #f #f)
+(define (http-read server)
+  (let* ((poll-set (http-poll-set server)))
+    (let lp ((idx (http-poll-idx server)))
+      (let ((revents (poll-set-revents poll-set idx)))
+        (cond
+         ((zero? idx)
+          ;; The server socket, and the end of our downward loop.
+          (cond
+           ((zero? revents)
+            ;; No client ready, and no error; poll and loop.
+            (poll poll-set)
+            (lp (1- (poll-set-nfds poll-set))))
+           ((not (zero? (logand revents *error-events*)))
+            ;; An error.
+            (set-http-poll-idx! server idx)
+            (throw 'interrupt))
+           (else
+            ;; A new client. Add to set, poll, and loop.
+            ;;
+            ;; FIXME_ preserve meta-info.
+            (let ((client (accept (poll-set-port poll-set idx))))
+              ;; Buffer input and output on this port.
+              (setvbuf (car client) _IOFBF)
+              ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
+              (setsockopt (car client) SOL_SOCKET SO_SNDBUF (* 12 1024))
+              (poll-set-add! poll-set (car client) *events*)
+              (poll poll-set)
+              (lp (1- (poll-set-nfds poll-set)))))))
+         ((zero? revents)
+          ;; Nothing on this port.
+          (lp (1- idx)))
+         ;; Otherwise, a client socket with some activity on
+         ;; it. Remove it from the poll set.
+         (else
+          (let ((port (poll-set-remove! poll-set idx)))
+            ;; Record the next index in all cases, in case the EOF check
+            ;; throws an error.
+            (set-http-poll-idx! server (1- idx))
+            (cond
+             ((eof-object? (peek-char port))
+              ;; EOF.
+              (close-port port)
+              (lp (1- idx)))
+             (else
+              ;; Otherwise, try to read a request from this port.
+              (with-throw-handler
+               #t
+               (lambda ()
+                 (let ((req (read-request port)))
+                   (values port
+                           req
+                           (read-request-body req))))
+               (lambda (k . args)
+                 (define-syntax-rule (cleanup-catch statement)
+                   (catch #t
+                     (lambda () statement)
+                     (lambda (k . args)
+                       (format (current-error-port) "In ~a_\n" 'statement)
+                       (print-exception (current-error-port) #f k args))))
+                 (cleanup-catch (bad-request port))
+                 (cleanup-catch (close-port port)))))))))))))
+
+(define (keep-alive? response)
+  (let ((v (response-version response)))
+    (and (or (< (response-code response) 400)
+             (= (response-code response) 404))
+         (case (car v)
+           ((1)
+            (case (cdr v)
+              ((1) (not (memq 'close (response-connection response))))
+              ((0) (memq 'keep-alive (response-connection response)))))
+           (else #f)))))
+
+;; -> 0 values
+(define (http-write server client response body)
+  (let* ((response (write-response response client))
+         (port (response-port response)))
+    (cond
+     ((not body))                       ; pass
+     ((bytevector? body)
+      (write-response-body response body))
+     (else
+      (error "Expected a bytevector for body" body)))
+    (cond
+     ((keep-alive? response)
+      (force-output port)
+      (poll-set-add! (http-poll-set server) port *events*))
+     (else
+      (close-port port)))
+    (values)))
+
+;; -> unspecified values
+(define (http-close server)
+  (let ((poll-set (http-poll-set server)))
+    (let lp ((n (poll-set-nfds poll-set)))
+      (if (positive? n)
+          (begin
+            (close-port (poll-set-remove! poll-set (1- n)))
+            (lp (1- n)))))))
+
+(define-server-impl http
+  http-open
+  http-read
+  http-write
+  http-close)
+;;;; (web uri) --- URI manipulation tools
+;;;;
+;;;; Copyright (C) 1997,2001,2002,2010,2011,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
+;;;;
+
+;;; Commentary_
+
+;; A data type for Universal Resource Identifiers, as defined in RFC
+;; 3986.
+
+;;; Code_
+
+(define-module (web uri)
+  #\use-module (srfi srfi-9)
+  #\use-module (ice-9 regex)
+  #\use-module (ice-9 rdelim)
+  #\use-module (ice-9 control)
+  #\use-module (rnrs bytevectors)
+  #\use-module (ice-9 binary-ports)
+  #\export (uri?
+            uri-scheme uri-userinfo uri-host uri-port
+            uri-path uri-query uri-fragment
+
+            build-uri
+            declare-default-port!
+            string->uri uri->string
+            uri-decode uri-encode
+            split-and-decode-uri-path
+            encode-and-join-uri-path))
+
+(define-record-type <uri>
+  (make-uri scheme userinfo host port path query fragment)
+  uri?
+  (scheme uri-scheme)
+  (userinfo uri-userinfo)
+  (host uri-host)
+  (port uri-port)
+  (path uri-path)
+  (query uri-query)
+  (fragment uri-fragment))
+
+(define (absolute-uri? obj)
+  (and (uri? obj) (uri-scheme obj) #t))
+
+(define (uri-error message . args)
+  (throw 'uri-error message args))
+
+(define (positive-exact-integer? port)
+  (and (number? port) (exact? port) (integer? port) (positive? port)))
+
+(define (validate-uri scheme userinfo host port path query fragment)
+  (cond
+   ((not (symbol? scheme))
+    (uri-error "Expected a symbol for the URI scheme_ ~s" scheme))
+   ((and (or userinfo port) (not host))
+    (uri-error "Expected a host, given userinfo or port"))
+   ((and port (not (positive-exact-integer? port)))
+    (uri-error "Expected port to be an integer_ ~s" port))
+   ((and host (or (not (string? host)) (not (valid-host? host))))
+    (uri-error "Expected valid host_ ~s" host))
+   ((and userinfo (not (string? userinfo)))
+    (uri-error "Expected string for userinfo_ ~s" userinfo))
+   ((not (string? path))
+    (uri-error "Expected string for path_ ~s" path))
+   ((and host (not (string-null? path))
+         (not (eqv? (string-ref path 0) #\/)))
+    (uri-error "Expected path of absolute URI to start with a /_ ~a" path))))
+
+(define* (build-uri scheme #\key userinfo host port (path "") query fragment
+                    (validate? #t))
+  "Construct a URI object.  SCHEME should be a symbol, PORT
+either a positive, exact integer or ‘#f’, and the rest of the
+fields are either strings or ‘#f’.  If VALIDATE? is true,
+also run some consistency checks to make sure that the constructed URI
+is valid."
+  (if validate?
+      (validate-uri scheme userinfo host port path query fragment))
+  (make-uri scheme userinfo host port path query fragment))
+
+;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC
+;; 3490), and non-ASCII host names.
+;;
+(define ipv4-regexp
+  (make-regexp "^([0-9.]+)$"))
+(define ipv6-regexp
+  (make-regexp "^([0-9a-fA-F_.]+)$"))
+(define domain-label-regexp
+  (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
+(define top-label-regexp
+  (make-regexp "^[a-zA-Z]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
+
+(define (valid-host? host)
+  (cond
+   ((regexp-exec ipv4-regexp host)
+    (false-if-exception (inet-pton AF_INET host)))
+   ((regexp-exec ipv6-regexp host)
+    (false-if-exception (inet-pton AF_INET6 host)))
+   (else
+    (let lp ((start 0))
+      (let ((end (string-index host #\. start)))
+        (if end
+            (and (regexp-exec domain-label-regexp
+                              (substring host start end))
+                 (lp (1+ end)))
+            (regexp-exec top-label-regexp host start)))))))
+
+(define userinfo-pat
+  "[a-zA-Z0-9_.!~*'();_&=+$,-]+")
+(define host-pat
+  "[a-zA-Z0-9.-]+")
+(define ipv6-host-pat
+  "[0-9a-fA-F_.]+")
+(define port-pat
+  "[0-9]*")
+(define authority-regexp
+  (make-regexp
+   (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(_(~a))?$"
+           userinfo-pat host-pat ipv6-host-pat port-pat)))
+
+(define (parse-authority authority fail)
+  (if (equal? authority "//")
+      ;; Allow empty authorities_ file_///etc/hosts is a synonym of
+      ;; file_/etc/hosts.
+      (values #f #f #f)
+      (let ((m (regexp-exec authority-regexp authority)))
+        (if (and m (valid-host? (or (match_substring m 4)
+                                    (match_substring m 6))))
+            (values (match_substring m 2)
+                    (or (match_substring m 4)
+                        (match_substring m 6))
+                    (let ((port (match_substring m 8)))
+                      (and port (not (string-null? port))
+                           (string->number port))))
+            (fail)))))
+
+
+;;; RFC 3986, #3.
+;;;
+;;;   URI         = scheme "_" hier-part [ "?" query ] [ "#" fragment ]
+;;;
+;;;   hier-part   = "//" authority path-abempty
+;;;               / path-absolute
+;;;               / path-rootless
+;;;               / path-empty
+
+(define scheme-pat
+  "[a-zA-Z][a-zA-Z0-9+.-]*")
+(define authority-pat
+  "[^/?#]*")
+(define path-pat
+  "[^?#]*")
+(define query-pat
+  "[^#]*")
+(define fragment-pat
+  ".*")
+(define uri-pat
+  (format #f "^((~a)_)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
+          scheme-pat authority-pat path-pat query-pat fragment-pat))
+(define uri-regexp
+  (make-regexp uri-pat))
+
+(define (string->uri* string)
+  "Parse STRING into a URI object.  Return ‘#f’ if the string
+could not be parsed."
+  (% (let ((m (regexp-exec uri-regexp string)))
+       (if (not m) (abort))
+       (let ((scheme (let ((str (match_substring m 2)))
+                       (and str (string->symbol (string-downcase str)))))
+             (authority (match_substring m 3))
+             (path (match_substring m 4))
+             (query (match_substring m 6))
+             (fragment (match_substring m 7)))
+         (call-with-values
+             (lambda ()
+               (if authority
+                   (parse-authority authority abort)
+                   (values #f #f #f)))
+           (lambda (userinfo host port)
+             (make-uri scheme userinfo host port path query fragment)))))
+     (lambda (k)
+       #f)))
+
+(define (string->uri string)
+  "Parse STRING into a URI object.  Return ‘#f’ if the string
+could not be parsed."
+  (let ((uri (string->uri* string)))
+    (and uri (uri-scheme uri) uri)))
+
+(define *default-ports* (make-hash-table))
+
+(define (declare-default-port! scheme port)
+  "Declare a default port for the given URI scheme."
+  (hashq-set! *default-ports* scheme port))
+
+(define (default-port? scheme port)
+  (or (not port)
+      (eqv? port (hashq-ref *default-ports* scheme))))
+
+(declare-default-port! 'http 80)
+(declare-default-port! 'https 443)
+
+(define (uri->string uri)
+  "Serialize URI to a string.  If the URI has a port that is the
+default port for its scheme, the port is not included in the
+serialization."
+  (let* ((scheme (uri-scheme uri))
+         (userinfo (uri-userinfo uri))
+         (host (uri-host uri))
+         (port (uri-port uri))
+         (path (uri-path uri))
+         (query (uri-query uri))
+         (fragment (uri-fragment uri)))
+    (string-append
+     (if scheme
+         (string-append (symbol->string scheme) "_")
+         "")
+     (if host
+         (string-append "//"
+                        (if userinfo (string-append userinfo "@")
+                            "")
+                        (if (string-index host #\_)
+                            (string-append "[" host "]")
+                            host)
+                        (if (default-port? (uri-scheme uri) port)
+                            ""
+                            (string-append "_" (number->string port))))
+         "")
+     path
+     (if query
+         (string-append "?" query)
+         "")
+     (if fragment
+         (string-append "#" fragment)
+         ""))))
+
+
+;; like call-with-output-string, but actually closes the port (doh)
+(define (call-with-output-string* proc)
+  (let ((port (open-output-string)))
+    (proc port)
+    (let ((str (get-output-string port)))
+      (close-port port)
+      str)))
+
+(define (call-with-output-bytevector* proc)
+  (call-with-values
+      (lambda ()
+        (open-bytevector-output-port))
+    (lambda (port get-bytevector)
+      (proc port)
+      (let ((bv (get-bytevector)))
+        (close-port port)
+        bv))))
+
+(define (call-with-encoded-output-string encoding proc)
+  (if (string-ci=? encoding "utf-8")
+      (string->utf8 (call-with-output-string* proc))
+      (call-with-output-bytevector*
+       (lambda (port)
+         (set-port-encoding! port encoding)
+         (proc port)))))
+
+(define (encode-string str encoding)
+  (if (string-ci=? encoding "utf-8")
+      (string->utf8 str)
+      (call-with-encoded-output-string encoding
+                                       (lambda (port)
+                                         (display str port)))))
+
+(define (decode-string bv encoding)
+  (if (string-ci=? encoding "utf-8")
+      (utf8->string bv)
+      (let ((p (open-bytevector-input-port bv)))
+        (set-port-encoding! p encoding)
+        (let ((res (read-string p)))
+          (close-port p)
+          res))))
+
+
+;; A note on characters and bytes_ URIs are defined to be sequences of
+;; characters in a subset of ASCII. Those characters may encode a
+;; sequence of bytes (octets), which in turn may encode sequences of
+;; characters in other character sets.
+;;
+
+;; Return a new string made from uri-decoding STR.  Specifically,
+;; turn ‘+’ into space, and hex-encoded ‘%XX’ strings into
+;; their eight-bit characters.
+;;
+(define hex-chars
+  (string->char-set "0123456789abcdefABCDEF"))
+
+(define* (uri-decode str #\key (encoding "utf-8") (decode-plus-to-space? #t))
+  "Percent-decode the given STR, according to ENCODING,
+which should be the name of a character encoding.
+
+Note that this function should not generally be applied to a full URI
+string. For paths, use ‘split-and-decode-uri-path’ instead. For query
+strings, split the query on ‘&’ and ‘=’ boundaries, and decode
+the components separately.
+
+Note also that percent-encoded strings encode _bytes_, not characters.
+There is no guarantee that a given byte sequence is a valid string
+encoding. Therefore this routine may signal an error if the decoded
+bytes are not valid for the given encoding. Pass ‘#f’ for ENCODING if
+you want decoded bytes as a bytevector directly.  ‘set-port-encoding!’,
+for more information on character encodings.
+
+If DECODE-PLUS-TO-SPACE? is true, which is the default, also replace
+instances of the plus character (+) with a space character.  This is
+needed when parsing application/x-www-form-urlencoded data.
+
+Returns a string of the decoded characters, or a bytevector if
+ENCODING was ‘#f’."
+  (let* ((len (string-length str))
+         (bv
+          (call-with-output-bytevector*
+           (lambda (port)
+             (let lp ((i 0))
+               (if (< i len)
+                   (let ((ch (string-ref str i)))
+                     (cond
+                      ((and (eqv? ch #\+) decode-plus-to-space?)
+                       (put-u8 port (char->integer #\space))
+                       (lp (1+ i)))
+                      ((and (< (+ i 2) len) (eqv? ch #\%)
+                            (let ((a (string-ref str (+ i 1)))
+                                  (b (string-ref str (+ i 2))))
+                              (and (char-set-contains? hex-chars a)
+                                   (char-set-contains? hex-chars b)
+                                   (string->number (string a b) 16))))
+                       => (lambda (u8)
+                            (put-u8 port u8)
+                            (lp (+ i 3))))
+                      ((< (char->integer ch) 128)
+                       (put-u8 port (char->integer ch))
+                       (lp (1+ i)))
+                      (else
+                       (uri-error "Invalid character in encoded URI ~a_ ~s"
+                                  str ch))))))))))
+    (if encoding
+        (decode-string bv encoding)
+        ;; Otherwise return raw bytevector
+        bv)))
+
+(define ascii-alnum-chars
+  (string->char-set
+   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
+
+;; RFC 3986, #2.2.
+(define gen-delims
+  (string->char-set "_/?#[]@"))
+(define sub-delims
+  (string->char-set "!$&'()*+,l="))
+(define reserved-chars
+  (char-set-union gen-delims sub-delims))
+
+;; RFC 3986, #2.3
+(define unreserved-chars
+  (char-set-union ascii-alnum-chars
+                  (string->char-set "-._~")))
+
+;; Return a new string made from uri-encoding STR, unconditionally
+;; transforming any characters not in UNESCAPED-CHARS.
+;;
+(define* (uri-encode str #\key (encoding "utf-8")
+                     (unescaped-chars unreserved-chars))
+  "Percent-encode any character not in the character set,
+UNESCAPED-CHARS.
+
+The default character set includes alphanumerics from ASCII, as well as
+the special characters ‘-’, ‘.’, ‘_’, and ‘~’.  Any other character will
+be percent-encoded, by writing out the character to a bytevector within
+the given ENCODING, then encoding each byte as ‘%HH’, where HH is the
+uppercase hexadecimal representation of the byte."
+  (define (needs-escaped? ch)
+    (not (char-set-contains? unescaped-chars ch)))
+  (if (string-index str needs-escaped?)
+      (call-with-output-string*
+       (lambda (port)
+         (string-for-each
+          (lambda (ch)
+            (if (char-set-contains? unescaped-chars ch)
+                (display ch port)
+                (let* ((bv (encode-string (string ch) encoding))
+                       (len (bytevector-length bv)))
+                  (let lp ((i 0))
+                    (if (< i len)
+                        (let ((byte (bytevector-u8-ref bv i)))
+                          (display #\% port)
+                          (when (< byte 16)
+                            (display #\0 port))
+                          (display (string-upcase (number->string byte 16))
+                                   port)
+                          (lp (1+ i))))))))
+          str)))
+      str))
+
+(define (split-and-decode-uri-path path)
+  "Split PATH into its components, and decode each component,
+removing empty components.
+
+For example, ‘\"/foo/bar%20baz/\"’ decodes to the two-element list,
+‘(\"foo\" \"bar baz\")’."
+  (filter (lambda (x) (not (string-null? x)))
+          (map (lambda (s) (uri-decode s #\decode-plus-to-space? #f))
+               (string-split path #\/))))
+
+(define (encode-and-join-uri-path parts)
+  "URI-encode each element of PARTS, which should be a list of
+strings, and join the parts together with ‘/’ as a delimiter.
+
+For example, the list ‘(\"scrambled eggs\" \"biscuits&gravy\")’
+encodes as ‘\"scrambled%20eggs/biscuits%26gravy\"’."
+  (string-join (map uri-encode parts) "/"))
+;;; common-test.scm --
+;;;
+
+;; Slightly modified for Guile by Ludovic Courtès <ludo@gnu.org>, 2010.
+
+(use-modules (system base lalr)
+             (ice-9 pretty-print))
+
+(define *error* '())
+
+(define-syntax check
+  (syntax-rules (=>)
+    ((_ ?expr => ?expected-result)
+     (check ?expr (=> equal?) ?expected-result))
+
+    ((_ ?expr (=> ?equal) ?expected-result)
+     (let ((result	?expr)
+	   (expected	?expected-result))
+       (set! *error* '())
+       (when (not (?equal result expected))
+	 (display "Failed test_ \n")
+	 (pretty-print (quote ?expr))(newline)
+	 (display "\tresult was_ ")
+	 (pretty-print result)(newline)
+	 (display "\texpected_ ")
+	 (pretty-print expected)(newline)
+         (exit 1))))))
+
+;;; --------------------------------------------------------------------
+
+(define (display-result v)
+  (if v
+      (begin
+        (display "==> ")
+        (display v)
+        (newline))))
+
+(define eoi-token
+  (make-lexical-token '*eoi* #f #f))
+
+(define (make-lexer tokens)
+  (lambda ()
+    (if (null? tokens)
+	eoi-token
+      (let ((t (car tokens)))
+	(set! tokens (cdr tokens))
+	t))))
+
+(define (error-handler message . args)
+  (set! *error* (cons `(error-handler ,message . ,(if (pair? args)
+						      (lexical-token-category (car args))
+						    '()))
+		      *error*))
+  (cons message args))
+
+;;; end of file
+"_";exec snow -- "$0" "$@"

+;;;

+;;;; Tests for the GLR parser generator

+;;;

+;;

+;; @created   "Fri Aug 19 11_23_48 EDT 2005"

+;;

+

+(package* glr-test/v1.0.0

+  (require_ lalr/v2.4.0))

+

+

+(define (syntax-error msg . args)

+  (display msg (current-error-port))

+  (for-each (cut format (current-error-port) " ~A" <>) args)

+  (newline (current-error-port))

+  (throw 'misc-error))

+

+

+(define (make-lexer words)

+  (let ((phrase words))

+    (lambda ()

+      (if (null? phrase)

+          '*eoi*

+          (let ((word (car phrase)))

+            (set! phrase (cdr phrase))

+            word)))))

+

+

+;;;

+;;;; Test 1

+;;;

+

+

+(define parser-1

+  ;; Grammar taken from Tomita's "An Efficient Augmented-Context-Free Parsing Algorithm"

+  (lalr-parser

+   (driver_ glr)

+   (expect_ 2)

+   (*n *v *d *p)

+   (<s>  (<np> <vp>)

+         (<s> <pp>))

+   (<np> (*n)

+         (*d *n)

+         (<np> <pp>))

+   (<pp> (*p <np>))

+   (<vp> (*v <np>))))

+

+

+(define *phrase-1* '(*n *v *d *n *p *d *n *p *d *n *p *d *n))

+

+(define (test-1)

+  (parser-1 (make-lexer *phrase-1*) syntax-error))

+

+

+;;;

+;;;; Test 2

+;;;

+

+

+(define parser-2

+  ;; The dangling-else problem

+  (lalr-parser

+   (driver_ glr)

+   (expect_ 1)

+   ((nonassoc_ if then else e s))

+   (<s> (s)

+        (if e then <s>)

+        (if e then <s> else <s>))))

+

+

+(define *phrase-2* '(if e then if e then s else s))

+

+(define (test-2)

+  (parser-2 (make-lexer *phrase-2*) syntax-error))

+

+

+

+

+(define (assert-length l n test-name)

+  (display "Test '") 

+  (display test-name)

+  (display (if (not (= (length l) n)) "' failed!" "' passed!"))

+  (newline))

+

+(assert-length (test-1) 14 1)

+(assert-length (test-2) 2 2)

+

+;;; test-glr-associativity.scm
+;;
+;;With the GLR parser both  the terminal precedence and the non-terminal
+;;associativity  are  not  respected;  rather they  generate  two  child
+;;processes.
+;;
+
+(load "common-test.scm")
+
+(define parser
+  (lalr-parser
+   (driver\_ glr)
+   (expect\_ 0)
+
+   (N LPAREN RPAREN
+	(left\_ + -)
+	(right\_ * /)
+	(nonassoc\_ uminus))
+
+   (output	(expr)			\_ $1)
+   (expr	(expr + expr)           \_ (list $1 '+ $3)
+		(expr - expr)           \_ (list $1 '- $3)
+		(expr * expr)           \_ (list $1 '* $3)
+		(expr / expr)           \_ (list $1 '/ $3)
+		(- expr (prec\_ uminus)) \_ (list '- $2)
+		(N)                   \_ $1
+		(LPAREN expr RPAREN)    \_ $2)))
+
+(define (doit . tokens)
+  (parser (make-lexer tokens) error-handler))
+
+;;; --------------------------------------------------------------------
+
+;;Remember that the result of the GLR  driver is a list of parses, not a
+;;single parse.
+
+(check
+    (doit (make-lexical-token 'N #f 1))
+  => '(1))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '+ #f '+)
+	  (make-lexical-token 'N #f 2))
+  => '((1 + 2)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '* #f '*)
+	  (make-lexical-token 'N #f 2))
+  => '((1 * 2)))
+
+(check
+    (doit (make-lexical-token '- #f '-)
+	  (make-lexical-token 'N #f 1))
+  => '((- 1)))
+
+(check
+    (doit (make-lexical-token '- #f '-)
+	  (make-lexical-token '- #f '-)
+	  (make-lexical-token 'N #f 1))
+  => '((- (- 1))))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '+ #f '+)
+	  (make-lexical-token '- #f '-)
+	  (make-lexical-token 'N #f 2))
+  => '((1 + (- 2))))
+
+;;; --------------------------------------------------------------------
+
+(check
+    ;;left-associativity
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '+ #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token '+ #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '(((1 + 2) + 3)))
+
+(check
+    ;;right-associativity
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '* #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token '* #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(((1 * 2) * 3)
+       (1 * (2 * 3))))
+
+(check
+    ;;precedence
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token '+ #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token '* #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(((1 + 2) * 3)
+       (1 + (2 * 3))))
+
+;;; end of file
+;;; test-lr-basics-01.scm --
+;;
+;;A grammar that only accept a single terminal as input.  It refuses the
+;;end-of-input as first token.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let* ((lexer		(make-lexer tokens))
+	 (parser	(lalr-parser (expect\_ 0)
+				     (driver\_ glr)
+				     (A)
+				     (e (A) \_ $1))))
+    (parser lexer error-handler)))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '(1))
+
+(check
+    (doit)
+  => '())
+
+(check
+    ;;Parse correctly the first A  and reduce it.  The second A triggers
+    ;;an  error which  empties  the  stack and  consumes  all the  input
+    ;;tokens.   Finally, an  unexpected end-of-input  error  is returned
+    ;;because EOI is invalid as first token after the start.
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '())
+
+;;; end of file
+;;; test-lr-basics-02.scm --
+;;
+;;A grammar that only accept a single terminal or the EOI.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (A)
+			     (e (A) \_ $1
+				()  \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => '(0))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '(1))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '())
+
+;;; end of file
+;;; test-lr-basics-03.scm --
+;;
+;;A grammar  that accepts  fixed sequences of  a single terminal  or the
+;;EOI.
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (A)
+			     (e (A)     \_ (list $1)
+				(A A)   \_ (list $1 $2)
+				(A A A) \_ (list $1 $2 $3)
+				()      \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '((1)))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2))
+  => '((1 2)))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '((1 2 3)))
+
+(check
+    (doit)
+  => '(0))
+
+;;; end of file
+;;; test-lr-basics-04.scm --
+;;
+;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
+;;The return value is the value of the last parsed token.
+
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (A)
+			     (e (e A) \_ $2
+				(A)   \_ $1
+				()    \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => '(0))
+
+(check
+    ;;Two  results because  there  is a  shift/reduce  conflict, so  two
+    ;;processes are generated.
+    (doit (make-lexical-token 'A #f 1))
+  => '(1 1))
+
+(check
+    ;;Two  results because  there  is a  shift/reduce  conflict, so  two
+    ;;processes are generated.  Notice that the rules_
+    ;;
+    ;;  (e A) (A)
+    ;;
+    ;;generate only one  conflict when the second "A"  comes.  The third
+    ;;"A" comes when  the state is inside the rule "(e  A)", so there is
+    ;;no conflict.
+    ;;
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '(3 3))
+
+;;; end of file
+;;; test-lr-basics-05.scm --
+;;
+;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
+;;The return value is the list of values.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (A)
+			     (e (e A) \_ (cons $2 $1)
+				(A)   \_ (list $1)
+				()    \_ (list 0)))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => '((0)))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '((1 0)
+       (1)))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2))
+  => '((2 1 0)
+       (2 1)))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '((3 2 1 0)
+       (3 2 1)))
+
+;;; end of file
+;;; test-lr-script-expression.scm --
+;;
+;;Parse scripts, each line an expression.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (N O C T (left\_ A) (left\_ M) (nonassoc\_ U))
+
+			     (script	(lines)		\_ (reverse $1))
+
+			     (lines	(lines line)	\_ (cons $2 $1)
+					(line)		\_ (list $1))
+
+			     (line	(T)		\_ #\newline
+					(E T)		\_ $1
+					(error T)	\_ (list 'error-clause $2))
+
+			     (E	(N)		\_ $1
+				(E A E)		\_ ($2 $1 $3)
+				(E M E)		\_ ($2 $1 $3)
+				(A E (prec\_ U))	\_ ($1 $2)
+				(O E C)		\_ $2))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Correct input
+
+(check
+    (doit (make-lexical-token 'T #f #\newline))
+  => '((#\newline)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'T #f #\newline))
+  => '((1)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'T #f #\newline))
+  => '((3)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline))
+  => '((9) (7)))
+
+(check
+    (doit (make-lexical-token 'N #f 10)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline))
+  => '((23)))
+
+(check
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline))
+  => '((9)))
+
+(check
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline)
+
+	  (make-lexical-token 'N #f 4)
+	  (make-lexical-token 'M #f /)
+	  (make-lexical-token 'N #f 5)
+	  (make-lexical-token 'T #f #\newline))
+  => '((9 4/5)))
+
+;;; --------------------------------------------------------------------
+
+(check
+    ;;Successful error recovery.
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline)
+
+	  (make-lexical-token 'N #f 4)
+	  (make-lexical-token 'M #f /)
+	  (make-lexical-token 'N #f 5)
+	  (make-lexical-token 'T #f #\newline))
+  => '())
+
+(check
+    ;;Unexpected end of input.
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2))
+  => '())
+
+(check
+    ;;Unexpected end of input.
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'T #f #\newline))
+  => '())
+
+;;; end of file
+;;; test-lr-single-expressions.scm --
+;;
+;;Grammar accepting single expressions.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (driver\_ glr)
+			     (N O C (left\_ A) (left\_ M) (nonassoc\_ U))
+
+			     (E	(N)		\_ $1
+				(E A E)		\_ ($2 $1 $3)
+				(E M E)		\_ ($2 $1 $3)
+				(A E (prec\_ U))	\_ ($1 $2)
+				(O E C)		\_ $2))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1))
+  => '(1))
+
+(check	;correct input
+    (doit (make-lexical-token 'A #f -)
+	  (make-lexical-token 'N #f 1))
+  => '(-1))
+
+(check	;correct input
+    (doit (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 1))
+  => '(1))
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2))
+  => '(3))
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3))
+  => '(9 7))
+
+(check	;correct input
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3))
+  => '(9))
+
+;;; end of file
+;;; test-lr-associativity-01.scm --
+;;
+;;Show  how  to use  left  and  right  associativity.  Notice  that  the
+;;terminal  M is  declared  as right  associative;  this influences  the
+;;binding  of values to  the $n  symbols in  the semantic  clauses.  The
+;;semantic clause in the rule_
+;;
+;;  (E M E M E)     _ (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like it is right-associated,  and it is because we have declared
+;;M as "right_".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser
+		 (expect\_ 0)
+		 (N (left\_ A)
+		    (right\_ M)
+		    (nonassoc\_ U))
+		 (E	(N)		\_ $1
+			(E A E)         \_ (list $1 $2 $3)
+			(E M E)         \_ (list $1 $2 $3)
+			(E M E M E)     \_ (list $1 $2 (list $3 $4 $5))
+			(A E (prec\_ U))	\_ (list '- $2)))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+    (doit (make-lexical-token 'N #f 1))
+  => 1)
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2))
+  => '(1 + 2))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2))
+  => '(1 * 2))
+
+(check
+    (doit (make-lexical-token 'A #f '-)
+	  (make-lexical-token 'N #f 1))
+  => '(- 1))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 + (2 * 3)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 + 2) + 3))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 * (2 * 3)))
+
+;;; end of file
+;;; test-lr-associativity-02.scm --
+;;
+;;Show  how  to use  left  and  right  associativity.  Notice  that  the
+;;terminal  M  is declared  as  left  associative;  this influences  the
+;;binding  of values to  the $n  symbols in  the semantic  clauses.  The
+;;semantic clause in the rule_
+;;
+;;  (E M E M E)     \_ (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like  it is right-associated, but the  result is left-associated
+;;because we have declared M as "left_".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser
+		 (expect\_ 0)
+		 (N (left\_ A)
+		    (left\_ M)
+		    (nonassoc\_ U))
+		 (E	(N)		\_ $1
+			(E A E)         \_ (list $1 $2 $3)
+			(E M E)         \_ (list $1 $2 $3)
+			(E M E M E)     \_ (list $1 $2 (list $3 $4 $5))
+			(A E (prec\_ U))	\_ (list '- $2)))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+    (doit (make-lexical-token 'N #f 1))
+  => 1)
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2))
+  => '(1 + 2))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2))
+  => '(1 * 2))
+
+(check
+    (doit (make-lexical-token 'A #f '-)
+	  (make-lexical-token 'N #f 1))
+  => '(- 1))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 + (2 * 3)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 + 2) + 3))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) * 3))
+
+;;; end of file
+;;; test-lr-associativity-01.scm --
+;;
+;;Show  how  to use  left  and  right  associativity.  Notice  that  the
+;;terminal M is declared as non-associative; this influences the binding
+;;of values  to the  $n symbols in  the semantic clauses.   The semantic
+;;clause in the rule_
+;;
+;;  (E M E M E)     \_ (list $1 $2 (list $3 $4 $5))
+;;
+;;looks like it is right-associated,  and it is because we have declared
+;;M as "right_".
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser
+		 (expect\_ 0)
+		 (N (nonassoc\_ A)
+		    (nonassoc\_ M))
+		 (E	(N)		\_ $1
+			(E A E)         \_ (list $1 $2 $3)
+			(E A E A E)     \_ (list (list $1 $2 $3) $4 $5)
+			(E M E)         \_ (list $1 $2 $3)
+			(E M E M E)     \_ (list $1 $2 (list $3 $4 $5))))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+    (doit (make-lexical-token 'N #f 1))
+  => 1)
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2))
+  => '(1 + 2))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2))
+  => '(1 * 2))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 + (2 * 3)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 + 2) + 3))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 * (2 * 3)))
+
+;;; end of file
+;;; test-lr-associativity-04.scm --
+;;
+;;Show how to use associativity.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser
+		 (expect\_ 0)
+		 (N (left\_ A)
+		    (left\_ M))
+		 (E	(N)		\_ $1
+
+			(E A E)         \_ (list $1 $2 $3)
+			(E A E A E)     \_ (list (list $1 $2 $3) $4 $5)
+
+			(E M E)         \_ (list $1 $2 $3)
+			(E M E M E)     \_ (list $1 $2 (list $3 $4 $5))
+
+			(E A E M E)     \_ (list $1 $2 $3 $4 $5)
+			(E M E A E)     \_ (list $1 $2 $3 $4 $5)
+			))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Single operator.
+
+(check
+    (doit (make-lexical-token 'N #f 1))
+  => 1)
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2))
+  => '(1 + 2))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2))
+  => '(1 * 2))
+
+;;; --------------------------------------------------------------------
+;;; Precedence.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '(1 + (2 * 3)))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) + 3))
+
+;;; --------------------------------------------------------------------
+;;; Associativity.
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'A #f '+)
+	  (make-lexical-token 'N #f 3))
+  => '((1 + 2) + 3))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f '*)
+	  (make-lexical-token 'N #f 3))
+  => '((1 * 2) * 3))
+
+;;; end of file
+;;; test-lr-basics-01.scm --
+;;
+;;A grammar that only accept a single terminal as input.  It refuses the
+;;end-of-input as first token.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let* ((lexer		(make-lexer tokens))
+	 (parser	(lalr-parser (expect\_ 0)
+				     (A)
+				     (e (A) \_ $1))))
+    (parser lexer error-handler)))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => 1)
+
+(check
+    (let ((r (doit)))
+      (cons r *error*))
+  => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+    ;;Parse correctly the first A  and reduce it.  The second A triggers
+    ;;an  error which  empties  the  stack and  consumes  all the  input
+    ;;tokens.   Finally, an  unexpected end-of-input  error  is returned
+    ;;because EOI is invalid as first token after the start.
+    (let ((r (doit (make-lexical-token 'A #f 1)
+		   (make-lexical-token 'A #f 2)
+		   (make-lexical-token 'A #f 3))))
+      (cons r *error*))
+  => '(#f
+       (error-handler "Syntax error: unexpected end of input")
+       (error-handler "Syntax error: unexpected token : " . A)))
+
+;;; end of file
+;;; test-lr-basics-02.scm --
+;;
+;;A grammar that only accept a single terminal or the EOI.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (A)
+			     (e (A) \_ $1
+				()  \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => 0)
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => 1)
+
+(check
+    ;;Parse correctly the first A  and reduce it.  The second A triggers
+    ;;an  error which  empties  the  stack and  consumes  all the  input
+    ;;tokens.  Finally, the end-of-input token is correctly parsed.
+    (let ((r (doit (make-lexical-token 'A #f 1)
+		   (make-lexical-token 'A #f 2)
+		   (make-lexical-token 'A #f 3))))
+      (cons r *error*))
+  => '(0 (error-handler "Syntax error: unexpected token : " . A)))
+
+;;; end of file
+;;; test-lr-basics-03.scm --
+;;
+;;A grammar  that accepts  fixed sequences of  a single terminal  or the
+;;EOI.
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (A)
+			     (e (A)     \_ (list $1)
+				(A A)   \_ (list $1 $2)
+				(A A A) \_ (list $1 $2 $3)
+				()      \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '(1))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2))
+  => '(1 2))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '(1 2 3))
+
+(check
+    (doit)
+  => 0)
+
+;;; end of file
+;;; test-lr-basics-04.scm --
+;;
+;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
+;;The return value is the value of the last parsed token.
+
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (A)
+			     (e (e A) \_ $2
+				(A)   \_ $1
+				()    \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => 0)
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => 1)
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => 3)
+
+;;; end of file
+;;; test-lr-basics-05.scm --
+;;
+;;A grammar  accepting a sequence  of equal tokens of  arbitrary length.
+;;The return value is the list of values.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (A)
+			     (e (e A) \_ (cons $2 $1)
+				(A)   \_ (list $1)
+				()    \_ 0))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    (doit)
+  => 0)
+
+(check
+    (doit (make-lexical-token 'A #f 1))
+  => '(1))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2))
+  => '(2 1))
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'A #f 2)
+	  (make-lexical-token 'A #f 3))
+  => '(3 2 1))
+
+;;; end of file
+;;; test-lr-error-recovery-01.scm --
+;;
+;;Test error recovery with a terminator terminal.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser
+		 (expect\_ 0)
+		 (NUMBER BAD NEWLINE)
+
+		 (script	(lines)		\_ (reverse $1)
+				()		\_ 0)
+		 (lines	(lines line)		\_ (cons $2 $1)
+			(line)			\_ (list $1))
+		 (line	(NEWLINE)		\_ (list 'line $1)
+			(NUMBER NEWLINE)	\_ (list 'line $1 $2)
+			(NUMBER NUMBER NEWLINE)	\_ (list 'line $1 $2 $3)
+
+			;;This semantic  action will cause  "(recover $1
+			;;$2)" to be the result of the offending line.
+			(error NEWLINE)		\_ (list 'recover $1 $2)))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; No errors, grammar tests.
+
+(check
+    (doit)
+  => 0)
+
+(check
+    (doit (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line #\newline)))
+
+(check
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line 1 #\newline)))
+
+(check
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NUMBER  #f 2)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line 1 2 #\newline)))
+
+(check
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 2)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line 1 #\newline)
+       (line 2 #\newline)))
+
+(check
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 2)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 3)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line 1 #\newline)
+       (line 2 #\newline)
+       (line 3 #\newline)))
+
+(check
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 2)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 3)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'NUMBER  #f 41)
+	  (make-lexical-token 'NUMBER  #f 42)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '((line 1 #\newline)
+       (line 2 #\newline)
+       (line 3 #\newline)
+       (line 41 42 #\newline)))
+
+;;; --------------------------------------------------------------------
+;;; Successful error recovery.
+
+(check
+    ;;The BAD triggers an error,  recovery happens, the first NEWLINE is
+    ;;correctly parsed as recovery token; the second line is correct.
+    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
+		   (make-lexical-token 'BAD      #f 'alpha)
+		   (make-lexical-token 'NEWLINE #f #\newline)
+		   (make-lexical-token 'NUMBER  #f 2)
+		   (make-lexical-token 'NEWLINE #f #\newline))))
+      (cons r *error*))
+  => '(((recover #f #f)
+	(line 2 #\newline))
+       (error-handler "Syntax error: unexpected token : " . BAD)))
+
+
+(check
+    ;;The  first BAD triggers  an error,  recovery happens  skipping the
+    ;;second  and   third  BADs,  the  first  NEWLINE   is  detected  as
+    ;;synchronisation token; the second line is correct.
+    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
+		   (make-lexical-token 'BAD     #f 'alpha)
+		   (make-lexical-token 'BAD     #f 'beta)
+		   (make-lexical-token 'BAD     #f 'delta)
+		   (make-lexical-token 'NEWLINE #f #\newline)
+		   (make-lexical-token 'NUMBER  #f 2)
+		   (make-lexical-token 'NEWLINE #f #\newline))))
+      (cons r *error*))
+  => '(((recover #f #f)
+	(line 2 #\newline))
+       (error-handler "Syntax error: unexpected token : " . BAD)))
+
+;;; --------------------------------------------------------------------
+;;; Failed error recovery.
+
+(check
+    ;;End-of-input is found after NUMBER.
+    (let ((r (doit (make-lexical-token 'NUMBER  #f 1))))
+      (cons r *error*))
+  => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+    ;;The BAD triggers  the error, the stack is rewind  up to the start,
+    ;;then end-of-input  happens while trying  to skip tokens  until the
+    ;;synchronisation one is found.  End-of-input is an acceptable token
+    ;;after the start.
+    (let ((r (doit (make-lexical-token 'NUMBER  #f 1)
+		   (make-lexical-token 'BAD     #f 'alpha)
+		   (make-lexical-token 'BAD     #f 'beta)
+		   (make-lexical-token 'BAD     #f 'delta))))
+      (cons r *error*))
+  => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))
+
+(check
+    ;;The BAD triggers  the error, the stack is rewind  up to the start,
+    ;;then end-of-input  happens while trying  to skip tokens  until the
+    ;;synchronisation one is found.  End-of-input is an acceptable token
+    ;;after the start.
+    (let ((r (doit (make-lexical-token 'BAD #f 'alpha))))
+      (cons r *error*))
+  => '(0 (error-handler "Syntax error: unexpected token : " . BAD)))
+
+;;; end of file
+;;; test-lr-error-recovery-02.scm --
+;;
+;;Test error  recovery policy when the synchronisation  terminal has the
+;;same category of the lookahead that raises the error.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (A B C)
+			     (alphas (alpha)		\_ $1
+				     (alphas alpha)	\_ $2)
+			     (alpha (A B)	\_ (list $1 $2)
+				    (C)		\_ $1
+				    (error C)	\_ 'error-form))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; No error, just grammar tests.
+
+(check
+    (doit (make-lexical-token 'A #f 1)
+	  (make-lexical-token 'B #f 2))
+  => '(1 2))
+
+(check
+    (doit (make-lexical-token 'C #f 3))
+  => '3)
+
+;;; --------------------------------------------------------------------
+;;; Successful error recovery.
+
+(check
+    ;;Error, recovery, end-of-input.
+    (let ((r (doit (make-lexical-token 'A #f 1)
+		   (make-lexical-token 'C #f 3))))
+      (cons r *error*))
+  => '(error-form (error-handler "Syntax error: unexpected token : " . C)))
+
+(check
+    ;;Error, recovery, correct parse of "A B".
+    (let ((r (doit (make-lexical-token 'A #f 1)
+		   (make-lexical-token 'C #f 3)
+		   (make-lexical-token 'A #f 1)
+		   (make-lexical-token 'B #f 2))))
+      (cons r *error*))
+  => '((1 2)
+       (error-handler "Syntax error: unexpected token : " . C)))
+
+;;; end of file
+;;; test-lr-no-clause.scm --
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (NUMBER COMMA NEWLINE)
+
+			     (lines (lines line)	\_ (list $2)
+				    (line)		\_ (list $1))
+			     (line (NEWLINE)		\_ #\newline
+				   (NUMBER NEWLINE)	\_ $1
+				   ;;this is a rule with no semantic action
+				   (COMMA NUMBER NEWLINE)))))
+    (parser (make-lexer tokens) error-handler)))
+
+(check
+    ;;correct input
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '(1))
+
+(check
+    ;;correct input with comma, which is a rule with no client form
+    (doit (make-lexical-token 'COMMA   #f #\,)
+	  (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '(#(line-3 #\, 1 #\newline)))
+
+(check
+    ;;correct input with comma, which is a rule with no client form
+    (doit (make-lexical-token 'NUMBER  #f 1)
+	  (make-lexical-token 'NEWLINE #f #\newline)
+	  (make-lexical-token 'COMMA   #f #\,)
+	  (make-lexical-token 'NUMBER  #f 2)
+	  (make-lexical-token 'NEWLINE #f #\newline))
+  => '(#(line-3 #\, 2 #\newline)))
+
+;;; end of file
+;;; test-lr-script-expression.scm --
+;;
+;;Parse scripts, each line an expression.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (N O C T (left\_ A) (left\_ M) (nonassoc\_ U))
+
+			     (script	(lines)		\_ (reverse $1))
+
+			     (lines	(lines line)	\_ (cons $2 $1)
+					(line)		\_ (list $1))
+
+			     (line	(T)		\_ #\newline
+					(E T)		\_ $1
+					(error T)	\_ (list 'error-clause $2))
+
+			     (E	(N)		\_ $1
+				(E A E)		\_ ($2 $1 $3)
+				(E M E)		\_ ($2 $1 $3)
+				(A E (prec\_ U))	\_ ($1 $2)
+				(O E C)		\_ $2))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+;;; Correct input
+
+(check
+    (doit (make-lexical-token 'T #f #\newline))
+  => '(#\newline))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'T #f #\newline))
+  => '(1))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'T #f #\newline))
+  => '(3))
+
+(check
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline))
+  => '(7))
+
+(check
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline))
+  => '(9))
+
+(check
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline)
+
+	  (make-lexical-token 'N #f 4)
+	  (make-lexical-token 'M #f /)
+	  (make-lexical-token 'N #f 5)
+	  (make-lexical-token 'T #f #\newline))
+  => '(9 4/5))
+
+;;; --------------------------------------------------------------------
+
+(check
+    ;;Successful error recovery.
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3)
+	  (make-lexical-token 'T #f #\newline)
+
+	  (make-lexical-token 'N #f 4)
+	  (make-lexical-token 'M #f /)
+	  (make-lexical-token 'N #f 5)
+	  (make-lexical-token 'T #f #\newline))
+  => '((error-clause #f)
+       4/5))
+
+(check
+    ;;Unexpected end of input.
+    (let ((r (doit (make-lexical-token 'N #f 1)
+		   (make-lexical-token 'A #f +)
+		   (make-lexical-token 'N #f 2))))
+      (cons r *error*))
+  => '(#f (error-handler "Syntax error: unexpected end of input")))
+
+(check
+    ;;Unexpected end of input.
+    (let ((r (doit (make-lexical-token 'N #f 1)
+		   (make-lexical-token 'A #f +)
+		   (make-lexical-token 'T #f #\newline))))
+      (cons r *error*))
+  => '(((error-clause #f))
+       (error-handler "Syntax error: unexpected token : " . T)))
+
+;;; end of file
+;;; test-lr-single-expressions.scm --
+;;
+;;Grammar accepting single expressions.
+;;
+
+(load "common-test.scm")
+
+(define (doit . tokens)
+  (let ((parser (lalr-parser (expect\_ 0)
+			     (N O C (left\_ A) (left\_ M) (nonassoc\_ U))
+
+			     (E	(N)		\_ $1
+				(E A E)		\_ ($2 $1 $3)
+				(E M E)		\_ ($2 $1 $3)
+				(A E (prec\_ U))	\_ ($1 $2)
+				(O E C)		\_ $2))))
+    (parser (make-lexer tokens) error-handler)))
+
+;;; --------------------------------------------------------------------
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1))
+  => 1)
+
+(check	;correct input
+    (doit (make-lexical-token 'A #f -)
+	  (make-lexical-token 'N #f 1))
+  => -1)
+
+(check	;correct input
+    (doit (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 1))
+  => 1)
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2))
+  => 3)
+
+(check	;correct input
+    (doit (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3))
+  => 7)
+
+(check	;correct input
+    (doit (make-lexical-token 'O #f #\()
+	  (make-lexical-token 'N #f 1)
+	  (make-lexical-token 'A #f +)
+	  (make-lexical-token 'N #f 2)
+	  (make-lexical-token 'C #f #\))
+	  (make-lexical-token 'M #f *)
+	  (make-lexical-token 'N #f 3))
+  => 9)
+
+;;; end of file
+(define-module (test-import-order-a)
+  #\use-module (base))
+
+(push!)
+(define-module (test-import-order-b)
+  #\use-module (base))
+
+(push!)
+(define-module (test-import-order-c)
+  #\use-module (base))
+
+(push!)
+(define-module (test-import-order-d)
+  #\use-module (base))
+
+(push!)
+;;;; test-suite/lib.scm --- generic support for testing
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
+;;;;   2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This program 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, or (at your option) any later version.
+;;;;
+;;;; This program 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 software; see the file COPYING.LESSER.
+;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
+;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite lib)
+  #\use-module (ice-9 stack-catch)
+  #\use-module (ice-9 regex)
+  #\autoload   (srfi srfi-1)  (append-map)
+  #\autoload   (system base compile) (compile)
+  #\export (
+
+ ;; Exceptions which are commonly being tested for.
+ exception_syntax-pattern-unmatched
+ exception_bad-variable
+ exception_missing-expression
+ exception_out-of-range exception_unbound-var
+ exception_used-before-defined
+ exception_wrong-num-args exception_wrong-type-arg
+ exception_numerical-overflow
+ exception_struct-set!-denied
+ exception_system-error
+ exception_encoding-error
+ exception_miscellaneous-error
+ exception_string-contains-nul
+ exception_read-error
+ exception_null-pointer-error
+ exception_vm-error
+
+ ;; Reporting passes and failures.
+ run-test
+ pass-if expect-fail
+ pass-if-equal
+ pass-if-exception expect-fail-exception
+
+ ;; Naming groups of tests in a regular fashion.
+ with-test-prefix
+ with-test-prefix*
+ with-test-prefix/c&e
+ current-test-prefix
+ format-test-name
+
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
+
+ ;; Clearing stale references on the C stack for GC-sensitive tests.
+ clear-stale-stack-references
+
+ ;; Using a given locale
+ with-locale with-locale* with-latin1-locale with-latin1-locale*
+
+ ;; The bit bucket.
+ %null-device
+
+ ;; Reporting results in various ways.
+ register-reporter unregister-reporter reporter-registered?
+ make-count-reporter print-counts
+ make-log-reporter
+ full-reporter
+ user-reporter))
+
+
+;;;; If you're using Emacs's Scheme mode_
+;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
+
+
+;;;; CORE FUNCTIONS
+;;;;
+;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; testing environment.  The first parameter NAME is a unique name for the
+;;;; test to be executed (for an explanation of this parameter see below under
+;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
+;;;; that indicates whether the corresponding test is expected to pass.  If
+;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
+;;;; #f the test is expected to fail.  Finally, THUNK is the function that
+;;;; actually performs the test.  For example_
+;;;;
+;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;;
+;;;; To report success, THUNK should either return #t or throw 'pass.  To
+;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
+;;;; returns a non boolean value or throws 'unresolved, this indicates that
+;;;; the test did not perform as expected.  For example the property that was
+;;;; to be tested could not be tested because something else went wrong.
+;;;; THUNK may also throw 'untested to indicate that the test was deliberately
+;;;; not performed, for example because the test case is not complete yet.
+;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
+;;;; requires some feature that is not available in the configured testing
+;;;; environment.  All other exceptions thrown by THUNK are considered as
+;;;; errors.
+;;;;
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
+;;;; * (pass-if name body) is a short form for
+;;;;   (run-test name #t (lambda () body))
+;;;; * (expect-fail name body) is a short form for
+;;;;   (run-test name #f (lambda () body))
+;;;;
+;;;; For example_
+;;;;
+;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;;   body causes the given exception to be thrown.  If no exception is
+;;;;   thrown, the test fails.  If some other exception is thrown, it is an
+;;;;   error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;;   the execution of body causes the given exception to be thrown.  If no
+;;;;   exception is thrown, the test fails expectedly.  If some other
+;;;;   exception is thrown, it is an error.
+
+
+;;;; TEST NAMES
+;;;;
+;;;; Every test in the test suite has a unique name, to help
+;;;; developers find tests that are failing (or unexpectedly passing),
+;;;; and to help gather statistics.
+;;;;
+;;;; A test name is a list of printable objects.  For example_
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Test names may contain arbitrary objects, but they always have
+;;;; the following properties_
+;;;; - Test names can be compared with EQUAL?.
+;;;; - Test names can be reliably stored and retrieved with the standard WRITE
+;;;;   and READ procedures; doing so preserves their identity.
+;;;;
+;;;; For example_
+;;;;
+;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
+;;;;
+;;;; In that case, the test name is the list ("simple addition").
+;;;;
+;;;; In the case of simple tests the expression that is tested would often
+;;;; suffice as a test name by itself.  Therefore, the convenience macros
+;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
+;;;; a test name in such cases.
+;;;;
+;;;; * (pass-if expression) is a short form for
+;;;;   (run-test 'expression #t (lambda () expression))
+;;;; * (expect-fail expression) is a short form for
+;;;;   (run-test 'expression #f (lambda () expression))
+;;;;
+;;;; For example_
+;;;;
+;;;;    (pass-if (= 2 (+ 1 1)))
+;;;;
+;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
+;;;; a prefix for the names of all tests whose results are reported
+;;;; within their dynamic scope.  For example_
+;;;;
+;;;; (begin
+;;;;   (with-test-prefix "basic arithmetic"
+;;;;     (pass-if "addition" (= (+ 2 2) 4))
+;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
+;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
+;;;;
+;;;; In that example, the three test names are_
+;;;;   ("basic arithmetic" "addition"),
+;;;;   ("basic arithmetic" "subtraction"), and
+;;;;   ("multiplication").
+;;;;
+;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX appends
+;;;; a new element to the current prefix_
+;;;;
+;;;; (with-test-prefix "arithmetic"
+;;;;   (with-test-prefix "addition"
+;;;;     (pass-if "integer" (= (+ 2 2) 4))
+;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
+;;;;   (with-test-prefix "subtraction"
+;;;;     (pass-if "integer" (= (- 2 2) 0))
+;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
+;;;;
+;;;; The four test names here are_
+;;;;   ("arithmetic" "addition" "integer")
+;;;;   ("arithmetic" "addition" "complex")
+;;;;   ("arithmetic" "subtraction" "integer")
+;;;;   ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by "_ ".  So, the last set of test names would be
+;;;; reported as_
+;;;;
+;;;;   arithmetic_ addition_ integer
+;;;;   arithmetic_ addition_ complex
+;;;;   arithmetic_ subtraction_ integer
+;;;;   arithmetic_ subtraction_ complex
+;;;;
+;;;; The Guile benchmarks use with-test-prefix to include the name of
+;;;; the source file containing the test in the test name, to help
+;;;; developers to find failing tests, and to provide each file with its
+;;;; own namespace.
+
+
+;;;; REPORTERS
+;;;;
+;;;; A reporter is a function which we apply to each test outcome.
+;;;; Reporters can log results, print interesting results to the
+;;;; standard output, collect statistics, etc.
+;;;;
+;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
+;;;; possibly additional arguments depending on RESULT; its return value
+;;;; is ignored.  RESULT has one of the following forms_
+;;;;
+;;;; pass         - The test named TEST passed.
+;;;;                Additional arguments are ignored.
+;;;; upass        - The test named TEST passed unexpectedly.
+;;;;                Additional arguments are ignored.
+;;;; fail         - The test named TEST failed.
+;;;;                Additional arguments are ignored.
+;;;; xfail        - The test named TEST failed, as expected.
+;;;;                Additional arguments are ignored.
+;;;; unresolved   - The test named TEST did not perform as expected, for
+;;;;                example the property that was to be tested could not be
+;;;;                tested because something else went wrong.
+;;;;                Additional arguments are ignored.
+;;;; untested     - The test named TEST was not actually performed, for
+;;;;                example because the test case is not complete yet.
+;;;;                Additional arguments are ignored.
+;;;; unsupported  - The test named TEST requires some feature that is not
+;;;;                available in the configured testing environment.
+;;;;                Additional arguments are ignored.
+;;;; error        - An error occurred while the test named TEST was
+;;;;                performed.  Since this result means that the system caught
+;;;;                an exception it could not handle, the exception arguments
+;;;;                are passed as additional arguments.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, and
+;;;; collecting totals.
+;;;;
+;;;; You can use the REGISTER-REPORTER function and friends to add
+;;;; whatever reporting functions you like.  If you don't register any
+;;;; reporters, the library uses FULL-REPORTER, which simply writes
+;;;; all results to the standard output.
+
+
+;;;; MISCELLANEOUS
+;;;;
+
+;;; Define some exceptions which are commonly being tested for.
+(define exception_syntax-pattern-unmatched
+  (cons 'syntax-error "source expression failed to match any pattern"))
+(define exception_bad-variable
+  (cons 'syntax-error "Bad variable"))
+(define exception_missing-expression
+  (cons 'misc-error "^missing or extra expression"))
+(define exception_out-of-range
+  (cons 'out-of-range "^.*out of range"))
+(define exception_unbound-var
+  (cons 'unbound-variable "^Unbound variable"))
+(define exception_used-before-defined
+  (cons 'unbound-variable "^Variable used before given a value"))
+(define exception_wrong-num-args
+  (cons 'wrong-number-of-args "^Wrong number of arguments"))
+(define exception_wrong-type-arg
+  (cons 'wrong-type-arg "^Wrong type"))
+(define exception_numerical-overflow
+  (cons 'numerical-overflow "^Numerical overflow"))
+(define exception_struct-set!-denied
+  (cons 'misc-error "^set! denied for field"))
+(define exception_system-error
+  (cons 'system-error ".*"))
+(define exception_encoding-error
+  (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)"))
+(define exception_miscellaneous-error
+  (cons 'misc-error "^.*"))
+(define exception_read-error
+  (cons 'read-error "^.*$"))
+(define exception_null-pointer-error
+  (cons 'null-pointer-error "^.*$"))
+(define exception_vm-error
+  (cons 'vm-error "^.*$"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception_string-contains-nul
+  (cons 'misc-error "^string contains #\\\\nul character"))
+
+
+;;; Display all parameters to the default output port, followed by a newline.
+(define (display-line . objs)
+  (for-each display objs)
+  (newline))
+
+;;; Display all parameters to the given output port, followed by a newline.
+(define (display-line-port port . objs)
+  (for-each (lambda (obj) (display obj port)) objs)
+  (newline port))
+
+
+;;;; CORE FUNCTIONS
+;;;;
+
+;;; The central testing routine.
+;;; The idea is taken from Greg, the GNUstep regression test environment.
+(define run-test
+  (let ((test-running #f))
+    (lambda (name expect-pass thunk)
+      (if test-running
+          (error "Nested calls to run-test are not permitted."))
+      (let ((test-name (full-name name)))
+            (set! test-running #t)
+            (catch #t
+              (lambda ()
+                (let ((result (thunk)))
+                  (if (eq? result #t) (throw 'pass))
+                  (if (eq? result #f) (throw 'fail))
+                  (throw 'unresolved)))
+              (lambda (key . args)
+                (case key
+                  ((pass)
+                   (report (if expect-pass 'pass 'upass) test-name))
+                  ((fail)
+                   ;; ARGS may contain extra info about the failure,
+                   ;; such as the expected and actual value.
+                   (apply report (if expect-pass 'fail 'xfail)
+                          test-name
+                          args))
+                  ((unresolved untested unsupported)
+                   (report key test-name))
+                  ((quit)
+                   (report 'unresolved test-name)
+                   (quit))
+                  (else
+                   (report 'error test-name (cons key args))))))
+            (set! test-running #f)))))
+
+;;; A short form for tests that are expected to pass, taken from Greg.
+(define-syntax pass-if
+  (syntax-rules ()
+    ((_ name)
+     ;; presume this is a simple test, i.e. (pass-if (even? 2))
+     ;; where the body should also be the name.
+     (run-test 'name #t (lambda () name)))
+    ((_ name rest ...)
+     (run-test name #t (lambda () rest ...)))))
+
+(define-syntax pass-if-equal
+  (syntax-rules ()
+    "Succeed if and only if BODY's return value is equal? to EXPECTED."
+    ((_ expected body)
+     (pass-if-equal 'body expected body))
+    ((_ name expected body ...)
+     (run-test name #t
+               (lambda ()
+                 (let ((result (begin body ...)))
+                   (or (equal? expected result)
+                       (throw 'fail
+                              'expected-value expected
+                              'actual-value result))))))))
+
+;;; A short form for tests that are expected to fail, taken from Greg.
+(define-syntax expect-fail
+  (syntax-rules ()
+    ((_ name)
+     ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+     ;; where the body should also be the name.
+     (run-test 'name #f (lambda () name)))
+    ((_ name rest ...)
+     (run-test name #f (lambda () rest ...)))))
+
+;;; A helper function to implement the macros that test for exceptions.
+(define (run-test-exception name exception expect-pass thunk)
+  (run-test name expect-pass
+    (lambda ()
+      (stack-catch (car exception)
+	(lambda () (thunk) #f)
+	(lambda (key proc message . rest)
+	  (cond
+           ;; handle explicit key
+           ((string-match (cdr exception) message)
+            #t)
+           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'misc-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
+           ;; handle syntax errors which use `syntax-error' for key and don't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'syntax-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
+           ;; unhandled; throw again
+           (else
+            (apply throw key proc message rest))))))))
+
+;;; A short form for tests that expect a certain exception to be thrown.
+(define-syntax pass-if-exception
+  (syntax-rules ()
+    ((_ name exception body rest ...)
+     (run-test-exception name exception #t (lambda () body rest ...)))))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(define-syntax expect-fail-exception
+  (syntax-rules ()
+    ((_ name exception body rest ...)
+     (run-test-exception name exception #f (lambda () body rest ...)))))
+
+
+;;;; TEST NAMES
+;;;;
+
+;;;; Turn a test name into a nice human-readable string.
+(define (format-test-name name)
+  ;; Choose a Unicode-capable encoding so that the string port can contain any
+  ;; valid Unicode character.
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (call-with-output-string
+     (lambda (port)
+       (let loop ((name name)
+                  (separator ""))
+         (if (pair? name)
+             (begin
+               (display separator port)
+               (display (car name) port)
+               (loop (cdr name) "_ "))))))))
+
+;;;; For a given test-name, deliver the full name including all prefixes.
+(define (full-name name)
+  (append (current-test-prefix) (list name)))
+
+;;; A fluid containing the current test prefix, as a list.
+(define prefix-fluid (make-fluid '()))
+(define (current-test-prefix)
+  (fluid-ref prefix-fluid))
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-test-prefix*.  Return the value returned by THUNK.
+(define (with-test-prefix* prefix thunk)
+  (with-fluids ((prefix-fluid
+		 (append (fluid-ref prefix-fluid) (list prefix))))
+    (thunk)))
+
+;;; (with-test-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-test-prefix expression.  Return the value returned by the last
+;;; BODY expression.
+(define-syntax with-test-prefix
+  (syntax-rules ()
+    ((_ prefix body ...)
+     (with-test-prefix* prefix (lambda () body ...)))))
+
+(define-syntax c&e
+  (syntax-rules (pass-if pass-if-equal pass-if-exception)
+    "Run the given tests both with the evaluator and the compiler/VM."
+    ((_ (pass-if test-name exp))
+     (begin (pass-if (string-append test-name " (eval)")
+                     (primitive-eval 'exp))
+            (pass-if (string-append test-name " (compile)")
+                     (compile 'exp #\to 'value #\env (current-module)))))
+    ((_ (pass-if-equal test-name val exp))
+     (begin (pass-if-equal (string-append test-name " (eval)") val
+              (primitive-eval 'exp))
+            (pass-if-equal (string-append test-name " (compile)") val
+              (compile 'exp #\to 'value #\env (current-module)))))
+    ((_ (pass-if-exception test-name exc exp))
+     (begin (pass-if-exception (string-append test-name " (eval)")
+                               exc (primitive-eval 'exp))
+            (pass-if-exception (string-append test-name " (compile)")
+                               exc (compile 'exp #\to 'value
+                                            #\env (current-module)))))))
+
+;;; (with-test-prefix/c&e PREFIX BODY ...)
+;;; Same as `with-test-prefix', but the enclosed tests are run both with
+;;; the compiler/VM and the evaluator.
+(define-syntax with-test-prefix/c&e
+  (syntax-rules ()
+    ((_ section-name exp ...)
+     (with-test-prefix section-name (c&e exp) ...))))
+
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+  (let ((dopts #f))
+    (dynamic-wind
+	(lambda ()
+	  (set! dopts (debug-options)))
+	thunk
+	(lambda ()
+	  (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+  `(with-debugging-evaluator* (lambda () ,@body)))
+
+;; Recurse through a C function that should clear any values that might
+;; have spilled on the stack temporarily.  (The salient feature of
+;; with-continuation-barrier is that currently it is implemented as a C
+;; function that recursively calls the VM.)
+;;
+(define* (clear-stale-stack-references #\optional (n 10))
+  (if (positive? n)
+      (with-continuation-barrier
+       (lambda ()
+         (clear-stale-stack-references (1- n))))))
+
+;;; Call THUNK with a given locale
+(define (with-locale* nloc thunk)
+  (let ((loc #f))
+    (dynamic-wind
+	(lambda ()
+          (if (defined? 'setlocale)
+              (begin
+                (set! loc (false-if-exception (setlocale LC_ALL)))
+                (if (or (not loc)
+                        (not (false-if-exception (setlocale LC_ALL nloc))))
+                    (throw 'unresolved)))
+              (throw 'unresolved)))
+	thunk
+	(lambda ()
+          (if (and (defined? 'setlocale) loc)
+              (setlocale LC_ALL loc))))))
+
+;;; Evaluate BODY... using the given locale.
+(define-syntax with-locale
+  (syntax-rules ()
+    ((_ loc body ...)
+     (with-locale* loc (lambda () body ...)))))
+
+;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
+;;; (if any).
+(define (with-latin1-locale* thunk)
+  (define %locales
+    (append-map (lambda (name)
+                  (list (string-append name ".ISO-8859-1")
+                        (string-append name ".iso88591")
+                        (string-append name ".ISO8859-1")))
+                '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
+                  "fr_FR" "pt_PT" "nl_NL" "sv_SE")))
+
+  (let loop ((locales %locales))
+    (if (null? locales)
+        (throw 'unresolved)
+        (catch 'unresolved
+          (lambda ()
+            (with-locale* (car locales) thunk))
+          (lambda (key . args)
+            (loop (cdr locales)))))))
+
+;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
+;;; was found.
+(define-syntax with-latin1-locale
+  (syntax-rules ()
+    ((_ body ...)
+     (with-latin1-locale* (lambda () body ...)))))
+
+(define %null-device
+  ;; On Windows (MinGW), /dev/null does not exist and we must instead
+  ;; use NUL.  Note that file system procedures automatically translate
+  ;; /dev/null, so this variable is only useful for shell snippets.
+
+  ;; Test for Windowsness by checking whether the current directory name
+  ;; starts with a drive letter.
+  (if (string-match "^[a-zA-Z]_[/\\]" (getcwd))
+      "NUL"
+      "/dev/null"))
+
+
+;;;; REPORTERS
+;;;;
+
+;;; The global list of reporters.
+(define reporters '())
+
+;;; The default reporter, to be used only if no others exist.
+(define default-reporter #f)
+
+;;; Add the procedure REPORTER to the current set of reporter functions.
+;;; Signal an error if that reporter procedure object is already registered.
+(define (register-reporter reporter)
+  (if (memq reporter reporters)
+      (error "register-reporter_ reporter already registered_ " reporter))
+  (set! reporters (cons reporter reporters)))
+
+;;; Remove the procedure REPORTER from the current set of reporter
+;;; functions.  Signal an error if REPORTER is not currently registered.
+(define (unregister-reporter reporter)
+  (if (memq reporter reporters)
+      (set! reporters (delq! reporter reporters))
+      (error "unregister-reporter_ reporter not registered_ " reporter)))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+  (if (memq reporter reporters) #t #f))
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report . args)
+  (if (pair? reporters)
+      (for-each (lambda (reporter) (apply reporter args))
+		reporters)
+      (apply default-reporter args)))
+
+
+;;;; Some useful standard reporters_
+;;;; Count reporters count the occurrence of each test result type.
+;;;; Log reporters write all test results to a given log file.
+;;;; Full reporters write all test results to the standard output.
+;;;; User reporters write interesting test results to the standard output.
+
+;;; The complete list of possible test results.
+(define result-tags
+  '((pass        "PASS"        "passes_                 ")
+    (fail        "FAIL"        "failures_               ")
+    (upass       "UPASS"       "unexpected passes_      ")
+    (xfail       "XFAIL"       "expected failures_      ")
+    (unresolved  "UNRESOLVED"  "unresolved test cases_  ")
+    (untested    "UNTESTED"    "untested test cases_    ")
+    (unsupported "UNSUPPORTED" "unsupported test cases_ ")
+    (error       "ERROR"       "errors_                 ")))
+
+;;; The list of important test results.
+(define important-result-tags
+  '(fail upass unresolved error))
+
+;;; Display a single test result in formatted form to the given port
+(define (print-result port result name . args)
+  (let* ((tag (assq result result-tags))
+	 (label (if tag (cadr tag) #f)))
+    (if label
+	(begin
+	  (display label port)
+	  (display "_ " port)
+	  (display (format-test-name name) port)
+	  (if (pair? args)
+	      (begin
+		(display " - arguments_ " port)
+		(write args port)))
+	  (newline port))
+	(error "(test-suite lib) FULL-REPORTER_ unrecognized result_ "
+	       result))))
+
+;;; Return a list of the form (COUNTER RESULTS), where_
+;;; - COUNTER is a reporter procedure, and
+;;; - RESULTS is a procedure taking no arguments which returns the
+;;;   results seen so far by COUNTER.  The return value is an alist
+;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
+(define (make-count-reporter)
+  (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
+    (list
+     (lambda (result name . args)
+       (let ((pair (assq result counts)))
+	 (if pair
+	     (set-cdr! pair (+ 1 (cdr pair)))
+	     (error "count-reporter_ unexpected test result_ "
+		    (cons result (cons name args))))))
+     (lambda ()
+       (append counts '())))))
+
+;;; Print a count reporter's results nicely.  Pass this function the value
+;;; returned by a count reporter's RESULTS procedure.
+(define (print-counts results . port?)
+  (let ((port (if (pair? port?)
+		  (car port?)
+		  (current-output-port))))
+    (newline port)
+    (display-line-port port "Totals for this test run_")
+    (for-each
+     (lambda (tag)
+       (let ((result (assq (car tag) results)))
+	 (if result
+	     (display-line-port port (caddr tag) (cdr result))
+	     (display-line-port port
+				"Test suite bug_ "
+				"no total available for `" (car tag) "'"))))
+     result-tags)
+    (newline port)))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form.  FILE may be a filename, or a port.
+(define (make-log-reporter file)
+  (let ((port (if (output-port? file) file
+		  (open-output-file file))))
+    (lambda args
+      (apply print-result port args)
+      (force-output port))))
+
+;;; A reporter that reports all results to the user.
+(define (full-reporter . args)
+  (apply print-result (current-output-port) args))
+
+;;; A reporter procedure which shows interesting results (failures,
+;;; unexpected passes etc.) to the user.
+(define (user-reporter result name . args)
+  (if (memq result important-result-tags)
+      (apply full-reporter result name args)))
+
+(set! default-reporter full-reporter)
+(close-port (current-input-port))
+(let loop ()
+  (display "closed\n" (current-error-port))
+  (force-output  (current-error-port))
+  (loop))
+;;; test of defining rnrs libraries
+
+;;      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
+
+
+(library (tests rnrs-test-a)
+  (export double)
+  (import (guile))
+ 
+  (define (double x)
+    (* x 2)))
+;;;
+;;;  This is a test suite written in the notation of 
+;;;  SRFI-64, A Scheme API for test suites
+;;;
+
+(test-begin "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;;  Ironically, in order to set up the meta-test environment,
+;;;  we have to invoke one of the most sophisticated features_
+;;;  custom test runners
+;;;
+
+;;;  The `prop-runner' invokes `thunk' in the context of a new
+;;;  test runner, and returns the indicated properties of the 
+;;;  last-executed test result.
+
+(define (prop-runner props thunk)
+  (let ((r (test-runner-null))
+        (plist '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! plist (test-result-alist runner))))
+    ;;
+    (test-with-runner r (thunk))
+    ;; reorder the properties so they are in the order
+    ;; given by `props'.  Note that any property listed in `props'
+    ;; that is not in the property alist will occur as #f
+    (map (lambda (k)
+           (assq k plist))
+         props)))
+
+;;;  `on-test-runner' creates a null test runner and then
+;;;  arranged for `visit' to be called with the runner
+;;;  whenever a test is run.  The results of the calls to
+;;;  `visit' are returned in a list
+
+(define (on-test-runner thunk visit)
+  (let ((r (test-runner-null))
+        (results '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! results (cons (visit r) results))))
+    ;;
+    (test-with-runner r (thunk))
+    (reverse results)))
+
+;;;
+;;;  The `triv-runner' invokes `thunk'
+;;;  and returns a list of 6 lists, the first 5 of which
+;;;  are a list of the names of the tests that, respectively,
+;;;  PASS, FAIL, XFAIL, XPASS, and SKIP.
+;;;  The last item is a list of counts.
+;;;
+
+(define (triv-runner thunk)
+  (let ((r (test-runner-null))
+        (accum-pass '())
+        (accum-fail '())
+        (accum-xfail '())
+        (accum-xpass '())
+        (accum-skip '()))
+    ;;
+    (test-runner-on-bad-count!
+     r
+     (lambda (runner count expected-count)
+       (error (string-append "bad count " (number->string count)
+			     " but expected "
+			     (number->string expected-count)))))
+    (test-runner-on-bad-end-name!
+     r
+     (lambda (runner begin end)
+       (error (string-append "bad end group name " end
+			     " but expected " begin))))
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (let ((n (test-runner-test-name runner)))
+         (case (test-result-kind runner)
+           ((pass) (set! accum-pass (cons n accum-pass)))
+           ((fail) (set! accum-fail (cons n accum-fail)))
+           ((xpass) (set! accum-xpass (cons n accum-xpass)))
+           ((xfail) (set! accum-xfail (cons n accum-xfail)))
+           ((skip) (set! accum-skip (cons n accum-skip)))))))
+    ;;
+    (test-with-runner r (thunk))
+    (list (reverse accum-pass)    ; passed as expected
+          (reverse accum-fail)    ; failed, but was expected to pass
+          (reverse accum-xfail)   ; failed as expected
+          (reverse accum-xpass)   ; passed, but was expected to fail
+          (reverse accum-skip)    ; was not executed
+          (list (test-runner-pass-count r)
+                (test-runner-fail-count r)
+                (test-runner-xfail-count r)
+                (test-runner-xpass-count r)
+                (test-runner-skip-count r)))))
+
+(define (path-revealing-runner thunk)
+  (let ((r (test-runner-null))
+        (seq '()))
+    ;;
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (set! seq (cons (list (test-runner-group-path runner)
+                             (test-runner-test-name runner))
+                       seq))))
+    (test-with-runner r (thunk))
+    (reverse seq)))
+
+;;;
+;;;  Now we can start testing compliance with SRFI-64
+;;;
+
+(test-begin "1. Simple test-cases")
+
+(test-begin "1.1. test-assert")
+
+(define (t)
+  (triv-runner
+   (lambda ()
+     (test-assert "a" #t)
+     (test-assert "b" #f))))
+
+(test-equal
+ "1.1.1. Very simple"
+ '(("a") ("b") () () () (1 1 0 0 0))
+ (t))
+
+(test-equal
+ "1.1.2. A test with no name"
+ '(("a") ("") () () () (1 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
+
+(test-equal
+ "1.1.3. Tests can have the same name"
+ '(("a" "a") () () () () (2 0 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
+
+(define (choke)
+  (vector-ref '#(1 2) 3))
+
+(test-equal
+ "1.1.4. One way to FAIL is to throw an error"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" (choke)))))
+
+(test-end);1.1
+
+(test-begin "1.2. test-eqv")
+
+(define (mean x y)
+  (/ (+ x y) 2.0))
+
+(test-equal
+ "1.2.1.  Simple numerical equivalence"
+ '(("c") ("a" "b") () () () (1 2 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-eqv "a" (mean 3 5) 4)
+    (test-eqv "b" (mean 3 5) 4.5)
+    (test-eqv "c" (mean 3 5) 4.0))))
+
+(test-end);1.2
+
+(test-end "1. Simple test-cases")
+
+;;;
+;;;
+;;;
+
+(test-begin "2. Tests for catching errors")
+
+(test-begin "2.1. test-error")
+
+(test-equal
+ "2.1.1. Baseline test; PASS with no optional args"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.2. Baseline test; FAIL with no optional args"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL_ the expr does not raise an error and `test-error' is
+    ;;       claiming that it will, so this test should FAIL
+    (test-error (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.3. PASS with a test name and error type"
+ '(("a") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error "a" #t (vector-ref '#(1 2) 9)))))
+
+(test-end "2.1. test-error")
+
+(test-end "2. Tests for catching errors")
+
+;;;
+;;;
+;;;
+
+(test-begin "3. Test groups and paths")
+
+(test-equal
+ "3.1. test-begin with unspecific test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end))))
+
+(test-equal
+ "3.2. test-begin with name-matching test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+;;; since the error raised by `test-end' on a mismatch is not a test
+;;; error, we actually expect the triv-runner itself to fail
+
+(test-error
+ "3.3. test-begin with mismatched test-end"
+#t
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "x"))))
+
+(test-equal
+ "3.4. test-begin with name and count"
+ '(("b" "c") () () () () (2 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 2)
+    (test-assert "b" #t)
+    (test-assert "c" #t)
+    (test-end "a"))))
+
+;; similarly here, a mismatched count is a lexical error
+;; and not a test failure...
+
+(test-error
+ "3.5. test-begin with mismatched count"
+ #t
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 99)
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+(test-equal
+ "3.6. introspecting on the group path"
+ '((() "w")
+   (("a" "b") "x")
+   (("a" "b") "y")
+   (("a") "z"))
+ ;;
+ ;;  `path-revealing-runner' is designed to return a list
+ ;;  of the tests executed, in order.  Each entry is a list
+ ;;  (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
+ ;;  of test groups starting from the topmost
+ ;;
+ (path-revealing-runner
+  (lambda ()
+    (test-assert "w" #t)
+    (test-begin "a")
+    (test-begin "b")
+    (test-assert "x" #t)
+    (test-assert "y" #t)
+    (test-end)
+    (test-assert "z" #t))))
+
+
+(test-end "3. Test groups and paths")
+
+;;;
+;;;
+;;;
+
+(test-begin "4. Handling set-up and cleanup")
+
+(test-equal "4.1. Normal exit path"
+             '(in 1 2 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-group-with-cleanup
+                   "foo"
+                   (do 'in)
+                   (do 1)
+                   (do 2)
+                   (do 'out))))
+               (reverse ex)))
+               
+(test-equal "4.2. Exception exit path"
+             '(in 1 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               ;; the outer runner is to run the `test-error' in, to
+               ;; catch the exception raised in the inner runner,
+               ;; since we don't want to depend on any other
+               ;; exception-catching support
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-error
+                   (triv-runner
+                    (lambda ()
+                      (test-group-with-cleanup
+                       "foo"
+                       (do 'in) (test-assert #t)
+                       (do 1)   (test-assert #t)
+                       (choke)  (test-assert #t)
+                       (do 2)   (test-assert #t)
+                       (do 'out)))))))
+               (reverse ex)))
+
+(test-end "4. Handling set-up and cleanup")
+
+;;;
+;;;
+;;;
+
+(test-begin "5. Test specifiers")
+
+(test-begin "5.1. test-match-named")
+
+(test-equal "5.1.1. match test names"
+            '(("y") () () () ("x") (1 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-assert "x" #t)
+               (test-assert "y" #t))))
+
+(test-equal "5.1.2. but not group names"
+            '(("z") () () () () (1 0 0 0 0))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-begin "x")
+               (test-assert "z" #t)
+               (test-end))))
+
+(test-end)
+
+(test-begin "5.2. test-match-nth")
+;; See also_ [6.4. Short-circuit evaluation]
+
+(test-equal "5.2.1. skip the nth one after"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.2.2. skip m, starting at n"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3 SKIP
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.3. test-match-any")
+(test-equal "5.3.1. basic disjunction"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-nth 3)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.3.2. disjunction is commutative"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-name "x")
+                                          (test-match-nth 3)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.4. test-match-all")
+(test-equal "5.4.1. basic conjunction"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-nth 2 2)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.4.2. conjunction is commutative"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-name "x")
+                                          (test-match-nth 2 2)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-end "5. Test specifiers")
+
+;;;
+;;;
+;;;
+
+(test-begin "6. Skipping selected tests")
+
+(test-equal
+ "6.1. Skip by specifier - match-name"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-name "y"))
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-equal
+ "6.2. Shorthand specifiers"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-begin "6.3. Specifier Stack")
+
+(test-equal
+ "6.3.1. Clearing the Specifier Stack"
+ '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; FAIL
+    (test-end))))
+
+(test-equal
+ "6.3.2. Inheriting the Specifier Stack"
+ '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-skip "y")
+    (test-begin "a")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-end);6.3
+
+(test-begin "6.4. Short-circuit evaluation")
+
+(test-equal
+ "6.4.1. In test-match-all"
+ '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-all "y" (test-match-nth 2)))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  FAIL
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-equal
+ "6.4.2. In separate skip-list entries"
+ '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-skip (test-match-nth 2))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  SKIP
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-begin "6.4.3. Skipping test suites")
+
+(test-equal
+ "6.4.3.1. Introduced using 'test-begin'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-begin "b")            ; not skipped
+    (test-assert "x" #t)
+    (test-end "b")
+    (test-end "a"))))
+
+(test-expect-fail 1) ;; ???
+(test-equal
+ "6.4.3.2. Introduced using 'test-group'"
+ '(() () () () () (0 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-group 
+     "b"            ; skipped
+     (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-equal
+ "6.4.3.3. Non-skipped 'test-group'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "c")
+    (test-group "b" (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-end) ; 6.4.3
+ 
+(test-end);6.4
+
+(test-end "6. Skipping selected tests")
+
+;;;
+;;;
+;;;
+
+(test-begin "7. Expected failures")
+
+(test-equal "7.1. Simple example"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" #f))))
+
+(test-equal "7.2. Expected exception"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" (choke)))))
+
+(test-equal "7.3. Unexpectedly PASS"
+            '(() () ("y") ("x") () (0 0 1 1 0))
+            (triv-runner
+             (lambda ()
+               (test-expect-fail "x")
+               (test-expect-fail "y")
+               (test-assert "x" #t)
+               (test-assert "y" #f))))
+               
+
+
+(test-end "7. Expected failures")
+
+;;;
+;;;
+;;;
+
+(test-begin "8. Test-runner")
+
+;;;
+;;;  Because we want this test suite to be accurate even
+;;;  when the underlying implementation chooses to use, e.g.,
+;;;  a global variable to implement what could be thread variables
+;;;  or SRFI-39 parameter objects, we really need to save and restore
+;;;  their state ourselves
+;;;
+(define (with-factory-saved thunk)
+  (let* ((saved (test-runner-factory))
+         (result (thunk)))
+    (test-runner-factory saved)
+    result))
+
+(test-begin "8.1. test-runner-current")
+(test-assert "8.1.1. automatically restored"
+             (let ((a 0)
+                   (b 1)
+                   (c 2))
+               ;
+               (triv-runner
+                (lambda ()
+                  (set! a (test-runner-current))
+                  ;;
+                  (triv-runner
+                   (lambda ()
+                     (set! b (test-runner-current))))
+                  ;;
+                  (set! c (test-runner-current))))
+               ;;
+               (and (eq? a c)
+                    (not (eq? a b)))))
+              
+(test-end)
+
+(test-begin "8.2. test-runner-simple")
+(test-assert "8.2.1. default on-test hook"
+             (eq? (test-runner-on-test-end (test-runner-simple))
+                  test-on-test-end-simple))
+(test-assert "8.2.2. default on-final hook"
+             (eq? (test-runner-on-final (test-runner-simple))
+                  test-on-final-simple))
+(test-end)
+
+(test-begin "8.3. test-runner-factory")
+
+(test-assert "8.3.1. default factory"
+             (eq? (test-runner-factory) test-runner-simple))
+
+(test-assert "8.3.2. settable factory"
+             (with-factory-saved
+              (lambda ()
+                (test-runner-factory test-runner-null)
+                ;; we have no way, without bringing in other SRFIs,
+                ;; to make sure the following doesn't print anything,
+                ;; but it shouldn't_
+                (test-with-runner
+                 (test-runner-create)
+                 (lambda ()
+                   (test-begin "a")
+                   (test-assert #t)             ; pass
+                   (test-assert #f)             ; fail
+                   (test-assert (vector-ref '#(3) 10))  ; fail with error
+                   (test-end "a")))
+                (eq? (test-runner-factory) test-runner-null))))
+                
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.4. test-runner-create")
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2 
+
+(test-begin "8.5. test-runner-factory")
+(test-end)
+
+(test-begin "8.6. test-apply")
+(test-equal "8.6.1. Simple (form 1) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-equal "8.6.2. Simple (form 2) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-expect-fail 1) ;; depends on all test-match-nth being called.
+(test-equal "8.6.3. test-apply with skips"
+            '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-skip (test-match-nth 2))
+               (test-skip (test-match-nth 4))
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (test-match-name "q")
+                (lambda ()
+                                        ; only execute if SKIP=no and APPLY=yes
+                  (test-assert "x" #t)  ; # 1 SKIP=no  APPLY=no
+                  (test-assert "p" #t)  ; # 2 SKIP=yes APPLY=yes
+                  (test-assert "q" #t)  ; # 3 SKIP=no  APPLY=yes
+                  (test-assert "x" #f)  ; # 4 SKIP=yes APPLY=no
+                  0))
+               (test-assert "v" #t))))
+
+;;;  Unfortunately, since there is no way to UNBIND the current test runner,
+;;;  there is no way to test the behavior of `test-apply' in the absence
+;;;  of a current runner within our little meta-test framework.
+;;;
+;;;  To test the behavior manually, you should be able to invoke_
+;;;
+;;;     (test-apply "a" (lambda () (test-assert "a" #t)))
+;;;
+;;;  from the top level (with SRFI 64 available) and it should create a
+;;;  new, default (simple) test runner.
+
+(test-end)
+
+;;;  This entire suite depends heavily on 'test-with-runner'.  If it didn't
+;;;  work, this suite would probably go down in flames
+(test-begin "8.7. test-with-runner")
+(test-end)
+
+;;;  Again, this suite depends heavily on many of the test-runner
+;;;  components.  We'll just test those that aren't being exercised
+;;;  by the meta-test framework
+(test-begin "8.8. test-runner components")
+
+(define (auxtrack-runner thunk)
+  (let ((r (test-runner-null)))
+    (test-runner-aux-value! r '())
+    (test-runner-on-test-end! r (lambda (r)
+                              (test-runner-aux-value!
+                               r
+                               (cons (test-runner-test-name r)
+                                     (test-runner-aux-value r)))))
+    (test-with-runner r (thunk))
+    (reverse (test-runner-aux-value r))))
+
+(test-equal "8.8.1. test-runner-aux-value"
+            '("x" "" "y")
+            (auxtrack-runner
+             (lambda ()
+               (test-assert "x" #t)
+               (test-begin "a")
+               (test-assert #t)
+               (test-end)
+               (test-assert "y" #f))))
+
+(test-end) ; 8.8
+
+(test-end "8. Test-runner")
+
+(test-begin "9. Test Result Properties")
+
+(test-begin "9.1. test-result-alist")
+
+(define (symbol-alist? l)
+  (if (null? l)
+      #t
+      (and (pair? l)
+           (pair? (car l))
+           (symbol? (caar l))
+           (symbol-alist? (cdr l)))))
+
+;;; check the various syntactic forms
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+;;; check to make sure the required properties are returned
+
+(test-equal '((result-kind . pass))
+	    (prop-runner
+             '(result-kind)
+             (lambda ()
+               (test-assert #t)))
+	    )
+
+(test-equal 
+            '((result-kind . fail)
+              (expected-value . 2)
+              (actual-value . 3))
+	    (prop-runner
+             '(result-kind expected-value actual-value)
+             (lambda ()
+               (test-equal 2 (+ 1 2)))))
+
+(test-end "9.1. test-result-alist")
+
+(test-begin "9.2. test-result-ref")
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(fail pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-end "9.2. test-result-ref")
+
+(test-begin "9.3. test-result-set!")
+
+(test-equal '(100 100)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-set! r 'foo 100)
+               (test-result-ref r 'foo))))
+
+(test-end "9.3. test-result-set!")
+
+(test-end "9. Test Result Properties")
+
+;;;
+;;;
+;;;
+
+;#|  Time to stop having fun...
+;
+;(test-begin "9. For fun, some meta-test errors")
+;
+;(test-equal
+; "9.1. Really PASSes, but test like it should FAIL"
+; '(() ("b") () () ())
+; (triv-runner
+;  (lambda ()
+;    (test-assert "b" #t))))
+;
+;(test-expect-fail "9.2. Expect to FAIL and do so")
+;(test-expect-fail "9.3. Expect to FAIL but PASS")
+;(test-skip "9.4. SKIP this one")
+;
+;(test-assert "9.2. Expect to FAIL and do so" #f)
+;(test-assert "9.3. Expect to FAIL but PASS" #t)
+;(test-assert "9.4. SKIP this one" #t)
+;
+;(test-end)
+; |#
+
+(test-end "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005, 2009, 2010 Free Software Foundation, Inc.
+;;;
+;;; This program 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 program 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 program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+
+
+(use-modules (system vm vm)
+             (system vm program)
+	     (system base compile)
+	     (system base language)
+             (language scheme spec)
+             (language objcode spec)
+	     (srfi srfi-1)
+	     (ice-9 r5rs))
+
+
+(define (fetch-sexp-from-file file)
+  (with-input-from-file file
+    (lambda ()
+      (let loop ((sexp (read))
+		 (result '()))
+	(if (eof-object? sexp)
+	    (cons 'begin (reverse result))
+	    (loop (read) (cons sexp result)))))))
+
+(define (compile-to-objcode sexp)
+  "Compile the expression @var{sexp} into a VM program and return it."
+  (compile sexp #\from scheme #\to objcode))
+
+(define (run-vm-program objcode)
+  "Run VM program contained into @var{objcode}."
+  ((make-program objcode)))
+
+(define (compile/run-test-from-file file)
+  "Run test from source file @var{file} and return a value indicating whether
+it succeeded."
+  (run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
+
+
+(define-macro (watch-proc proc-name str)
+  `(let ((orig-proc ,proc-name))
+     (set! ,proc-name
+	   (lambda args
+	     (format #t (string-append ,str "...  "))
+	     (apply orig-proc args)))))
+
+(watch-proc fetch-sexp-from-file  "reading")
+(watch-proc compile-to-objcode    "compiling")
+(watch-proc run-vm-program        "running")
+
+
+;; The program.
+
+(define (run-vm-tests files)
+  "For each file listed in @var{files}, load it and run it through both the
+interpreter and the VM (after having it compiled).  Both results must be
+equal in the sense of @code{equal?}."
+  (let* ((res (map (lambda (file)
+		     (format #t "running `~a'...  " file)
+		     (if (catch #t
+				(lambda ()
+				  (equal? (compile/run-test-from-file file)
+					  (primitive-eval (fetch-sexp-from-file file))))
+				(lambda (key . args)
+				  (format #t "[~a/~a] " key args)
+				  #f))
+			 (format #t "ok~%")
+			 (begin (format #t "FAILED~%") #f)))
+		   files))
+	 (total (length files))
+	 (failed (length (filter not res))))
+
+    (if (= 0 failed)
+        (exit 0)
+	(begin
+	  (format #t "~%~a tests failed out of ~a~%"
+		  failed total)
+	  (exit failed)))))
+
+;;; Basic RnRS constructs.
+
+(and (eq? 2 (begin (+ 2 4) 5 2))
+     ((lambda (x y)
+	(and (eq? x 1) (eq? y 2)
+	     (begin
+	       (set! x 11) (set! y 22)
+	       (and (eq? x 11) (eq? y 22)))))
+      1 2)
+     (let ((x 1) (y 3))
+       (and (eq? x 1) (eq? y 3)))
+     (let loop ((x #t))
+       (if (not x)
+	   #t
+	   (loop #f))))
+
+(let ((set-counter2 #f))
+  (define (get-counter2)
+    (call/cc
+     (lambda (k)
+       (set! set-counter2 k)
+       1)))
+  (define (loop counter1)
+    (let ((counter2 (get-counter2)))
+      (set! counter1 (1+ counter1))
+      (cond ((not (= counter1 counter2))
+             (error "bad call/cc behaviour" counter1 counter2))
+            ((> counter1 10)
+             #t)
+            (else
+             (set-counter2 (1+ counter2))))))
+  (loop 0))
+
+(let* ((next #f)
+       (counter 0)
+       (result (call/cc
+                 (lambda (k)
+                   (set! next k)
+                   1))))
+  (set! counter (+ 1 counter))
+  (cond ((not (= counter result))
+         (error "bad call/cc behaviour" counter result))
+        ((> counter 10)
+         #t)
+        (else
+         (next (+ 1 counter)))))
+;; Test that nonlocal exits of the VM work.
+
+(begin
+  (define (foo thunk)
+    (catch #t thunk (lambda args args)))
+  (foo
+   (lambda ()
+     (let ((a 'one))
+       (1+ a)))))
+       
+(define func
+  (let ((x 2))
+    (lambda ()
+      (let ((x++ (+ 1 x)))
+	(set! x x++)
+	x++))))
+
+(list (func) (func) (func))
+
+(define (uid)
+  (let* ((x 2)
+	 (do-uid (lambda ()
+		   (let ((x++ (+ 1 x)))
+		     (set! x x++)
+		     x++))))
+    (do-uid)))
+
+(list (uid) (uid) (uid))
+(define (stuff)
+  (let* ((x 2)
+	 (chbouib (lambda (z)
+		    (+ 7 z x))))
+    (chbouib 77)))
+
+(stuff)
+(define (extract-symbols exp)
+  (define (process x out cont)
+    (cond ((pair? x)
+           (process (car x)
+                    out
+                    (lambda (car-x out)
+                      ;; used to have a bug here whereby `x' was
+                      ;; modified in the self-tail-recursion to (process
+                      ;; (cdr x) ...), because we didn't allocate fresh
+                      ;; externals when doing self-tail-recursion.
+                      (process (cdr x)
+                               out
+                               (lambda (cdr-x out)
+                                 (cont (cons car-x cdr-x)
+                                       out))))))
+          ((symbol? x)
+           (cont x (cons x out)))
+          (else
+           (cont x out))))
+  (process exp '() (lambda (x out) out)))
+
+(extract-symbols '(a b . c))
+(let ((n+ 0))
+  (do ((n- 5  (1- n-))
+       (n+ n+ (1+ n+)))
+      ((= n- 0))
+    (format #f "n- = ~a~%" n-)))
+;; Are global bindings reachable at run-time?  This relies on the
+;; `object-ref' and `object-set' instructions.
+
+(begin
+
+  (define the-binding "hello")
+
+  ((lambda () the-binding))
+
+  ((lambda () (set! the-binding "world")))
+
+  ((lambda () the-binding)))
+
+;; Check whether literal integers are correctly signed.
+
+(and (=  4294967295 (- (expt 2 32) 1))      ;; unsigned
+     (= -2147483648 (- (expt 2 31)))        ;; signed
+     (=  2147483648 (expt 2 31)))           ;; unsigned
+;; Are built-in macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
+(read-options)
+;; Are macros well-expanded at compilation-time?
+
+(defmacro minus-binary (a b)
+  `(- ,a ,b))
+
+(define-macro (plus . args)
+  `(let ((res (+ ,@args)))
+     ;;(format #t "plus -> ~a~%" res)
+     res))
+
+
+(plus (let* ((x (minus-binary 12 7)) ;; 5
+	     (y (minus-binary x 1))) ;; 4
+	(plus x y 5)) ;; 14
+      12              ;; 26
+      (expt 2 3))     ;; => 34
+
+; Currently, map is a C function, so this is a way of testing that the
+; VM is reentrant.
+
+(begin
+
+  (define (square x)
+    (* x x))
+
+  (map (lambda (x) (square x))
+       '(1 2 3)))
+;;; Pattern matching with `(ice-9 match)'.
+;;;
+
+(use-modules (ice-9 match)
+             (srfi srfi-9))  ;; record type (FIXME_ See `t-records.scm')
+
+(define-record-type <stuff>
+  (%make-stuff chbouib)
+  stuff?
+  (chbouib stuff_chbouib stuff_set-chbouib!))
+
+(define (matches? obj)
+;  (format #t "matches? ~a~%" obj)
+  (match obj
+	 (($ <stuff>) #t)
+;	 (blurps    #t)
+	 ("hello"   #t)
+	 (else #f)))
+
+
+;(format #t "go!~%")
+(and (matches? (%make-stuff 12))
+     (matches? (%make-stuff 7))
+     (matches? "hello")
+;     (matches? 'blurps)
+     (not (matches? 66)))
+(define (even? x)
+  (or (zero? x)
+      (not (odd? (1- x)))))
+
+(define (odd? x)
+  (not (even? (1- x))))
+
+(even? 20)
+;; all the different permutations of or
+(list
+ ;; not in tail position, no args
+ (or)
+ ;; not in tail position, one arg
+ (or 'what)
+ (or #f)
+ ;; not in tail position, two arg
+ (or 'what 'where)
+ (or #f 'where)
+ (or #f #f)
+ (or 'what #f)
+ ;; not in tail position, value discarded
+ (begin (or 'what (error "two")) 'two)
+ ;; in tail position (within the lambdas)
+ ((lambda ()
+    (or)))
+ ((lambda ()
+    (or 'what)))
+ ((lambda ()
+    (or #f)))
+ ((lambda ()
+    (or 'what 'where)))
+ ((lambda ()
+    (or #f 'where)))
+ ((lambda ()
+    (or #f #f)))
+ ((lambda ()
+    (or 'what #f))))
+(define the-struct (vector 1 2))
+
+(define get/set
+  (make-procedure-with-setter
+   (lambda (struct name)
+     (case name
+       ((first)  (vector-ref struct 0))
+       ((second) (vector-ref struct 1))
+       (else     #f)))
+   (lambda (struct name val)
+     (case name
+       ((first)  (vector-set! struct 0 val))
+       ((second) (vector-set! struct 1 val))
+       (else     #f)))))
+
+(and (eq? (vector-ref the-struct 0) (get/set the-struct 'first))
+     (eq? (vector-ref the-struct 1) (get/set the-struct 'second))
+     (begin
+       (set! (get/set the-struct 'second) 77)
+       (eq? (vector-ref the-struct 1) (get/set the-struct 'second))))
+(list
+  `()
+  `foo
+  `(foo)
+  `(foo bar)
+  `(1 2)
+  (let ((x 1)) `,x)
+  (let ((x 1)) `(,x))
+  (let ((x 1)) ``(,x))
+  (let ((head '(a b))
+        (tail 'c))
+    `(,@head . ,tail)))
+;;; SRFI-9 Records.
+;;;
+
+(use-modules (srfi srfi-9))
+
+(define-record-type <stuff>
+  (%make-stuff chbouib)
+  stuff?
+  (chbouib stuff_chbouib stuff_set-chbouib!))
+
+
+(and (stuff? (%make-stuff 12))
+     (= 7 (stuff_chbouib (%make-stuff 7)))
+     (not (stuff? 12)))
+(list (call-with-values
+          (lambda () (values 1 2))
+        (lambda (x y) (cons x y)))
+      
+      ;; the start-stack forces a bounce through the interpreter
+      (call-with-values
+          (lambda () (start-stack 'foo (values 1 2)))
+        list)
+
+      (call-with-values
+          (lambda () (apply values '(1)))
+        list))
+