path: root/src/test/data/parser-torture.scm

;;; 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))