code:
;;; Extensions to SRFI-4

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

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

;; 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 (uniform-vector? obj)
            (eq? (uniform-vector-element-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 (* (uniform-vector-length v)
                     (/ ,size (uniform-vector-element-size v)))))
         (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-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 x)
  (bytevector-ieee-single-native-set! v (+ i 4) 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 x)
  (bytevector-ieee-double-native-set! v (+ i 8) x))
(define-bytevector-type c32 c32-native 8)
(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))
                       ((generalized-vector? obj)
                        (let* ((len (generalized-vector-length obj))
                               (v (,(symbol-append 'make- tag 'vector) len)))
                          (let lp ((i 0))
                            (if (< i len)
                                (begin
                                  (,(symbol-append tag 'vector-set!)
                                   v i (generalized-vector-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)


code:
;;; srfi-6.scm --- Basic String Ports

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

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-6)
  #:re-export (open-input-string open-output-string get-output-string))

;; Currently, guile provides these functions by default, so no action
;; is needed, and this file is just a placeholder.

(cond-expand-provide (current-module) '(srfi-6))

;;; srfi-6.scm ends here

license: mit


code:
;;; 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 "libguile-srfi-srfi-60-v-3" "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))


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

(cond-expand-provide (current-module) '(srfi-37))

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


code:
;;; 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


code:
;;; 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 (compile load)
  (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


code:
;;; srfi-9.scm --- define-record-type

;; 	Copyright (C) 2001, 2002, 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 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> <accessor name>)
;;               -> (<field tag> <accessor name> <modifier 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)
  #:export (define-record-type))

(cond-expand-provide (current-module) '(srfi-9))

(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)
    (define (make-procedure-name name)
      (datum->syntax name
                     (symbol-append '% (syntax->datum name)
                                    '-procedure)))

    (syntax-case x ()
      ((_ (name formals ...) body ...)
       (identifier? #'name)
       (with-syntax ((proc-name (make-procedure-name #'name)))
         #`(begin
             (define (proc-name formals ...)
               body ...)
             proc-name ;; unused
             (define-syntax name
               (lambda (x)
                 (syntax-case x ()
                   ((_ formals ...)
                    #'(begin body ...))
                   (_
                    (identifier? x)
                    #'proc-name))))))))))

(define-syntax define-record-type
  (lambda (x)
    (define (field-identifiers field-specs)
      (syntax-case field-specs ()
        (()
         '())
        ((field-spec)
         (syntax-case #'field-spec ()
           ((name accessor) #'(name))
           ((name accessor modifier) #'(name))))
        ((field-spec rest ...)
         (append (field-identifiers #'(field-spec))
                 (field-identifiers #'(rest ...))))))

    (define (field-indices fields)
      (fold (lambda (field result)
              (let ((i (if (null? result)
                           0
                           (+ 1 (cdar result)))))
                (alist-cons field i result)))
            '()
            fields))

    (define (constructor type-name constructor-spec indices)
      (syntax-case constructor-spec ()
        ((ctor field ...)
         (let ((field-count (length indices))
               (ctor-args   (map (lambda (field)
                                   (cons (syntax->datum field) field))
                                 #'(field ...))))
           #`(define-inlinable #,constructor-spec
               (make-struct #,type-name 0
                            #,@(unfold
                                (lambda (field-num)
                                  (>= field-num field-count))
                                (lambda (field-num)
                                  (let* ((name
                                          (car (find (lambda (f+i)
                                                       (= (cdr f+i) field-num))
                                                     indices)))
                                         (arg (assq name ctor-args)))
                                    (if (pair? arg)
                                        (cdr arg)
                                        #'#f)))
                                1+
                                0)))))))

    (define (accessors type-name field-specs indices)
      (syntax-case field-specs ()
        (()
         #'())
        ((field-spec)
         (syntax-case #'field-spec ()
           ((name accessor)
            (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
              #`((define-inlinable (accessor s)
                   (if (eq? (struct-vtable s) #,type-name)
                       (struct-ref s index)
                       (throw 'wrong-type-arg 'accessor
                              "Wrong type argument: ~S" (list s)
                              (list s)))))))
           ((name accessor modifier)
            (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
              #`(#,@(accessors type-name #'((name accessor)) indices)
                 (define-inlinable (modifier s val)
                   (if (eq? (struct-vtable s) #,type-name)
                       (struct-set! s index val)
                       (throw 'wrong-type-arg 'modifier
                              "Wrong type argument: ~S" (list s)
                              (list s)))))))))
        ((field-spec rest ...)
         #`(#,@(accessors type-name #'(field-spec) indices)
            #,@(accessors type-name #'(rest ...) indices)))))

    (syntax-case x ()
      ((_ type-name constructor-spec predicate-name field-spec ...)
       (let* ((fields      (field-identifiers #'(field-spec ...)))
              (field-count (length fields))
              (layout      (string-concatenate (make-list field-count "pw")))
              (indices     (field-indices (map syntax->datum fields))))
         #`(begin
             (define type-name
               (make-vtable #,layout
                            (lambda (obj port)
                              (format port "#<~A" 'type-name)
                              #,@(map (lambda (field)
                                        (let* ((f (syntax->datum field))
                                               (i (assoc-ref indices f)))
                                          #`(format port " ~A: ~S" '#,field
                                                    (struct-ref obj #,i))))
                                      fields)
                              (format port ">"))))
             (define-inlinable (predicate-name obj)
               (and (struct? obj)
                    (eq? (struct-vtable obj) type-name)))

             #,(constructor #'type-name #'constructor-spec indices)

             #,@(accessors #'type-name #'(field-spec ...) indices)))))))

;;; srfi-9.scm ends here


code:
;;; Extensions to SRFI-9

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

;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-9 gnu)
  #:export (set-record-type-printer!))

(define (set-record-type-printer! type thunk)
  "Set a custom printer THUNK for TYPE."
  (struct-set! type vtable-index-printer thunk))


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


code:
;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
;;;; 	Copyright (C) 2009, 2010  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))

;; 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?
                        . 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? (and (pair? full-stacks?) (car full-stacks?)))
  (set! stacks '())
  (debug-enable 'debug)
  (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 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))
  "Profiles the execution of @var{thunk}.

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))
        (if (not (zero? i))
            (begin
              (thunk)
              (lp (1- i))))))
    (lambda ()
      (statprof-stop)
      (statprof-display)
      (set! procedure-data #f))))

(define-macro (with-statprof . args)
  "Profiles the expressions in its body.

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


code:
;;;; (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


code:
;;;; (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))))


code:
;;; -*- 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 (sxml match)
  #:export (sxml-match
            sxml-match-let
            sxml-match-let*)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11))

;;; 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 syntax-object->datum
  (syntax-rules ()
    ((_ stx)
     (syntax->datum stx))))

(define-syntax void
  (syntax-rules ()
    ((_) *unspecified*)))

(define %call/ec-prompt
  (make-prompt-tag))

(define-syntax call/ec
  ;; aka. `call-with-escape-continuation'
  (syntax-rules ()
    ((_ proc)
     (call-with-prompt %call/ec-prompt
                       (lambda ()
                         (proc (lambda args
                                 (apply abort-to-prompt
                                        %call/ec-prompt args))))
                       (lambda (_ . args)
                         (apply values args))))))

(define-syntax let/ec
  (syntax-rules ()
    ((_ cont body ...)
     (call/ec (lambda (cont) body ...)))))

(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


code:
;;;; (sxml simple) -- a simple interface to the SSAX parser
;;;;
;;;; 	Copyright (C) 2009, 2010  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)
  #:use-module (sxml transform)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-13)
  #:export (xml->sxml sxml->xml sxml->string universal-sxslt-rules))

(define* (xml->sxml #:optional (port (current-input-port)))
  "Use SSAX to parse an XML document into SXML. Takes one optional
argument, @var{port}, which defaults to the current input port."
  (ssax:xml->sxml port '()))

;; Universal transformation rules. Works for all XML.
(define universal-sxslt-rules
  #;
  "A set of @code{pre-post-order} rules that transform any SXML tree
into a form suitable for XML serialization by @code{(sxml transform)}'s
@code{SRV:send-reply}. Used internally by @code{sxml->xml}."
  `((@
     ((*default* . ,(lambda (attr-key . value) ((enattr attr-key) value))))
     . ,(lambda (trigger . value) (list '@ value)))
    (*TOP*       . ,(lambda (tag . xml) xml))
    (*ENTITY*    . ,(lambda (tag name) (list "&" name ";")))
    (*PI*    . ,(lambda (pi tag str) (list "<?" tag " " str "?>")))
    ;; Is this right for entities? I don't have a reference for
    ;; public-id/system-id at the moment...
    (*default*   . ,(lambda (tag . elems) (apply (entag tag) elems)))
    (*text*      . ,(lambda (trigger str)
                      (if (string? str) (string->escaped-xml str) str)))))

(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."
  (with-output-to-port port
    (lambda ()
      (SRV:send-reply
       (post-order
        tree
        universal-sxslt-rules)))))

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

;; The following two functions serialize tags and attributes. They are
;; being used in the node handlers for the post-order function, see
;; above.

(define (check-name 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))))

(define (entag tag)
  (check-name tag)
  (lambda elems
    (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
        (list #\< tag (cdar elems)
              (if (pair? (cdr elems))
                  (list #\> (cdr elems) "</" tag #\>)
                  " />"))
        (list #\< tag
              (if (pair? elems)
                  (list #\> elems "</" tag #\>)
                  " />")))))

(define (enattr attr-key)
  (check-name attr-key)
  (let ((attr-str (symbol->string attr-key)))
    (lambda (value)
      (list #\space attr-str
            "=\"" (and (not (null? value)) value) #\"))))

(define (make-char-quotator char-encoding)
  (let ((bad-chars (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)
      (let loop ((i i))
        (and (< i (string-length str))
             (if (memv (string-ref str i) charset) i
                 (loop (+ 1 i))))))

    ;; The body of the function
    (lambda (str)
      (let ((bad-pos (index-cset str 0 bad-chars)))
        (if (not bad-pos) str   ; str had all good chars
            (string-concatenate-reverse
             (let loop ((from 0) (to bad-pos) (out '()))
               (cond
                ((>= from (string-length str)) out)
                ((not to)
                 (cons (substring str from (string-length str)) out))
                (else
                 (let ((quoted-char
                        (cdr (assv (string-ref str to) char-encoding)))
                       (new-to
                        (index-cset str (+ 1 to) bad-chars)))
                   (loop (1+ to) new-to
                         (if (< from to)
                             (cons* quoted-char (substring str from to) out)
                             (cons quoted-char out)))))))))))))

;; 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
   '((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """))))

;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
;;; simple.scm ends here


code:
;;;; (sxml ssax) -- the SSAX parser
;;;;
;;;; 	Copyright (C) 2009  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
                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-fluid))
(define (current-ssax-error-port)
  (fluid-ref *current-ssax-error-port*))

(define (with-ssax-error-to-port port thunk)
  (with-fluids ((*current-ssax-error-port* port))
    (thunk)))

(define (ssax:warn port msg . args)
  (format (current-ssax-error-port)
          ";;; SSAX warning: ~a ~a\n" msg args))

(define (ucscode->string codepoint)
  (string (integer->char codepoint)))

(define char-newline #\newline)
(define char-return #\return)
(define char-tab #\tab)
(define nl "\n")

;; if condition is true, execute stmts in turn and return the result of
;; the last statement otherwise, return #f
(define-syntax when
  (syntax-rules ()
    ((when condition . stmts)
      (and condition (begin . stmts)))))

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