uhhhh buncha changes

1 files changed, 0 insertions, 132358 deletions

diff --git a/src/test/data/parser-torture.scm b/src/test/data/parser-torture.scm
deleted file mode 100644
index d475379..0000000
--- a/src/test/data/parser-torture.scm
+++ /dev/null
@@ -1,132358 +0,0 @@
-;;; 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))
-