summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi')
-rw-r--r--module/srfi/srfi-1.scm1061
-rw-r--r--module/srfi/srfi-10.scm89
-rw-r--r--module/srfi/srfi-11.scm146
-rw-r--r--module/srfi/srfi-111.scm37
-rw-r--r--module/srfi/srfi-13.scm132
-rw-r--r--module/srfi/srfi-14.scm99
-rw-r--r--module/srfi/srfi-16.scm51
-rw-r--r--module/srfi/srfi-17.scm174
-rw-r--r--module/srfi/srfi-18.scm382
-rw-r--r--module/srfi/srfi-19.scm1460
-rw-r--r--module/srfi/srfi-2.scm31
-rw-r--r--module/srfi/srfi-26.scm66
-rw-r--r--module/srfi/srfi-27.scm96
-rw-r--r--module/srfi/srfi-28.scm34
-rw-r--r--module/srfi/srfi-31.scm35
-rw-r--r--module/srfi/srfi-34.scm84
-rw-r--r--module/srfi/srfi-35.scm350
-rw-r--r--module/srfi/srfi-37.scm234
-rw-r--r--module/srfi/srfi-38.scm207
-rw-r--r--module/srfi/srfi-39.scm55
-rw-r--r--module/srfi/srfi-4.scm118
-rw-r--r--module/srfi/srfi-4/gnu.scm80
-rw-r--r--module/srfi/srfi-41.scm505
-rw-r--r--module/srfi/srfi-42.scm66
-rw-r--r--module/srfi/srfi-42/ec.scm1053
-rw-r--r--module/srfi/srfi-43.scm1081
-rw-r--r--module/srfi/srfi-45.scm93
-rw-r--r--module/srfi/srfi-6.scm29
-rw-r--r--module/srfi/srfi-60.scm73
-rw-r--r--module/srfi/srfi-64.scm55
-rw-r--r--module/srfi/srfi-64/testing.scm1040
-rw-r--r--module/srfi/srfi-67.scm88
-rw-r--r--module/srfi/srfi-67/compare.scm686
-rw-r--r--module/srfi/srfi-69.scm336
-rw-r--r--module/srfi/srfi-71.scm267
-rw-r--r--module/srfi/srfi-8.scm31
-rw-r--r--module/srfi/srfi-88.scm53
-rw-r--r--module/srfi/srfi-9.scm348
-rw-r--r--module/srfi/srfi-9/gnu.scm168
-rw-r--r--module/srfi/srfi-98.scm44
40 files changed, 11037 insertions, 0 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
new file mode 100644
index 000000000..0806e7363
--- /dev/null
+++ b/module/srfi/srfi-1.scm
@@ -0,0 +1,1061 @@
+;;; srfi-1.scm --- List Library
+
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Some parts from the reference implementation, which is
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use.
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;; Date: 2001-06-06
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-1 (List Library).
+;;
+;; All procedures defined in SRFI-1, which are not already defined in
+;; the Guile core library, are exported. The procedures in this
+;; implementation work, but they have not been tuned for speed or
+;; memory usage.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-1)
+ :export (
+;;; Constructors
+ ;; cons <= in the core
+ ;; list <= in the core
+ xcons
+ ;; cons* <= in the core
+ ;; make-list <= in the core
+ list-tabulate
+ list-copy
+ circular-list
+ ;; iota ; Extended.
+
+;;; Predicates
+ proper-list?
+ circular-list?
+ dotted-list?
+ ;; pair? <= in the core
+ ;; null? <= in the core
+ null-list?
+ not-pair?
+ list=
+
+;;; Selectors
+ ;; car <= in the core
+ ;; cdr <= in the core
+ ;; caar <= in the core
+ ;; cadr <= in the core
+ ;; cdar <= in the core
+ ;; cddr <= in the core
+ ;; caaar <= in the core
+ ;; caadr <= in the core
+ ;; cadar <= in the core
+ ;; caddr <= in the core
+ ;; cdaar <= in the core
+ ;; cdadr <= in the core
+ ;; cddar <= in the core
+ ;; cdddr <= in the core
+ ;; caaaar <= in the core
+ ;; caaadr <= in the core
+ ;; caadar <= in the core
+ ;; caaddr <= in the core
+ ;; cadaar <= in the core
+ ;; cadadr <= in the core
+ ;; caddar <= in the core
+ ;; cadddr <= in the core
+ ;; cdaaar <= in the core
+ ;; cdaadr <= in the core
+ ;; cdadar <= in the core
+ ;; cdaddr <= in the core
+ ;; cddaar <= in the core
+ ;; cddadr <= in the core
+ ;; cdddar <= in the core
+ ;; cddddr <= in the core
+ ;; list-ref <= in the core
+ first
+ second
+ third
+ fourth
+ fifth
+ sixth
+ seventh
+ eighth
+ ninth
+ tenth
+ car+cdr
+ take
+ drop
+ take-right
+ drop-right
+ take!
+ drop-right!
+ split-at
+ split-at!
+ last
+ ;; last-pair <= in the core
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+ ;; length <= in the core
+ length+
+ ;; append <= in the core
+ ;; append! <= in the core
+ concatenate
+ concatenate!
+ ;; reverse <= in the core
+ ;; reverse! <= in the core
+ append-reverse
+ append-reverse!
+ zip
+ unzip1
+ unzip2
+ unzip3
+ unzip4
+ unzip5
+ count
+
+;;; Fold, unfold & map
+ fold
+ fold-right
+ pair-fold
+ pair-fold-right
+ reduce
+ reduce-right
+ unfold
+ unfold-right
+ ;; map ; Extended.
+ ;; for-each ; Extended.
+ append-map
+ append-map!
+ map!
+ ;; map-in-order ; Extended.
+ pair-for-each
+ filter-map
+
+;;; Filtering & partitioning
+ ;; filter <= in the core
+ partition
+ remove
+ ;; filter! <= in the core
+ partition!
+ remove!
+
+;;; Searching
+ find
+ find-tail
+ take-while
+ take-while!
+ drop-while
+ span
+ span!
+ break
+ break!
+ any
+ every
+ ;; list-index ; Extended.
+ ;; member ; Extended.
+ ;; memq <= in the core
+ ;; memv <= in the core
+
+;;; Deletion
+ ;; delete ; Extended.
+ ;; delete! ; Extended.
+ delete-duplicates
+ delete-duplicates!
+
+;;; Association lists
+ ;; assoc ; Extended.
+ ;; assq <= in the core
+ ;; assv <= in the core
+ alist-cons
+ alist-copy
+ alist-delete
+ alist-delete!
+
+;;; Set operations on lists
+ lset<=
+ lset=
+ lset-adjoin
+ lset-union
+ lset-intersection
+ lset-difference
+ lset-xor
+ lset-diff+intersection
+ lset-union!
+ lset-intersection!
+ lset-difference!
+ lset-xor!
+ lset-diff+intersection!
+
+;;; Primitive side-effects
+ ;; set-car! <= in the core
+ ;; set-cdr! <= in the core
+ )
+ :re-export (cons list cons* make-list pair? null?
+ car cdr caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ list-ref last-pair length append append! reverse reverse!
+ filter filter! memq memv assq assv set-car! set-cdr!)
+ :replace (iota map for-each map-in-order list-copy list-index member
+ delete delete! assoc)
+ )
+
+(cond-expand-provide (current-module) '(srfi-1))
+
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_srfi_1")
+
+
+;;; Constructors
+
+(define (xcons d a)
+ "Like `cons', but with interchanged arguments. Useful mostly when passed to
+higher-order procedures."
+ (cons a d))
+
+(define (wrong-type-arg caller arg)
+ (scm-error 'wrong-type-arg (symbol->string caller)
+ "Wrong type argument: ~S" (list arg) '()))
+
+(define-syntax-rule (check-arg pred arg caller)
+ (if (not (pred arg))
+ (wrong-type-arg 'caller arg)))
+
+(define (out-of-range proc arg)
+ (scm-error 'out-of-range proc
+ "Value out of range: ~A" (list arg) (list arg)))
+
+;; the srfi spec doesn't seem to forbid inexact integers.
+(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
+
+(define (list-tabulate n init-proc)
+ "Return an N-element list, where each list element is produced by applying the
+procedure INIT-PROC to the corresponding list index. The order in which
+INIT-PROC is applied to the indices is not specified."
+ (check-arg non-negative-integer? n list-tabulate)
+ (let lp ((n n) (acc '()))
+ (if (<= n 0)
+ acc
+ (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+
+(define (circular-list elt1 . elts)
+ (set! elts (cons elt1 elts))
+ (set-cdr! (last-pair elts) elts)
+ elts)
+
+(define* (iota count #:optional (start 0) (step 1))
+ (check-arg non-negative-integer? count iota)
+ (let lp ((n 0) (acc '()))
+ (if (= n count)
+ (reverse! acc)
+ (lp (+ n 1) (cons (+ start (* n step)) acc)))))
+
+;;; Predicates
+
+(define (proper-list? x)
+ (list? x))
+
+(define (circular-list? x)
+ (if (not-pair? x)
+ #f
+ (let lp ((hare (cdr x)) (tortoise x))
+ (if (not-pair? hare)
+ #f
+ (let ((hare (cdr hare)))
+ (if (not-pair? hare)
+ #f
+ (if (eq? hare tortoise)
+ #t
+ (lp (cdr hare) (cdr tortoise)))))))))
+
+(define (dotted-list? x)
+ (cond
+ ((null? x) #f)
+ ((not-pair? x) #t)
+ (else
+ (let lp ((hare (cdr x)) (tortoise x))
+ (cond
+ ((null? hare) #f)
+ ((not-pair? hare) #t)
+ (else
+ (let ((hare (cdr hare)))
+ (cond
+ ((null? hare) #f)
+ ((not-pair? hare) #t)
+ ((eq? hare tortoise) #f)
+ (else
+ (lp (cdr hare) (cdr tortoise)))))))))))
+
+(define (null-list? x)
+ (cond
+ ((proper-list? x)
+ (null? x))
+ ((circular-list? x)
+ #f)
+ (else
+ (error "not a proper list in null-list?"))))
+
+(define (not-pair? x)
+ "Return #t if X is not a pair, #f otherwise.
+
+This is shorthand notation `(not (pair? X))' and is supposed to be used for
+end-of-list checking in contexts where dotted lists are allowed."
+ (not (pair? x)))
+
+(define (list= elt= . rest)
+ (define (lists-equal a b)
+ (let lp ((a a) (b b))
+ (cond ((null? a)
+ (null? b))
+ ((null? b)
+ #f)
+ (else
+ (and (elt= (car a) (car b))
+ (lp (cdr a) (cdr b)))))))
+
+ (check-arg procedure? elt= list=)
+ (or (null? rest)
+ (let lp ((lists rest))
+ (or (null? (cdr lists))
+ (and (lists-equal (car lists) (cadr lists))
+ (lp (cdr lists)))))))
+
+;;; Selectors
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr x)
+ "Return two values, the `car' and the `cdr' of PAIR."
+ (values (car x) (cdr x)))
+
+(define take list-head)
+(define drop list-tail)
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end. Note that they diverge for circular lists.
+
+(define (take-right lis k)
+ (let lp ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ lag)))
+
+(define (drop-right lis k)
+ (let recur ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (cons (car lag) (recur (cdr lag) (cdr lead)))
+ '())))
+
+(define (take! lst i)
+ "Linear-update variant of `take'."
+ (if (= i 0)
+ '()
+ (let ((tail (drop lst (- i 1))))
+ (set-cdr! tail '())
+ lst)))
+
+(define (drop-right! lst i)
+ "Linear-update variant of `drop-right'."
+ (let ((tail (drop lst i)))
+ (if (null? tail)
+ '()
+ (let loop ((prev lst)
+ (tail (cdr tail)))
+ (if (null? tail)
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ lst)
+ lst)
+ (loop (cdr prev)
+ (cdr tail)))))))
+
+(define (split-at lst i)
+ "Return two values, a list of the elements before index I in LST, and
+a list of those after."
+ (if (< i 0)
+ (out-of-range 'split-at i)
+ (let lp ((l lst) (n i) (acc '()))
+ (if (<= n 0)
+ (values (reverse! acc) l)
+ (lp (cdr l) (- n 1) (cons (car l) acc))))))
+
+(define (split-at! lst i)
+ "Linear-update variant of `split-at'."
+ (cond ((< i 0)
+ (out-of-range 'split-at! i))
+ ((= i 0)
+ (values '() lst))
+ (else
+ (let lp ((l lst) (n (- i 1)))
+ (if (<= n 0)
+ (let ((tmp (cdr l)))
+ (set-cdr! l '())
+ (values lst tmp))
+ (lp (cdr l) (- n 1)))))))
+
+(define (last pair)
+ "Return the last element of the non-empty, finite list PAIR."
+ (car (last-pair pair)))
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+
+(define (zip clist1 . rest)
+ (let lp ((l (cons clist1 rest)) (acc '()))
+ (if (any null? l)
+ (reverse! acc)
+ (lp (map cdr l) (cons (map car l) acc)))))
+
+
+(define (unzip1 l)
+ (map first l))
+(define (unzip2 l)
+ (values (map first l) (map second l)))
+(define (unzip3 l)
+ (values (map first l) (map second l) (map third l)))
+(define (unzip4 l)
+ (values (map first l) (map second l) (map third l) (map fourth l)))
+(define (unzip5 l)
+ (values (map first l) (map second l) (map third l) (map fourth l)
+ (map fifth l)))
+
+;;; Fold, unfold & map
+
+(define fold
+ (case-lambda
+ "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+that result. See the manual for details."
+ ((kons knil list1)
+ (check-arg procedure? kons fold)
+ (check-arg list? list1 fold)
+ (let fold1 ((knil knil) (list1 list1))
+ (if (pair? list1)
+ (fold1 (kons (car list1) knil) (cdr list1))
+ knil)))
+ ((kons knil list1 list2)
+ (check-arg procedure? kons fold)
+ (let* ((len1 (length+ list1))
+ (len2 (length+ list2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "fold"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list list1 list2)) #f))
+ (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
+ (if (zero? len)
+ knil
+ (fold2 (kons (car list1) (car list2) knil)
+ (cdr list1) (cdr list2) (1- len))))))
+ ((kons knil list1 . rest)
+ (check-arg procedure? kons fold)
+ (let foldn ((knil knil) (lists (cons list1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((cars (map car lists))
+ (cdrs (map cdr lists)))
+ (foldn (apply kons (append! cars (list knil))) cdrs)))))))
+
+(define (fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons fold-right)
+ (if (null? rest)
+ (let loop ((lst (reverse clist1))
+ (result knil))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (kons (car lst) result))))
+ (let loop ((lists (map reverse (cons clist1 rest)))
+ (result knil))
+ (if (any1 null? lists)
+ result
+ (loop (map cdr lists)
+ (apply kons (append! (map car lists) (list result))))))))
+
+(define (pair-fold kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold)
+ (if (null? rest)
+ (let f ((knil knil) (list1 clist1))
+ (if (null? list1)
+ knil
+ (let ((tail (cdr list1)))
+ (f (kons list1 knil) tail))))
+ (let f ((knil knil) (lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((tails (map cdr lists)))
+ (f (apply kons (append! lists (list knil))) tails))))))
+
+
+(define (pair-fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold-right)
+ (if (null? rest)
+ (let f ((list1 clist1))
+ (if (null? list1)
+ knil
+ (kons list1 (f (cdr list1)))))
+ (let f ((lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (apply kons (append! lists (list (f (map cdr lists)))))))))
+
+(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
+ (define (reverse+tail lst seed)
+ (let loop ((lst lst)
+ (result (tail-gen seed)))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (cons (car lst) result)))))
+
+ (check-arg procedure? p unfold)
+ (check-arg procedure? f unfold)
+ (check-arg procedure? g unfold)
+ (check-arg procedure? tail-gen unfold)
+ (let loop ((seed seed)
+ (result '()))
+ (if (p seed)
+ (reverse+tail result seed)
+ (loop (g seed)
+ (cons (f seed) result)))))
+
+(define* (unfold-right p f g seed #:optional (tail '()))
+ (check-arg procedure? p unfold-right)
+ (check-arg procedure? f unfold-right)
+ (check-arg procedure? g unfold-right)
+ (let uf ((seed seed) (lis tail))
+ (if (p seed)
+ lis
+ (uf (g seed) (cons (f seed) lis)))))
+
+(define (reduce f ridentity lst)
+ "`reduce' is a variant of `fold', where the first call to F is on two
+elements from LST, rather than one element and a given initial value.
+If LST is empty, RIDENTITY is returned. If LST has just one element
+then that's the return value."
+ (check-arg procedure? f reduce)
+ (if (null? lst)
+ ridentity
+ (fold f (car lst) (cdr lst))))
+
+(define (reduce-right f ridentity lst)
+ "`reduce-right' is a variant of `fold-right', where the first call to
+F is on two elements from LST, rather than one element and a given
+initial value. If LST is empty, RIDENTITY is returned. If LST
+has just one element then that's the return value."
+ (check-arg procedure? f reduce)
+ (if (null? lst)
+ ridentity
+ (fold-right f (last lst) (drop-right lst 1))))
+
+(define map
+ (case-lambda
+ ((f l)
+ (check-arg procedure? f map)
+ (check-arg list? l map)
+ (let map1 ((l l))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
+ ((f l1 l2)
+ (check-arg procedure? f map)
+ (let* ((len1 (length+ l1))
+ (len2 (length+ l2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "map"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list l1 l2)) #f))
+ (let map2 ((l1 l1) (l2 l2) (len len))
+ (if (zero? len)
+ '()
+ (cons (f (car l1) (car l2))
+ (map2 (cdr l1) (cdr l2) (1- len)))))))
+
+ ((f l1 . rest)
+ (check-arg procedure? f map)
+ (let ((len (fold (lambda (ls len)
+ (let ((ls-len (length+ ls)))
+ (if len
+ (if ls-len (min ls-len len) len)
+ ls-len)))
+ (length+ l1)
+ rest)))
+ (if (not len)
+ (scm-error 'wrong-type-arg "map"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (cons l1 rest)) #f))
+ (let mapn ((l1 l1) (rest rest) (len len))
+ (if (zero? len)
+ '()
+ (cons (apply f (car l1) (map car rest))
+ (mapn (cdr l1) (map cdr rest) (1- len)))))))))
+
+(define map-in-order map)
+
+(define for-each
+ (case-lambda
+ ((f l)
+ (check-arg procedure? f for-each)
+ (check-arg list? l for-each)
+ (let for-each1 ((l l))
+ (unless (null? l)
+ (f (car l))
+ (for-each1 (cdr l)))))
+
+ ((f l1 l2)
+ (check-arg procedure? f for-each)
+ (let* ((len1 (length+ l1))
+ (len2 (length+ l2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "for-each"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list l1 l2)) #f))
+ (let for-each2 ((l1 l1) (l2 l2) (len len))
+ (unless (zero? len)
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2) (1- len))))))
+
+ ((f l1 . rest)
+ (check-arg procedure? f for-each)
+ (let ((len (fold (lambda (ls len)
+ (let ((ls-len (length+ ls)))
+ (if len
+ (if ls-len (min ls-len len) len)
+ ls-len)))
+ (length+ l1)
+ rest)))
+ (if (not len)
+ (scm-error 'wrong-type-arg "for-each"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (cons l1 rest)) #f))
+ (let for-eachn ((l1 l1) (rest rest) (len len))
+ (if (> len 0)
+ (begin
+ (apply f (car l1) (map car rest))
+ (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
+
+(define (append-map f clist1 . rest)
+ (concatenate (apply map f clist1 rest)))
+
+(define (append-map! f clist1 . rest)
+ (concatenate! (apply map f clist1 rest)))
+
+;; OPTIMIZE-ME: Re-use cons cells of list1
+(define map! map)
+
+(define (filter-map proc list1 . rest)
+ "Apply PROC to the elements of LIST1... and return a list of the
+results as per SRFI-1 `map', except that any #f results are omitted from
+the list returned."
+ (check-arg procedure? proc filter-map)
+ (if (null? rest)
+ (let lp ((l list1)
+ (rl '()))
+ (if (null? l)
+ (reverse! rl)
+ (let ((res (proc (car l))))
+ (if res
+ (lp (cdr l) (cons res rl))
+ (lp (cdr l) rl)))))
+ (let lp ((l (cons list1 rest))
+ (rl '()))
+ (if (any1 null? l)
+ (reverse! rl)
+ (let ((res (apply proc (map car l))))
+ (if res
+ (lp (map cdr l) (cons res rl))
+ (lp (map cdr l) rl)))))))
+
+(define (pair-for-each f clist1 . rest)
+ (check-arg procedure? f pair-for-each)
+ (if (null? rest)
+ (let lp ((l clist1))
+ (if (null? l)
+ (if #f #f)
+ (begin
+ (f l)
+ (lp (cdr l)))))
+ (let lp ((l (cons clist1 rest)))
+ (if (any1 null? l)
+ (if #f #f)
+ (begin
+ (apply f l)
+ (lp (map cdr l)))))))
+
+
+;;; Searching
+
+(define (take-while pred ls)
+ "Return a new list which is the longest initial prefix of LS whose
+elements all satisfy the predicate PRED."
+ (check-arg procedure? pred take-while)
+ (cond ((null? ls) '())
+ ((not (pred (car ls))) '())
+ (else
+ (let ((result (list (car ls))))
+ (let lp ((ls (cdr ls)) (p result))
+ (cond ((null? ls) result)
+ ((not (pred (car ls))) result)
+ (else
+ (set-cdr! p (list (car ls)))
+ (lp (cdr ls) (cdr p)))))))))
+
+(define (take-while! pred lst)
+ "Linear-update variant of `take-while'."
+ (check-arg procedure? pred take-while!)
+ (let loop ((prev #f)
+ (rest lst))
+ (cond ((null? rest)
+ lst)
+ ((pred (car rest))
+ (loop rest (cdr rest)))
+ (else
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ lst)
+ '())))))
+
+(define (drop-while pred lst)
+ "Drop the longest initial prefix of LST whose elements all satisfy the
+predicate PRED."
+ (check-arg procedure? pred drop-while)
+ (let loop ((lst lst))
+ (cond ((null? lst)
+ '())
+ ((pred (car lst))
+ (loop (cdr lst)))
+ (else lst))))
+
+(define (span pred lst)
+ "Return two values, the longest initial prefix of LST whose elements
+all satisfy the predicate PRED, and the remainder of LST."
+ (check-arg procedure? pred span)
+ (let lp ((lst lst) (rl '()))
+ (if (and (not (null? lst))
+ (pred (car lst)))
+ (lp (cdr lst) (cons (car lst) rl))
+ (values (reverse! rl) lst))))
+
+(define (span! pred list)
+ "Linear-update variant of `span'."
+ (check-arg procedure? pred span!)
+ (let loop ((prev #f)
+ (rest list))
+ (cond ((null? rest)
+ (values list '()))
+ ((pred (car rest))
+ (loop rest (cdr rest)))
+ (else
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ (values list rest))
+ (values '() list))))))
+
+(define (break pred clist)
+ "Return two values, the longest initial prefix of LST whose elements
+all fail the predicate PRED, and the remainder of LST."
+ (check-arg procedure? pred break)
+ (let lp ((clist clist) (rl '()))
+ (if (or (null? clist)
+ (pred (car clist)))
+ (values (reverse! rl) clist)
+ (lp (cdr clist) (cons (car clist) rl)))))
+
+(define (break! pred list)
+ "Linear-update variant of `break'."
+ (check-arg procedure? pred break!)
+ (let loop ((l list)
+ (prev #f))
+ (cond ((null? l)
+ (values list '()))
+ ((pred (car l))
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ (values list l))
+ (values '() list)))
+ (else
+ (loop (cdr l) l)))))
+
+(define (any pred ls . lists)
+ (check-arg procedure? pred any)
+ (if (null? lists)
+ (any1 pred ls)
+ (let lp ((lists (cons ls lists)))
+ (cond ((any1 null? lists)
+ #f)
+ ((any1 null? (map cdr lists))
+ (apply pred (map car lists)))
+ (else
+ (or (apply pred (map car lists)) (lp (map cdr lists))))))))
+
+(define (any1 pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls)
+ #f)
+ ((null? (cdr ls))
+ (pred (car ls)))
+ (else
+ (or (pred (car ls)) (lp (cdr ls)))))))
+
+(define (every pred ls . lists)
+ (check-arg procedure? pred every)
+ (if (null? lists)
+ (every1 pred ls)
+ (let lp ((lists (cons ls lists)))
+ (cond ((any1 null? lists)
+ #t)
+ ((any1 null? (map cdr lists))
+ (apply pred (map car lists)))
+ (else
+ (and (apply pred (map car lists)) (lp (map cdr lists))))))))
+
+(define (every1 pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls)
+ #t)
+ ((null? (cdr ls))
+ (pred (car ls)))
+ (else
+ (and (pred (car ls)) (lp (cdr ls)))))))
+
+(define (list-index pred clist1 . rest)
+ "Return the index of the first set of elements, one from each of
+CLIST1 ... CLISTN, that satisfies PRED."
+ (check-arg procedure? pred list-index)
+ (if (null? rest)
+ (let lp ((l clist1) (i 0))
+ (if (null? l)
+ #f
+ (if (pred (car l))
+ i
+ (lp (cdr l) (+ i 1)))))
+ (let lp ((lists (cons clist1 rest)) (i 0))
+ (cond ((any1 null? lists)
+ #f)
+ ((apply pred (map car lists)) i)
+ (else
+ (lp (map cdr lists) (+ i 1)))))))
+
+;;; Association lists
+
+(define alist-cons acons)
+
+(define (alist-copy alist)
+ "Return a copy of ALIST, copying both the pairs comprising the list
+and those making the associations."
+ (let lp ((a alist)
+ (rl '()))
+ (if (null? a)
+ (reverse! rl)
+ (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
+
+(define* (alist-delete key alist #:optional (k= equal?))
+ (check-arg procedure? k= alist-delete)
+ (let lp ((a alist) (rl '()))
+ (if (null? a)
+ (reverse! rl)
+ (if (k= key (caar a))
+ (lp (cdr a) rl)
+ (lp (cdr a) (cons (car a) rl))))))
+
+(define* (alist-delete! key alist #:optional (k= equal?))
+ (alist-delete key alist k=)) ; XXX:optimize
+
+;;; Delete / assoc / member
+
+(define* (member x ls #:optional (= equal?))
+ (cond
+ ;; This might be performance-sensitive, so punt on the check here,
+ ;; relying on memq/memv to check that = is a procedure.
+ ((eq? = eq?) (memq x ls))
+ ((eq? = eqv?) (memv x ls))
+ (else
+ (check-arg procedure? = member)
+ (find-tail (lambda (y) (= x y)) ls))))
+
+;;; Set operations on lists
+
+(define (lset<= = . rest)
+ (check-arg procedure? = lset<=)
+ (if (null? rest)
+ #t
+ (let lp ((f (car rest)) (r (cdr rest)))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (lp (car r) (cdr r)))))))
+
+(define (lset= = . rest)
+ (check-arg procedure? = lset<=)
+ (if (null? rest)
+ #t
+ (let lp ((f (car rest)) (r (cdr rest)))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
+ (lp (car r) (cdr r)))))))
+
+;; It's not quite clear if duplicates among the `rest' elements are meant to
+;; be cast out. The spec says `=' is called as (= lstelem restelem),
+;; suggesting perhaps not, but the reference implementation shows the "list"
+;; at each stage as including those elements already added. The latter
+;; corresponds to what's described for lset-union, so that's what's done.
+;;
+(define (lset-adjoin = list . rest)
+ "Add to LIST any of the elements of REST not already in the list.
+These elements are `cons'ed onto the start of LIST (so the return shares
+a common tail with LIST), but the order they're added is unspecified.
+
+The given `=' procedure is used for comparing elements, called
+as `(@var{=} listelem elem)', i.e., the second argument is one of the
+given REST parameters."
+ ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
+ ;; first, so we can pass the raw procedure through to `member',
+ ;; allowing `memq' / `memv' to be selected.
+ (define pred
+ (if (or (eq? = eq?) (eq? = eqv?))
+ =
+ (begin
+ (check-arg procedure? = lset-adjoin)
+ (lambda (x y) (= y x)))))
+
+ (let lp ((ans list) (rest rest))
+ (if (null? rest)
+ ans
+ (lp (if (member (car rest) ans pred)
+ ans
+ (cons (car rest) ans))
+ (cdr rest)))))
+
+(define (lset-union = . rest)
+ ;; Likewise, allow memq / memv to be used if possible.
+ (define pred
+ (if (or (eq? = eq?) (eq? = eqv?))
+ =
+ (begin
+ (check-arg procedure? = lset-union)
+ (lambda (x y) (= y x)))))
+
+ (fold (lambda (lis ans) ; Compute ANS + LIS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (fold (lambda (elt ans)
+ (if (member elt ans pred)
+ ans
+ (cons elt ans)))
+ ans lis))))
+ '()
+ rest))
+
+(define (lset-intersection = list1 . rest)
+ (check-arg procedure? = lset-intersection)
+ (let lp ((l list1) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (if (every (lambda (ll) (member (car l) ll =)) rest)
+ (lp (cdr l) (cons (car l) acc))
+ (lp (cdr l) acc)))))
+
+(define (lset-difference = list1 . rest)
+ (check-arg procedure? = lset-difference)
+ (if (null? rest)
+ list1
+ (let lp ((l list1) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (if (any (lambda (ll) (member (car l) ll =)) rest)
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc)))))))
+
+;(define (fold kons knil list1 . rest)
+
+(define (lset-xor = . rest)
+ (check-arg procedure? = lset-xor)
+ (fold (lambda (lst res)
+ (let lp ((l lst) (acc '()))
+ (if (null? l)
+ (let lp0 ((r res) (acc acc))
+ (if (null? r)
+ (reverse! acc)
+ (if (member (car r) lst =)
+ (lp0 (cdr r) acc)
+ (lp0 (cdr r) (cons (car r) acc)))))
+ (if (member (car l) res =)
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc))))))
+ '()
+ rest))
+
+(define (lset-diff+intersection = list1 . rest)
+ (check-arg procedure? = lset-diff+intersection)
+ (let lp ((l list1) (accd '()) (acci '()))
+ (if (null? l)
+ (values (reverse! accd) (reverse! acci))
+ (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
+ (if appears
+ (lp (cdr l) accd (cons (car l) acci))
+ (lp (cdr l) (cons (car l) accd) acci))))))
+
+
+(define (lset-union! = . rest)
+ (check-arg procedure? = lset-union!)
+ (apply lset-union = rest)) ; XXX:optimize
+
+(define (lset-intersection! = list1 . rest)
+ (check-arg procedure? = lset-intersection!)
+ (apply lset-intersection = list1 rest)) ; XXX:optimize
+
+(define (lset-xor! = . rest)
+ (check-arg procedure? = lset-xor!)
+ (apply lset-xor = rest)) ; XXX:optimize
+
+(define (lset-diff+intersection! = list1 . rest)
+ (check-arg procedure? = lset-diff+intersection!)
+ (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
+
+;;; srfi-1.scm ends here
diff --git a/module/srfi/srfi-10.scm b/module/srfi/srfi-10.scm
new file mode 100644
index 000000000..533d9f769
--- /dev/null
+++ b/module/srfi/srfi-10.scm
@@ -0,0 +1,89 @@
+;;; srfi-10.scm --- Hash-Comma Reader Extension
+
+;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module implements the syntax extension #,(), also called
+;; hash-comma, which is defined in SRFI-10.
+;;
+;; The support for SRFI-10 consists of the procedure
+;; `define-reader-ctor' for defining new reader constructors and the
+;; read syntax form
+;;
+;; #,(<ctor> <datum> ...)
+;;
+;; where <ctor> must be a symbol for which a read constructor was
+;; defined previously.
+;;
+;; Example:
+;;
+;; (define-reader-ctor 'file open-input-file)
+;; (define f '#,(file "/etc/passwd"))
+;; (read-line f)
+;; =>
+;; "root:x:0:0:root:/root:/bin/bash"
+;;
+;; Please note the quote before the #,(file ...) expression. This is
+;; necessary because ports are not self-evaluating in Guile.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-10)
+ :use-module (ice-9 rdelim)
+ :export (define-reader-ctor))
+
+(cond-expand-provide (current-module) '(srfi-10))
+
+;; This hash table stores the association between comma-hash tags and
+;; the corresponding constructor procedures.
+;;
+(define reader-ctors (make-hash-table 31))
+
+;; This procedure installs the procedure @var{proc} as the constructor
+;; for the comma-hash tag @var{symbol}.
+;;
+(define (define-reader-ctor symbol proc)
+ (hashq-set! reader-ctors symbol proc)
+ (if #f #f)) ; Return unspecified value.
+
+;; Retrieve the constructor procedure for the tag @var{symbol} or
+;; throw an error if no such tag is defined.
+;;
+(define (lookup symbol)
+ (let ((p (hashq-ref reader-ctors symbol #f)))
+ (if (procedure? p)
+ p
+ (error "unknown hash-comma tag " symbol))))
+
+;; This is the actual reader extension.
+;;
+(define (hash-comma char port)
+ (let* ((obj (read port)))
+ (if (and (list? obj) (positive? (length obj)) (symbol? (car obj)))
+ (let ((p (lookup (car obj))))
+ (let ((res (apply p (cdr obj))))
+ res))
+ (error "syntax error in hash-comma expression"))))
+
+;; Install the hash extension.
+;;
+(read-hash-extend #\, hash-comma)
+
+;;; srfi-10.scm ends here
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
new file mode 100644
index 000000000..22bda21a2
--- /dev/null
+++ b/module/srfi/srfi-11.scm
@@ -0,0 +1,146 @@
+;;; srfi-11.scm --- let-values and let*-values
+
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module exports two syntax forms: let-values and let*-values.
+;;
+;; Sample usage:
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; This binds `x' and `y' to the first to values returned by `foo',
+;; `z' to the rest of the values from `foo', and `p' and `q' to the
+;; values returned by `bar'. All of these are available to `baz'.
+;;
+;; let*-values : let-values :: let* : let
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-11)
+ :export-syntax (let-values let*-values))
+
+(cond-expand-provide (current-module) '(srfi-11))
+
+;;;;;;;;;;;;;;
+;; let-values
+;;
+;; Current approach is to translate
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
+;; (call-with-values (lambda () (bar c))
+;; (lambda (<tmp-p> <tmp-q>)
+;; (let ((x <tmp-x>)
+;; (y <tmp-y>)
+;; (z <tmp-z>)
+;; (p <tmp-p>)
+;; (q <tmp-q>))
+;; (baz x y z p q))))))
+
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((binds exp)) b0 b1 ...)
+ (syntax (call-with-values (lambda () exp)
+ (lambda binds b0 b1 ...))))
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
+
+;;;;;;;;;;;;;;
+;; let*-values
+;;
+;; Current approach is to translate
+;;
+;; (let*-values (((x y z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (x y z)
+;; (call-with-values (lambda (bar c))
+;; (lambda (p q)
+;; (baz x y z p q)))))
+
+(define-syntax let*-values
+ (syntax-rules ()
+ ((let*-values () body ...)
+ (let () body ...))
+ ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
+ (call-with-values (lambda () binding-1)
+ (lambda vars-1
+ (let*-values ((vars-2 binding-2) ...)
+ body ...))))))
+
+;;; srfi-11.scm ends here
diff --git a/module/srfi/srfi-111.scm b/module/srfi/srfi-111.scm
new file mode 100644
index 000000000..3d3cd896b
--- /dev/null
+++ b/module/srfi/srfi-111.scm
@@ -0,0 +1,37 @@
+;;; srfi-111.scm -- SRFI 111 Boxes
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-111)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (box box? unbox set-box!))
+
+(cond-expand-provide (current-module) '(srfi-111))
+
+(define-record-type <box>
+ (box value)
+ box?
+ (value unbox set-box!))
+
+(set-record-type-printer! <box>
+ (lambda (box port)
+ (display "#<box " port)
+ (display (number->string (object-address box) 16) port)
+ (display " value: ")
+ (write (unbox box) port)
+ (display ">" port)))
diff --git a/module/srfi/srfi-13.scm b/module/srfi/srfi-13.scm
new file mode 100644
index 000000000..a2d64cba3
--- /dev/null
+++ b/module/srfi/srfi-13.scm
@@ -0,0 +1,132 @@
+;;; srfi-13.scm --- String Library
+
+;; Copyright (C) 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+;;
+;; All procedures are in the core and are simply reexported here.
+
+;;; Code:
+
+(define-module (srfi srfi-13))
+
+(re-export
+;;; Predicates
+ string?
+ string-null?
+ string-any
+ string-every
+
+;;; Constructors
+ make-string
+ string
+ string-tabulate
+
+;;; List/string conversion
+ string->list
+ list->string
+ reverse-list->string
+ string-join
+
+;;; Selection
+ string-length
+ string-ref
+ string-copy
+ substring/shared
+ string-copy!
+ string-take string-take-right
+ string-drop string-drop-right
+ string-pad string-pad-right
+ string-trim string-trim-right
+ string-trim-both
+
+;;; Modification
+ string-set!
+ string-fill!
+
+;;; Comparison
+ string-compare
+ string-compare-ci
+ string= string<>
+ string< string>
+ string<= string>=
+ string-ci= string-ci<>
+ string-ci< string-ci>
+ string-ci<= string-ci>=
+ string-hash string-hash-ci
+
+;;; Prefixes/Suffixes
+ string-prefix-length
+ string-prefix-length-ci
+ string-suffix-length
+ string-suffix-length-ci
+ string-prefix?
+ string-prefix-ci?
+ string-suffix?
+ string-suffix-ci?
+
+;;; Searching
+ string-index
+ string-index-right
+ string-skip string-skip-right
+ string-count
+ string-contains string-contains-ci
+
+;;; Alphabetic case mapping
+ string-upcase
+ string-upcase!
+ string-downcase
+ string-downcase!
+ string-titlecase
+ string-titlecase!
+
+;;; Reverse/Append
+ string-reverse
+ string-reverse!
+ string-append
+ string-append/shared
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate/shared
+ string-concatenate-reverse/shared
+
+;;; Fold/Unfold/Map
+ string-map string-map!
+ string-fold
+ string-fold-right
+ string-unfold
+ string-unfold-right
+ string-for-each
+ string-for-each-index
+
+;;; Replicate/Rotate
+ xsubstring
+ string-xcopy!
+
+;;; Miscellaneous
+ string-replace
+ string-tokenize
+
+;;; Filtering/Deleting
+ string-filter
+ string-delete)
+
+(cond-expand-provide (current-module) '(srfi-13))
+
+;;; srfi-13.scm ends here
diff --git a/module/srfi/srfi-14.scm b/module/srfi/srfi-14.scm
new file mode 100644
index 000000000..ecc21e52e
--- /dev/null
+++ b/module/srfi/srfi-14.scm
@@ -0,0 +1,99 @@
+;;; srfi-14.scm --- Character-set Library
+
+;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-14))
+
+(re-export
+;;; General procedures
+ char-set?
+ char-set=
+ char-set<=
+ char-set-hash
+
+;;; Iterating over character sets
+ char-set-cursor
+ char-set-ref
+ char-set-cursor-next
+ end-of-char-set?
+ char-set-fold
+ char-set-unfold char-set-unfold!
+ char-set-for-each
+ char-set-map
+
+;;; Creating character sets
+ char-set-copy
+ char-set
+ list->char-set list->char-set!
+ string->char-set string->char-set!
+ char-set-filter char-set-filter!
+ ucs-range->char-set ucs-range->char-set!
+ ->char-set
+
+;;; Querying character sets
+ char-set-size
+ char-set-count
+ char-set->list
+ char-set->string
+ char-set-contains?
+ char-set-every
+ char-set-any
+
+;;; Character set algebra
+ char-set-adjoin char-set-adjoin!
+ char-set-delete char-set-delete!
+ char-set-complement
+ char-set-union
+ char-set-intersection
+ char-set-difference
+ char-set-xor
+ char-set-diff+intersection
+ char-set-complement!
+ char-set-union!
+ char-set-intersection!
+ char-set-difference!
+ char-set-xor!
+ char-set-diff+intersection!
+
+;;; Standard character sets
+ char-set:lower-case
+ char-set:upper-case
+ char-set:title-case
+ char-set:letter
+ char-set:digit
+ char-set:letter+digit
+ char-set:graphic
+ char-set:printing
+ char-set:whitespace
+ char-set:iso-control
+ char-set:punctuation
+ char-set:symbol
+ char-set:hex-digit
+ char-set:blank
+ char-set:ascii
+ char-set:empty
+ char-set:full)
+
+(cond-expand-provide (current-module) '(srfi-14))
+
+;;; srfi-14.scm ends here
diff --git a/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm
new file mode 100644
index 000000000..d103ce979
--- /dev/null
+++ b/module/srfi/srfi-16.scm
@@ -0,0 +1,51 @@
+;;; srfi-16.scm --- case-lambda
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller
+
+;;; Commentary:
+
+;; Implementation of SRFI-16. `case-lambda' is a syntactic form
+;; which permits writing functions acting different according to the
+;; number of arguments passed.
+;;
+;; The syntax of the `case-lambda' form is defined in the following
+;; EBNF grammar.
+;;
+;; <case-lambda>
+;; --> (case-lambda <case-lambda-clause>)
+;; <case-lambda-clause>
+;; --> (<signature> <definition-or-command>*)
+;; <signature>
+;; --> (<identifier>*)
+;; | (<identifier>* . <identifier>)
+;; | <identifier>
+;;
+;; The value returned by a `case-lambda' form is a procedure which
+;; matches the number of actual arguments against the signatures in
+;; the various clauses, in order. The first matching clause is
+;; selected, the corresponding values from the actual parameter list
+;; are bound to the variable names in the clauses and the body of the
+;; clause is evaluated.
+
+;;; Code:
+
+(define-module (srfi srfi-16)
+ #:re-export (case-lambda))
+
+;; Case-lambda is now provided by core psyntax.
diff --git a/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm
new file mode 100644
index 000000000..a14c5c33b
--- /dev/null
+++ b/module/srfi/srfi-17.scm
@@ -0,0 +1,174 @@
+;;; srfi-17.scm --- Generalized set!
+
+;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-17: Generalized set!
+;;
+;; It exports the Guile procedure `make-procedure-with-setter' under
+;; the SRFI name `getter-with-setter' and exports the standard
+;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
+;; `vector-ref' as procedures with setters, as required by the SRFI.
+;;
+;; SRFI-17 was heavily criticized during its discussion period but it
+;; was finalized anyway. One issue was its concept of globally
+;; associating setter "properties" with (procedure) values, which is
+;; non-Schemy. For this reason, this implementation chooses not to
+;; provide a way to set the setter of a procedure. In fact, (set!
+;; (setter PROC) SETTER) signals an error. The only way to attach a
+;; setter to a procedure is to create a new object (a "procedure with
+;; setter") via the `getter-with-setter' procedure. This procedure is
+;; also specified in the SRFI. Using it avoids the described
+;; problems.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-17)
+ :export (getter-with-setter)
+ :replace (;; redefined standard procedures
+ setter
+ car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
+ cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
+ caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
+ cdddar cddddr string-ref vector-ref))
+
+(cond-expand-provide (current-module) '(srfi-17))
+
+;;; Procedures
+
+(define getter-with-setter make-procedure-with-setter)
+
+(define setter
+ (getter-with-setter
+ (@ (guile) setter)
+ (lambda args
+ (error "Setting setters is not supported for a good reason."))))
+
+;;; Redefine R5RS procedures to appropriate procedures with setters
+
+(define (compose-setter setter location)
+ (lambda (obj value)
+ (setter (location obj) value)))
+
+(define car
+ (getter-with-setter (@ (guile) car)
+ set-car!))
+(define cdr
+ (getter-with-setter (@ (guile) cdr)
+ set-cdr!))
+
+(define caar
+ (getter-with-setter (@ (guile) caar)
+ (compose-setter set-car! (@ (guile) car))))
+(define cadr
+ (getter-with-setter (@ (guile) cadr)
+ (compose-setter set-car! (@ (guile) cdr))))
+(define cdar
+ (getter-with-setter (@ (guile) cdar)
+ (compose-setter set-cdr! (@ (guile) car))))
+(define cddr
+ (getter-with-setter (@ (guile) cddr)
+ (compose-setter set-cdr! (@ (guile) cdr))))
+
+(define caaar
+ (getter-with-setter (@ (guile) caaar)
+ (compose-setter set-car! (@ (guile) caar))))
+(define caadr
+ (getter-with-setter (@ (guile) caadr)
+ (compose-setter set-car! (@ (guile) cadr))))
+(define cadar
+ (getter-with-setter (@ (guile) cadar)
+ (compose-setter set-car! (@ (guile) cdar))))
+(define caddr
+ (getter-with-setter (@ (guile) caddr)
+ (compose-setter set-car! (@ (guile) cddr))))
+(define cdaar
+ (getter-with-setter (@ (guile) cdaar)
+ (compose-setter set-cdr! (@ (guile) caar))))
+(define cdadr
+ (getter-with-setter (@ (guile) cdadr)
+ (compose-setter set-cdr! (@ (guile) cadr))))
+(define cddar
+ (getter-with-setter (@ (guile) cddar)
+ (compose-setter set-cdr! (@ (guile) cdar))))
+(define cdddr
+ (getter-with-setter (@ (guile) cdddr)
+ (compose-setter set-cdr! (@ (guile) cddr))))
+
+(define caaaar
+ (getter-with-setter (@ (guile) caaaar)
+ (compose-setter set-car! (@ (guile) caaar))))
+(define caaadr
+ (getter-with-setter (@ (guile) caaadr)
+ (compose-setter set-car! (@ (guile) caadr))))
+(define caadar
+ (getter-with-setter (@ (guile) caadar)
+ (compose-setter set-car! (@ (guile) cadar))))
+(define caaddr
+ (getter-with-setter (@ (guile) caaddr)
+ (compose-setter set-car! (@ (guile) caddr))))
+(define cadaar
+ (getter-with-setter (@ (guile) cadaar)
+ (compose-setter set-car! (@ (guile) cdaar))))
+(define cadadr
+ (getter-with-setter (@ (guile) cadadr)
+ (compose-setter set-car! (@ (guile) cdadr))))
+(define caddar
+ (getter-with-setter (@ (guile) caddar)
+ (compose-setter set-car! (@ (guile) cddar))))
+(define cadddr
+ (getter-with-setter (@ (guile) cadddr)
+ (compose-setter set-car! (@ (guile) cdddr))))
+(define cdaaar
+ (getter-with-setter (@ (guile) cdaaar)
+ (compose-setter set-cdr! (@ (guile) caaar))))
+(define cdaadr
+ (getter-with-setter (@ (guile) cdaadr)
+ (compose-setter set-cdr! (@ (guile) caadr))))
+(define cdadar
+ (getter-with-setter (@ (guile) cdadar)
+ (compose-setter set-cdr! (@ (guile) cadar))))
+(define cdaddr
+ (getter-with-setter (@ (guile) cdaddr)
+ (compose-setter set-cdr! (@ (guile) caddr))))
+(define cddaar
+ (getter-with-setter (@ (guile) cddaar)
+ (compose-setter set-cdr! (@ (guile) cdaar))))
+(define cddadr
+ (getter-with-setter (@ (guile) cddadr)
+ (compose-setter set-cdr! (@ (guile) cdadr))))
+(define cdddar
+ (getter-with-setter (@ (guile) cdddar)
+ (compose-setter set-cdr! (@ (guile) cddar))))
+(define cddddr
+ (getter-with-setter (@ (guile) cddddr)
+ (compose-setter set-cdr! (@ (guile) cdddr))))
+
+(define string-ref
+ (getter-with-setter (@ (guile) string-ref)
+ string-set!))
+
+(define vector-ref
+ (getter-with-setter (@ (guile) vector-ref)
+ vector-set!))
+
+;;; srfi-17.scm ends here
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
new file mode 100644
index 000000000..7177e0690
--- /dev/null
+++ b/module/srfi/srfi-18.scm
@@ -0,0 +1,382 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2008-04-11
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-18 (Multithreading support).
+;;
+;; All procedures defined in SRFI-18, which are not already defined in
+;; the Guile core library, are exported.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-18)
+ #:use-module ((ice-9 threads) #:prefix threads:)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module ((srfi srfi-34) #:prefix srfi-34:)
+ #:use-module ((srfi srfi-35) #:select (define-condition-type
+ &error
+ condition))
+ #:export (;; Threads
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+ thread-sleep!
+ thread-terminate!
+ thread-join!
+
+ ;; Mutexes
+ make-mutex
+ mutex
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-lock!
+ mutex-unlock!
+
+ ;; Condition variables
+ make-condition-variable
+ condition-variable-name
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable-signal!
+ condition-variable-broadcast!
+
+ ;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
+
+ current-exception-handler
+ with-exception-handler
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason)
+ #:re-export ((srfi-34:raise . raise))
+ #:replace (current-time
+ current-thread
+ thread?
+ make-thread
+ make-mutex
+ mutex?
+ make-condition-variable
+ condition-variable?))
+
+(unless (provided? 'threads)
+ (error "SRFI-18 requires Guile with threads support"))
+
+(cond-expand-provide (current-module) '(srfi-18))
+
+(define (check-arg-type pred arg caller)
+ (if (pred arg)
+ arg
+ (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S" (list arg) '())))
+
+(define-condition-type &abandoned-mutex-exception &error
+ abandoned-mutex-exception?)
+(define-condition-type &join-timeout-exception &error
+ join-timeout-exception?)
+(define-condition-type &terminated-thread-exception &error
+ terminated-thread-exception?)
+(define-condition-type &uncaught-exception &error
+ uncaught-exception?
+ (reason uncaught-exception-reason))
+
+(define-record-type <mutex>
+ (%make-mutex prim name specific owner abandoned?)
+ mutex?
+ (prim mutex-prim)
+ (name mutex-name)
+ (specific mutex-specific mutex-specific-set!)
+ (owner mutex-owner set-mutex-owner!)
+ (abandoned? mutex-abandoned? set-mutex-abandoned?!))
+
+(define-record-type <condition-variable>
+ (%make-condition-variable prim name specific)
+ condition-variable?
+ (prim condition-variable-prim)
+ (name condition-variable-name)
+ (specific condition-variable-specific condition-variable-specific-set!))
+
+(define-record-type <thread>
+ (%make-thread prim name specific start-conds exception)
+ thread?
+ (prim thread-prim set-thread-prim!)
+ (name thread-name)
+ (specific thread-specific thread-specific-set!)
+ (start-conds thread-start-conds set-thread-start-conds!)
+ (exception thread-exception set-thread-exception!))
+
+(define current-thread (make-parameter (%make-thread #f #f #f #f #f)))
+(define thread-mutexes (make-parameter #f))
+
+(define (timeout->absolute-time timeout)
+ "Return an absolute time in seconds corresponding to TIMEOUT. TIMEOUT
+can be any value authorized by SRFI-18: a number (relative time), a time
+object (absolute point in time), or #f."
+ (cond ((number? timeout) ;seconds relative to now
+ (+ ((@ (guile) current-time)) timeout))
+ ((time? timeout) ;absolute point in time
+ (time->seconds timeout))
+ (else timeout))) ;pair or #f
+
+;; EXCEPTIONS
+
+;; All threads created by SRFI-18 have an initial handler installed that
+;; will squirrel away an uncaught exception to allow it to bubble out to
+;; joining threads. However for the main thread and other threads not
+;; created by SRFI-18, just let the exception bubble up by passing on
+;; doing anything with the exception.
+(define (exception-handler-for-foreign-threads obj)
+ (values))
+
+(define current-exception-handler
+ (make-parameter exception-handler-for-foreign-threads))
+
+(define (with-exception-handler handler thunk)
+ (check-arg-type procedure? handler "with-exception-handler")
+ (check-arg-type thunk? thunk "with-exception-handler")
+ (srfi-34:with-exception-handler
+ (let ((prev-handler (current-exception-handler)))
+ (lambda (obj)
+ (parameterize ((current-exception-handler prev-handler))
+ (handler obj))))
+ (lambda ()
+ (parameterize ((current-exception-handler handler))
+ (thunk)))))
+
+;; THREADS
+
+;; Create a new thread and prevent it from starting using a condition variable.
+;; Once started, install a top-level exception handler that rethrows any
+;; exceptions wrapped in an uncaught-exception wrapper.
+
+(define (with-thread-mutex-cleanup thunk)
+ (let ((mutexes (make-weak-key-hash-table)))
+ (dynamic-wind
+ values
+ (lambda ()
+ (parameterize ((thread-mutexes mutexes))
+ (thunk)))
+ (lambda ()
+ (let ((thread (current-thread)))
+ (hash-for-each (lambda (mutex _)
+ (when (eq? (mutex-owner mutex) thread)
+ (abandon-mutex! mutex)))
+ mutexes))))))
+
+(define* (make-thread thunk #:optional name)
+ (let* ((sm (make-mutex 'start-mutex))
+ (sc (make-condition-variable 'start-condition-variable))
+ (thread (%make-thread #f name #f (cons sm sc) #f)))
+ (mutex-lock! sm)
+ (let ((prim (threads:call-with-new-thread
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (parameterize ((current-thread thread))
+ (with-thread-mutex-cleanup
+ (lambda ()
+ (mutex-lock! sm)
+ (condition-variable-signal! sc)
+ (mutex-unlock! sm sc)
+ (thunk)))))
+ (lambda (key . args)
+ (set-thread-exception!
+ thread
+ (condition (&uncaught-exception
+ (reason
+ (match (cons key args)
+ (('srfi-34 obj) obj)
+ (obj obj))))))))))))
+ (set-thread-prim! thread prim)
+ (mutex-unlock! sm sc)
+ thread)))
+
+(define (thread-start! thread)
+ (match (thread-start-conds thread)
+ ((smutex . scond)
+ (set-thread-start-conds! thread #f)
+ (mutex-lock! smutex)
+ (condition-variable-signal! scond)
+ (mutex-unlock! smutex))
+ (#f #f))
+ thread)
+
+(define (thread-yield!) (threads:yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+ (let* ((t (cond ((time? timeout) (- (time->seconds timeout)
+ (time->seconds (current-time))))
+ ((number? timeout) timeout)
+ (else (scm-error 'wrong-type-arg "thread-sleep!"
+ "Wrong type argument: ~S"
+ (list timeout)
+ '()))))
+ (secs (inexact->exact (truncate t)))
+ (usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
+ (when (> secs 0) (sleep secs))
+ (when (> usecs 0) (usleep usecs))
+ *unspecified*))
+
+;; Whereas SRFI-34 leaves the continuation of a call to an exception
+;; handler unspecified, SRFI-18 has this to say:
+;;
+;; When one of the primitives defined in this SRFI raises an exception
+;; defined in this SRFI, the exception handler is called with the same
+;; continuation as the primitive (i.e. it is a tail call to the
+;; exception handler).
+;;
+;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run
+;; handlers with the continuation of the primitive call, for those
+;; primitives that throw exceptions.
+
+(define (with-exception-handlers-here thunk)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda ()
+ (with-exception-handler (lambda (exn) (abort-to-prompt tag exn))
+ thunk))
+ (lambda (k exn)
+ ((current-exception-handler) exn)))))
+
+;; A unique value.
+(define %cancel-sentinel (list 'cancelled))
+(define (thread-terminate! thread)
+ (threads:cancel-thread (thread-prim thread) %cancel-sentinel)
+ *unspecified*)
+
+;; A unique value.
+(define %timeout-sentinel (list 1))
+(define* (thread-join! thread #:optional (timeout %timeout-sentinel)
+ (timeoutval %timeout-sentinel))
+ (let ((t (thread-prim thread)))
+ (with-exception-handlers-here
+ (lambda ()
+ (let* ((v (if (eq? timeout %timeout-sentinel)
+ (threads:join-thread t)
+ (threads:join-thread t timeout %timeout-sentinel))))
+ (cond
+ ((eq? v %timeout-sentinel)
+ (if (eq? timeoutval %timeout-sentinel)
+ (srfi-34:raise (condition (&join-timeout-exception)))
+ timeoutval))
+ ((eq? v %cancel-sentinel)
+ (srfi-34:raise (condition (&terminated-thread-exception))))
+ ((thread-exception thread) => srfi-34:raise)
+ (else v)))))))
+
+;; MUTEXES
+
+(define* (make-mutex #:optional name)
+ (%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f))
+
+(define (mutex-state mutex)
+ (cond
+ ((mutex-abandoned? mutex) 'abandoned)
+ ((mutex-owner mutex))
+ ((> (threads:mutex-level (mutex-prim mutex)) 0) 'not-owned)
+ (else 'not-abandoned)))
+
+(define (abandon-mutex! mutex)
+ (set-mutex-abandoned?! mutex #t)
+ (threads:unlock-mutex (mutex-prim mutex)))
+
+(define* (mutex-lock! mutex #:optional timeout (thread (current-thread)))
+ (let ((mutexes (thread-mutexes)))
+ (when mutexes
+ (hashq-set! mutexes mutex #t)))
+ (with-exception-handlers-here
+ (lambda ()
+ (cond
+ ((threads:lock-mutex (mutex-prim mutex)
+ (timeout->absolute-time timeout))
+ (set-mutex-owner! mutex thread)
+ (when (mutex-abandoned? mutex)
+ (set-mutex-abandoned?! mutex #f)
+ (srfi-34:raise
+ (condition (&abandoned-mutex-exception))))
+ #t)
+ (else #f)))))
+
+(define %unlock-sentinel (list 'unlock))
+(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
+ (timeout %unlock-sentinel))
+ (let ((timeout (timeout->absolute-time timeout)))
+ (when (mutex-owner mutex)
+ (set-mutex-owner! mutex #f)
+ (cond
+ ((eq? cond-var %unlock-sentinel)
+ (threads:unlock-mutex (mutex-prim mutex)))
+ ((eq? timeout %unlock-sentinel)
+ (threads:wait-condition-variable (condition-variable-prim cond-var)
+ (mutex-prim mutex))
+ (threads:unlock-mutex (mutex-prim mutex)))
+ ((threads:wait-condition-variable (condition-variable-prim cond-var)
+ (mutex-prim mutex)
+ timeout)
+ (threads:unlock-mutex (mutex-prim mutex)))
+ (else #f)))))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define* (make-condition-variable #:optional name)
+ (%make-condition-variable (threads:make-condition-variable) name #f))
+
+(define (condition-variable-signal! cond)
+ (threads:signal-condition-variable (condition-variable-prim cond))
+ *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+ (threads:broadcast-condition-variable (condition-variable-prim cond))
+ *unspecified*)
+
+;; TIME
+
+(define current-time gettimeofday)
+(define (time? obj)
+ (and (pair? obj)
+ (let ((co (car obj))) (and (integer? co) (>= co 0)))
+ (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
+
+(define (time->seconds time)
+ (and (check-arg-type time? time "time->seconds")
+ (+ (car time) (/ (cdr time) 1000000))))
+
+(define (seconds->time x)
+ (and (check-arg-type number? x "seconds->time")
+ (let ((fx (truncate x)))
+ (cons (inexact->exact fx)
+ (inexact->exact (truncate (* (- x fx) 1000000)))))))
+
+;; srfi-18.scm ends here
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
new file mode 100644
index 000000000..b1c5f9e78
--- /dev/null
+++ b/module/srfi/srfi-19.scm
@@ -0,0 +1,1460 @@
+;;; srfi-19.scm --- Time/Date Library
+
+;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2018
+;; Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Rob Browning <rlb@cs.utexas.edu>
+;;; Originally from SRFI reference implementation by Will Fitzgerald.
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+;; FIXME: I haven't checked a decent amount of this code for potential
+;; performance improvements, but I suspect that there may be some
+;; substantial ones to be realized, esp. in the later "parsing" half
+;; of the file, by rewriting the code with use of more Guile native
+;; functions that do more work in a "chunk".
+;;
+;; FIXME: mkoeppe: Time zones are treated a little simplistic in
+;; SRFI-19; they are only a numeric offset. Thus, printing time zones
+;; (LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The
+;; functions taking an optional TZ-OFFSET should be extended to take a
+;; symbolic time-zone (like "CET"); this string should be stored in
+;; the DATE structure.
+
+(define-module (srfi srfi-19)
+ :use-module (srfi srfi-6)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-9)
+ :autoload (ice-9 rdelim) (read-line)
+ :use-module (ice-9 i18n)
+ :replace (current-time)
+ :export (;; Constants
+ time-duration
+ time-monotonic
+ time-process
+ time-tai
+ time-thread
+ time-utc
+ ;; Current time and clock resolution
+ current-date
+ current-julian-day
+ current-modified-julian-day
+ time-resolution
+ ;; Time object and accessors
+ make-time
+ time?
+ time-type
+ time-nanosecond
+ time-second
+ set-time-type!
+ set-time-nanosecond!
+ set-time-second!
+ copy-time
+ ;; Time comparison procedures
+ time<=?
+ time<?
+ time=?
+ time>=?
+ time>?
+ ;; Time arithmetic procedures
+ time-difference
+ time-difference!
+ add-duration
+ add-duration!
+ subtract-duration
+ subtract-duration!
+ ;; Date object and accessors
+ make-date
+ date?
+ date-nanosecond
+ date-second
+ date-minute
+ date-hour
+ date-day
+ date-month
+ date-year
+ date-zone-offset
+ date-year-day
+ date-week-day
+ date-week-number
+ ;; Time/Date/Julian Day/Modified Julian Day converters
+ date->julian-day
+ date->modified-julian-day
+ date->time-monotonic
+ date->time-tai
+ date->time-utc
+ julian-day->date
+ julian-day->time-monotonic
+ julian-day->time-tai
+ julian-day->time-utc
+ modified-julian-day->date
+ modified-julian-day->time-monotonic
+ modified-julian-day->time-tai
+ modified-julian-day->time-utc
+ time-monotonic->date
+ time-monotonic->julian-day
+ time-monotonic->modified-julian-day
+ time-monotonic->time-tai
+ time-monotonic->time-tai!
+ time-monotonic->time-utc
+ time-monotonic->time-utc!
+ time-tai->date
+ time-tai->julian-day
+ time-tai->modified-julian-day
+ time-tai->time-monotonic
+ time-tai->time-monotonic!
+ time-tai->time-utc
+ time-tai->time-utc!
+ time-utc->date
+ time-utc->julian-day
+ time-utc->modified-julian-day
+ time-utc->time-monotonic
+ time-utc->time-monotonic!
+ time-utc->time-tai
+ time-utc->time-tai!
+ ;; Date to string/string to date converters.
+ date->string
+ string->date))
+
+(cond-expand-provide (current-module) '(srfi-19))
+
+(define time-tai 'time-tai)
+(define time-utc 'time-utc)
+(define time-monotonic 'time-monotonic)
+(define time-thread 'time-thread)
+(define time-process 'time-process)
+(define time-duration 'time-duration)
+
+;; FIXME: do we want to add gc time?
+;; (define time-gc 'time-gc)
+
+;;-- LOCALE dependent constants
+
+;; See date->string
+(define locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
+(define locale-short-date-format "~m/~d/~y")
+(define locale-time-format "~H:~M:~S")
+(define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
+
+;;-- Miscellaneous Constants.
+;;-- only the tai-epoch-in-jd might need changing if
+;; a different epoch is used.
+
+(define nano 1000000000) ; nanoseconds in a second
+(define sid 86400) ; seconds in a day
+(define sihd 43200) ; seconds in a half day
+(define tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+
+;; FIXME: should this be something other than misc-error?
+(define (time-error caller type value)
+ (if value
+ (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
+ (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
+
+;; A table of leap seconds
+;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
+;; and update as necessary.
+;; this procedures reads the file in the above
+;; format and creates the leap second table
+;; it also calls the almost standard, but not R5 procedures read-line
+;; & open-input-string
+;; ie (set! leap-second-table (read-tai-utc-date "tai-utc.dat"))
+
+(define (read-tai-utc-data filename)
+ (define (convert-jd jd)
+ (* (- (inexact->exact jd) tai-epoch-in-jd) sid))
+ (define (convert-sec sec)
+ (inexact->exact sec))
+ (let ((port (open-input-file filename))
+ (table '()))
+ (let loop ((line (read-line port)))
+ (if (not (eof-object? line))
+ (begin
+ (let* ((data (read (open-input-string
+ (string-append "(" line ")"))))
+ (year (car data))
+ (jd (cadddr (cdr data)))
+ (secs (cadddr (cdddr data))))
+ (if (>= year 1972)
+ (set! table (cons
+ (cons (convert-jd jd) (convert-sec secs))
+ table)))
+ (loop (read-line port))))))
+ table))
+
+;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
+;; note they go higher to lower, and end in 1972.
+(define leap-second-table
+ '((1435708800 . 36)
+ (1341100800 . 35)
+ (1230768000 . 34)
+ (1136073600 . 33)
+ (915148800 . 32)
+ (867715200 . 31)
+ (820454400 . 30)
+ (773020800 . 29)
+ (741484800 . 28)
+ (709948800 . 27)
+ (662688000 . 26)
+ (631152000 . 25)
+ (567993600 . 24)
+ (489024000 . 23)
+ (425865600 . 22)
+ (394329600 . 21)
+ (362793600 . 20)
+ (315532800 . 19)
+ (283996800 . 18)
+ (252460800 . 17)
+ (220924800 . 16)
+ (189302400 . 15)
+ (157766400 . 14)
+ (126230400 . 13)
+ (94694400 . 12)
+ (78796800 . 11)
+ (63072000 . 10)))
+
+(define (read-leap-second-table filename)
+ (set! leap-second-table (read-tai-utc-data filename)))
+
+
+(define (leap-second-delta utc-seconds)
+ (letrec ((lsd (lambda (table)
+ (cond ((>= utc-seconds (caar table))
+ (cdar table))
+ (else (lsd (cdr table)))))))
+ (if (< utc-seconds (* (- 1972 1970) 365 sid)) 0
+ (lsd leap-second-table))))
+
+
+;;; the TIME structure; creates the accessors, too.
+
+(define-record-type time
+ (make-time-unnormalized type nanosecond second)
+ time?
+ (type time-type set-time-type!)
+ (nanosecond time-nanosecond set-time-nanosecond!)
+ (second time-second set-time-second!))
+
+(define (copy-time time)
+ (make-time (time-type time) (time-nanosecond time) (time-second time)))
+
+(define (split-real r)
+ (if (integer? r)
+ (values (inexact->exact r) 0)
+ (let ((l (truncate r)))
+ (values (inexact->exact l) (- r l)))))
+
+(define (time-normalize! t)
+ (if (>= (abs (time-nanosecond t)) 1000000000)
+ (receive (int frac)
+ (split-real (time-nanosecond t))
+ (set-time-second! t (+ (time-second t)
+ (quotient int 1000000000)))
+ (set-time-nanosecond! t (+ (remainder int 1000000000)
+ frac))))
+ (if (and (positive? (time-second t))
+ (negative? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (- (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
+ (if (and (negative? (time-second t))
+ (positive? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (+ (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
+ t)
+
+(define (make-time type nanosecond second)
+ (time-normalize! (make-time-unnormalized type nanosecond second)))
+
+;;; current-time
+
+;;; specific time getters.
+
+(define (current-time-utc)
+ ;; Resolution is microseconds.
+ (let ((tod (gettimeofday)))
+ (make-time time-utc (* (cdr tod) 1000) (car tod))))
+
+(define (current-time-tai)
+ ;; Resolution is microseconds.
+ (let* ((tod (gettimeofday))
+ (sec (car tod))
+ (usec (cdr tod)))
+ (make-time time-tai
+ (* usec 1000)
+ (+ (car tod) (leap-second-delta sec)))))
+
+;;(define (current-time-ms-time time-type proc)
+;; (let ((current-ms (proc)))
+;; (make-time time-type
+;; (quotient current-ms 10000)
+;; (* (remainder current-ms 1000) 10000))))
+
+;; -- we define it to be the same as TAI.
+;; A different implemation of current-time-montonic
+;; will require rewriting all of the time-monotonic converters,
+;; of course.
+
+(define (current-time-monotonic)
+ ;; Guile monotonic and TAI times are the same.
+ (let ((tai (current-time-tai)))
+ (make-time time-monotonic
+ (time-nanosecond tai)
+ (time-second tai))))
+
+(define (current-time-thread)
+ (time-error 'current-time 'unsupported-clock-type 'time-thread))
+
+(define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
+
+(define (current-time-process)
+ (let ((run-time (get-internal-run-time)))
+ (make-time
+ time-process
+ (* (remainder run-time internal-time-units-per-second)
+ ns-per-guile-tick)
+ (quotient run-time internal-time-units-per-second))))
+
+;;(define (current-time-gc)
+;; (current-time-ms-time time-gc current-gc-milliseconds))
+
+(define (current-time . clock-type)
+ (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+ (cond
+ ((eq? clock-type time-tai) (current-time-tai))
+ ((eq? clock-type time-utc) (current-time-utc))
+ ((eq? clock-type time-monotonic) (current-time-monotonic))
+ ((eq? clock-type time-thread) (current-time-thread))
+ ((eq? clock-type time-process) (current-time-process))
+ ;; ((eq? clock-type time-gc) (current-time-gc))
+ (else (time-error 'current-time 'invalid-clock-type clock-type)))))
+
+;; -- Time Resolution
+;; This is the resolution of the clock in nanoseconds.
+;; This will be implementation specific.
+
+(define (time-resolution . clock-type)
+ (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+ (case clock-type
+ ((time-tai) 1000)
+ ((time-utc) 1000)
+ ((time-monotonic) 1000)
+ ((time-process) ns-per-guile-tick)
+ ;; ((eq? clock-type time-thread) 1000)
+ ;; ((eq? clock-type time-gc) 10000)
+ (else (time-error 'time-resolution 'invalid-clock-type clock-type)))))
+
+;; -- Time comparisons
+
+(define (time=? t1 t2)
+ ;; Arrange tests for speed and presume that t1 and t2 are actually times.
+ ;; also presume it will be rare to check two times of different types.
+ (and (= (time-second t1) (time-second t2))
+ (= (time-nanosecond t1) (time-nanosecond t2))
+ (eq? (time-type t1) (time-type t2))))
+
+(define (time>? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (> (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<? t1 t2)
+ (or (< (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (< (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time>=? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (>= (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<=? t1 t2)
+ (or (< (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (<= (time-nanosecond t1) (time-nanosecond t2)))))
+
+;; -- Time arithmetic
+
+(define (time-difference! time1 time2)
+ (let ((sec-diff (- (time-second time1) (time-second time2)))
+ (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
+ (set-time-type! time1 time-duration)
+ (set-time-second! time1 sec-diff)
+ (set-time-nanosecond! time1 nsec-diff)
+ (time-normalize! time1)))
+
+(define (time-difference time1 time2)
+ (let ((result (copy-time time1)))
+ (time-difference! result time2)))
+
+(define (add-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (time-error 'add-duration 'not-duration duration)
+ (let ((sec-plus (+ (time-second t) (time-second duration)))
+ (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-plus)
+ (set-time-nanosecond! t nsec-plus)
+ (time-normalize! t))))
+
+(define (add-duration t duration)
+ (let ((result (copy-time t)))
+ (add-duration! result duration)))
+
+(define (subtract-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (time-error 'add-duration 'not-duration duration)
+ (let ((sec-minus (- (time-second t) (time-second duration)))
+ (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-minus)
+ (set-time-nanosecond! t nsec-minus)
+ (time-normalize! t))))
+
+(define (subtract-duration time1 duration)
+ (let ((result (copy-time time1)))
+ (subtract-duration! result duration)))
+
+;; -- Converters between types.
+
+(define (priv:time-tai->time-utc! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-tai))
+ (time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-utc)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (- (time-second time-in)
+ (leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-tai->time-utc time-in)
+ (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
+
+
+(define (time-tai->time-utc! time-in)
+ (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
+
+(define (priv:time-utc->time-tai! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-utc))
+ (time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-tai)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (+ (time-second time-in)
+ (leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-utc->time-tai time-in)
+ (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
+
+(define (time-utc->time-tai! time-in)
+ (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
+
+;; -- these depend on time-monotonic having the same definition as time-tai!
+(define (time-monotonic->time-utc time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (time-error 'time-monotonic->time-utc
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
+
+(define (time-monotonic->time-utc! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (time-error 'time-monotonic->time-utc!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
+
+(define (time-monotonic->time-tai time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (time-error 'time-monotonic->time-tai
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ ntime))
+
+(define (time-monotonic->time-tai! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (time-error 'time-monotonic->time-tai!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ time-in)
+
+(define (time-utc->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (time-error 'time-utc->time-monotonic
+ 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
+ 'time-utc->time-monotonic)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-utc->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (time-error 'time-utc->time-monotonic!
+ 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in time-in
+ 'time-utc->time-monotonic!)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (time-error 'time-tai->time-monotonic
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (time-error 'time-tai->time-monotonic!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-monotonic)
+ time-in)
+
+;; -- Date Structures
+
+;; FIXME: to be really safe, perhaps we should normalize the
+;; seconds/nanoseconds/minutes coming in to make-date...
+
+(define-record-type date
+ (make-date nanosecond second minute
+ hour day month
+ year
+ zone-offset)
+ date?
+ (nanosecond date-nanosecond set-date-nanosecond!)
+ (second date-second set-date-second!)
+ (minute date-minute set-date-minute!)
+ (hour date-hour set-date-hour!)
+ (day date-day set-date-day!)
+ (month date-month set-date-month!)
+ (year date-year set-date-year!)
+ (zone-offset date-zone-offset set-date-zone-offset!))
+
+;; gives the julian day which starts at noon.
+(define (encode-julian-day-number day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- (+ year 4800) a (if (negative? year) -1 0)))
+ (m (- (+ month (* 12 a)) 3)))
+ (+ day
+ (quotient (+ (* 153 m) 2) 5)
+ (* 365 y)
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ -32045)))
+
+;; gives the seconds/date/month/year
+(define (decode-julian-day-number jdn)
+ (let* ((days (inexact->exact (truncate jdn)))
+ (a (+ days 32044))
+ (b (quotient (+ (* 4 a) 3) 146097))
+ (c (- a (quotient (* 146097 b) 4)))
+ (d (quotient (+ (* 4 c) 3) 1461))
+ (e (- c (quotient (* 1461 d) 4)))
+ (m (quotient (+ (* 5 e) 2) 153))
+ (y (+ (* 100 b) d -4800 (quotient m 10))))
+ (values ; seconds date month year
+ (* (- jdn days) sid)
+ (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
+ (+ m 3 (* -12 (quotient m 10)))
+ (if (>= 0 y) (- y 1) y))))
+
+;; relies on the fact that we named our time zone accessor
+;; differently from MzScheme's....
+;; This should be written to be OS specific.
+
+(define (local-tz-offset utc-time)
+ ;; SRFI uses seconds West, but guile (and libc) use seconds East.
+ (- (tm:gmtoff (localtime (time-second utc-time)))))
+
+;; special thing -- ignores nanos
+(define (time->julian-day-number seconds tz-offset)
+ (+ (/ (+ seconds tz-offset sihd)
+ sid)
+ tai-epoch-in-jd))
+
+(define (leap-second? second)
+ (and (assoc second leap-second-table) #t))
+
+(define (time-utc->date time . tz-offset)
+ (if (not (eq? (time-type time) time-utc))
+ (time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (local-tz-offset time)
+ (car tz-offset)))
+ (leap-second? (leap-second? (+ offset (time-second time))))
+ (jdn (time->julian-day-number (if leap-second?
+ (- (time-second time) 1)
+ (time-second time))
+ offset)))
+
+ (call-with-values (lambda () (decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (time-tai->date time . tz-offset)
+ (if (not (eq? (time-type time) time-tai))
+ (time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (local-tz-offset (time-tai->time-utc time))
+ (car tz-offset)))
+ (seconds (- (time-second time)
+ (leap-second-delta (time-second time))))
+ (leap-second? (leap-second? (+ offset seconds)))
+ (jdn (time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ ;; adjust for leap seconds if necessary ...
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+;; this is the same as time-tai->date.
+(define (time-monotonic->date time . tz-offset)
+ (if (not (eq? (time-type time) time-monotonic))
+ (time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (local-tz-offset (time-monotonic->time-utc time))
+ (car tz-offset)))
+ (seconds (- (time-second time)
+ (leap-second-delta (time-second time))))
+ (leap-second? (leap-second? (+ offset seconds)))
+ (jdn (time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ ;; adjust for leap seconds if necessary ...
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (date->time-utc date)
+ (let* ((jdays (- (encode-julian-day-number (date-day date)
+ (date-month date)
+ (date-year date))
+ tai-epoch-in-jd))
+ ;; jdays is an integer plus 1/2,
+ (jdays-1/2 (inexact->exact (- jdays 1/2))))
+ (make-time
+ time-utc
+ (date-nanosecond date)
+ (+ (* jdays-1/2 24 60 60)
+ (* (date-hour date) 60 60)
+ (* (date-minute date) 60)
+ (date-second date)
+ (- (date-zone-offset date))))))
+
+(define (date->time-tai date)
+ (time-utc->time-tai! (date->time-utc date)))
+
+(define (date->time-monotonic date)
+ (time-utc->time-monotonic! (date->time-utc date)))
+
+(define (leap-year? year)
+ (or (= (modulo year 400) 0)
+ (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+
+;; Map 1-based month number M to number of days in the year before the
+;; start of month M (in a non-leap year).
+(define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
+ (5 . 120) (6 . 151) (7 . 181) (8 . 212)
+ (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
+
+(define (year-day day month year)
+ (let ((days-pr (assoc month month-assoc)))
+ (if (not days-pr)
+ (time-error 'date-year-day 'invalid-month-specification month))
+ (if (and (leap-year? year) (> month 2))
+ (+ day (cdr days-pr) 1)
+ (+ day (cdr days-pr)))))
+
+(define (date-year-day date)
+ (year-day (date-day date) (date-month date) (date-year date)))
+
+;; from calendar faq
+(define (week-day day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- year a))
+ (m (+ month (* 12 a) -2)))
+ (modulo (+ day
+ y
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ (quotient (* 31 m) 12))
+ 7)))
+
+(define (date-week-day date)
+ (week-day (date-day date) (date-month date) (date-year date)))
+
+(define (days-before-first-week date day-of-week-starting-week)
+ (let* ((first-day (make-date 0 0 0 0
+ 1
+ 1
+ (date-year date)
+ #f))
+ (fdweek-day (date-week-day first-day)))
+ (modulo (- day-of-week-starting-week fdweek-day)
+ 7)))
+
+;; The "-1" here is a fix for the reference implementation, to make a new
+;; week start on the given day-of-week-starting-week. date-year-day returns
+;; a day starting from 1 for 1st Jan.
+;;
+(define (date-week-number date day-of-week-starting-week)
+ (quotient (- (date-year-day date)
+ 1
+ (days-before-first-week date day-of-week-starting-week))
+ 7))
+
+(define (current-date . tz-offset)
+ (let ((time (current-time time-utc)))
+ (time-utc->date
+ time
+ (if (null? tz-offset)
+ (local-tz-offset time)
+ (car tz-offset)))))
+
+;; given a 'two digit' number, find the year within 50 years +/-
+(define (natural-year n)
+ (let* ((current-year (date-year (current-date)))
+ (current-century (* (quotient current-year 100) 100)))
+ (cond
+ ((>= n 100) n)
+ ((< n 0) n)
+ ((<= (- (+ current-century n) current-year) 50) (+ current-century n))
+ (else (+ (- current-century 100) n)))))
+
+(define (date->julian-day date)
+ (let ((nanosecond (date-nanosecond date))
+ (second (date-second date))
+ (minute (date-minute date))
+ (hour (date-hour date))
+ (day (date-day date))
+ (month (date-month date))
+ (year (date-year date))
+ (offset (date-zone-offset date)))
+ (+ (encode-julian-day-number day month year)
+ (- 1/2)
+ (+ (/ (+ (- offset)
+ (* hour 60 60)
+ (* minute 60)
+ second
+ (/ nanosecond nano))
+ sid)))))
+
+(define (date->modified-julian-day date)
+ (- (date->julian-day date)
+ 4800001/2))
+
+(define (time-utc->julian-day time)
+ (if (not (eq? (time-type time) time-utc))
+ (time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
+
+(define (time-utc->modified-julian-day time)
+ (- (time-utc->julian-day time)
+ 4800001/2))
+
+(define (time-tai->julian-day time)
+ (if (not (eq? (time-type time) time-tai))
+ (time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
+
+(define (time-tai->modified-julian-day time)
+ (- (time-tai->julian-day time)
+ 4800001/2))
+
+;; this is the same as time-tai->julian-day
+(define (time-monotonic->julian-day time)
+ (if (not (eq? (time-type time) time-monotonic))
+ (time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
+
+(define (time-monotonic->modified-julian-day time)
+ (- (time-monotonic->julian-day time)
+ 4800001/2))
+
+(define (julian-day->time-utc jdn)
+ (let ((secs (* sid (- jdn tai-epoch-in-jd))))
+ (receive (seconds parts)
+ (split-real secs)
+ (make-time time-utc
+ (* parts nano)
+ seconds))))
+
+(define (julian-day->time-tai jdn)
+ (time-utc->time-tai! (julian-day->time-utc jdn)))
+
+(define (julian-day->time-monotonic jdn)
+ (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define (julian-day->date jdn . tz-offset)
+ (let* ((time (julian-day->time-utc jdn))
+ (offset (if (null? tz-offset)
+ (local-tz-offset time)
+ (car tz-offset))))
+ (time-utc->date time offset)))
+
+(define (modified-julian-day->date jdn . tz-offset)
+ (apply julian-day->date (+ jdn 4800001/2)
+ tz-offset))
+
+(define (modified-julian-day->time-utc jdn)
+ (julian-day->time-utc (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-tai jdn)
+ (julian-day->time-tai (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-monotonic jdn)
+ (julian-day->time-monotonic (+ jdn 4800001/2)))
+
+(define (current-julian-day)
+ (time-utc->julian-day (current-time time-utc)))
+
+(define (current-modified-julian-day)
+ (time-utc->modified-julian-day (current-time time-utc)))
+
+;; returns a string rep. of number N, of minimum LENGTH, padded with
+;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
+;; as if number->string was used. if string is longer than or equal
+;; in length to LENGTH, it's as if number->string was used.
+
+(define (padding n pad-with length)
+ (let* ((str (number->string n))
+ (str-len (string-length str)))
+ (if (or (>= str-len length)
+ (not pad-with))
+ str
+ (string-append (make-string (- length str-len) pad-with) str))))
+
+(define (last-n-digits i n)
+ (abs (remainder i (expt 10 n))))
+
+(define (locale-abbr-weekday n) (locale-day-short (+ 1 n)))
+(define (locale-long-weekday n) (locale-day (+ 1 n)))
+(define locale-abbr-month locale-month-short)
+(define locale-long-month locale-month)
+
+(define (date-reverse-lookup needle haystack-ref haystack-len
+ same?)
+ ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure
+ ;; that returns a string corresponding to the given index) by passing it
+ ;; indices lower than HAYSTACK-LEN.
+ (let loop ((index 1))
+ (cond ((> index haystack-len) #f)
+ ((same? needle (haystack-ref index))
+ index)
+ (else (loop (+ index 1))))))
+
+(define (locale-abbr-weekday->index string)
+ (date-reverse-lookup string locale-day-short 7 string=?))
+
+(define (locale-long-weekday->index string)
+ (date-reverse-lookup string locale-day 7 string=?))
+
+(define (locale-abbr-month->index string)
+ (date-reverse-lookup string locale-abbr-month 12 string=?))
+
+(define (locale-long-month->index string)
+ (date-reverse-lookup string locale-long-month 12 string=?))
+
+
+;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
+;; Print it here instead of the numerical offset if available.
+(define (locale-print-time-zone date port)
+ (tz-printer (date-zone-offset date) port))
+
+(define (locale-am-string/pm hr)
+ (if (> hr 11) (locale-pm-string) (locale-am-string)))
+
+(define (tz-printer offset port)
+ (cond
+ ((= offset 0) (display "Z" port))
+ ((negative? offset) (display "-" port))
+ (else (display "+" port)))
+ (if (not (= offset 0))
+ (let ((hours (abs (quotient offset (* 60 60))))
+ (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
+ (display (padding hours #\0 2) port)
+ (display (padding minutes #\0 2) port))))
+
+;; A table of output formatting directives.
+;; the first time is the format char.
+;; the second is a procedure that takes the date, a padding character
+;; (which might be #f), and the output port.
+;;
+(define directives
+ (list
+ (cons #\~ (lambda (date pad-with port)
+ (display #\~ port)))
+ (cons #\a (lambda (date pad-with port)
+ (display (locale-abbr-weekday (date-week-day date))
+ port)))
+ (cons #\A (lambda (date pad-with port)
+ (display (locale-long-weekday (date-week-day date))
+ port)))
+ (cons #\b (lambda (date pad-with port)
+ (display (locale-abbr-month (date-month date))
+ port)))
+ (cons #\B (lambda (date pad-with port)
+ (display (locale-long-month (date-month date))
+ port)))
+ (cons #\c (lambda (date pad-with port)
+ (display (date->string date locale-date-time-format) port)))
+ (cons #\d (lambda (date pad-with port)
+ (display (padding (date-day date)
+ #\0 2)
+ port)))
+ (cons #\D (lambda (date pad-with port)
+ (display (date->string date "~m/~d/~y") port)))
+ (cons #\e (lambda (date pad-with port)
+ (display (padding (date-day date)
+ #\Space 2)
+ port)))
+ (cons #\f (lambda (date pad-with port)
+ (receive (s ns) (floor/ (+ (* (date-second date) nano)
+ (date-nanosecond date))
+ nano)
+ (display (number->string s) port)
+ (display (locale-decimal-point) port)
+ (let ((str (padding ns #\0 9)))
+ (display (substring str 0 1) port)
+ (display (string-trim-right str #\0 1) port)))))
+ (cons #\h (lambda (date pad-with port)
+ (display (date->string date "~b") port)))
+ (cons #\H (lambda (date pad-with port)
+ (display (padding (date-hour date)
+ pad-with 2)
+ port)))
+ (cons #\I (lambda (date pad-with port)
+ (let ((hr (date-hour date)))
+ (if (> hr 12)
+ (display (padding (- hr 12)
+ pad-with 2)
+ port)
+ (display (padding hr
+ pad-with 2)
+ port)))))
+ (cons #\j (lambda (date pad-with port)
+ (display (padding (date-year-day date)
+ pad-with 3)
+ port)))
+ (cons #\k (lambda (date pad-with port)
+ (display (padding (date-hour date)
+ #\Space 2)
+ port)))
+ (cons #\l (lambda (date pad-with port)
+ (let ((hr (if (> (date-hour date) 12)
+ (- (date-hour date) 12) (date-hour date))))
+ (display (padding hr #\Space 2)
+ port))))
+ (cons #\m (lambda (date pad-with port)
+ (display (padding (date-month date)
+ pad-with 2)
+ port)))
+ (cons #\M (lambda (date pad-with port)
+ (display (padding (date-minute date)
+ pad-with 2)
+ port)))
+ (cons #\n (lambda (date pad-with port)
+ (newline port)))
+ (cons #\N (lambda (date pad-with port)
+ (display (padding (date-nanosecond date)
+ pad-with 9)
+ port)))
+ (cons #\p (lambda (date pad-with port)
+ (display (locale-am-string/pm (date-hour date)) port)))
+ (cons #\r (lambda (date pad-with port)
+ (display (date->string date "~I:~M:~S ~p") port)))
+ (cons #\s (lambda (date pad-with port)
+ (display (time-second (date->time-utc date)) port)))
+ (cons #\S (lambda (date pad-with port)
+ (if (> (date-nanosecond date)
+ nano)
+ (display (padding (+ (date-second date) 1)
+ pad-with 2)
+ port)
+ (display (padding (date-second date)
+ pad-with 2)
+ port))))
+ (cons #\t (lambda (date pad-with port)
+ (display #\Tab port)))
+ (cons #\T (lambda (date pad-with port)
+ (display (date->string date "~H:~M:~S") port)))
+ (cons #\U (lambda (date pad-with port)
+ (if (> (days-before-first-week date 0) 0)
+ (display (padding (+ (date-week-number date 0) 1)
+ #\0 2) port)
+ (display (padding (date-week-number date 0)
+ #\0 2) port))))
+ (cons #\V (lambda (date pad-with port)
+ (display (padding (date-week-number date 1)
+ #\0 2) port)))
+ (cons #\w (lambda (date pad-with port)
+ (display (date-week-day date) port)))
+ (cons #\x (lambda (date pad-with port)
+ (display (date->string date locale-short-date-format) port)))
+ (cons #\X (lambda (date pad-with port)
+ (display (date->string date locale-time-format) port)))
+ (cons #\W (lambda (date pad-with port)
+ (if (> (days-before-first-week date 1) 0)
+ (display (padding (+ (date-week-number date 1) 1)
+ #\0 2) port)
+ (display (padding (date-week-number date 1)
+ #\0 2) port))))
+ (cons #\y (lambda (date pad-with port)
+ (display (padding (last-n-digits
+ (date-year date) 2)
+ pad-with
+ 2)
+ port)))
+ (cons #\Y (lambda (date pad-with port)
+ (display (date-year date) port)))
+ (cons #\z (lambda (date pad-with port)
+ (tz-printer (date-zone-offset date) port)))
+ (cons #\Z (lambda (date pad-with port)
+ (locale-print-time-zone date port)))
+ (cons #\1 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~d") port)))
+ (cons #\2 (lambda (date pad-with port)
+ (display (date->string date "~H:~M:~S~z") port)))
+ (cons #\3 (lambda (date pad-with port)
+ (display (date->string date "~H:~M:~S") port)))
+ (cons #\4 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
+ (cons #\5 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
+
+
+(define (get-formatter char)
+ (let ((associated (assoc char directives)))
+ (if associated (cdr associated) #f)))
+
+(define (date-printer date index format-string str-len port)
+ (if (< index str-len)
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (begin
+ (display current-char port)
+ (date-printer date (+ index 1) format-string str-len port))
+ (if (= (+ index 1) str-len) ; bad format string.
+ (time-error 'date-printer 'bad-date-format-string
+ format-string)
+ (let ((pad-char? (string-ref format-string (+ index 1))))
+ (cond
+ ((char=? pad-char? #\-)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (time-error 'date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (time-error 'date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #f port)
+ (date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+
+ ((char=? pad-char? #\_)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (time-error 'date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (time-error 'date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\Space port)
+ (date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+ (else
+ (let ((formatter (get-formatter
+ (string-ref format-string
+ (+ index 1)))))
+ (if (not formatter)
+ (time-error 'date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\0 port)
+ (date-printer date
+ (+ index 2)
+ format-string
+ str-len
+ port))))))))))))
+
+
+(define (date->string date . format-string)
+ (let ((str-port (open-output-string))
+ (fmt-str (if (null? format-string) "~c" (car format-string))))
+ (date-printer date 0 fmt-str (string-length fmt-str) str-port)
+ (get-output-string str-port)))
+
+(define (char->int ch)
+ (case ch
+ ((#\0) 0)
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ (else (time-error 'char->int 'bad-date-template-string
+ (list "Non-integer character" ch)))))
+
+;; read an integer upto n characters long on port; upto -> #f is any length
+(define (integer-reader upto port)
+ (let loop ((accum 0) (nchars 0))
+ (let ((ch (peek-char port)))
+ (if (or (eof-object? ch)
+ (not (char-numeric? ch))
+ (and upto (>= nchars upto)))
+ accum
+ (loop (+ (* accum 10) (char->int (read-char port)))
+ (+ nchars 1))))))
+
+(define (make-integer-reader upto)
+ (lambda (port)
+ (integer-reader upto port)))
+
+;; read *exactly* n characters and convert to integer; could be padded
+(define (integer-reader-exact n port)
+ (let ((padding-ok #t))
+ (define (accum-int port accum nchars)
+ (let ((ch (peek-char port)))
+ (cond
+ ((>= nchars n) accum)
+ ((eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ "Premature ending to integer read."))
+ ((char-numeric? ch)
+ (set! padding-ok #f)
+ (accum-int port
+ (+ (* accum 10) (char->int (read-char port)))
+ (+ nchars 1)))
+ (padding-ok
+ (read-char port) ; consume padding
+ (accum-int port accum (+ nchars 1)))
+ (else ; padding where it shouldn't be
+ (time-error 'string->date 'bad-date-template-string
+ "Non-numeric characters in integer read.")))))
+ (accum-int port 0 0)))
+
+
+(define (make-integer-exact-reader n)
+ (lambda (port)
+ (integer-reader-exact n port)))
+
+(define (zone-reader port)
+ (let ((offset 0)
+ (positive? #f))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch)))
+ (if (or (char=? ch #\Z) (char=? ch #\z))
+ 0
+ (begin
+ (cond
+ ((char=? ch #\+) (set! positive? #t))
+ ((char=? ch #\-) (set! positive? #f))
+ (else
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (* (char->int ch)
+ 10 60 60)))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (char->int ch)
+ 60 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (char->int ch)
+ 10 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (char->int ch)
+ 60))))
+ (if positive? offset (- offset)))))))
+
+;; looking at a char, read the char string, run thru indexer, return index
+(define (locale-reader port indexer)
+
+ (define (read-char-string result)
+ (let ((ch (peek-char port)))
+ (if (char-alphabetic? ch)
+ (read-char-string (cons (read-char port) result))
+ (list->string (reverse! result)))))
+
+ (let* ((str (read-char-string '()))
+ (index (indexer str)))
+ (if index index (time-error 'string->date
+ 'bad-date-template-string
+ (list "Invalid string for " indexer)))))
+
+(define (make-locale-reader indexer)
+ (lambda (port)
+ (locale-reader port indexer)))
+
+(define (make-char-id-reader char)
+ (lambda (port)
+ (if (char=? char (read-char port))
+ char
+ (time-error 'string->date
+ 'bad-date-template-string
+ "Invalid character match."))))
+
+;; A List of formatted read directives.
+;; Each entry is a list.
+;; 1. the character directive;
+;; a procedure, which takes a character as input & returns
+;; 2. #t as soon as a character on the input port is acceptable
+;; for input,
+;; 3. a port reader procedure that knows how to read the current port
+;; for a value. Its one parameter is the port.
+;; 4. an optional action procedure, that takes the value (from 3.) and
+;; some object (here, always the date) and (probably) side-effects it.
+;; If no action is required, as with ~A, this element may be #f.
+
+(define read-directives
+ (let ((ireader4 (make-integer-reader 4))
+ (ireader2 (make-integer-reader 2))
+ (eireader2 (make-integer-exact-reader 2))
+ (locale-reader-abbr-weekday (make-locale-reader
+ locale-abbr-weekday->index))
+ (locale-reader-long-weekday (make-locale-reader
+ locale-long-weekday->index))
+ (locale-reader-abbr-month (make-locale-reader
+ locale-abbr-month->index))
+ (locale-reader-long-month (make-locale-reader
+ locale-long-month->index))
+ (char-fail (lambda (ch) #t)))
+
+ (list
+ (list #\~ char-fail (make-char-id-reader #\~) #f)
+ (list #\a char-alphabetic? locale-reader-abbr-weekday #f)
+ (list #\A char-alphabetic? locale-reader-long-weekday #f)
+ (list #\b char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\B char-alphabetic? locale-reader-long-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\d char-numeric? ireader2 (lambda (val object)
+ (set-date-day!
+ object val)))
+ (list #\e char-fail eireader2 (lambda (val object)
+ (set-date-day! object val)))
+ (list #\h char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\H char-numeric? ireader2 (lambda (val object)
+ (set-date-hour! object val)))
+ (list #\k char-fail eireader2 (lambda (val object)
+ (set-date-hour! object val)))
+ (list #\m char-numeric? ireader2 (lambda (val object)
+ (set-date-month! object val)))
+ (list #\M char-numeric? ireader2 (lambda (val object)
+ (set-date-minute!
+ object val)))
+ (list #\S char-numeric? ireader2 (lambda (val object)
+ (set-date-second! object val)))
+ (list #\y char-fail eireader2
+ (lambda (val object)
+ (set-date-year! object (natural-year val))))
+ (list #\Y char-numeric? ireader4 (lambda (val object)
+ (set-date-year! object val)))
+ (list #\z (lambda (c)
+ (or (char=? c #\Z)
+ (char=? c #\z)
+ (char=? c #\+)
+ (char=? c #\-)))
+ zone-reader (lambda (val object)
+ (set-date-zone-offset! object val))))))
+
+(define (priv:string->date date index format-string str-len port template-string)
+ (define (skip-until port skipper)
+ (let ((ch (peek-char port)))
+ (if (eof-object? ch)
+ (time-error 'string->date 'bad-date-format-string template-string)
+ (if (not (skipper ch))
+ (begin (read-char port) (skip-until port skipper))))))
+ (if (< index str-len)
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (let ((port-char (read-char port)))
+ (if (or (eof-object? port-char)
+ (not (char=? current-char port-char)))
+ (time-error 'string->date
+ 'bad-date-format-string template-string))
+ (priv:string->date date
+ (+ index 1)
+ format-string
+ str-len
+ port
+ template-string))
+ ;; otherwise, it's an escape, we hope
+ (if (> (+ index 1) str-len)
+ (time-error 'string->date
+ 'bad-date-format-string template-string)
+ (let* ((format-char (string-ref format-string (+ index 1)))
+ (format-info (assoc format-char read-directives)))
+ (if (not format-info)
+ (time-error 'string->date
+ 'bad-date-format-string template-string)
+ (begin
+ (let ((skipper (cadr format-info))
+ (reader (caddr format-info))
+ (actor (cadddr format-info)))
+ (skip-until port skipper)
+ (let ((val (reader port)))
+ (if (eof-object? val)
+ (time-error 'string->date
+ 'bad-date-format-string
+ template-string)
+ (if actor (actor val date))))
+ (priv:string->date date
+ (+ index 2)
+ format-string
+ str-len
+ port
+ template-string))))))))))
+
+(define (string->date input-string template-string)
+ (define (date-ok? date)
+ (and (date-nanosecond date)
+ (date-second date)
+ (date-minute date)
+ (date-hour date)
+ (date-day date)
+ (date-month date)
+ (date-year date)
+ (date-zone-offset date)))
+ (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
+ (priv:string->date newdate
+ 0
+ template-string
+ (string-length template-string)
+ (open-input-string input-string)
+ template-string)
+ (if (not (date-zone-offset newdate))
+ (begin
+ ;; this is necessary to get DST right -- as far as we can
+ ;; get it right (think of the double/missing hour in the
+ ;; night when we are switching between normal time and DST).
+ (set-date-zone-offset! newdate
+ (local-tz-offset
+ (make-time time-utc 0 0)))
+ (set-date-zone-offset! newdate
+ (local-tz-offset
+ (date->time-utc newdate)))))
+ (if (date-ok? newdate)
+ newdate
+ (time-error
+ 'string->date
+ 'bad-date-format-string
+ (list "Incomplete date read. " newdate template-string)))))
+
+;;; srfi-19.scm ends here
diff --git a/module/srfi/srfi-2.scm b/module/srfi/srfi-2.scm
new file mode 100644
index 000000000..c09323fbb
--- /dev/null
+++ b/module/srfi/srfi-2.scm
@@ -0,0 +1,31 @@
+;;; srfi-2.scm --- and-let*
+
+;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-2)
+ :use-module (ice-9 and-let-star)
+ :re-export-syntax (and-let*))
+
+(cond-expand-provide (current-module) '(srfi-2))
+
+;;; srfi-2.scm ends here
diff --git a/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm
new file mode 100644
index 000000000..4a9f4413a
--- /dev/null
+++ b/module/srfi/srfi-26.scm
@@ -0,0 +1,66 @@
+;;; srfi-26.scm --- specializing parameters without currying.
+
+;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-26)
+ :export (cut cute))
+
+(cond-expand-provide (current-module) '(srfi-26))
+
+(define-syntax cut
+ (lambda (stx)
+ (syntax-case stx ()
+ ((cut slot0 slot1+ ...)
+ (let loop ((slots #'(slot0 slot1+ ...))
+ (params '())
+ (args '()))
+ (if (null? slots)
+ #`(lambda #,(reverse params) #,(reverse args))
+ (let ((s (car slots))
+ (rest (cdr slots)))
+ (with-syntax (((var) (generate-temporaries '(var))))
+ (syntax-case s (<> <...>)
+ (<>
+ (loop rest (cons #'var params) (cons #'var args)))
+ (<...>
+ (if (pair? rest)
+ (error "<...> not on the end of cut expression"))
+ #`(lambda #,(append (reverse params) #'var)
+ (apply #,@(reverse (cons #'var args)))))
+ (else
+ (loop rest params (cons s args))))))))))))
+
+(define-syntax cute
+ (lambda (stx)
+ (syntax-case stx ()
+ ((cute slots ...)
+ (let loop ((slots #'(slots ...))
+ (bindings '())
+ (arguments '()))
+ (define (process-hole)
+ (loop (cdr slots) bindings (cons (car slots) arguments)))
+ (if (null? slots)
+ #`(let #,bindings
+ (cut #,@(reverse arguments)))
+ (syntax-case (car slots) (<> <...>)
+ (<> (process-hole))
+ (<...> (process-hole))
+ (expr
+ (with-syntax (((t) (generate-temporaries '(t))))
+ (loop (cdr slots)
+ (cons #'(t expr) bindings)
+ (cons #'t arguments)))))))))))
diff --git a/module/srfi/srfi-27.scm b/module/srfi/srfi-27.scm
new file mode 100644
index 000000000..0794a437d
--- /dev/null
+++ b/module/srfi/srfi-27.scm
@@ -0,0 +1,96 @@
+;;; srfi-27.scm --- Sources of Random Bits
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-27)
+ #:export (random-integer
+ random-real
+ default-random-source
+ make-random-source
+ random-source?
+ random-source-state-ref
+ random-source-state-set!
+ random-source-randomize!
+ random-source-pseudo-randomize!
+ random-source-make-integers
+ random-source-make-reals)
+ #:use-module (srfi srfi-9))
+
+(cond-expand-provide (current-module) '(srfi-27))
+
+(define-record-type :random-source
+ (%make-random-source state)
+ random-source?
+ (state random-source-state set-random-source-state!))
+
+(define (make-random-source)
+ (%make-random-source (seed->random-state 0)))
+
+(define (random-source-state-ref s)
+ (random-state->datum (random-source-state s)))
+
+(define (random-source-state-set! s state)
+ (set-random-source-state! s (datum->random-state state)))
+
+(define (random-source-randomize! s)
+ (let ((time (gettimeofday)))
+ (set-random-source-state! s (seed->random-state
+ (+ (* (car time) 1e6) (cdr time))))))
+
+(define (random-source-pseudo-randomize! s i j)
+ (set-random-source-state! s (seed->random-state (i+j->seed i j))))
+
+(define (i+j->seed i j)
+ (logior (ash (spread i 2) 1)
+ (spread j 2)))
+
+(define (spread n amount)
+ (let loop ((result 0) (n n) (shift 0))
+ (if (zero? n)
+ result
+ (loop (logior result
+ (ash (logand n 1) shift))
+ (ash n -1)
+ (+ shift amount)))))
+
+(define (random-source-make-integers s)
+ (lambda (n)
+ (random n (random-source-state s))))
+
+(define random-source-make-reals
+ (case-lambda
+ ((s)
+ (lambda ()
+ (let loop ()
+ (let ((x (random:uniform (random-source-state s))))
+ (if (zero? x)
+ (loop)
+ x)))))
+ ((s unit)
+ (or (and (real? unit) (< 0 unit 1))
+ (error "unit must be real between 0 and 1" unit))
+ (random-source-make-reals s))))
+
+(define default-random-source (make-random-source))
+(define random-integer (random-source-make-integers default-random-source))
+(define random-real (random-source-make-reals default-random-source))
diff --git a/module/srfi/srfi-28.scm b/module/srfi/srfi-28.scm
new file mode 100644
index 000000000..7fc73eb7e
--- /dev/null
+++ b/module/srfi/srfi-28.scm
@@ -0,0 +1,34 @@
+;;; srfi-28.scm --- Basic Format Strings
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module provides a wrapper for simple-format that always outputs
+;; to a string.
+;;
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-28)
+ #:replace (format))
+
+(define (format message . args)
+ (apply simple-format #f message args))
+
+(cond-expand-provide (current-module) '(srfi-28))
diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
new file mode 100644
index 000000000..f11aa8419
--- /dev/null
+++ b/module/srfi/srfi-31.scm
@@ -0,0 +1,35 @@
+;;; srfi-31.scm --- special form for recursive evaluation
+
+;; Copyright (C) 2004, 2006, 2012 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Original author: Rob Browning <rlb@defaultvalue.org>
+
+(define-module (srfi srfi-31)
+ #:export (rec))
+
+(cond-expand-provide (current-module) '(srfi-31))
+
+(define-syntax rec
+ (syntax-rules ()
+ "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+ ((_ (name . formals) body ...) ; procedure
+ (letrec ((name (lambda formals body ...)))
+ name))
+ ((_ name expr) ; arbitrary object
+ (letrec ((name expr))
+ name))))
diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm
new file mode 100644
index 000000000..183f0ae23
--- /dev/null
+++ b/module/srfi/srfi-34.scm
@@ -0,0 +1,84 @@
+;;; srfi-34.scm --- Exception handling for programs
+
+;; Copyright (C) 2003, 2006, 2008, 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram <neil@ossau.uklinux.net>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-34: Exception Handling for
+;; Programs. For documentation please see the SRFI-34 document; this
+;; module is not yet documented at all in the Guile manual.
+
+;;; Code:
+
+(define-module (srfi srfi-34)
+ #:export (with-exception-handler)
+ #:replace (raise)
+ #:export-syntax (guard))
+
+(cond-expand-provide (current-module) '(srfi-34))
+
+(define throw-key 'srfi-34)
+
+(define (with-exception-handler handler thunk)
+ "Returns the result(s) of invoking THUNK. HANDLER must be a
+procedure that accepts one argument. It is installed as the current
+exception handler for the dynamic extent (as determined by
+dynamic-wind) of the invocation of THUNK."
+ (with-throw-handler throw-key
+ thunk
+ (lambda (key obj)
+ (handler obj))))
+
+(define (raise obj)
+ "Invokes the current exception handler on OBJ. The handler is
+called in the dynamic environment of the call to raise, except that
+the current exception handler is that in place for the call to
+with-exception-handler that installed the handler being called. The
+handler's continuation is otherwise unspecified."
+ (throw throw-key obj))
+
+(define-syntax guard
+ (syntax-rules (else)
+ "Syntax: (guard (<var> <clause1> <clause2> ...) <body>)
+Each <clause> should have the same form as a `cond' clause.
+
+Semantics: Evaluating a guard form evaluates <body> with an exception
+handler that binds the raised object to <var> and within the scope of
+that binding evaluates the clauses as if they were the clauses of a
+cond expression. That implicit cond expression is evaluated with the
+continuation and dynamic environment of the guard expression. If
+every <clause>'s <test> evaluates to false and there is no else
+clause, then raise is re-invoked on the raised object within the
+dynamic environment of the original call to raise except that the
+current exception handler is that of the guard expression."
+ ((guard (var clause ... (else e e* ...)) body body* ...)
+ (catch throw-key
+ (lambda () body body* ...)
+ (lambda (key var)
+ (cond clause ...
+ (else e e* ...)))))
+ ((guard (var clause clause* ...) body body* ...)
+ (catch throw-key
+ (lambda () body body* ...)
+ (lambda (key var)
+ (cond clause clause* ...
+ (else (throw key var))))))))
+
+
+;;; (srfi srfi-34) ends here.
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
new file mode 100644
index 000000000..626026d74
--- /dev/null
+++ b/module/srfi/srfi-35.scm
@@ -0,0 +1,350 @@
+;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
+
+;; Copyright (C) 2007-2011, 2017 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-35, "Conditions". Conditions are a
+;; means to convey information about exceptional conditions between parts of
+;; a program.
+
+;;; Code:
+
+(define-module (srfi srfi-35)
+ #:use-module (srfi srfi-1)
+ #:export (make-condition-type condition-type?
+ make-condition condition? condition-has-type? condition-ref
+ make-compound-condition extract-condition
+ define-condition-type condition
+ &condition
+ &message message-condition? condition-message
+ &serious serious-condition?
+ &error error?))
+
+(cond-expand-provide (current-module) '(srfi-35))
+
+
+;;;
+;;; Condition types.
+;;;
+
+(define %condition-type-vtable
+ ;; The vtable of all condition types.
+ ;; user fields: id, parent, all-field-names
+ (let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
+
+(define (%make-condition-type layout id parent all-fields)
+ (let ((struct (make-struct/no-tail %condition-type-vtable
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields)))
+
+ ;; Hack to associate STRUCT with a name, providing a better name for
+ ;; GOOPS classes as returned by `class-of' et al.
+ (set-struct-vtable-name! struct (cond ((symbol? id) id)
+ ((string? id) (string->symbol id))
+ (else (string->symbol ""))))
+ struct))
+
+(define (condition-type? obj)
+ "Return true if OBJ is a condition type."
+ (and (struct? obj)
+ (eq? (struct-vtable obj)
+ %condition-type-vtable)))
+
+(define (condition-type-id ct)
+ (and (condition-type? ct)
+ (struct-ref ct (+ vtable-offset-user 0))))
+
+(define (condition-type-parent ct)
+ (and (condition-type? ct)
+ (struct-ref ct (+ vtable-offset-user 1))))
+
+(define (condition-type-all-fields ct)
+ (and (condition-type? ct)
+ (struct-ref ct (+ vtable-offset-user 2))))
+
+
+(define (struct-layout-for-condition field-names)
+ ;; Return a string denoting the layout required to hold the fields listed
+ ;; in FIELD-NAMES.
+ (let loop ((field-names field-names)
+ (layout '("pw")))
+ (if (null? field-names)
+ (string-concatenate/shared layout)
+ (loop (cdr field-names)
+ (cons "pw" layout)))))
+
+(define (print-condition c port)
+ ;; Print condition C to PORT in a way similar to how records print:
+ ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
+ (define (field-values)
+ (let* ((type (struct-vtable c))
+ (strings (fold (lambda (field result)
+ (cons (format #f "~A: ~S" field
+ (condition-ref c field))
+ result))
+ '()
+ (condition-type-all-fields type))))
+ (string-join (reverse strings) " ")))
+
+ (format port "#<condition ~a [~a] ~a>"
+ (condition-type-id (condition-type c))
+ (field-values)
+ (number->string (object-address c) 16)))
+
+(define (make-condition-type id parent field-names)
+ "Return a new condition type named ID, inheriting from PARENT, and with the
+fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of
+symbols and must not contain names already used by PARENT or one of its
+supertypes."
+ (if (symbol? id)
+ (if (condition-type? parent)
+ (let ((parent-fields (condition-type-all-fields parent)))
+ (if (and (every symbol? field-names)
+ (null? (lset-intersection eq?
+ field-names parent-fields)))
+ (let* ((all-fields (append parent-fields field-names))
+ (layout (struct-layout-for-condition all-fields)))
+ (%make-condition-type layout
+ id parent all-fields))
+ (error "invalid condition type field names"
+ field-names)))
+ (error "parent is not a condition type" parent))
+ (error "condition type identifier is not a symbol" id)))
+
+(define (make-compound-condition-type id parents)
+ ;; Return a compound condition type made of the types listed in PARENTS.
+ ;; All fields from PARENTS are kept, even same-named ones, since they are
+ ;; needed by `extract-condition'.
+ (cond ((null? parents)
+ (error "`make-compound-condition-type' passed empty parent list"
+ id))
+ ((null? (cdr parents))
+ (car parents))
+ (else
+ (let* ((all-fields (append-map condition-type-all-fields
+ parents))
+ (layout (struct-layout-for-condition all-fields)))
+ (%make-condition-type layout
+ id
+ parents ;; list of parents!
+ all-fields)))))
+
+
+;;;
+;;; Conditions.
+;;;
+
+(define (condition? c)
+ "Return true if C is a condition."
+ (and (struct? c)
+ (condition-type? (struct-vtable c))))
+
+(define (condition-type c)
+ (and (struct? c)
+ (let ((vtable (struct-vtable c)))
+ (if (condition-type? vtable)
+ vtable
+ #f))))
+
+(define (condition-has-type? c type)
+ "Return true if condition C has type TYPE."
+ (if (and (condition? c) (condition-type? type))
+ (let loop ((ct (condition-type c)))
+ (or (eq? ct type)
+ (and ct
+ (let ((parent (condition-type-parent ct)))
+ (if (list? parent)
+ (any loop parent) ;; compound condition
+ (loop (condition-type-parent ct)))))))
+ (throw 'wrong-type-arg "condition-has-type?"
+ "Wrong type argument")))
+
+(define (condition-ref c field-name)
+ "Return the value of the field named FIELD-NAME from condition C."
+ (if (condition? c)
+ (if (symbol? field-name)
+ (let* ((type (condition-type c))
+ (fields (condition-type-all-fields type))
+ (index (list-index (lambda (name)
+ (eq? name field-name))
+ fields)))
+ (if index
+ (struct-ref c index)
+ (error "invalid field name" field-name)))
+ (error "field name is not a symbol" field-name))
+ (throw 'wrong-type-arg "condition-ref"
+ "Wrong type argument: ~S" c)))
+
+(define (make-condition-from-values type values)
+ (apply make-struct/no-tail type values))
+
+(define (make-condition type . field+value)
+ "Return a new condition of type TYPE with fields initialized as specified
+by FIELD+VALUE, a sequence of field names (symbols) and values."
+ (if (condition-type? type)
+ (let* ((all-fields (condition-type-all-fields type))
+ (inits (fold-right (lambda (field inits)
+ (let ((v (memq field field+value)))
+ (if (pair? v)
+ (cons (cadr v) inits)
+ (error "field not specified"
+ field))))
+ '()
+ all-fields)))
+ (make-condition-from-values type inits))
+ (throw 'wrong-type-arg "make-condition"
+ "Wrong type argument: ~S" type)))
+
+(define (make-compound-condition . conditions)
+ "Return a new compound condition composed of CONDITIONS."
+ (let* ((types (map condition-type conditions))
+ (ct (make-compound-condition-type 'compound types))
+ (inits (append-map (lambda (c)
+ (let ((ct (condition-type c)))
+ (map (lambda (f)
+ (condition-ref c f))
+ (condition-type-all-fields ct))))
+ conditions)))
+ (make-condition-from-values ct inits)))
+
+(define (extract-condition c type)
+ "Return a condition of condition type TYPE with the field values specified
+by C."
+
+ (define (first-field-index parents)
+ ;; Return the index of the first field of TYPE within C.
+ (let loop ((parents parents)
+ (index 0))
+ (let ((parent (car parents)))
+ (cond ((null? parents)
+ #f)
+ ((eq? parent type)
+ index)
+ ((pair? parent)
+ (or (loop parent index)
+ (loop (cdr parents)
+ (+ index
+ (apply + (map condition-type-all-fields
+ parent))))))
+ (else
+ (let ((shift (length (condition-type-all-fields parent))))
+ (loop (cdr parents)
+ (+ index shift))))))))
+
+ (define (list-fields start-index field-names)
+ ;; Return a list of the form `(FIELD-NAME VALUE...)'.
+ (let loop ((index start-index)
+ (field-names field-names)
+ (result '()))
+ (if (null? field-names)
+ (reverse! result)
+ (loop (+ 1 index)
+ (cdr field-names)
+ (cons* (struct-ref c index)
+ (car field-names)
+ result)))))
+
+ (if (and (condition? c) (condition-type? type))
+ (let* ((ct (condition-type c))
+ (parent (condition-type-parent ct)))
+ (cond ((eq? type ct)
+ c)
+ ((pair? parent)
+ ;; C is a compound condition.
+ (let ((field-index (first-field-index parent)))
+ ;;(format #t "field-index: ~a ~a~%" field-index
+ ;; (list-fields field-index
+ ;; (condition-type-all-fields type)))
+ (apply make-condition type
+ (list-fields field-index
+ (condition-type-all-fields type)))))
+ (else
+ ;; C does not have type TYPE.
+ #f)))
+ (throw 'wrong-type-arg "extract-condition"
+ "Wrong type argument")))
+
+
+;;;
+;;; Syntax.
+;;;
+
+(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
+ (begin
+ (define name
+ (make-condition-type 'name parent '(field-name ...)))
+ (define (pred c)
+ (condition-has-type? c name))
+ (define (field-accessor c)
+ (condition-ref c 'field-name))
+ ...))
+
+(define-syntax-rule (compound-condition (type ...) (field ...))
+ ;; Create a compound condition using `make-compound-condition-type'.
+ (condition ((make-compound-condition-type '%compound `(,type ...))
+ field ...)))
+
+(define-syntax condition-instantiation
+ ;; Build the `(make-condition type ...)' call.
+ (syntax-rules ()
+ ((_ type (out ...))
+ (make-condition type out ...))
+ ((_ type (out ...) (field-name field-value) rest ...)
+ (condition-instantiation type (out ... 'field-name field-value) rest ...))))
+
+(define-syntax condition
+ (syntax-rules ()
+ ((_ (type field ...))
+ (condition-instantiation type () field ...))
+ ((_ (type field ...) ...)
+ (compound-condition (type ...) (field ... ...)))))
+
+
+;;;
+;;; Standard condition types.
+;;;
+
+(define &condition
+ ;; The root condition type.
+ (make-struct/no-tail %condition-type-vtable
+ (make-struct-layout "")
+ (lambda (c port)
+ (display "<&condition>"))
+ '&condition #f '() '()))
+
+(define-condition-type &message &condition
+ message-condition?
+ (message condition-message))
+
+(define-condition-type &serious &condition
+ serious-condition?)
+
+(define-condition-type &error &serious
+ error?)
+
+;;; srfi-35.scm ends here
diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm
new file mode 100644
index 000000000..c34b0d083
--- /dev/null
+++ b/module/srfi/srfi-37.scm
@@ -0,0 +1,234 @@
+;;; srfi-37.scm --- args-fold
+
+;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+;;; Commentary:
+;;
+;; To use this module with Guile, use (cdr (program-arguments)) as
+;; the ARGS argument to `args-fold'. Here is a short example:
+;;
+;; (args-fold (cdr (program-arguments))
+;; (let ((display-and-exit-proc
+;; (lambda (msg)
+;; (lambda (opt name arg)
+;; (display msg) (quit) (values)))))
+;; (list (option '(#\v "version") #f #f
+;; (display-and-exit-proc "Foo version 42.0\n"))
+;; (option '(#\h "help") #f #f
+;; (display-and-exit-proc
+;; "Usage: foo scheme-file ..."))))
+;; (lambda (opt name arg)
+;; (error "Unrecognized option `~A'" name))
+;; (lambda (op) (load op) (values)))
+;;
+;;; Code:
+
+
+;;;; Module definition & exports
+(define-module (srfi srfi-37)
+ #:use-module (srfi srfi-9)
+ #:export (option option-names option-required-arg?
+ option-optional-arg? option-processor
+ args-fold))
+
+(cond-expand-provide (current-module) '(srfi-37))
+
+;;;; args-fold and periphery procedures
+
+;;; An option as answered by `option'. `names' is a list of
+;;; characters and strings, representing associated short-options and
+;;; long-options respectively that should use this option's
+;;; `processor' in an `args-fold' call.
+;;;
+;;; `required-arg?' and `optional-arg?' are mutually exclusive
+;;; booleans and indicate whether an argument must be or may be
+;;; provided. Besides the obvious, this affects semantics of
+;;; short-options, as short-options with a required or optional
+;;; argument cannot be followed by other short options in the same
+;;; program-arguments string, as they will be interpreted collectively
+;;; as the option's argument.
+;;;
+;;; `processor' is called when this option is encountered. It should
+;;; accept the containing option, the element of `names' (by `equal?')
+;;; encountered, the option's argument (or #f if none), and the seeds
+;;; as variadic arguments, answering the new seeds as values.
+(define-record-type srfi-37:option
+ (option names required-arg? optional-arg? processor)
+ option?
+ (names option-names)
+ (required-arg? option-required-arg?)
+ (optional-arg? option-optional-arg?)
+ (processor option-processor))
+
+(define (error-duplicate-option option-name)
+ (scm-error 'program-error "args-fold"
+ "Duplicate option name `~A~A'"
+ (list (if (char? option-name) #\- "--")
+ option-name)
+ #f))
+
+(define (build-options-lookup options)
+ "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
+to the containing options, signalling an error if a name is
+encountered more than once."
+ (let ((lookup (make-hash-table (* 2 (length options)))))
+ (for-each
+ (lambda (opt)
+ (for-each (lambda (name)
+ (let ((assoc (hash-create-handle!
+ lookup name #f)))
+ (if (cdr assoc)
+ (error-duplicate-option (car assoc))
+ (set-cdr! assoc opt))))
+ (option-names opt)))
+ options)
+ lookup))
+
+(define (args-fold args options unrecognized-option-proc
+ operand-proc . seeds)
+ "Answer the results of folding SEEDS as multiple values against the
+program-arguments in ARGS, as decided by the OPTIONS'
+`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
+ (let ((lookup (build-options-lookup options)))
+ ;; I don't like Guile's `error' here
+ (define (error msg . args)
+ (scm-error 'misc-error "args-fold" msg args #f))
+
+ (define (mutate-seeds! procedure . params)
+ (set! seeds (call-with-values
+ (lambda ()
+ (apply procedure (append params seeds)))
+ list)))
+
+ ;; Clean up the rest of ARGS, assuming they're all operands.
+ (define (rest-operands)
+ (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
+ args)
+ (set! args '()))
+
+ ;; Call OPT's processor with OPT, NAME, an argument to be decided,
+ ;; and the seeds. Depending on OPT's *-arg? specification, get
+ ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
+ ;; if no argument is allowed, call NO-ARG-PROC thunk.
+ (define (invoke-option-processor
+ opt name req-arg-proc opt-arg-proc no-arg-proc)
+ (mutate-seeds!
+ (option-processor opt) opt name
+ (cond ((option-required-arg? opt) (req-arg-proc))
+ ((option-optional-arg? opt) (opt-arg-proc))
+ (else (no-arg-proc) #f))))
+
+ ;; Compute and answer a short option argument, advancing ARGS as
+ ;; necessary, for the short option whose character is at POSITION
+ ;; in the current ARG.
+ (define (short-option-argument position)
+ (cond ((< (1+ position) (string-length (car args)))
+ (let ((result (substring (car args) (1+ position))))
+ (set! args (cdr args))
+ result))
+ ((pair? (cdr args))
+ (let ((result (cadr args)))
+ (set! args (cddr args))
+ result))
+ ((pair? args)
+ (set! args (cdr args))
+ #f)
+ (else #f)))
+
+ ;; Interpret the short-option at index POSITION in (car ARGS),
+ ;; followed by the remaining short options in (car ARGS).
+ (define (short-option position)
+ (if (>= position (string-length (car args)))
+ (begin
+ (set! args (cdr args))
+ (next-arg))
+ (let* ((opt-name (string-ref (car args) position))
+ (option-here (hash-ref lookup opt-name)))
+ (cond ((not option-here)
+ (mutate-seeds! unrecognized-option-proc
+ (option (list opt-name) #f #f
+ unrecognized-option-proc)
+ opt-name #f)
+ (short-option (1+ position)))
+ (else
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (or (short-option-argument position)
+ (error "Missing required argument after `-~A'" opt-name)))
+ (lambda ()
+ ;; edge case: -xo -zf or -xo -- where opt-name=#\o
+ ;; GNU getopt_long resolves these like I do
+ (short-option-argument position))
+ (lambda () #f))
+ (if (not (or (option-required-arg? option-here)
+ (option-optional-arg? option-here)))
+ (short-option (1+ position))))))))
+
+ ;; Process the long option in (car ARGS). We make the
+ ;; interesting, possibly non-standard assumption that long option
+ ;; names might contain #\=, so keep looking for more #\= in (car
+ ;; ARGS) until we find a named option in lookup.
+ (define (long-option)
+ (let ((arg (car args)))
+ (let place-=-after ((start-pos 2))
+ (let* ((index (string-index arg #\= start-pos))
+ (opt-name (substring arg 2 (or index (string-length arg))))
+ (option-here (hash-ref lookup opt-name)))
+ (if (not option-here)
+ ;; look for a later #\=, unless there can't be one
+ (if index
+ (place-=-after (1+ index))
+ (mutate-seeds!
+ unrecognized-option-proc
+ (option (list opt-name) #f #f unrecognized-option-proc)
+ opt-name #f))
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (if index
+ (substring arg (1+ index))
+ (error "Missing required argument after `--~A'" opt-name)))
+ (lambda () (and index (substring arg (1+ index))))
+ (lambda ()
+ (if index
+ (error "Extraneous argument after `--~A'" opt-name))))))))
+ (set! args (cdr args)))
+
+ ;; Process the remaining in ARGS. Basically like calling
+ ;; `args-fold', but without having to regenerate `lookup' and the
+ ;; funcs above.
+ (define (next-arg)
+ (if (null? args)
+ (apply values seeds)
+ (let ((arg (car args)))
+ (cond ((or (string-null? arg)
+ (not (char=? #\- (string-ref arg 0)))
+ (= 1 (string-length arg))) ;"-"
+ (mutate-seeds! operand-proc arg)
+ (set! args (cdr args)))
+ ((char=? #\- (string-ref arg 1))
+ (if (= 2 (string-length arg)) ;"--"
+ (begin (set! args (cdr args)) (rest-operands))
+ (long-option)))
+ (else (short-option 1)))
+ (next-arg))))
+
+ (next-arg)))
+
+;;; srfi-37.scm ends here
diff --git a/module/srfi/srfi-38.scm b/module/srfi/srfi-38.scm
new file mode 100644
index 000000000..34cf22ef7
--- /dev/null
+++ b/module/srfi/srfi-38.scm
@@ -0,0 +1,207 @@
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) Ray Dillinger 2003. All Rights Reserved.
+;;
+;; Contains code based upon Alex Shinn's public-domain implementation of
+;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-38)
+ #:export (write-with-shared-structure
+ read-with-shared-structure)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-69)
+ #:use-module (system vm trap-state))
+
+(cond-expand-provide (current-module) '(srfi-38))
+
+;; A printer that shows all sharing of substructures. Uses the Common
+;; Lisp print-circle notation: #n# refers to a previous substructure
+;; labeled with #n=. Takes O(n^2) time.
+
+;; Code attributed to Al Petrofsky, modified by Ray Dillinger.
+
+;; Modified in 2010 by Andreas Rottmann to use SRFI 69 hashtables,
+;; making the time O(n), and adding some of Guile's data types to the
+;; `interesting' objects.
+
+(define* (write-with-shared-structure obj
+ #:optional
+ (outport (current-output-port))
+ (optarg #f))
+
+ ;; We only track duplicates of pairs, vectors, strings, bytevectors,
+ ;; structs (which subsume R6RS and SRFI-9 records), ports and (native)
+ ;; hash-tables. We ignore zero-length vectors and strings because
+ ;; r5rs doesn't guarantee that eq? treats them sanely (and they aren't
+ ;; very interesting anyway).
+
+ (define (interesting? obj)
+ (or (pair? obj)
+ (and (vector? obj) (not (zero? (vector-length obj))))
+ (and (string? obj) (not (zero? (string-length obj))))
+ (bytevector? obj)
+ (struct? obj)
+ (port? obj)
+ (hash-table? obj)))
+
+ ;; (write-obj OBJ STATE):
+ ;;
+ ;; STATE is a hashtable which has an entry for each interesting part
+ ;; of OBJ. The associated value will be:
+ ;;
+ ;; -- a number if the part has been given one,
+ ;; -- #t if the part will need to be assigned a number but has not been yet,
+ ;; -- #f if the part will not need a number.
+ ;; The entry `counter' in STATE should be the most recently
+ ;; assigned number.
+ ;;
+ ;; Mutates STATE for any parts that had numbers assigned.
+ (define (write-obj obj state)
+ (define (write-interesting)
+ (cond ((pair? obj)
+ (display "(" outport)
+ (write-obj (car obj) state)
+ (let write-cdr ((obj (cdr obj)))
+ (cond ((and (pair? obj) (not (hash-table-ref state obj)))
+ (display " " outport)
+ (write-obj (car obj) state)
+ (write-cdr (cdr obj)))
+ ((null? obj)
+ (display ")" outport))
+ (else
+ (display " . " outport)
+ (write-obj obj state)
+ (display ")" outport)))))
+ ((vector? obj)
+ (display "#(" outport)
+ (let ((len (vector-length obj)))
+ (write-obj (vector-ref obj 0) state)
+ (let write-vec ((i 1))
+ (cond ((= i len) (display ")" outport))
+ (else (display " " outport)
+ (write-obj (vector-ref obj i) state)
+ (write-vec (+ i 1)))))))
+ ;; else it's a string
+ (else (write obj outport))))
+ (cond ((interesting? obj)
+ (let ((val (hash-table-ref state obj)))
+ (cond ((not val) (write-interesting))
+ ((number? val)
+ (begin (display "#" outport)
+ (write val outport)
+ (display "#" outport)))
+ (else
+ (let ((n (+ 1 (hash-table-ref state 'counter))))
+ (display "#" outport)
+ (write n outport)
+ (display "=" outport)
+ (hash-table-set! state 'counter n)
+ (hash-table-set! state obj n)
+ (write-interesting))))))
+ (else
+ (write obj outport))))
+
+ ;; Scan computes the initial value of the hash table, which maps each
+ ;; interesting part of the object to #t if it occurs multiple times,
+ ;; #f if only once.
+ (define (scan obj state)
+ (cond ((not (interesting? obj)))
+ ((hash-table-exists? state obj)
+ (hash-table-set! state obj #t))
+ (else
+ (hash-table-set! state obj #f)
+ (cond ((pair? obj)
+ (scan (car obj) state)
+ (scan (cdr obj) state))
+ ((vector? obj)
+ (let ((len (vector-length obj)))
+ (do ((i 0 (+ 1 i)))
+ ((= i len))
+ (scan (vector-ref obj i) state))))))))
+
+ (let ((state (make-hash-table eq?)))
+ (scan obj state)
+ (hash-table-set! state 'counter 0)
+ (write-obj obj state)))
+
+;; A reader that understands the output of the above writer. This has
+;; been written by Andreas Rottmann to re-use Guile's built-in reader,
+;; with inspiration from Alex Shinn's public-domain implementation of
+;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
+
+(define* (read-with-shared-structure #:optional (port (current-input-port)))
+ (let ((parts-table (make-hash-table eqv?)))
+
+ ;; reads chars that match PRED and returns them as a string.
+ (define (read-some-chars pred initial)
+ (let iter ((chars initial))
+ (let ((c (peek-char port)))
+ (if (or (eof-object? c) (not (pred c)))
+ (list->string (reverse chars))
+ (iter (cons (read-char port) chars))))))
+
+ (define (read-hash c port)
+ (let* ((n (string->number (read-some-chars char-numeric? (list c))))
+ (c (read-char port))
+ (thunk (hash-table-ref/default parts-table n #f)))
+ (case c
+ ((#\=)
+ (if thunk
+ (error "Double declaration of part " n))
+ (let* ((cell (list #f))
+ (thunk (lambda () (car cell))))
+ (hash-table-set! parts-table n thunk)
+ (let ((obj (read port)))
+ (set-car! cell obj)
+ obj)))
+ ((#\#)
+ (or thunk
+ (error "Use of undeclared part " n)))
+ (else
+ (error "Malformed shared part specifier")))))
+
+ (with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures)
+ (lambda ()
+ (for-each (lambda (digit)
+ (read-hash-extend digit read-hash))
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ (let ((result (read port)))
+ (if (< 0 (hash-table-size parts-table))
+ (patch! result))
+ result)))))
+
+(define (hole? x) (procedure? x))
+(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
+
+(define (patch! x)
+ (cond
+ ((pair? x)
+ (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch! (car x)))
+ (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch! (cdr x))))
+ ((vector? x)
+ (do ((i (- (vector-length x) 1) (- i 1)))
+ ((< i 0))
+ (let ((elt (vector-ref x i)))
+ (if (hole? elt)
+ (vector-set! x i (fill-hole elt))
+ (patch! elt)))))))
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
new file mode 100644
index 000000000..661ab0fbe
--- /dev/null
+++ b/module/srfi/srfi-39.scm
@@ -0,0 +1,55 @@
+;;; srfi-39.scm --- Parameter objects
+
+;; Copyright (C) 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;;; Date: 2004-05-05
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-39 (Parameter objects).
+;;
+;; The implementation is based on Guile's fluid objects, and is, therefore,
+;; thread-safe (parameters are thread-local).
+;;
+;; In addition to the forms defined in SRFI-39 (`make-parameter',
+;; `parameterize'), a new procedure `with-parameters*' is provided.
+;; This procedures is analogous to `with-fluids*' but taking as first
+;; argument a list of parameter objects instead of a list of fluids.
+;;
+
+;;; Code:
+
+(define-module (srfi srfi-39)
+ ;; helper procedure not in srfi-39.
+ #:export (with-parameters*)
+ #:re-export (make-parameter
+ parameterize
+ current-input-port current-output-port current-error-port))
+
+(cond-expand-provide (current-module) '(srfi-39))
+
+(define (with-parameters* params values thunk)
+ (let more ((params params)
+ (values values)
+ (fluids '()) ;; fluids from each of PARAMS
+ (convs '())) ;; VALUES with conversion proc applied
+ (if (null? params)
+ (with-fluids* fluids convs thunk)
+ (more (cdr params) (cdr values)
+ (cons (parameter-fluid (car params)) fluids)
+ (cons ((parameter-converter (car params)) (car values)) convs)))))
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
new file mode 100644
index 000000000..b2e6f4928
--- /dev/null
+++ b/module/srfi/srfi-4.scm
@@ -0,0 +1,118 @@
+;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
+
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
+;; 2012, 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+;;; Commentary:
+
+;; This module exports the homogeneous numeric vector procedures as
+;; defined in SRFI-4. They are fully documented in the Guile
+;; Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4)
+ #:use-module (rnrs bytevectors)
+ #:export (;; Unsigned 8-bit vectors.
+ u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+ u8vector-set! u8vector->list list->u8vector
+
+ ;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+ ;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+ ;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+ ;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+ ;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+ ;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+ ;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+ ;; 32-bit floating point vectors.
+ f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+ f32vector-set! f32vector->list list->f32vector
+
+ ;; 64-bit floating point vectors.
+ f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+ f64vector-set! f64vector->list list->f64vector))
+
+(cond-expand-provide (current-module) '(srfi-4))
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+ `(begin
+ (define (,(symbol-append tag 'vector?) obj)
+ (and (bytevector? obj) (eq? (array-type obj) ',tag)))
+ (define (,(symbol-append 'make- tag 'vector) len . fill)
+ (apply make-srfi-4-vector ',tag len fill))
+ (define (,(symbol-append tag 'vector-length) v)
+ (let ((len (/ (bytevector-length v) ,size)))
+ (if (integer? len)
+ len
+ (error "fractional length" v ',tag ,size))))
+ (define (,(symbol-append tag 'vector) . elts)
+ (,(symbol-append 'list-> tag 'vector) elts))
+ (define (,(symbol-append 'list-> tag 'vector) elts)
+ (let* ((len (length elts))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0) (elts elts))
+ (if (and (< i len) (pair? elts))
+ (begin
+ (,(symbol-append tag 'vector-set!) v i (car elts))
+ (lp (1+ i) (cdr elts)))
+ v))))
+ (define (,(symbol-append tag 'vector->list) v)
+ (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+ (if (< i 0)
+ elts
+ (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+ (define (,(symbol-append tag 'vector-ref) v i)
+ (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define-bytevector-type u8 u8 1)
+(define-bytevector-type s8 s8 1)
+(define-bytevector-type u16 u16-native 2)
+(define-bytevector-type s16 s16-native 2)
+(define-bytevector-type u32 u32-native 4)
+(define-bytevector-type s32 s32-native 4)
+(define-bytevector-type u64 u64-native 8)
+(define-bytevector-type s64 s64-native 8)
+(define-bytevector-type f32 ieee-single-native 4)
+(define-bytevector-type f64 ieee-double-native 8)
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
new file mode 100644
index 000000000..42bbf33c5
--- /dev/null
+++ b/module/srfi/srfi-4/gnu.scm
@@ -0,0 +1,80 @@
+;;; Extensions to SRFI-4
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4 gnu)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-4)
+ #:export (;; Complex numbers with 32- and 64-bit components.
+ c32vector? make-c32vector c32vector c32vector-length c32vector-ref
+ c32vector-set! c32vector->list list->c32vector
+
+ c64vector? make-c64vector c64vector c64vector-length c64vector-ref
+ c64vector-set! c64vector->list list->c64vector
+
+ make-srfi-4-vector
+
+ ;; Somewhat polymorphic conversions.
+ any->u8vector any->s8vector any->u16vector any->s16vector
+ any->u32vector any->s32vector any->u64vector any->s64vector
+ any->f32vector any->f64vector any->c32vector any->c64vector))
+
+
+(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
+
+(define (bytevector-c32-native-ref v i)
+ (make-rectangular (bytevector-ieee-single-native-ref v i)
+ (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-native-set! v i x)
+ (bytevector-ieee-single-native-set! v i (real-part x))
+ (bytevector-ieee-single-native-set! v (+ i 4) (imag-part x)))
+(define (bytevector-c64-native-ref v i)
+ (make-rectangular (bytevector-ieee-double-native-ref v i)
+ (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-native-set! v i x)
+ (bytevector-ieee-double-native-set! v i (real-part x))
+ (bytevector-ieee-double-native-set! v (+ i 8) (imag-part x)))
+
+((@@ (srfi srfi-4) define-bytevector-type) c32 c32-native 8)
+((@@ (srfi srfi-4) define-bytevector-type) c64 c64-native 16)
+
+(define-macro (define-any->vector . tags)
+ `(begin
+ ,@(map (lambda (tag)
+ `(define (,(symbol-append 'any-> tag 'vector) obj)
+ (cond ((,(symbol-append tag 'vector?) obj) obj)
+ ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
+ ((and (array? obj) (eqv? 1 (array-rank obj)))
+ (let* ((len (array-length obj))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0))
+ (if (< i len)
+ (begin
+ (,(symbol-append tag 'vector-set!)
+ v i (array-ref obj i))
+ (lp (1+ i)))
+ v))))
+ (else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
+ tags)))
+
+(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64)
diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm
new file mode 100644
index 000000000..3589b359d
--- /dev/null
+++ b/module/srfi/srfi-41.scm
@@ -0,0 +1,505 @@
+;;; srfi-41.scm -- SRFI 41 streams
+
+;; Copyright (c) 2007 Philip L. Bewig
+;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-module (srfi srfi-41)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (stream-null stream-cons stream? stream-null? stream-pair?
+ stream-car stream-cdr stream-lambda define-stream
+ list->stream port->stream stream stream->list stream-append
+ stream-concat stream-constant stream-drop stream-drop-while
+ stream-filter stream-fold stream-for-each stream-from
+ stream-iterate stream-length stream-let stream-map
+ stream-match stream-of stream-range stream-ref stream-reverse
+ stream-scan stream-take stream-take-while stream-unfold
+ stream-unfolds stream-zip))
+
+(cond-expand-provide (current-module) '(srfi-41))
+
+;;; Private supporting functions and macros.
+
+(define-syntax-rule (must pred obj func msg args ...)
+ (let ((item obj))
+ (unless (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-not pred obj func msg args ...)
+ (let ((item obj))
+ (when (pred item)
+ (throw 'wrong-type-arg func msg (list args ...) (list item)))))
+
+(define-syntax-rule (must-every pred objs func msg args ...)
+ (let ((flunk (remove pred objs)))
+ (unless (null? flunk)
+ (throw 'wrong-type-arg func msg (list args ...) flunk))))
+
+(define-syntax-rule (first-value expr)
+ (receive (first . _) expr
+ first))
+
+(define-syntax-rule (second-value expr)
+ (receive (first second . _) expr
+ second))
+
+(define-syntax-rule (third-value expr)
+ (receive (first second third . _) expr
+ third))
+
+(define-syntax define-syntax*
+ (syntax-rules ()
+ ((_ (name . args) body ...)
+ (define-syntax name (lambda* args body ...)))
+ ((_ name syntax)
+ (define-syntax name syntax))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Here we include a copy of the code of srfi-45.scm (but with renamed
+;; identifiers), in order to create a new promise type that's disjoint
+;; from the promises created by srfi-45. Ideally this should be done
+;; using a 'make-promise-type' macro that instantiates a copy of this
+;; code, but a psyntax bug in Guile 2.0 prevents this from working
+;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the
+;; code.
+
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-record-type stream-promise (make-stream-promise val) stream-promise?
+ (val stream-promise-val stream-promise-val-set!))
+
+(define-record-type stream-value (make-stream-value tag proc) stream-value?
+ (tag stream-value-tag stream-value-tag-set!)
+ (proc stream-value-proc stream-value-proc-set!))
+
+(define-syntax-rule (stream-lazy exp)
+ (make-stream-promise (make-stream-value 'lazy (lambda () exp))))
+
+(define (stream-eager x)
+ (make-stream-promise (make-stream-value 'eager x)))
+
+(define-syntax-rule (stream-delay exp)
+ (stream-lazy (stream-eager exp)))
+
+(define (stream-force promise)
+ (let ((content (stream-promise-val promise)))
+ (case (stream-value-tag content)
+ ((eager) (stream-value-proc content))
+ ((lazy) (let* ((promise* ((stream-value-proc content)))
+ (content (stream-promise-val promise)))
+ (if (not (eqv? (stream-value-tag content) 'eager))
+ (begin (stream-value-tag-set! content
+ (stream-value-tag (stream-promise-val promise*)))
+ (stream-value-proc-set! content
+ (stream-value-proc (stream-promise-val promise*)))
+ (stream-promise-val-set! promise* content)))
+ (stream-force promise))))))
+
+;;
+;; End of the copy of the code from srfi-45.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Primitive stream functions and macros: (streams primitive)
+
+(define stream? stream-promise?)
+
+(define %stream-null (cons 'stream 'null))
+(define stream-null (stream-eager %stream-null))
+
+(define (stream-null? obj)
+ (and (stream-promise? obj)
+ (eqv? (stream-force obj) %stream-null)))
+
+(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare?
+ (kar stream-kar)
+ (kdr stream-kdr))
+
+(define (stream-pair? obj)
+ (and (stream-promise? obj) (stream-pare? (stream-force obj))))
+
+(define-syntax-rule (stream-cons obj strm)
+ (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))
+
+(define (stream-car strm)
+ (must stream? strm 'stream-car "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-car "null stream")
+ (stream-force (stream-kar pare))))
+
+(define (stream-cdr strm)
+ (must stream? strm 'stream-cdr "non-stream")
+ (let ((pare (stream-force strm)))
+ (must stream-pare? pare 'stream-cdr "null stream")
+ (stream-kdr pare)))
+
+(define-syntax-rule (stream-lambda formals body0 body1 ...)
+ (lambda formals (stream-lazy (begin body0 body1 ...))))
+
+(define* (stream-promise-visit promise #:key on-eager on-lazy)
+ (define content (stream-promise-val promise))
+ (case (stream-value-tag content)
+ ((eager) (on-eager (stream-value-proc content)))
+ ((lazy) (on-lazy (stream-value-proc content)))))
+
+(set-record-type-printer! stream-promise
+ (lambda (strm port)
+ (display "#<stream" port)
+ (let loop ((strm strm))
+ (stream-promise-visit strm
+ #:on-eager (lambda (pare)
+ (cond ((eq? pare %stream-null)
+ (write-char #\> port))
+ (else
+ (write-char #\space port)
+ (stream-promise-visit (stream-kar pare)
+ #:on-eager (cut write <> port)
+ #:on-lazy (lambda (_) (write-char #\? port)))
+ (loop (stream-kdr pare)))))
+ #:on-lazy (lambda (_) (display " ...>" port))))))
+
+;;; Derived stream functions and macros: (streams derived)
+
+(define-syntax-rule (define-stream (name . formal) body0 body1 ...)
+ (define name (stream-lambda formal body0 body1 ...)))
+
+(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))
+
+(define (list->stream objs)
+ (define (list? x)
+ (or (proper-list? x) (circular-list? x)))
+ (must list? objs 'list->stream "non-list argument")
+ (stream-let recur ((objs objs))
+ (if (null? objs) stream-null
+ (stream-cons (car objs) (recur (cdr objs))))))
+
+(define* (port->stream #:optional (port (current-input-port)))
+ (must input-port? port 'port->stream "non-input-port argument")
+ (stream-let recur ()
+ (let ((c (read-char port)))
+ (if (eof-object? c) stream-null
+ (stream-cons c (recur))))))
+
+(define-syntax stream
+ (syntax-rules ()
+ ((_) stream-null)
+ ((_ x y ...) (stream-cons x (stream y ...)))))
+
+;; Common helper for the various eager-folding functions, such as
+;; stream-fold, stream-drop, stream->list, stream-length, etc.
+(define-inlinable (stream-fold-aux proc base strm limit)
+ (do ((val base (and proc (proc val (stream-car strm))))
+ (strm strm (stream-cdr strm))
+ (limit limit (and limit (1- limit))))
+ ((or (and limit (zero? limit)) (stream-null? strm))
+ (values val strm limit))))
+
+(define stream->list
+ (case-lambda
+ ((strm) (stream->list #f strm))
+ ((n strm)
+ (must stream? strm 'stream->list "non-stream argument")
+ (when n
+ (must integer? n 'stream->list "non-integer count")
+ (must exact? n 'stream->list "inexact count")
+ (must-not negative? n 'stream->list "negative count"))
+ (reverse! (first-value (stream-fold-aux xcons '() strm n))))))
+
+(define (stream-append . strms)
+ (must-every stream? strms 'stream-append "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (null? strms) stream-null
+ (let ((strm (car strms)))
+ (if (stream-null? strm) (recur (cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (cons (stream-cdr strm) (cdr strms)))))))))
+
+(define (stream-concat strms)
+ (must stream? strms 'stream-concat "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (stream-null? strms) stream-null
+ (let ((strm (stream-car strms)))
+ (must stream? strm 'stream-concat "non-stream object in input stream")
+ (if (stream-null? strm) (recur (stream-cdr strms))
+ (stream-cons (stream-car strm)
+ (recur (stream-cons (stream-cdr strm)
+ (stream-cdr strms)))))))))
+
+(define stream-constant
+ (case-lambda
+ (() stream-null)
+ (objs (list->stream (apply circular-list objs)))))
+
+(define-syntax* (stream-do x)
+ (define (end x)
+ (syntax-case x ()
+ (() #'(if #f #f))
+ ((result) #'result)
+ ((result ...) #'(begin result ...))))
+ (define (var-step v s)
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation 'stream-do "bad step expression" x s))))
+
+ (syntax-case x ()
+ ((_ ((var init . step) ...)
+ (test result ...)
+ expr ...)
+ (with-syntax ((result (end #'(result ...)))
+ ((step ...) (map var-step #'(var ...) #'(step ...))))
+ #'(stream-let loop ((var init) ...)
+ (if test result
+ (begin
+ expr ...
+ (loop step ...))))))))
+
+(define (stream-drop n strm)
+ (must integer? n 'stream-drop "non-integer argument")
+ (must exact? n 'stream-drop "inexact argument")
+ (must-not negative? n 'stream-drop "negative argument")
+ (must stream? strm 'stream-drop "non-stream argument")
+ (second-value (stream-fold-aux #f #f strm n)))
+
+(define (stream-drop-while pred? strm)
+ (must procedure? pred? 'stream-drop-while "non-procedural argument")
+ (must stream? strm 'stream-drop-while "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm)))
+ ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm)))
+
+(define (stream-filter pred? strm)
+ (must procedure? pred? 'stream-filter "non-procedural argument")
+ (must stream? strm 'stream-filter "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else (recur (stream-cdr strm))))))
+
+(define (stream-fold proc base strm)
+ (must procedure? proc 'stream-fold "non-procedural argument")
+ (must stream? strm 'stream-fold "non-stream argument")
+ (first-value (stream-fold-aux proc base strm #f)))
+
+(define stream-for-each
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must stream? strm 'stream-for-each "non-stream argument")
+ (do ((strm strm (stream-cdr strm)))
+ ((stream-null? strm))
+ (proc (stream-car strm))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-for-each "non-procedural argument")
+ (must-every stream? strms 'stream-for-each "non-stream argument")
+ (do ((strms strms (map stream-cdr strms)))
+ ((any stream-null? strms))
+ (apply proc (map stream-car strms)))))))
+
+(define* (stream-from first #:optional (step 1))
+ (must number? first 'stream-from "non-numeric starting number")
+ (must number? step 'stream-from "non-numeric step size")
+ (stream-let recur ((first first))
+ (stream-cons first (recur (+ first step)))))
+
+(define (stream-iterate proc base)
+ (must procedure? proc 'stream-iterate "non-procedural argument")
+ (stream-let recur ((base base))
+ (stream-cons base (recur (proc base)))))
+
+(define (stream-length strm)
+ (must stream? strm 'stream-length "non-stream argument")
+ (- -1 (third-value (stream-fold-aux #f #f strm -1))))
+
+(define stream-map
+ (case-lambda
+ ((proc strm)
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must stream? strm 'stream-map "non-stream argument")
+ (stream-let recur ((strm strm))
+ (if (stream-null? strm) stream-null
+ (stream-cons (proc (stream-car strm))
+ (recur (stream-cdr strm))))))
+ ((proc strm . rest)
+ (let ((strms (cons strm rest)))
+ (must procedure? proc 'stream-map "non-procedural argument")
+ (must-every stream? strms 'stream-map "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (apply proc (map stream-car strms))
+ (recur (map stream-cdr strms)))))))))
+
+(define-syntax* (stream-match x)
+ (define (make-matcher x)
+ (syntax-case x ()
+ (() #'(? stream-null?))
+ (rest (identifier? #'rest) #'rest)
+ ((var . rest) (identifier? #'var)
+ (with-syntax ((next (make-matcher #'rest)))
+ #'(? (negate stream-null?)
+ (= stream-car var)
+ (= stream-cdr next))))))
+ (define (make-guarded x fail)
+ (syntax-case (list x fail) ()
+ (((expr) _) #'expr)
+ (((guard expr) fail) #'(if guard expr (fail)))))
+
+ (syntax-case x ()
+ ((_ strm-expr (pat . expr) ...)
+ (with-syntax (((fail ...) (generate-temporaries #'(pat ...))))
+ (with-syntax (((matcher ...) (map make-matcher #'(pat ...)))
+ ((expr ...) (map make-guarded #'(expr ...) #'(fail ...))))
+ #'(let ((strm strm-expr))
+ (must stream? strm 'stream-match "non-stream argument")
+ (match strm (matcher (=> fail) expr) ...)))))))
+
+(define-syntax-rule (stream-of expr rest ...)
+ (stream-of-aux expr stream-null rest ...))
+
+(define-syntax stream-of-aux
+ (syntax-rules (in is)
+ ((_ expr base)
+ (stream-cons expr base))
+ ((_ expr base (var in stream) rest ...)
+ (stream-let recur ((strm stream))
+ (if (stream-null? strm) base
+ (let ((var (stream-car strm)))
+ (stream-of-aux expr (recur (stream-cdr strm)) rest ...)))))
+ ((_ expr base (var is exp) rest ...)
+ (let ((var exp)) (stream-of-aux expr base rest ...)))
+ ((_ expr base pred? rest ...)
+ (if pred? (stream-of-aux expr base rest ...) base))))
+
+(define* (stream-range first past #:optional step)
+ (must number? first 'stream-range "non-numeric starting number")
+ (must number? past 'stream-range "non-numeric ending number")
+ (when step
+ (must number? step 'stream-range "non-numeric step size"))
+ (let* ((step (or step (if (< first past) 1 -1)))
+ (lt? (if (< 0 step) < >)))
+ (stream-let recur ((first first))
+ (if (lt? first past)
+ (stream-cons first (recur (+ first step)))
+ stream-null))))
+
+(define (stream-ref strm n)
+ (must stream? strm 'stream-ref "non-stream argument")
+ (must integer? n 'stream-ref "non-integer argument")
+ (must exact? n 'stream-ref "inexact argument")
+ (must-not negative? n 'stream-ref "negative argument")
+ (let ((res (stream-drop n strm)))
+ (must-not stream-null? res 'stream-ref "beyond end of stream")
+ (stream-car res)))
+
+(define (stream-reverse strm)
+ (must stream? strm 'stream-reverse "non-stream argument")
+ (stream-do ((strm strm (stream-cdr strm))
+ (rev stream-null (stream-cons (stream-car strm) rev)))
+ ((stream-null? strm) rev)))
+
+(define (stream-scan proc base strm)
+ (must procedure? proc 'stream-scan "non-procedural argument")
+ (must stream? strm 'stream-scan "non-stream argument")
+ (stream-let recur ((base base) (strm strm))
+ (if (stream-null? strm) (stream base)
+ (stream-cons base (recur (proc base (stream-car strm))
+ (stream-cdr strm))))))
+
+(define (stream-take n strm)
+ (must stream? strm 'stream-take "non-stream argument")
+ (must integer? n 'stream-take "non-integer argument")
+ (must exact? n 'stream-take "inexact argument")
+ (must-not negative? n 'stream-take "negative argument")
+ (stream-let recur ((n n) (strm strm))
+ (if (or (zero? n) (stream-null? strm)) stream-null
+ (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm))))))
+
+(define (stream-take-while pred? strm)
+ (must procedure? pred? 'stream-take-while "non-procedural argument")
+ (must stream? strm 'stream-take-while "non-stream argument")
+ (stream-let recur ((strm strm))
+ (cond ((stream-null? strm) stream-null)
+ ((pred? (stream-car strm))
+ (stream-cons (stream-car strm) (recur (stream-cdr strm))))
+ (else stream-null))))
+
+(define (stream-unfold mapper pred? generator base)
+ (must procedure? mapper 'stream-unfold "non-procedural mapper")
+ (must procedure? pred? 'stream-unfold "non-procedural pred?")
+ (must procedure? generator 'stream-unfold "non-procedural generator")
+ (stream-let recur ((base base))
+ (if (pred? base)
+ (stream-cons (mapper base) (recur (generator base)))
+ stream-null)))
+
+(define (stream-unfolds gen seed)
+ (define-stream (generator-stream seed)
+ (receive (next . items) (gen seed)
+ (stream-cons (list->vector items) (generator-stream next))))
+ (define-stream (make-result-stream genstrm index)
+ (define head (vector-ref (stream-car genstrm) index))
+ (define-stream (tail) (make-result-stream (stream-cdr genstrm) index))
+ (match head
+ (() stream-null)
+ (#f (tail))
+ ((item) (stream-cons item (tail)))
+ ((? list? items) (stream-append (list->stream items) (tail)))))
+
+ (must procedure? gen 'stream-unfolds "non-procedural argument")
+ (let ((genstrm (generator-stream seed)))
+ (apply values (list-tabulate (vector-length (stream-car genstrm))
+ (cut make-result-stream genstrm <>)))))
+
+(define (stream-zip strm . rest)
+ (let ((strms (cons strm rest)))
+ (must-every stream? strms 'stream-zip "non-stream argument")
+ (stream-let recur ((strms strms))
+ (if (any stream-null? strms) stream-null
+ (stream-cons (map stream-car strms) (recur (map stream-cdr strms)))))))
diff --git a/module/srfi/srfi-42.scm b/module/srfi/srfi-42.scm
new file mode 100644
index 000000000..c826f6f9e
--- /dev/null
+++ b/module/srfi/srfi-42.scm
@@ -0,0 +1,66 @@
+;;; srfi-42.scm --- Eager comprehensions
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-42)
+ #:export (:
+ :-dispatch-ref
+ :-dispatch-set!
+ :char-range
+ :dispatched
+ :do
+ :generator-proc
+ :integers
+ :let
+ :list
+ :parallel
+ :port
+ :range
+ :real-range
+ :string
+ :until
+ :vector
+ :while
+ any?-ec
+ append-ec
+ dispatch-union
+ do-ec
+ every?-ec
+ first-ec
+ fold-ec
+ fold3-ec
+ last-ec
+ list-ec
+ make-initial-:-dispatch
+ max-ec
+ min-ec
+ product-ec
+ string-append-ec
+ string-ec
+ sum-ec
+ vector-ec
+ vector-of-length-ec))
+
+(cond-expand-provide (current-module) '(srfi-42))
+
+(include-from-path "srfi/srfi-42/ec.scm")
diff --git a/module/srfi/srfi-42/ec.scm b/module/srfi/srfi-42/ec.scm
new file mode 100644
index 000000000..bc0616ec3
--- /dev/null
+++ b/module/srfi/srfi-42/ec.scm
@@ -0,0 +1,1053 @@
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Loading the implementation into Scheme48 0.57:
+; ,open srfi-23
+; ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+; ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+;
+; Implementation comments:
+; * All local (not exported) identifiers are named ec-<something>.
+; * This implementation focuses on portability, performance,
+; readability, and simplicity roughly in this order. Design
+; decisions related to performance are taken for Scheme48.
+; * Alternative implementations, Comments and Warnings are
+; mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do.
+;
+; We use the following short names for syntactic variables
+; q - qualifier
+; cc - current continuation, thing to call at the end;
+; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+; cmd - an expression being evaluated for its side-effects
+; expr - an expression
+; gen - a generator of an eager comprehension
+; ob - outer binding
+; oc - outer command
+; lb - loop binding
+; ne1? - not-end1? (before the payload)
+; ib - inner binding
+; ic - inner command
+; ne2? - not-end2? (after the payload)
+; ls - loop step
+; etc - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+; handles nested, if/not/and/or, begin, :let, and calls generator
+; macros in CPS to transform them into fully decorated :do.
+; The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+ (syntax-rules (nested if not and or begin :do let)
+
+ ; explicit nesting -> implicit nesting
+ ((do-ec (nested q ...) etc ...)
+ (do-ec q ... etc ...) )
+
+ ; implicit nesting -> fold do-ec
+ ((do-ec q1 q2 etc1 etc ...)
+ (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+ ; no qualifiers at all -> evaluate cmd once
+ ((do-ec cmd)
+ (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+ ; filter -> make conditional
+ ((do-ec (if test) cmd)
+ (if test (do-ec cmd)) )
+ ((do-ec (not test) cmd)
+ (if (not test) (do-ec cmd)) )
+ ((do-ec (and test ...) cmd)
+ (if (and test ...) (do-ec cmd)) )
+ ((do-ec (or test ...) cmd)
+ (if (or test ...) (do-ec cmd)) )
+
+ ; begin -> make a sequence
+ ((do-ec (begin etc ...) cmd)
+ (begin etc ... (do-ec cmd)) )
+
+ ; fully decorated :do-generator -> delegate to do-ec:do
+ ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
+ (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+ ((do-ec (g arg1 arg ...) cmd)
+ (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))
+; generates code for a single fully decorated :do-generator
+; with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+ (syntax-rules (:do let)
+
+ ; reentry point (*) -> generate code
+ ((do-ec:do cmd
+ (:do (let obs oc ...)
+ lbs
+ ne1?
+ (let ibs ic ...)
+ ne2?
+ (ls ...) ))
+ (ec-simplify
+ (let obs
+ oc ...
+ (let loop lbs
+ (ec-simplify
+ (if ne1?
+ (ec-simplify
+ (let ibs
+ ic ...
+ cmd
+ (ec-simplify
+ (if ne2?
+ (loop ls ...) )))))))))) ))
+
+
+; (ec-simplify <expression>)
+; generates potentially more efficient code for <expression>.
+; The macro handles if, (begin <command>*), and (let () <command>*)
+; and takes care of special cases.
+
+(define-syntax ec-simplify
+ (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+ ; literal <test>
+ ((ec-simplify (if #t consequent))
+ consequent )
+ ((ec-simplify (if #f consequent))
+ (if #f #f) )
+ ((ec-simplify (if #t consequent alternate))
+ consequent )
+ ((ec-simplify (if #f consequent alternate))
+ alternate )
+
+ ; (not (not <test>))
+ ((ec-simplify (if (not (not test)) consequent))
+ (ec-simplify (if test consequent)) )
+ ((ec-simplify (if (not (not test)) consequent alternate))
+ (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*)
+
+ ; empty <binding spec>*
+ ((ec-simplify (let () command ...))
+ (ec-simplify (begin command ...)) )
+
+; begin
+
+ ; flatten use helper (ec-simplify 1 done to-do)
+ ((ec-simplify (begin command ...))
+ (ec-simplify 1 () (command ...)) )
+ ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+ (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+ ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+ (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+ ; exit helper
+ ((ec-simplify 1 () ())
+ (if #f #f) )
+ ((ec-simplify 1 (command) ())
+ command )
+ ((ec-simplify 1 (command1 command ...) ())
+ (begin command1 command ...) )
+
+; anything else
+
+ ((ec-simplify expression)
+ expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax :do
+ (syntax-rules ()
+
+ ; full decorated -> continue with cc, reentry at (*)
+ ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
+ (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
+
+ ; short form -> fill in default values
+ ((:do cc lbs ne1? lss)
+ (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+
+
+(define-syntax :let
+ (syntax-rules (index)
+ ((:let cc var (index i) expression)
+ (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+ ((:let cc var expression)
+ (:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax :parallel
+ (syntax-rules (:do)
+ ((:parallel cc)
+ cc )
+ ((:parallel cc (g arg1 arg ...) gen ...)
+ (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (:parallel-1 cc (to-do ...) result [ next ] )
+; iterates over to-do by converting the first generator into
+; the :do-generator next and merging next into result.
+
+(define-syntax :parallel-1 ; used as
+ (syntax-rules (:do let)
+
+ ; process next element of to-do, reentry at (**)
+ ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+ (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+ ; reentry point (**) -> merge next into result
+ ((:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ...) oc1 ...)
+ (lb1 ...)
+ ne1?1
+ (let (ib1 ...) ic1 ...)
+ ne2?1
+ (ls1 ...) )
+ (:do (let (ob2 ...) oc2 ...)
+ (lb2 ...)
+ ne1?2
+ (let (ib2 ...) ic2 ...)
+ ne2?2
+ (ls2 ...) ))
+ (:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)
+ (lb1 ... lb2 ...)
+ (and ne1?1 ne1?2)
+ (let (ib1 ... ib2 ...) ic1 ... ic2 ...)
+ (and ne2?1 ne2?2)
+ (ls1 ... ls2 ...) )))
+
+ ; no more gens -> continue with cc, reentry at (*)
+ ((:parallel-1 (cc ...) () result)
+ (cc ... result) )))
+
+(define-syntax :while
+ (syntax-rules ()
+ ((:while cc (g arg1 arg ...) test)
+ (g (:while-1 cc test) arg1 arg ...) )))
+
+; (:while-1 cc test (:do ...))
+; modifies the fully decorated :do-generator such that it
+; runs while test is a true value.
+; The original implementation just replaced ne1? by
+; (and ne1? test) as follows:
+;
+; (define-syntax :while-1
+; (syntax-rules (:do)
+; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+; (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+; Unfortunately, this code is wrong because ne1? may depend
+; in the inner bindings introduced in ilet, but ne1? is evaluated
+; outside of the inner bindings. (Refer to the specification of
+; :do to see the structure.)
+; The problem manifests itself (as sunnan@handgranat.org
+; observed, 25-Apr-2005) when the :list-generator is modified:
+;
+; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).
+;
+; In order to generate proper code, we introduce temporary
+; variables saving the values of the inner bindings. The inner
+; bindings are executed in a new ne1?, which also evaluates ne1?
+; outside the scope of the inner bindings, then the inner commands
+; are executed (possibly changing the variables), and then the
+; values of the inner bindings are saved and (and ne1? test) is
+; returned. In the new ilet, the inner variables are bound and
+; initialized and their values are restored. So we construct:
+;
+; (let (ob .. (ib-tmp #f) ...)
+; oc ...
+; (let loop (lb ...)
+; (if (let (ne1?-value ne1?)
+; (let ((ib-var ib-rhs) ...)
+; ic ...
+; (set! ib-tmp ib-var) ...)
+; (and ne1?-value test))
+; (let ((ib-var ib-tmp) ...)
+; /payload/
+; (if ne2?
+; (loop ls ...) )))))
+;
+; Bug #2:
+; Unfortunately, the above expansion is still incorrect (as Jens-Axel
+; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+; if ne1?-value is #f, indicating that the loop has ended.
+; The problem manifests itself in the following example:
+;
+; (do-ec (:while (:list x '(1)) #t) (display x))
+;
+; Which iterates :list beyond exhausting the list '(1).
+;
+; For the fix, we follow Jens-Axel's approach of guarding the evaluation
+; of ib-rhs with a check on ne1?-value.
+
+(define-syntax :while-1
+ (syntax-rules (:do let)
+ ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax :while-2
+ (syntax-rules (:do let)
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do olet
+ lbs
+ ne1?
+ (let ((ib-var ib-rhs) ib ...) ic ...)
+ ne2?
+ lss))
+ (:while-2 cc
+ test
+ (ib-let ... (ib-tmp #f))
+ (ib-save ... (ib-var ib-rhs))
+ (ib-restore ... (ib-var ib-tmp))
+ (:do olet
+ lbs
+ ne1?
+ (let (ib ...) ic ... (set! ib-tmp ib-var))
+ ne2?
+ lss)))
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+ (:do cc
+ (let (ob ... ib-let ...) oc ...)
+ lbs
+ (let ((ne1?-value ne1?))
+ (and ne1?-value
+ (let (ib-save ...)
+ ic ...
+ test)))
+ (let (ib-restore ...))
+ ne2?
+ lss))))
+
+
+(define-syntax :until
+ (syntax-rules ()
+ ((:until cc (g arg1 arg ...) test)
+ (g (:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax :until-1
+ (syntax-rules (:do)
+ ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax :list
+ (syntax-rules (index)
+ ((:list cc var (index i) arg ...)
+ (:parallel cc (:list var arg ...) (:integers i)) )
+ ((:list cc var arg1 arg2 arg ...)
+ (:list cc var (append arg1 arg2 arg ...)) )
+ ((:list cc var arg)
+ (:do cc
+ (let ())
+ ((t arg))
+ (not (null? t))
+ (let ((var (car t))))
+ #t
+ ((cdr t)) ))))
+
+
+(define-syntax :string
+ (syntax-rules (index)
+ ((:string cc var (index i) arg)
+ (:do cc
+ (let ((str arg) (len 0))
+ (set! len (string-length str)))
+ ((i 0))
+ (< i len)
+ (let ((var (string-ref str i))))
+ #t
+ ((+ i 1)) ))
+ ((:string cc var (index i) arg1 arg2 arg ...)
+ (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+ ((:string cc var arg1 arg ...)
+ (:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+; be used for :string. However, it is less interesting as the
+; overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax :vector
+ (syntax-rules (index)
+ ((:vector cc var arg)
+ (:vector cc var (index i) arg) )
+ ((:vector cc var (index i) arg)
+ (:do cc
+ (let ((vec arg) (len 0))
+ (set! len (vector-length vec)))
+ ((i 0))
+ (< i len)
+ (let ((var (vector-ref vec i))))
+ #t
+ ((+ i 1)) ))
+
+ ((:vector cc var (index i) arg1 arg2 arg ...)
+ (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
+ ((:vector cc var arg1 arg2 arg ...)
+ (:do cc
+ (let ((vec #f)
+ (len 0)
+ (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+ ((k 0))
+ (if (< k len)
+ #t
+ (if (null? vecs)
+ #f
+ (begin (set! vec (car vecs))
+ (set! vecs (cdr vecs))
+ (set! len (vector-length vec))
+ (set! k 0)
+ #t )))
+ (let ((var (vector-ref vec k))))
+ #t
+ ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+ (if (null? vecs)
+ '()
+ (if (zero? (vector-length (car vecs)))
+ (ec-:vector-filter (cdr vecs))
+ (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+; append and :list in the multi-argument case. Please refer to the
+; 'design.scm' for more details.
+
+
+(define-syntax :integers
+ (syntax-rules (index)
+ ((:integers cc var (index i))
+ (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+ ((:integers cc var)
+ (:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax :range
+ (syntax-rules (index)
+
+ ; handle index variable and add optional args
+ ((:range cc var (index i) arg1 arg ...)
+ (:parallel cc (:range var arg1 arg ...) (:integers i)) )
+ ((:range cc var arg1)
+ (:range cc var 0 arg1 1) )
+ ((:range cc var arg1 arg2)
+ (:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+ ((:range cc var 0 arg2 1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var 0 arg2 -1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+ ((:range cc var arg1 arg2 1)
+ (:do cc
+ (let ((a arg1) (b arg2))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b 1 )) )
+ ((var a))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var arg1 arg2 -1)
+ (:do cc
+ (let ((a arg1) (b arg2) (s -1) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b -1 )) )
+ ((var a))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+; the general case
+
+ ((:range cc var arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b)
+ (integer? s) (exact? s) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b s ))
+ (if (zero? s)
+ (error "step size must not be zero in :range") )
+ (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+ ((var a))
+ (not (= var stop))
+ (let ())
+ #t
+ ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+; are exact integers. This overhead has proven very helpful for
+; saving users from themselves.
+
+
+(define-syntax :real-range
+ (syntax-rules (index)
+
+ ; add optional args and index variable
+ ((:real-range cc var arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var (index i) arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var (index i) arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var arg1 arg2 arg3)
+ (:real-range cc var (index i) arg1 arg2 arg3) )
+
+ ; the fully qualified case
+ ((:real-range cc var (index i) arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (istop 0))
+ (if (not (and (real? a) (real? b) (real? s)))
+ (error "arguments of :real-range are not real" a b s) )
+ (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+ (set! a (exact->inexact a)) )
+ (set! istop (/ (- b a) s)) )
+ ((i 0))
+ (< i istop)
+ (let ((var (+ a (* s i)))))
+ #t
+ ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+; value in case any of the other values is inexact. This is a
+; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
+
+
+(define-syntax :char-range
+ (syntax-rules (index)
+ ((:char-range cc var (index i) arg1 arg2)
+ (:parallel cc (:char-range var arg1 arg2) (:integers i)) )
+ ((:char-range cc var arg1 arg2)
+ (:do cc
+ (let ((imax (char->integer arg2))))
+ ((i (char->integer arg1)))
+ (<= i imax)
+ (let ((var (integer->char i))))
+ #t
+ ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator
+; because the integers obtained by char->integer are not necessarily
+; consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax :port
+ (syntax-rules (index)
+ ((:port cc var (index i) arg1 arg ...)
+ (:parallel cc (:port var arg1 arg ...) (:integers i)) )
+ ((:port cc var arg)
+ (:port cc var arg read) )
+ ((:port cc var arg1 arg2)
+ (:do cc
+ (let ((port arg1) (read-proc arg2)))
+ ((var (read-proc port)))
+ (not (eof-object? var))
+ (let ())
+ #t
+ ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax :dispatched
+ (syntax-rules (index)
+ ((:dispatched cc var (index i) dispatch arg1 arg ...)
+ (:parallel cc
+ (:integers i)
+ (:dispatched var dispatch arg1 arg ...) ))
+ ((:dispatched cc var dispatch arg1 arg ...)
+ (:do cc
+ (let ((d dispatch)
+ (args (list arg1 arg ...))
+ (g #f)
+ (empty (list #f)) )
+ (set! g (d args))
+ (if (not (procedure? g))
+ (error "unrecognized arguments in dispatching"
+ args
+ (d '()) )))
+ ((var (g empty)))
+ (not (eq? var empty))
+ (let ())
+ #t
+ ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+; non-empty list. It is compared using eq? which distinguishes
+; the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax :generator-proc
+ (syntax-rules (:do let)
+
+ ; call g with a variable, reentry at (**)
+ ((:generator-proc (g arg ...))
+ (g (:generator-proc var) var arg ...) )
+
+ ; reentry point (**) -> make the code from a single :do
+ ((:generator-proc
+ var
+ (:do (let obs oc ...)
+ ((lv li) ...)
+ ne1?
+ (let ((i v) ...) ic ...)
+ ne2?
+ (ls ...)) )
+ (ec-simplify
+ (let obs
+ oc ...
+ (let ((lv li) ... (ne2 #t))
+ (ec-simplify
+ (let ((i #f) ...) ; v not yet valid
+ (lambda (empty)
+ (if (and ne1? ne2)
+ (ec-simplify
+ (begin
+ (set! i v) ...
+ ic ...
+ (let ((value var))
+ (ec-simplify
+ (if ne2?
+ (ec-simplify
+ (begin (set! lv ls) ...) )
+ (set! ne2 #f) ))
+ value )))
+ empty ))))))))
+
+ ; silence warnings of some macro expanders
+ ((:generator-proc var)
+ (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+ (lambda (args)
+ (let ((g1 (d1 args)) (g2 (d2 args)))
+ (if g1
+ (if g2
+ (if (null? args)
+ (append (if (list? g1) g1 (list g1))
+ (if (list? g2) g2 (list g2)) )
+ (error "dispatching conflict" args (d1 '()) (d2 '())) )
+ g1 )
+ (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+ (lambda (args)
+ (case (length args)
+ ((0) 'SRFI42)
+ ((1) (let ((a1 (car args)))
+ (cond
+ ((list? a1)
+ (:generator-proc (:list a1)) )
+ ((string? a1)
+ (:generator-proc (:string a1)) )
+ ((vector? a1)
+ (:generator-proc (:vector a1)) )
+ ((and (integer? a1) (exact? a1))
+ (:generator-proc (:range a1)) )
+ ((real? a1)
+ (:generator-proc (:real-range a1)) )
+ ((input-port? a1)
+ (:generator-proc (:port a1)) )
+ (else
+ #f ))))
+ ((2) (let ((a1 (car args)) (a2 (cadr args)))
+ (cond
+ ((and (list? a1) (list? a2))
+ (:generator-proc (:list a1 a2)) )
+ ((and (string? a1) (string? a1))
+ (:generator-proc (:string a1 a2)) )
+ ((and (vector? a1) (vector? a2))
+ (:generator-proc (:vector a1 a2)) )
+ ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+ (:generator-proc (:range a1 a2)) )
+ ((and (real? a1) (real? a2))
+ (:generator-proc (:real-range a1 a2)) )
+ ((and (char? a1) (char? a2))
+ (:generator-proc (:char-range a1 a2)) )
+ ((and (input-port? a1) (procedure? a2))
+ (:generator-proc (:port a1 a2)) )
+ (else
+ #f ))))
+ ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+ (cond
+ ((and (list? a1) (list? a2) (list? a3))
+ (:generator-proc (:list a1 a2 a3)) )
+ ((and (string? a1) (string? a1) (string? a3))
+ (:generator-proc (:string a1 a2 a3)) )
+ ((and (vector? a1) (vector? a2) (vector? a3))
+ (:generator-proc (:vector a1 a2 a3)) )
+ ((and (integer? a1) (exact? a1)
+ (integer? a2) (exact? a2)
+ (integer? a3) (exact? a3))
+ (:generator-proc (:range a1 a2 a3)) )
+ ((and (real? a1) (real? a2) (real? a3))
+ (:generator-proc (:real-range a1 a2 a3)) )
+ (else
+ #f ))))
+ (else
+ (letrec ((every?
+ (lambda (pred args)
+ (if (null? args)
+ #t
+ (and (pred (car args))
+ (every? pred (cdr args)) )))))
+ (cond
+ ((every? list? args)
+ (:generator-proc (:list (apply append args))) )
+ ((every? string? args)
+ (:generator-proc (:string (apply string-append args))) )
+ ((every? vector? args)
+ (:generator-proc (:list (apply append (map vector->list args)))) )
+ (else
+ #f )))))))
+
+(define :-dispatch
+ (make-initial-:-dispatch) )
+
+(define (:-dispatch-ref)
+ :-dispatch )
+
+(define (:-dispatch-set! dispatch)
+ (if (not (procedure? dispatch))
+ (error "not a procedure" dispatch) )
+ (set! :-dispatch dispatch) )
+
+(define-syntax :
+ (syntax-rules (index)
+ ((: cc var (index i) arg1 arg ...)
+ (:dispatched cc var (index i) :-dispatch arg1 arg ...) )
+ ((: cc var arg1 arg ...)
+ (:dispatched cc var :-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+ (syntax-rules (nested)
+ ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 expression f1 f2)
+ (fold3-ec x0 (nested) expression f1 f2) )
+
+ ((fold3-ec x0 qualifier expression f1 f2)
+ (let ((result #f) (empty #t))
+ (do-ec qualifier
+ (let ((value expression)) ; don't duplicate
+ (if empty
+ (begin (set! result (f1 value))
+ (set! empty #f) )
+ (set! result (f2 value result)) )))
+ (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+ (syntax-rules (nested)
+ ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+ ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+ ((fold-ec x0 expression f2)
+ (fold-ec x0 (nested) expression f2) )
+
+ ((fold-ec x0 qualifier expression f2)
+ (let ((result x0))
+ (do-ec qualifier (set! result (f2 expression result)))
+ result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+ (syntax-rules ()
+ ((list-ec etc1 etc ...)
+ (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+; using set-cdr! to add at the tail. This removes the overhead of copying
+; at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+ (syntax-rules ()
+ ((append-ec etc1 etc ...)
+ (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+ (syntax-rules ()
+ ((string-ec etc1 etc ...)
+ (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+; problem. A more space-aware implementation collect the characters
+; in an intermediate list and when this list becomes too large it is
+; converted into an intermediate string. At the end, the intermediate
+; strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+ (syntax-rules ()
+ ((string-append-ec etc1 etc ...)
+ (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+ (syntax-rules ()
+ ((vector-ec etc1 etc ...)
+ (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+; However, the space overhead for the intermediate list is much lower
+; than for string-ec and as there is no vector-append, the intermediate
+; vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+ (syntax-rules (nested)
+ ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+ (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+ ((vector-of-length-ec k q1 q2 etc1 etc ...)
+ (vector-of-length-ec k (nested q1 q2) etc1 etc ...) )
+ ((vector-of-length-ec k expression)
+ (vector-of-length-ec k (nested) expression) )
+
+ ((vector-of-length-ec k qualifier expression)
+ (let ((len k))
+ (let ((vec (make-vector len))
+ (i 0) )
+ (do-ec qualifier
+ (if (< i len)
+ (begin (vector-set! vec i expression)
+ (set! i (+ i 1)) )
+ (error "vector is too short for the comprehension") ))
+ (if (= i len)
+ vec
+ (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+ (syntax-rules ()
+ ((sum-ec etc1 etc ...)
+ (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+ (syntax-rules ()
+ ((product-ec etc1 etc ...)
+ (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+ (syntax-rules ()
+ ((min-ec etc1 etc ...)
+ (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+ (syntax-rules ()
+ ((max-ec etc1 etc ...)
+ (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+ (syntax-rules (nested)
+ ((last-ec default (nested q1 ...) q etc1 etc ...)
+ (last-ec default (nested q1 ... q) etc1 etc ...) )
+ ((last-ec default q1 q2 etc1 etc ...)
+ (last-ec default (nested q1 q2) etc1 etc ...) )
+ ((last-ec default expression)
+ (last-ec default (nested) expression) )
+
+ ((last-ec default qualifier expression)
+ (let ((result default))
+ (do-ec qualifier (set! result expression))
+ result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+ (syntax-rules (nested)
+ ((first-ec default (nested q1 ...) q etc1 etc ...)
+ (first-ec default (nested q1 ... q) etc1 etc ...) )
+ ((first-ec default q1 q2 etc1 etc ...)
+ (first-ec default (nested q1 q2) etc1 etc ...) )
+ ((first-ec default expression)
+ (first-ec default (nested) expression) )
+
+ ((first-ec default qualifier expression)
+ (let ((result default) (stop #f))
+ (ec-guarded-do-ec
+ stop
+ (nested qualifier)
+ (begin (set! result expression)
+ (set! stop #t) ))
+ result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+; constructs (do-ec q ... cmd) where the generators gen in q ... are
+; replaced by (:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+ (syntax-rules (nested if not and or begin)
+
+ ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+ (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+ ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+ (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+ (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+ (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+ (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+ (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+ (do-ec
+ (:until gen stop)
+ (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+ ((ec-guarded-do-ec stop (nested) cmd)
+ (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+; possible to use call-with-current-continuation:
+;
+; (define-synatx first-ec
+; ...same as above...
+; ((first-ec default qualifier expression)
+; (call-with-current-continuation
+; (lambda (cc)
+; (do-ec qualifier (cc expression))
+; default ))) ))
+;
+; This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+ (syntax-rules (nested)
+ ((any?-ec (nested q1 ...) q etc1 etc ...)
+ (any?-ec (nested q1 ... q) etc1 etc ...) )
+ ((any?-ec q1 q2 etc1 etc ...)
+ (any?-ec (nested q1 q2) etc1 etc ...) )
+ ((any?-ec expression)
+ (any?-ec (nested) expression) )
+
+ ((any?-ec qualifier expression)
+ (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+ (syntax-rules (nested)
+ ((every?-ec (nested q1 ...) q etc1 etc ...)
+ (every?-ec (nested q1 ... q) etc1 etc ...) )
+ ((every?-ec q1 q2 etc1 etc ...)
+ (every?-ec (nested q1 q2) etc1 etc ...) )
+ ((every?-ec expression)
+ (every?-ec (nested) expression) )
+
+ ((every?-ec qualifier expression)
+ (first-ec #t qualifier (if (not expression)) #f) )))
+
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
new file mode 100644
index 000000000..e1bf19e9d
--- /dev/null
+++ b/module/srfi/srfi-43.scm
@@ -0,0 +1,1081 @@
+;;; srfi-43.scm -- SRFI 43 Vector library
+
+;; Copyright (C) 2014, 2018 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Mark H Weaver <mhw@netris.org>
+
+(define-module (srfi srfi-43)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:re-export (make-vector vector vector? vector-ref vector-set!
+ vector-length)
+ #:replace (vector-copy vector-fill! list->vector vector->list)
+ #:export (vector-empty? vector= vector-unfold vector-unfold-right
+ vector-reverse-copy
+ vector-append vector-concatenate
+ vector-fold vector-fold-right
+ vector-map vector-map!
+ vector-for-each vector-count
+ vector-index vector-index-right
+ vector-skip vector-skip-right
+ vector-binary-search
+ vector-any vector-every
+ vector-swap! vector-reverse!
+ vector-copy! vector-reverse-copy!
+ reverse-vector->list
+ reverse-list->vector))
+
+(cond-expand-provide (current-module) '(srfi-43))
+
+(define-syntax error-from
+ (lambda (stx)
+ (syntax-case stx (quote)
+ ((_ 'who msg arg ...)
+ #`(error #,(string-append (symbol->string (syntax->datum #'who))
+ ": "
+ (syntax->datum #'msg))
+ arg ...)))))
+
+(define-syntax-rule (assert-nonneg-exact-integer k who)
+ (unless (and (exact-integer? k)
+ (not (negative? k)))
+ (error-from who "expected non-negative exact integer, got" k)))
+
+(define-syntax-rule (assert-procedure f who)
+ (unless (procedure? f)
+ (error-from who "expected procedure, got" f)))
+
+(define-syntax-rule (assert-vector v who)
+ (unless (vector? v)
+ (error-from who "expected vector, got" v)))
+
+(define-syntax-rule (assert-valid-index i len who)
+ (unless (and (exact-integer? i)
+ (<= 0 i len))
+ (error-from who "invalid index" i)))
+
+(define-syntax-rule (assert-valid-start start len who)
+ (unless (and (exact-integer? start)
+ (<= 0 start len))
+ (error-from who "invalid start index" start)))
+
+(define-syntax-rule (assert-valid-range start end len who)
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start end len))
+ (error-from who "invalid index range" start end)))
+
+(define-syntax-rule (assert-vectors vs who)
+ (let loop ((vs vs))
+ (unless (null? vs)
+ (assert-vector (car vs) who)
+ (loop (cdr vs)))))
+
+;; Return the length of the shortest vector in VS.
+;; VS must have at least one element.
+(define (min-length vs)
+ (let loop ((vs (cdr vs))
+ (result (vector-length (car vs))))
+ (if (null? vs)
+ result
+ (loop (cdr vs) (min result (vector-length (car vs)))))))
+
+;; Return a list of the Ith elements of the vectors in VS.
+(define (vectors-ref vs i)
+ (let loop ((vs vs) (xs '()))
+ (if (null? vs)
+ (reverse! xs)
+ (loop (cdr vs) (cons (vector-ref (car vs) i)
+ xs)))))
+
+(define vector-unfold
+ (case-lambda
+ "(vector-unfold f length initial-seed ...) -> vector
+
+The fundamental vector constructor. Create a vector whose length is
+LENGTH and iterates across each index k from 0 up to LENGTH - 1,
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration. It is an
+error for the number of seeds to vary between iterations."
+ ((f len)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v i (f i))
+ (loop (+ i 1))))
+ v))
+ ((f len seed)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seed seed))
+ (unless (= i len)
+ (receive (x seed) (f i seed)
+ (vector-set! v i x)
+ (loop (+ i 1) seed))))
+ v))
+ ((f len seed1 seed2)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seed1 seed1) (seed2 seed2))
+ (unless (= i len)
+ (receive (x seed1 seed2) (f i seed1 seed2)
+ (vector-set! v i x)
+ (loop (+ i 1) seed1 seed2))))
+ v))
+ ((f len . seeds)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seeds seeds))
+ (unless (= i len)
+ (receive (x . seeds) (apply f i seeds)
+ (vector-set! v i x)
+ (loop (+ i 1) seeds))))
+ v))))
+
+(define vector-unfold-right
+ (case-lambda
+ "(vector-unfold-right f length initial-seed ...) -> vector
+
+The fundamental vector constructor. Create a vector whose length is
+LENGTH and iterates across each index k from LENGTH - 1 down to 0,
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration. It is an
+error for the number of seeds to vary between iterations."
+ ((f len)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (unless (negative? i)
+ (vector-set! v i (f i))
+ (loop (- i 1))))
+ v))
+ ((f len seed)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seed seed))
+ (unless (negative? i)
+ (receive (x seed) (f i seed)
+ (vector-set! v i x)
+ (loop (- i 1) seed))))
+ v))
+ ((f len seed1 seed2)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seed1 seed1) (seed2 seed2))
+ (unless (negative? i)
+ (receive (x seed1 seed2) (f i seed1 seed2)
+ (vector-set! v i x)
+ (loop (- i 1) seed1 seed2))))
+ v))
+ ((f len . seeds)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seeds seeds))
+ (unless (negative? i)
+ (receive (x . seeds) (apply f i seeds)
+ (vector-set! v i x)
+ (loop (- i 1) seeds))))
+ v))))
+
+(define guile-vector-copy (@ (guile) vector-copy))
+
+;; TODO: Enhance Guile core 'vector-copy' to do this.
+(define vector-copy
+ (case-lambda*
+ "(vector-copy vec [start [end [fill]]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec starting at index START
+and stopping at index END. START defaults to 0 and END defaults to
+the value of (vector-length VEC). If END extends beyond the length of
+VEC, the slots in the new vector that obviously cannot be filled by
+elements from VEC are filled with FILL, whose default value is
+unspecified."
+ ((v) (guile-vector-copy v))
+ ((v start)
+ (assert-vector v 'vector-copy)
+ (let ((len (vector-length v)))
+ (assert-valid-start start len 'vector-copy)
+ (let ((result (make-vector (- len start))))
+ (vector-move-left! v start len result 0)
+ result)))
+ ((v start end #:optional (fill *unspecified*))
+ (assert-vector v 'vector-copy)
+ (let ((len (vector-length v)))
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start end))
+ (error-from 'vector-copy "invalid index range" start end))
+ (let ((result (make-vector (- end start) fill)))
+ (vector-move-left! v start (min end len) result 0)
+ result)))))
+
+(define vector-reverse-copy
+ (let ()
+ (define (%vector-reverse-copy vec start end)
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i 0) (j (- end 1)))
+ (unless (= i len)
+ (vector-set! result i (vector-ref vec j))
+ (loop (+ i 1) (- j 1))))
+ result))
+ (case-lambda
+ "(vector-reverse-copy vec [start [end]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec in reverse order starting
+at index START and stopping at index END. START defaults to 0 and END
+defaults to the value of (vector-length VEC)."
+ ((vec)
+ (assert-vector vec 'vector-reverse-copy)
+ (%vector-reverse-copy vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector-reverse-copy)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-reverse-copy)
+ (%vector-reverse-copy vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector-reverse-copy)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-reverse-copy)
+ (%vector-reverse-copy vec start end))))))
+
+(define (%vector-concatenate vs)
+ (let* ((result-len (let loop ((vs vs) (len 0))
+ (if (null? vs)
+ len
+ (loop (cdr vs) (+ len (vector-length (car vs)))))))
+ (result (make-vector result-len)))
+ (let loop ((vs vs) (pos 0))
+ (unless (null? vs)
+ (let* ((v (car vs))
+ (len (vector-length v)))
+ (vector-move-left! v 0 len result pos)
+ (loop (cdr vs) (+ pos len)))))
+ result))
+
+(define vector-append
+ (case-lambda
+ "(vector-append vec ...) -> vector
+
+Return a newly allocated vector that contains all elements in order
+from the subsequent locations in VEC ..."
+ (() (vector))
+ ((v)
+ (assert-vector v 'vector-append)
+ (guile-vector-copy v))
+ ((v1 v2)
+ (assert-vector v1 'vector-append)
+ (assert-vector v2 'vector-append)
+ (let ((len1 (vector-length v1))
+ (len2 (vector-length v2)))
+ (let ((result (make-vector (+ len1 len2))))
+ (vector-move-left! v1 0 len1 result 0)
+ (vector-move-left! v2 0 len2 result len1)
+ result)))
+ (vs
+ (assert-vectors vs 'vector-append)
+ (%vector-concatenate vs))))
+
+(define (vector-concatenate vs)
+ "(vector-concatenate list-of-vectors) -> vector
+
+Append each vector in LIST-OF-VECTORS. Equivalent to:
+ (apply vector-append LIST-OF-VECTORS)"
+ (assert-vectors vs 'vector-concatenate)
+ (%vector-concatenate vs))
+
+(define (vector-empty? vec)
+ "(vector-empty? vec) -> boolean
+
+Return true if VEC is empty, i.e. its length is 0, and false if not."
+ (assert-vector vec 'vector-empty?)
+ (zero? (vector-length vec)))
+
+(define vector=
+ (let ()
+ (define (all-of-length? len vs)
+ (or (null? vs)
+ (and (= len (vector-length (car vs)))
+ (all-of-length? len (cdr vs)))))
+ (define (=up-to? i elt=? v1 v2)
+ (or (negative? i)
+ (let ((x1 (vector-ref v1 i))
+ (x2 (vector-ref v2 i)))
+ (and (or (eq? x1 x2) (elt=? x1 x2))
+ (=up-to? (- i 1) elt=? v1 v2)))))
+ (case-lambda
+ "(vector= elt=? vec ...) -> boolean
+
+Return true if the vectors VEC ... have equal lengths and equal
+elements according to ELT=?. ELT=? is always applied to two
+arguments. Element comparison must be consistent with eq?, in the
+following sense: if (eq? a b) returns true, then (elt=? a b) must also
+return true. The order in which comparisons are performed is
+unspecified."
+ ((elt=?)
+ (assert-procedure elt=? 'vector=)
+ #t)
+ ((elt=? v)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v 'vector=)
+ #t)
+ ((elt=? v1 v2)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v1 'vector=)
+ (assert-vector v2 'vector=)
+ (let ((len (vector-length v1)))
+ (and (= len (vector-length v2))
+ (=up-to? (- len 1) elt=? v1 v2))))
+ ((elt=? v1 . vs)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v1 'vector=)
+ (assert-vectors vs 'vector=)
+ (let ((len (vector-length v1)))
+ (and (all-of-length? len vs)
+ (let loop ((vs vs))
+ (or (null? vs)
+ (and (=up-to? (- len 1) elt=? v1 (car vs))
+ (loop (cdr vs)))))))))))
+
+(define vector-fold
+ (case-lambda
+ "(vector-fold kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator. KONS is iterated over each index in
+all of the vectors, stopping at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration. The iteration is strictly
+left-to-right."
+ ((kcons knil v)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vector v 'vector-fold)
+ (let ((len (vector-length v)))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1) (kcons i state (vector-ref v i)))))))
+ ((kcons knil v1 v2)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vector v1 'vector-fold)
+ (assert-vector v2 'vector-fold)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1)
+ (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+ ((kcons knil . vs)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vectors vs 'vector-fold)
+ (let ((len (min-length vs)))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-fold-right
+ (case-lambda
+ "(vector-fold-right kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator. KONS is iterated over each index in
+all of the vectors, starting at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration. The iteration is strictly
+right-to-left."
+ ((kcons knil v)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vector v 'vector-fold-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1) (kcons i state (vector-ref v i)))))))
+ ((kcons knil v1 v2)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vector v1 'vector-fold-right)
+ (assert-vector v2 'vector-fold-right)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1)
+ (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+ ((kcons knil . vs)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vectors vs 'vector-fold-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-map
+ (case-lambda
+ "(vector-map f vec2 vec2 ...) -> vector
+
+Return a new vector of the shortest size of the vector arguments.
+Each element at index i of the new vector is mapped from the old
+vectors by (F i (vector-ref VEC1 i) (vector-ref VEC2 i) ...). The
+dynamic order of application of F is unspecified."
+ ((f v)
+ (assert-procedure f 'vector-map)
+ (assert-vector v 'vector-map)
+ (let* ((len (vector-length v))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (f i (vector-ref v i)))
+ (loop (+ i 1))))
+ result))
+ ((f v1 v2)
+ (assert-procedure f 'vector-map)
+ (assert-vector v1 'vector-map)
+ (assert-vector v2 'vector-map)
+ (let* ((len (min (vector-length v1) (vector-length v2)))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i)))
+ (loop (+ i 1))))
+ result))
+ ((f . vs)
+ (assert-procedure f 'vector-map)
+ (assert-vectors vs 'vector-map)
+ (let* ((len (min-length vs))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (apply f i (vectors-ref vs i)))
+ (loop (+ i 1))))
+ result))))
+
+(define vector-map!
+ (case-lambda
+ "(vector-map! f vec2 vec2 ...) -> unspecified
+
+Similar to vector-map, but rather than mapping the new elements into a
+new vector, the new mapped elements are destructively inserted into
+VEC1. The dynamic order of application of F is unspecified."
+ ((f v)
+ (assert-procedure f 'vector-map!)
+ (assert-vector v 'vector-map!)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v i (f i (vector-ref v i)))
+ (loop (+ i 1))))))
+ ((f v1 v2)
+ (assert-procedure f 'vector-map!)
+ (assert-vector v1 'vector-map!)
+ (assert-vector v2 'vector-map!)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i)))
+ (loop (+ i 1))))))
+ ((f . vs)
+ (assert-procedure f 'vector-map!)
+ (assert-vectors vs 'vector-map!)
+ (let ((len (min-length vs))
+ (v1 (car vs)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v1 i (apply f i (vectors-ref vs i)))
+ (loop (+ i 1))))))))
+
+(define vector-for-each
+ (case-lambda
+ "(vector-for-each f vec1 vec2 ...) -> unspecified
+
+Call (F i VEC1[i] VEC2[i] ...) for each index i less than the length
+of the shortest vector passed. The iteration is strictly
+left-to-right."
+ ((f v)
+ (assert-procedure f 'vector-for-each)
+ (assert-vector v 'vector-for-each)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f i (vector-ref v i))
+ (loop (+ i 1))))))
+ ((f v1 v2)
+ (assert-procedure f 'vector-for-each)
+ (assert-vector v1 'vector-for-each)
+ (assert-vector v2 'vector-for-each)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f i (vector-ref v1 i) (vector-ref v2 i))
+ (loop (+ i 1))))))
+ ((f . vs)
+ (assert-procedure f 'vector-for-each)
+ (assert-vectors vs 'vector-for-each)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f i (vectors-ref vs i))
+ (loop (+ i 1))))))))
+
+(define vector-count
+ (case-lambda
+ "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer
+
+Count the number of indices i for which (PRED? VEC1[i] VEC2[i] ...)
+returns true, where i is less than the length of the shortest vector
+passed."
+ ((pred? v)
+ (assert-procedure pred? 'vector-count)
+ (assert-vector v 'vector-count)
+ (let ((len (vector-length v)))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((pred? i (vector-ref v i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-count)
+ (assert-vector v1 'vector-count)
+ (assert-vector v2 'vector-count)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((pred? i (vector-ref v1 i) (vector-ref v2 i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-count)
+ (assert-vectors vs 'vector-count)
+ (let ((len (min-length vs)))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((apply pred? i (vectors-ref vs i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))))
+
+(define vector-index
+ (case-lambda
+ "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+satisfy PRED?. If no matching element is found by the end of the
+shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-index)
+ (assert-vector v 'vector-index)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v i))
+ i
+ (loop (+ i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-index)
+ (assert-vector v1 'vector-index)
+ (assert-vector v2 'vector-index)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ i
+ (loop (+ i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-index)
+ (assert-vectors vs 'vector-index)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (apply pred? (vectors-ref vs i))
+ i
+ (loop (+ i 1)))))))))
+
+(define vector-index-right
+ (case-lambda
+ "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+satisfy PRED?, searching from right-to-left. If no matching element
+is found before the end of the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vector v 'vector-index-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (pred? (vector-ref v i))
+ i
+ (loop (- i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vector v1 'vector-index-right)
+ (assert-vector v2 'vector-index-right)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ i
+ (loop (- i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vectors vs 'vector-index-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (apply pred? (vectors-ref vs i))
+ i
+ (loop (- i 1)))))))))
+
+(define vector-skip
+ (case-lambda
+ "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+do not satisfy PRED?. If no matching element is found by the end of
+the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vector v 'vector-skip)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v i))
+ (loop (+ i 1))
+ i)))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vector v1 'vector-skip)
+ (assert-vector v2 'vector-skip)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (+ i 1))
+ i)))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vectors vs 'vector-skip)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (apply pred? (vectors-ref vs i))
+ (loop (+ i 1))
+ i)))))))
+
+(define vector-skip-right
+ (case-lambda
+ "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+do not satisfy PRED?, searching from right-to-left. If no matching
+element is found before the end of the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vector v 'vector-skip-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (pred? (vector-ref v i))
+ (loop (- i 1))
+ i)))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vector v1 'vector-skip-right)
+ (assert-vector v2 'vector-skip-right)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (- i 1))
+ i)))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vectors vs 'vector-skip-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (apply pred? (vectors-ref vs i))
+ (loop (- i 1))
+ i)))))))
+
+(define vector-binary-search
+ (let ()
+ (define (%vector-binary-search vec value cmp start end)
+ (let loop ((lo start) (hi end))
+ (and (< lo hi)
+ (let* ((i (quotient (+ lo hi) 2))
+ (x (vector-ref vec i))
+ (c (cmp x value)))
+ (cond ((zero? c) i)
+ ((positive? c) (loop lo i))
+ ((negative? c) (loop (+ i 1) hi)))))))
+ (case-lambda
+ "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative integer or #f
+
+Find and return an index of VEC between START and END whose value is
+VALUE using a binary search. If no matching element is found, return
+#f. The default START is 0 and the default END is the length of VEC.
+CMP must be a procedure of two arguments such that (CMP A B) returns
+a negative integer if A < B, a positive integer if A > B, or zero if
+A = B. The elements of VEC must be sorted in non-decreasing order
+according to CMP."
+ ((vec value cmp)
+ (assert-vector vec 'vector-binary-search)
+ (assert-procedure cmp 'vector-binary-search)
+ (%vector-binary-search vec value cmp 0 (vector-length vec)))
+
+ ((vec value cmp start)
+ (assert-vector vec 'vector-binary-search)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-binary-search)
+ (%vector-binary-search vec value cmp start len)))
+
+ ((vec value cmp start end)
+ (assert-vector vec 'vector-binary-search)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-binary-search)
+ (%vector-binary-search vec value cmp start end))))))
+
+(define vector-any
+ (case-lambda
+ "(vector-any pred? vec1 vec2 ...) -> value or #f
+
+Find the first parallel set of elements from VEC1 VEC2 ... for which
+PRED? returns a true value. If such a parallel set of elements
+exists, vector-any returns the value that PRED? returned for that set
+of elements. The iteration is strictly left-to-right."
+ ((pred? v)
+ (assert-procedure pred? 'vector-any)
+ (assert-vector v 'vector-any)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (pred? (vector-ref v i))
+ (loop (+ i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-any)
+ (assert-vector v1 'vector-any)
+ (assert-vector v2 'vector-any)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (+ i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-any)
+ (assert-vectors vs 'vector-any)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (apply pred? (vectors-ref vs i))
+ (loop (+ i 1)))))))))
+
+(define vector-every
+ (case-lambda
+ "(vector-every pred? vec1 vec2 ...) -> value or #f
+
+If, for every index i less than the length of the shortest vector
+argument, the set of elements VEC1[i] VEC2[i] ... satisfies PRED?,
+vector-every returns the value that PRED? returned for the last set of
+elements, at the last index of the shortest vector. The iteration is
+strictly left-to-right."
+ ((pred? v)
+ (assert-procedure pred? 'vector-every)
+ (assert-vector v 'vector-every)
+ (let ((len (vector-length v)))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (pred? (vector-ref v i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-every)
+ (assert-vector v1 'vector-every)
+ (assert-vector v2 'vector-every)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (pred? (vector-ref v1 i)
+ (vector-ref v2 i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-every)
+ (assert-vectors vs 'vector-every)
+ (let ((len (min-length vs)))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (apply pred? (vectors-ref vs i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))))
+
+(define (vector-swap! vec i j)
+ "(vector-swap! vec i j) -> unspecified
+
+Swap the values of the locations in VEC at I and J."
+ (assert-vector vec 'vector-swap!)
+ (let ((len (vector-length vec)))
+ (assert-valid-index i len 'vector-swap!)
+ (assert-valid-index j len 'vector-swap!)
+ (let ((tmp (vector-ref vec i)))
+ (vector-set! vec i (vector-ref vec j))
+ (vector-set! vec j tmp))))
+
+;; TODO: Enhance Guile core 'vector-fill!' to do this.
+(define vector-fill!
+ (let ()
+ (define guile-vector-fill!
+ (@ (guile) vector-fill!))
+ (define (%vector-fill! vec fill start end)
+ (let loop ((i start))
+ (when (< i end)
+ (vector-set! vec i fill)
+ (loop (+ i 1)))))
+ (case-lambda
+ "(vector-fill! vec fill [start [end]]) -> unspecified
+
+Assign the value of every location in VEC between START and END to
+FILL. START defaults to 0 and END defaults to the length of VEC."
+ ((vec fill)
+ (guile-vector-fill! vec fill))
+ ((vec fill start)
+ (assert-vector vec 'vector-fill!)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-fill!)
+ (%vector-fill! vec fill start len)))
+ ((vec fill start end)
+ (assert-vector vec 'vector-fill!)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-fill!)
+ (%vector-fill! vec fill start end))))))
+
+(define (%vector-reverse! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (let ((tmp (vector-ref vec i)))
+ (vector-set! vec i (vector-ref vec j))
+ (vector-set! vec j tmp)
+ (loop (+ i 1) (- j 1))))))
+
+(define vector-reverse!
+ (case-lambda
+ "(vector-reverse! vec [start [end]]) -> unspecified
+
+Destructively reverse the contents of VEC between START and END.
+START defaults to 0 and END defaults to the length of VEC."
+ ((vec)
+ (assert-vector vec 'vector-reverse!)
+ (%vector-reverse! vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector-reverse!)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-reverse!)
+ (%vector-reverse! vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector-reverse!)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-reverse!)
+ (%vector-reverse! vec start end)))))
+
+(define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
+ (define copy!
+ (let ((%copy! inner-proc))
+ (case-lambda
+ docstring
+ ((target tstart source)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (unless (>= tlen (+ tstart slen))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source 0 slen)))
+
+ ((target tstart source sstart)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (assert-valid-start sstart slen 'copy!)
+ (unless (>= tlen (+ tstart (- slen sstart)))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source sstart slen)))
+
+ ((target tstart source sstart send)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (assert-valid-range sstart send slen 'copy!)
+ (unless (>= tlen (+ tstart (- send sstart)))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source sstart send)))))))
+
+(define-vector-copier! vector-copy!
+ "(vector-copy! target tstart source [sstart [send]]) -> unspecified
+
+Copy a block of elements from SOURCE to TARGET, both of which must be
+vectors, starting in TARGET at TSTART and starting in SOURCE at
+SSTART, ending when SEND - SSTART elements have been copied. It is an
+error for TARGET to have a length less than TSTART + (SEND - SSTART).
+SSTART defaults to 0 and SEND defaults to the length of SOURCE."
+ (lambda (target tstart source sstart send)
+ (if (< tstart sstart)
+ (vector-move-left! source sstart send target tstart)
+ (vector-move-right! source sstart send target tstart))))
+
+(define-vector-copier! vector-reverse-copy!
+ "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
+
+Like vector-copy!, but copy the elements in the reverse order. It is
+an error if TARGET and SOURCE are identical vectors and the TARGET and
+SOURCE ranges overlap; however, if TSTART = SSTART,
+vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND)
+would."
+ (lambda (target tstart source sstart send)
+ (if (and (eq? target source) (= tstart sstart))
+ (%vector-reverse! target sstart send)
+ (let loop ((i tstart) (j (- send 1)))
+ (when (>= j sstart)
+ (vector-set! target i (vector-ref source j))
+ (loop (+ i 1) (- j 1)))))))
+
+(define vector->list
+ (let ()
+ (define (%vector->list vec start end)
+ (let loop ((i (- end 1))
+ (result '()))
+ (if (< i start)
+ result
+ (loop (- i 1) (cons (vector-ref vec i) result)))))
+ (case-lambda
+ "(vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END. START defaults to 0 and END defaults to the length of
+VEC."
+ ((vec)
+ (assert-vector vec 'vector->list)
+ (%vector->list vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector->list)
+ (%vector->list vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector->list)
+ (%vector->list vec start end))))))
+
+(define reverse-vector->list
+ (let ()
+ (define (%reverse-vector->list vec start end)
+ (let loop ((i start)
+ (result '()))
+ (if (>= i end)
+ result
+ (loop (+ i 1) (cons (vector-ref vec i) result)))))
+ (case-lambda
+ "(reverse-vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END in reverse order. START defaults to 0 and END defaults
+to the length of VEC."
+ ((vec)
+ (assert-vector vec 'reverse-vector->list)
+ (%reverse-vector->list vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'reverse-vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'reverse-vector->list)
+ (%reverse-vector->list vec start len)))
+ ((vec start end)
+ (assert-vector vec 'reverse-vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'reverse-vector->list)
+ (%reverse-vector->list vec start end))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (list->vector lst #:optional (start 0) (end (length lst)))
+ "(list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END. START defaults to 0 and END defaults
+to the length of PROPER-LIST."
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i 0) (lst (drop lst start)))
+ (if (= i len)
+ result
+ (begin (vector-set! result i (car lst))
+ (loop (+ i 1) (cdr lst)))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (reverse-list->vector lst #:optional (start 0) (end (length lst)))
+ "(reverse-list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END, in reverse order. START defaults to 0
+and END defaults to the length of PROPER-LIST."
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i (- len 1)) (lst (drop lst start)))
+ (if (negative? i)
+ result
+ (begin (vector-set! result i (car lst))
+ (loop (- i 1) (cdr lst)))))))
diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm
new file mode 100644
index 000000000..6f7ba7e04
--- /dev/null
+++ b/module/srfi/srfi-45.scm
@@ -0,0 +1,93 @@
+;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
+
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; Commentary:
+
+;; This is the code of the reference implementation of SRFI-45, modified
+;; to use SRFI-9 and to add 'promise?' to the list of exports.
+
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-45)
+ #:export (delay
+ lazy
+ force
+ eager
+ promise?)
+ #:replace (delay force promise?)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu))
+
+(cond-expand-provide (current-module) '(srfi-45))
+
+(define-record-type promise (make-promise val) promise?
+ (val promise-val promise-val-set!))
+
+(define-record-type value (make-value tag proc) value?
+ (tag value-tag value-tag-set!)
+ (proc value-proc value-proc-set!))
+
+(define-syntax-rule (lazy exp)
+ (make-promise (make-value 'lazy (lambda () exp))))
+
+(define (eager x)
+ (make-promise (make-value 'eager x)))
+
+(define-syntax-rule (delay exp)
+ (lazy (eager exp)))
+
+(define (force promise)
+ (let ((content (promise-val promise)))
+ (case (value-tag content)
+ ((eager) (value-proc content))
+ ((lazy) (let* ((promise* ((value-proc content)))
+ (content (promise-val promise))) ; *
+ (if (not (eqv? (value-tag content) 'eager)) ; *
+ (begin (value-tag-set! content
+ (value-tag (promise-val promise*)))
+ (value-proc-set! content
+ (value-proc (promise-val promise*)))
+ (promise-val-set! promise* content)))
+ (force promise))))))
+
+;; (*) These two lines re-fetch and check the original promise in case
+;; the first line of the let* caused it to be forced. For an example
+;; where this happens, see reentrancy test 3 below.
+
+(define* (promise-visit promise #:key on-eager on-lazy)
+ (define content (promise-val promise))
+ (case (value-tag content)
+ ((eager) (on-eager (value-proc content)))
+ ((lazy) (on-lazy (value-proc content)))))
+
+(set-record-type-printer! promise
+ (lambda (promise port)
+ (promise-visit promise
+ #:on-eager (lambda (value)
+ (format port "#<promise = ~s>" value))
+ #:on-lazy (lambda (proc)
+ (format port "#<promise => ~s>" proc)))))
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
new file mode 100644
index 000000000..e6f8b438a
--- /dev/null
+++ b/module/srfi/srfi-6.scm
@@ -0,0 +1,29 @@
+;;; srfi-6.scm --- Basic String Ports
+
+;; Copyright (C) 2001, 2002, 2003, 2006, 2012,
+;; 2013 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module 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))
+
+;;; srfi-6.scm ends here
diff --git a/module/srfi/srfi-60.scm b/module/srfi/srfi-60.scm
new file mode 100644
index 000000000..b3ddaada7
--- /dev/null
+++ b/module/srfi/srfi-60.scm
@@ -0,0 +1,73 @@
+;;; srfi-60.scm --- Integers as Bits
+
+;; Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-60)
+ #:export (bitwise-and
+ bitwise-ior
+ bitwise-xor
+ bitwise-not
+ any-bits-set?
+ bitwise-if bitwise-merge
+ log2-binary-factors first-set-bit
+ bit-set?
+ copy-bit
+ bit-field
+ copy-bit-field
+ arithmetic-shift
+ rotate-bit-field
+ reverse-bit-field
+ integer->list
+ list->integer
+ booleans->integer)
+ #:replace (bit-count)
+ #:re-export (logand
+ logior
+ logxor
+ integer-length
+ logtest
+ logcount
+ logbit?
+ ash))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_srfi_60")
+
+(define bitwise-and logand)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-not lognot)
+(define any-bits-set? logtest)
+(define bit-count logcount)
+
+(define (bitwise-if mask n0 n1)
+ (logior (logand mask n0)
+ (logand (lognot mask) n1)))
+(define bitwise-merge bitwise-if)
+
+(define first-set-bit log2-binary-factors)
+(define bit-set? logbit?)
+(define bit-field bit-extract)
+
+(define (copy-bit-field n newbits start end)
+ (logxor n (ash (logxor (bit-extract n start end) ;; cancel old
+ (bit-extract newbits 0 (- end start))) ;; insert new
+ start)))
+
+(define arithmetic-shift ash)
+
+(cond-expand-provide (current-module) '(srfi-60))
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
new file mode 100644
index 000000000..81dcc5dc5
--- /dev/null
+++ b/module/srfi/srfi-64.scm
@@ -0,0 +1,55 @@
+;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-64)
+ #:export
+ (test-begin
+ test-end test-assert test-eqv test-eq test-equal
+ test-approximate test-assert test-error test-apply test-with-runner
+ test-match-nth test-match-all test-match-any test-match-name
+ test-skip test-expect-fail test-read-eval-string
+ test-runner-group-path test-group test-group-with-cleanup
+ test-result-ref test-result-set! test-result-clear test-result-remove
+ test-result-kind test-passed?
+ test-log-to-file
+ test-runner? test-runner-reset test-runner-null
+ test-runner-simple test-runner-current test-runner-factory test-runner-get
+ test-runner-create test-runner-test-name
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+ test-result-alist test-result-alist!
+ test-runner-aux-value test-runner-aux-value!
+ test-on-group-begin-simple test-on-group-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ test-on-final-simple test-on-test-end-simple
+ test-on-final-simple))
+
+(cond-expand-provide (current-module) '(srfi-64))
+
+(include-from-path "srfi/srfi-64/testing.scm")
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
new file mode 100644
index 000000000..d686662bf
--- /dev/null
+++ b/module/srfi/srfi-64/testing.scm
@@ -0,0 +1,1040 @@
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;; Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(cond-expand
+ (chicken
+ (require-extension syntax-case))
+ (guile-2
+ (use-modules (srfi srfi-9)
+ ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
+ ;; with either Guile's native exceptions or R6RS exceptions.
+ ;;(srfi srfi-34) (srfi srfi-35)
+ (srfi srfi-39)))
+ (guile
+ (use-modules (ice-9 syncase) (srfi srfi-9)
+ ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
+ (srfi srfi-39)))
+ (sisc
+ (require-extension (srfi 9 34 35 39)))
+ (kawa
+ (module-compile-options warn-undefined-variable: #t
+ warn-invoke-unknown-method: #t)
+ (provide 'srfi-64)
+ (provide 'testing)
+ (require 'srfi-34)
+ (require 'srfi-35))
+ (else ()
+ ))
+
+(cond-expand
+ (kawa
+ (define-syntax %test-export
+ (syntax-rules ()
+ ((%test-export test-begin . other-names)
+ (module-export %test-begin . other-names)))))
+ (else
+ (define-syntax %test-export
+ (syntax-rules ()
+ ((%test-export . names) (if #f #f))))))
+
+;; List of exported names
+(%test-export
+ test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
+ test-end test-assert test-eqv test-eq test-equal
+ test-approximate test-assert test-error test-apply test-with-runner
+ test-match-nth test-match-all test-match-any test-match-name
+ test-skip test-expect-fail test-read-eval-string
+ test-runner-group-path test-group test-group-with-cleanup
+ test-result-ref test-result-set! test-result-clear test-result-remove
+ test-result-kind test-passed?
+ test-log-to-file
+ ; Misc test-runner functions
+ test-runner? test-runner-reset test-runner-null
+ test-runner-simple test-runner-current test-runner-factory test-runner-get
+ test-runner-create test-runner-test-name
+ ;; test-runner field setter and getter functions - see %test-record-define:
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+ test-result-alist test-result-alist!
+ test-runner-aux-value test-runner-aux-value!
+ ;; default/simple call-back functions, used in default test-runner,
+ ;; but can be called to construct more complex ones.
+ test-on-group-begin-simple test-on-group-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ test-on-final-simple test-on-test-end-simple
+ test-on-final-simple)
+
+(cond-expand
+ (srfi-9
+ (define-syntax %test-record-define
+ (syntax-rules ()
+ ((%test-record-define alloc runner? (name index setter getter) ...)
+ (define-record-type test-runner
+ (alloc)
+ runner?
+ (name setter getter) ...)))))
+ (else
+ (define %test-runner-cookie (list "test-runner"))
+ (define-syntax %test-record-define
+ (syntax-rules ()
+ ((%test-record-define alloc runner? (name index getter setter) ...)
+ (begin
+ (define (runner? obj)
+ (and (vector? obj)
+ (> (vector-length obj) 1)
+ (eq (vector-ref obj 0) %test-runner-cookie)))
+ (define (alloc)
+ (let ((runner (make-vector 23)))
+ (vector-set! runner 0 %test-runner-cookie)
+ runner))
+ (begin
+ (define (getter runner)
+ (vector-ref runner index)) ...)
+ (begin
+ (define (setter runner value)
+ (vector-set! runner index value)) ...)))))))
+
+(%test-record-define
+ %test-runner-alloc test-runner?
+ ;; Cumulate count of all tests that have passed and were expected to.
+ (pass-count 1 test-runner-pass-count test-runner-pass-count!)
+ (fail-count 2 test-runner-fail-count test-runner-fail-count!)
+ (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count 5 test-runner-skip-count test-runner-skip-count!)
+ (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
+ ;; Normally #t, except when in a test-apply.
+ (run-list 8 %test-runner-run-list %test-runner-run-list!)
+ (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
+ (group-stack 11 test-runner-group-stack test-runner-group-stack!)
+ (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
+ ;; Call-back when entering a group. Takes (runner suite-name count).
+ (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
+ ;; Call-back when leaving a group.
+ (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
+ ;; Call-back when leaving the outermost group.
+ (on-final 16 test-runner-on-final test-runner-on-final!)
+ ;; Call-back when expected number of tests was wrong.
+ (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
+ ;; Call-back when name in test=end doesn't match test-begin.
+ (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ ;; Cumulate count of all tests that have been done.
+ (total-count 19 %test-runner-total-count %test-runner-total-count!)
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list 20 %test-runner-count-list %test-runner-count-list!)
+ (result-alist 21 test-result-alist test-result-alist!)
+ ;; Field can be used by test-runner for any purpose.
+ ;; test-runner-simple uses it for a log file.
+ (aux-value 22 test-runner-aux-value test-runner-aux-value!)
+)
+
+(define (test-runner-reset runner)
+ (test-result-alist! runner '())
+ (test-runner-pass-count! runner 0)
+ (test-runner-fail-count! runner 0)
+ (test-runner-xpass-count! runner 0)
+ (test-runner-xfail-count! runner 0)
+ (test-runner-skip-count! runner 0)
+ (%test-runner-total-count! runner 0)
+ (%test-runner-count-list! runner '())
+ (%test-runner-run-list! runner #t)
+ (%test-runner-skip-list! runner '())
+ (%test-runner-fail-list! runner '())
+ (%test-runner-skip-save! runner '())
+ (%test-runner-fail-save! runner '())
+ (test-runner-group-stack! runner '()))
+
+(define (test-runner-group-path runner)
+ (reverse (test-runner-group-stack runner)))
+
+(define (%test-null-callback runner) #f)
+
+(define (test-runner-null)
+ (let ((runner (%test-runner-alloc)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner (lambda (runner name count) #f))
+ (test-runner-on-group-end! runner %test-null-callback)
+ (test-runner-on-final! runner %test-null-callback)
+ (test-runner-on-test-begin! runner %test-null-callback)
+ (test-runner-on-test-end! runner %test-null-callback)
+ (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
+ (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
+ runner))
+
+;; Not part of the specification. FIXME
+;; Controls whether a log file is generated.
+(define test-log-to-file #t)
+
+(define (test-runner-simple)
+ (let ((runner (%test-runner-alloc)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-on-group-begin-simple)
+ (test-runner-on-group-end! runner test-on-group-end-simple)
+ (test-runner-on-final! runner test-on-final-simple)
+ (test-runner-on-test-begin! runner test-on-test-begin-simple)
+ (test-runner-on-test-end! runner test-on-test-end-simple)
+ (test-runner-on-bad-count! runner test-on-bad-count-simple)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ runner))
+
+(cond-expand
+ (srfi-39
+ (define test-runner-current (make-parameter #f))
+ (define test-runner-factory (make-parameter test-runner-simple)))
+ (else
+ (define %test-runner-current #f)
+ (define-syntax test-runner-current
+ (syntax-rules ()
+ ((test-runner-current)
+ %test-runner-current)
+ ((test-runner-current runner)
+ (set! %test-runner-current runner))))
+ (define %test-runner-factory test-runner-simple)
+ (define-syntax test-runner-factory
+ (syntax-rules ()
+ ((test-runner-factory)
+ %test-runner-factory)
+ ((test-runner-factory runner)
+ (set! %test-runner-factory runner))))))
+
+;; A safer wrapper to test-runner-current.
+(define (test-runner-get)
+ (let ((r (test-runner-current)))
+ (if (not r)
+ (cond-expand
+ (srfi-23 (error "test-runner not initialized - test-begin missing?"))
+ (else #t)))
+ r))
+
+(define (%test-specifier-matches spec runner)
+ (spec runner))
+
+(define (test-runner-create)
+ ((test-runner-factory)))
+
+(define (%test-any-specifier-matches list runner)
+ (let ((result #f))
+ (let loop ((l list))
+ (cond ((null? l) result)
+ (else
+ (if (%test-specifier-matches (car l) runner)
+ (set! result #t))
+ (loop (cdr l)))))))
+
+;; Returns #f, #t, or 'xfail.
+(define (%test-should-execute runner)
+ (let ((run (%test-runner-run-list runner)))
+ (cond ((or
+ (not (or (eqv? run #t)
+ (%test-any-specifier-matches run runner)))
+ (%test-any-specifier-matches
+ (%test-runner-skip-list runner)
+ runner))
+ (test-result-set! runner 'result-kind 'skip)
+ #f)
+ ((%test-any-specifier-matches
+ (%test-runner-fail-list runner)
+ runner)
+ (test-result-set! runner 'result-kind 'xfail)
+ 'xfail)
+ (else #t))))
+
+(define (%test-begin suite-name count)
+ (if (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((runner (test-runner-current)))
+ ((test-runner-on-group-begin runner) runner suite-name count)
+ (%test-runner-skip-save! runner
+ (cons (%test-runner-skip-list runner)
+ (%test-runner-skip-save runner)))
+ (%test-runner-fail-save! runner
+ (cons (%test-runner-fail-list runner)
+ (%test-runner-fail-save runner)))
+ (%test-runner-count-list! runner
+ (cons (cons (%test-runner-total-count runner)
+ count)
+ (%test-runner-count-list runner)))
+ (test-runner-group-stack! runner (cons suite-name
+ (test-runner-group-stack runner)))))
+(cond-expand
+ (kawa
+ ;; Kawa has test-begin built in, implemented as:
+ ;; (begin
+ ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
+ ;; (%test-begin suite-name [count]))
+ ;; This puts test-begin but only test-begin in the default environment.,
+ ;; which makes normal test suites loadable without non-portable commands.
+ )
+ (else
+ (define-syntax test-begin
+ (syntax-rules ()
+ ((test-begin suite-name)
+ (%test-begin suite-name #f))
+ ((test-begin suite-name count)
+ (%test-begin suite-name count))))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+ (if (null? (test-runner-group-stack runner))
+ (begin
+ (display "%%%% Starting test ")
+ (display suite-name)
+ (if test-log-to-file
+ (let* ((log-file-name
+ (if (string? test-log-to-file) test-log-to-file
+ (string-append suite-name ".log")))
+ (log-file
+ (cond-expand (mzscheme
+ (open-output-file log-file-name 'truncate/replace))
+ (else (open-output-file log-file-name)))))
+ (display "%%%% Starting test " log-file)
+ (display suite-name log-file)
+ (newline log-file)
+ (test-runner-aux-value! runner log-file)
+ (display " (Writing full log to \"")
+ (display log-file-name)
+ (display "\")")))
+ (newline)))
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (begin
+ (display "Group begin: " log)
+ (display suite-name log)
+ (newline log))))
+ #f)
+
+(define (test-on-group-end-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (begin
+ (display "Group end: " log)
+ (display (car (test-runner-group-stack runner)) log)
+ (newline log))))
+ #f)
+
+(define (%test-on-bad-count-write runner count expected-count port)
+ (display "*** Total number of tests was " port)
+ (display count port)
+ (display " but should be " port)
+ (display expected-count port)
+ (display ". ***" port)
+ (newline port)
+ (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
+ (newline port))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (%test-on-bad-count-write runner count expected-count (current-output-port))
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (%test-on-bad-count-write runner count expected-count log))))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
+ " does not match test-begin " end-name)))
+ (cond-expand
+ (srfi-23 (error msg))
+ (else (display msg) (newline)))))
+
+
+(define (%test-final-report1 value label port)
+ (if (> value 0)
+ (begin
+ (display label port)
+ (display value port)
+ (newline port))))
+
+(define (%test-final-report-simple runner port)
+ (%test-final-report1 (test-runner-pass-count runner)
+ "# of expected passes " port)
+ (%test-final-report1 (test-runner-xfail-count runner)
+ "# of expected failures " port)
+ (%test-final-report1 (test-runner-xpass-count runner)
+ "# of unexpected successes " port)
+ (%test-final-report1 (test-runner-fail-count runner)
+ "# of unexpected failures " port)
+ (%test-final-report1 (test-runner-skip-count runner)
+ "# of skipped tests " port))
+
+(define (test-on-final-simple runner)
+ (%test-final-report-simple runner (current-output-port))
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (%test-final-report-simple runner log))))
+
+(define (%test-format-line runner)
+ (let* ((line-info (test-result-alist runner))
+ (source-file (assq 'source-file line-info))
+ (source-line (assq 'source-line line-info))
+ (file (if source-file (cdr source-file) "")))
+ (if source-line
+ (string-append file ":"
+ (number->string (cdr source-line)) ": ")
+ "")))
+
+(define (%test-end suite-name line-info)
+ (let* ((r (test-runner-get))
+ (groups (test-runner-group-stack r))
+ (line (%test-format-line r)))
+ (test-result-alist! r line-info)
+ (if (null? groups)
+ (let ((msg (string-append line "test-end not in a group")))
+ (cond-expand
+ (srfi-23 (error msg))
+ (else (display msg) (newline)))))
+ (if (and suite-name (not (equal? suite-name (car groups))))
+ ((test-runner-on-bad-end-name r) r suite-name (car groups)))
+ (let* ((count-list (%test-runner-count-list r))
+ (expected-count (cdar count-list))
+ (saved-count (caar count-list))
+ (group-count (- (%test-runner-total-count r) saved-count)))
+ (if (and expected-count
+ (not (= expected-count group-count)))
+ ((test-runner-on-bad-count r) r group-count expected-count))
+ ((test-runner-on-group-end r) r)
+ (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+ (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+ (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+ (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+ (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+ (%test-runner-count-list! r (cdr count-list))
+ (if (null? (test-runner-group-stack r))
+ ((test-runner-on-final r) r)))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((test-group suite-name . body)
+ (let ((r (test-runner-current)))
+ ;; Ideally should also set line-number, if available.
+ (test-result-alist! r (list (cons 'test-name suite-name)))
+ (if (%test-should-execute r)
+ (dynamic-wind
+ (lambda () (test-begin suite-name))
+ (lambda () . body)
+ (lambda () (test-end suite-name))))))))
+
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ ((test-group-with-cleanup suite-name form cleanup-form)
+ (test-group suite-name
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () form)
+ (lambda () cleanup-form))))
+ ((test-group-with-cleanup suite-name cleanup-form)
+ (test-group-with-cleanup suite-name #f cleanup-form))
+ ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
+ (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
+
+(define (test-on-test-begin-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (let* ((results (test-result-alist runner))
+ (source-file (assq 'source-file results))
+ (source-line (assq 'source-line results))
+ (source-form (assq 'source-form results))
+ (test-name (assq 'test-name results)))
+ (display "Test begin:" log)
+ (newline log)
+ (if test-name (%test-write-result1 test-name log))
+ (if source-file (%test-write-result1 source-file log))
+ (if source-line (%test-write-result1 source-line log))
+ (if source-form (%test-write-result1 source-form log))))))
+
+(define-syntax test-result-ref
+ (syntax-rules ()
+ ((test-result-ref runner pname)
+ (test-result-ref runner pname #f))
+ ((test-result-ref runner pname default)
+ (let ((p (assq pname (test-result-alist runner))))
+ (if p (cdr p) default)))))
+
+(define (test-on-test-end-simple runner)
+ (let ((log (test-runner-aux-value runner))
+ (kind (test-result-ref runner 'result-kind)))
+ (if (memq kind '(fail xpass))
+ (let* ((results (test-result-alist runner))
+ (source-file (assq 'source-file results))
+ (source-line (assq 'source-line results))
+ (test-name (assq 'test-name results)))
+ (if (or source-file source-line)
+ (begin
+ (if source-file (display (cdr source-file)))
+ (display ":")
+ (if source-line (display (cdr source-line)))
+ (display ": ")))
+ (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
+ (if test-name
+ (begin
+ (display " ")
+ (display (cdr test-name))))
+ (newline)))
+ (if (output-port? log)
+ (begin
+ (display "Test end:" log)
+ (newline log)
+ (let loop ((list (test-result-alist runner)))
+ (if (pair? list)
+ (let ((pair (car list)))
+ ;; Write out properties not written out by on-test-begin.
+ (if (not (memq (car pair)
+ '(test-name source-file source-line source-form)))
+ (%test-write-result1 pair log))
+ (loop (cdr list)))))))))
+
+(define (%test-write-result1 pair port)
+ (display " " port)
+ (display (car pair) port)
+ (display ": " port)
+ (write (cdr pair) port)
+ (newline port))
+
+(define (test-result-set! runner pname value)
+ (let* ((alist (test-result-alist runner))
+ (p (assq pname alist)))
+ (if p
+ (set-cdr! p value)
+ (test-result-alist! runner (cons (cons pname value) alist)))))
+
+(define (test-result-clear runner)
+ (test-result-alist! runner '()))
+
+(define (test-result-remove runner pname)
+ (let* ((alist (test-result-alist runner))
+ (p (assq pname alist)))
+ (if p
+ (test-result-alist! runner
+ (let loop ((r alist))
+ (if (eq? r p) (cdr r)
+ (cons (car r) (loop (cdr r)))))))))
+
+(define (test-result-kind . rest)
+ (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
+ (test-result-ref runner 'result-kind)))
+
+(define (test-passed? . rest)
+ (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
+ (memq (test-result-ref runner 'result-kind) '(pass xpass))))
+
+(define (%test-report-result)
+ (let* ((r (test-runner-get))
+ (result-kind (test-result-kind r)))
+ (case result-kind
+ ((pass)
+ (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
+ ((fail)
+ (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
+ ((xpass)
+ (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
+ ((xfail)
+ (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
+ (else
+ (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
+ (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
+ ((test-runner-on-test-end r) r)))
+
+(cond-expand
+ (guile
+ (define-syntax %test-evaluate-with-catch
+ (syntax-rules ()
+ ((%test-evaluate-with-catch test-expression)
+ (catch #t
+ (lambda () test-expression)
+ (lambda (key . args)
+ (test-result-set! (test-runner-current) 'actual-error
+ (cons key args))
+ #f))))))
+ (kawa
+ (define-syntax %test-evaluate-with-catch
+ (syntax-rules ()
+ ((%test-evaluate-with-catch test-expression)
+ (try-catch test-expression
+ (ex <java.lang.Throwable>
+ (test-result-set! (test-runner-current) 'actual-error ex)
+ #f))))))
+ (srfi-34
+ (define-syntax %test-evaluate-with-catch
+ (syntax-rules ()
+ ((%test-evaluate-with-catch test-expression)
+ (guard (err (else #f)) test-expression)))))
+ (chicken
+ (define-syntax %test-evaluate-with-catch
+ (syntax-rules ()
+ ((%test-evaluate-with-catch test-expression)
+ (condition-case test-expression (ex () #f))))))
+ (else
+ (define-syntax %test-evaluate-with-catch
+ (syntax-rules ()
+ ((%test-evaluate-with-catch test-expression)
+ test-expression)))))
+
+(cond-expand
+ ((or kawa mzscheme)
+ (cond-expand
+ (mzscheme
+ (define-for-syntax (%test-syntax-file form)
+ (let ((source (syntax-source form)))
+ (cond ((string? source) file)
+ ((path? source) (path->string source))
+ (else #f)))))
+ (kawa
+ (define (%test-syntax-file form)
+ (syntax-source form))))
+ (define (%test-source-line2 form)
+ (let* ((line (syntax-line form))
+ (file (%test-syntax-file form))
+ (line-pair (if line (list (cons 'source-line line)) '())))
+ (cons (cons 'source-form (syntax-object->datum form))
+ (if file (cons (cons 'source-file file) line-pair) line-pair)))))
+ (guile-2
+ (define (%test-source-line2 form)
+ (let* ((src-props (syntax-source form))
+ (file (and src-props (assq-ref src-props 'filename)))
+ (line (and src-props (assq-ref src-props 'line)))
+ (file-alist (if file
+ `((source-file . ,file))
+ '()))
+ (line-alist (if line
+ `((source-line . ,(+ line 1)))
+ '())))
+ (datum->syntax (syntax here)
+ `((source-form . ,(syntax->datum form))
+ ,@file-alist
+ ,@line-alist)))))
+ (else
+ (define (%test-source-line2 form)
+ '())))
+
+(define (%test-on-test-begin r)
+ (%test-should-execute r)
+ ((test-runner-on-test-begin r) r)
+ (not (eq? 'skip (test-result-ref r 'result-kind))))
+
+(define (%test-on-test-end r result)
+ (test-result-set! r 'result-kind
+ (if (eq? (test-result-ref r 'result-kind) 'xfail)
+ (if result 'xpass 'xfail)
+ (if result 'pass 'fail))))
+
+(define (test-runner-test-name runner)
+ (test-result-ref runner 'test-name ""))
+
+(define-syntax %test-comp2body
+ (syntax-rules ()
+ ((%test-comp2body r comp expected expr)
+ (let ()
+ (if (%test-on-test-begin r)
+ (let ((exp expected))
+ (test-result-set! r 'expected-value exp)
+ (let ((res (%test-evaluate-with-catch expr)))
+ (test-result-set! r 'actual-value res)
+ (%test-on-test-end r (comp exp res)))))
+ (%test-report-result)))))
+
+(define (%test-approximate= error)
+ (lambda (value expected)
+ (let ((rval (real-part value))
+ (ival (imag-part value))
+ (rexp (real-part expected))
+ (iexp (imag-part expected)))
+ (and (>= rval (- rexp error))
+ (>= ival (- iexp error))
+ (<= rval (+ rexp error))
+ (<= ival (+ iexp error))))))
+
+(define-syntax %test-comp1body
+ (syntax-rules ()
+ ((%test-comp1body r expr)
+ (let ()
+ (if (%test-on-test-begin r)
+ (let ()
+ (let ((res (%test-evaluate-with-catch expr)))
+ (test-result-set! r 'actual-value res)
+ (%test-on-test-end r res))))
+ (%test-report-result)))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+ ;; Should be made to work for any Scheme with syntax-case
+ ;; However, I haven't gotten the quoting working. FIXME.
+ (define-syntax test-end
+ (lambda (x)
+ (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+ (((mac suite-name) line)
+ (syntax
+ (%test-end suite-name line)))
+ (((mac) line)
+ (syntax
+ (%test-end #f line))))))
+ (define-syntax test-assert
+ (lambda (x)
+ (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+ (((mac tname expr) line)
+ (syntax
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r (cons (cons 'test-name tname) line))
+ (%test-comp1body r expr))))
+ (((mac expr) line)
+ (syntax
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r line)
+ (%test-comp1body r expr)))))))
+ (define (%test-comp2 comp x)
+ (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
+ (((mac tname expected expr) line comp)
+ (syntax
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r (cons (cons 'test-name tname) line))
+ (%test-comp2body r comp expected expr))))
+ (((mac expected expr) line comp)
+ (syntax
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r line)
+ (%test-comp2body r comp expected expr))))))
+ (define-syntax test-eqv
+ (lambda (x) (%test-comp2 (syntax eqv?) x)))
+ (define-syntax test-eq
+ (lambda (x) (%test-comp2 (syntax eq?) x)))
+ (define-syntax test-equal
+ (lambda (x) (%test-comp2 (syntax equal?) x)))
+ (define-syntax test-approximate ;; FIXME - needed for non-Kawa
+ (lambda (x)
+ (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+ (((mac tname expected expr error) line)
+ (syntax
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r (cons (cons 'test-name tname) line))
+ (%test-comp2body r (%test-approximate= error) expected expr))))
+ (((mac expected expr error) line)
+ (syntax
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r line)
+ (%test-comp2body r (%test-approximate= error) expected expr))))))))
+ (else
+ (define-syntax test-end
+ (syntax-rules ()
+ ((test-end)
+ (%test-end #f '()))
+ ((test-end suite-name)
+ (%test-end suite-name '()))))
+ (define-syntax test-assert
+ (syntax-rules ()
+ ((test-assert tname test-expression)
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r '((test-name . tname)))
+ (%test-comp1body r test-expression)))
+ ((test-assert test-expression)
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r '())
+ (%test-comp1body r test-expression)))))
+ (define-syntax %test-comp2
+ (syntax-rules ()
+ ((%test-comp2 comp tname expected expr)
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r (list (cons 'test-name tname)))
+ (%test-comp2body r comp expected expr)))
+ ((%test-comp2 comp expected expr)
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r '())
+ (%test-comp2body r comp expected expr)))))
+ (define-syntax test-equal
+ (syntax-rules ()
+ ((test-equal . rest)
+ (%test-comp2 equal? . rest))))
+ (define-syntax test-eqv
+ (syntax-rules ()
+ ((test-eqv . rest)
+ (%test-comp2 eqv? . rest))))
+ (define-syntax test-eq
+ (syntax-rules ()
+ ((test-eq . rest)
+ (%test-comp2 eq? . rest))))
+ (define-syntax test-approximate
+ (syntax-rules ()
+ ((test-approximate tname expected expr error)
+ (%test-comp2 (%test-approximate= error) tname expected expr))
+ ((test-approximate expected expr error)
+ (%test-comp2 (%test-approximate= error) expected expr))))))
+
+(cond-expand
+ (guile
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (cond ((%test-on-test-begin r)
+ (let ((et etype))
+ (test-result-set! r 'expected-error et)
+ (%test-on-test-end r
+ (catch #t
+ (lambda ()
+ (test-result-set! r 'actual-value expr)
+ #f)
+ (lambda (key . args)
+ ;; TODO: decide how to specify expected
+ ;; error types for Guile.
+ (test-result-set! r 'actual-error
+ (cons key args))
+ #t)))
+ (%test-report-result))))))))
+ (mzscheme
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
+ (let ()
+ (test-result-set! r 'actual-value expr)
+ #f)))))))
+ (chicken
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (%test-comp1body r (condition-case expr (ex () #t)))))))
+ (kawa
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r #t expr)
+ (cond ((%test-on-test-begin r)
+ (test-result-set! r 'expected-error #t)
+ (%test-on-test-end r
+ (try-catch
+ (let ()
+ (test-result-set! r 'actual-value expr)
+ #f)
+ (ex <java.lang.Throwable>
+ (test-result-set! r 'actual-error ex)
+ #t)))
+ (%test-report-result))))
+ ((%test-error r etype expr)
+ (if (%test-on-test-begin r)
+ (let ((et etype))
+ (test-result-set! r 'expected-error et)
+ (%test-on-test-end r
+ (try-catch
+ (let ()
+ (test-result-set! r 'actual-value expr)
+ #f)
+ (ex <java.lang.Throwable>
+ (test-result-set! r 'actual-error ex)
+ (cond ((and (instance? et <gnu.bytecode.ClassType>)
+ (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
+ (instance? ex et))
+ (else #t)))))
+ (%test-report-result)))))))
+ ((and srfi-34 srfi-35)
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (%test-comp1body r (guard (ex ((condition-type? etype)
+ (and (condition? ex) (condition-has-type? ex etype)))
+ ((procedure? etype)
+ (etype ex))
+ ((equal? etype #t)
+ #t)
+ (else #t))
+ expr #f))))))
+ (srfi-34
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (%test-comp1body r (guard (ex (else #t)) expr #f))))))
+ (else
+ (define-syntax %test-error
+ (syntax-rules ()
+ ((%test-error r etype expr)
+ (begin
+ ((test-runner-on-test-begin r) r)
+ (test-result-set! r 'result-kind 'skip)
+ (%test-report-result)))))))
+
+(cond-expand
+ ((or kawa mzscheme guile-2)
+
+ (define-syntax test-error
+ (lambda (x)
+ (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
+ (((mac tname etype expr) line)
+ (syntax
+ (let* ((r (test-runner-get))
+ (name tname))
+ (test-result-alist! r (cons (cons 'test-name tname) line))
+ (%test-error r etype expr))))
+ (((mac etype expr) line)
+ (syntax
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r line)
+ (%test-error r etype expr))))
+ (((mac expr) line)
+ (syntax
+ (let* ((r (test-runner-get)))
+ (test-result-alist! r line)
+ (%test-error r #t expr))))))))
+ (else
+ (define-syntax test-error
+ (syntax-rules ()
+ ((test-error name etype expr)
+ (let ((r (test-runner-get)))
+ (test-result-alist! r `((test-name . ,name)))
+ (%test-error r etype expr)))
+ ((test-error etype expr)
+ (let ((r (test-runner-get)))
+ (test-result-alist! r '())
+ (%test-error r etype expr)))
+ ((test-error expr)
+ (let ((r (test-runner-get)))
+ (test-result-alist! r '())
+ (%test-error r #t expr)))))))
+
+(define (test-apply first . rest)
+ (if (test-runner? first)
+ (test-with-runner first (apply test-apply rest))
+ (let ((r (test-runner-current)))
+ (if r
+ (let ((run-list (%test-runner-run-list r)))
+ (cond ((null? rest)
+ (%test-runner-run-list! r (reverse run-list))
+ (first)) ;; actually apply procedure thunk
+ (else
+ (%test-runner-run-list!
+ r
+ (if (eq? run-list #t) (list first) (cons first run-list)))
+ (apply test-apply rest)
+ (%test-runner-run-list! r run-list))))
+ (let ((r (test-runner-create)))
+ (test-with-runner r (apply test-apply first rest))
+ ((test-runner-on-final r) r))))))
+
+(define-syntax test-with-runner
+ (syntax-rules ()
+ ((test-with-runner runner form ...)
+ (let ((saved-runner (test-runner-current)))
+ (dynamic-wind
+ (lambda () (test-runner-current runner))
+ (lambda () form ...)
+ (lambda () (test-runner-current saved-runner)))))))
+
+;;; Predicates
+
+(define (%test-match-nth n count)
+ (let ((i 0))
+ (lambda (runner)
+ (set! i (+ i 1))
+ (and (>= i n) (< i (+ n count))))))
+
+(define-syntax test-match-nth
+ (syntax-rules ()
+ ((test-match-nth n)
+ (test-match-nth n 1))
+ ((test-match-nth n count)
+ (%test-match-nth n count))))
+
+(define (%test-match-all . pred-list)
+ (lambda (runner)
+ (let ((result #t))
+ (let loop ((l pred-list))
+ (if (null? l)
+ result
+ (begin
+ (if (not ((car l) runner))
+ (set! result #f))
+ (loop (cdr l))))))))
+
+(define-syntax test-match-all
+ (syntax-rules ()
+ ((test-match-all pred ...)
+ (%test-match-all (%test-as-specifier pred) ...))))
+
+(define (%test-match-any . pred-list)
+ (lambda (runner)
+ (let ((result #f))
+ (let loop ((l pred-list))
+ (if (null? l)
+ result
+ (begin
+ (if ((car l) runner)
+ (set! result #t))
+ (loop (cdr l))))))))
+
+(define-syntax test-match-any
+ (syntax-rules ()
+ ((test-match-any pred ...)
+ (%test-match-any (%test-as-specifier pred) ...))))
+
+;; Coerce to a predicate function:
+(define (%test-as-specifier specifier)
+ (cond ((procedure? specifier) specifier)
+ ((integer? specifier) (test-match-nth 1 specifier))
+ ((string? specifier) (test-match-name specifier))
+ (else
+ (error "not a valid test specifier"))))
+
+(define-syntax test-skip
+ (syntax-rules ()
+ ((test-skip pred ...)
+ (let ((runner (test-runner-get)))
+ (%test-runner-skip-list! runner
+ (cons (test-match-all (%test-as-specifier pred) ...)
+ (%test-runner-skip-list runner)))))))
+
+(define-syntax test-expect-fail
+ (syntax-rules ()
+ ((test-expect-fail pred ...)
+ (let ((runner (test-runner-get)))
+ (%test-runner-fail-list! runner
+ (cons (test-match-all (%test-as-specifier pred) ...)
+ (%test-runner-fail-list runner)))))))
+
+(define (test-match-name name)
+ (lambda (runner)
+ (equal? name (test-runner-test-name runner))))
+
+(define (test-read-eval-string string)
+ (let* ((port (open-input-string string))
+ (form (read port)))
+ (if (eof-object? (read-char port))
+ (cond-expand
+ (guile (eval form (current-module)))
+ (else (eval form)))
+ (cond-expand
+ (srfi-23 (error "(not at eof)"))
+ (else "error")))))
+
diff --git a/module/srfi/srfi-67.scm b/module/srfi/srfi-67.scm
new file mode 100644
index 000000000..6d9d4c5ad
--- /dev/null
+++ b/module/srfi/srfi-67.scm
@@ -0,0 +1,88 @@
+;;; srfi-67.scm --- Compare Procedures
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-67)
+ #:export (</<=?
+ </<?
+ <=/<=?
+ <=/<?
+ <=?
+ <?
+ =?
+ >/>=?
+ >/>?
+ >=/>=?
+ >=/>?
+ >=?
+ >?
+ boolean-compare
+ chain<=?
+ chain<?
+ chain=?
+ chain>=?
+ chain>?
+ char-compare
+ char-compare-ci
+ compare-by<
+ compare-by<=
+ compare-by=/<
+ compare-by=/>
+ compare-by>
+ compare-by>=
+ complex-compare
+ cond-compare
+ debug-compare
+ default-compare
+ if-not=?
+ if3
+ if<=?
+ if<?
+ if=?
+ if>=?
+ if>?
+ integer-compare
+ kth-largest
+ list-compare
+ list-compare-as-vector
+ max-compare
+ min-compare
+ not=?
+ number-compare
+ pair-compare
+ pair-compare-car
+ pair-compare-cdr
+ pairwise-not=?
+ rational-compare
+ real-compare
+ refine-compare
+ select-compare
+ symbol-compare
+ vector-compare
+ vector-compare-as-list)
+ #:replace (string-compare string-compare-ci)
+ #:use-module (srfi srfi-27))
+
+(cond-expand-provide (current-module) '(srfi-67))
+
+(include-from-path "srfi/srfi-67/compare.scm")
diff --git a/module/srfi/srfi-67/compare.scm b/module/srfi/srfi-67/compare.scm
new file mode 100644
index 000000000..767f3dba0
--- /dev/null
+++ b/module/srfi/srfi-67/compare.scm
@@ -0,0 +1,686 @@
+; Copyright (c) 2011 Free Software Foundation, Inc.
+; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
+;
+; Permission is hereby granted, free of charge, to any person obtaining
+; a copy of this software and associated documentation files (the
+; ``Software''), to deal in the Software without restriction, including
+; without limitation the rights to use, copy, modify, merge, publish,
+; distribute, sublicense, and/or sell copies of the Software, and to
+; permit persons to whom the Software is furnished to do so, subject to
+; the following conditions:
+;
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;
+; -----------------------------------------------------------------------
+;
+; Compare procedures SRFI (reference implementation)
+; Sebastian.Egner@philips.com, Jensaxel@soegaard.net
+; history of this file:
+; SE, 14-Oct-2004: first version
+; SE, 18-Oct-2004: 1st redesign: axioms for 'compare function'
+; SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite
+; SE, 2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's
+; SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare
+; SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added
+; SE, 12-Jan-2005: pair-compare-cdr
+; SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=?
+; SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc.
+; JS, 24-Feb-2005: selection-compare added
+; SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc.
+; JS, 28-Feb-2005: kth-largest modified - is "stable" now
+; SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged
+; SE, 07-Apr-2005: compare-based type checks made explicit
+; SE, 18-Apr-2005: added (rel? compare) and eq?-test
+; SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y
+
+; =============================================================================
+
+; Reference Implementation
+; ========================
+;
+; in R5RS (including hygienic macros)
+; + SRFI-16 (case-lambda)
+; + SRFI-23 (error)
+; + SRFI-27 (random-integer)
+
+; Implementation remarks:
+; * In general, the emphasis of this implementation is on correctness
+; and portability, not on efficiency.
+; * Variable arity procedures are expressed in terms of case-lambda
+; in the hope that this will produce efficient code for the case
+; where the arity is statically known at the call site.
+; * In procedures that are required to type-check their arguments,
+; we use (compare x x) for executing extra checks. This relies on
+; the assumption that eq? is used to catch this case quickly.
+; * Care has been taken to reference comparison procedures of R5RS
+; only at the time the operations here are being defined. This
+; makes it possible to redefine these operations, if need be.
+; * For the sake of efficiency, some inlining has been done by hand.
+; This is mainly expressed by macros producing defines.
+; * Identifiers of the form compare:<something> are private.
+;
+; Hints for low-level implementation:
+; * The basis of this SRFI are the atomic compare procedures,
+; i.e. boolean-compare, char-compare, etc. and the conditionals
+; if3, if=?, if<? etc., and default-compare. These should make
+; optimal use of the available type information.
+; * For the sake of speed, the reference implementation does not
+; use a LET to save the comparison value c for the ERROR call.
+; This can be fixed in a low-level implementation at no cost.
+; * Type-checks based on (compare x x) are made explicit by the
+; expression (compare:check result compare x ...).
+; * Eq? should can used to speed up built-in compare procedures,
+; but it can only be used after type-checking at least one of
+; the arguments.
+
+(define (compare:checked result compare . args)
+ (for-each (lambda (x) (compare x x)) args)
+ result)
+
+
+; 3-sided conditional
+
+(define-syntax-rule (if3 c less equal greater)
+ (case c
+ ((-1) less)
+ (( 0) equal)
+ (( 1) greater)
+ (else (error "comparison value not in {-1,0,1}"))))
+
+
+; 2-sided conditionals for comparisons
+
+(define-syntax compare:if-rel?
+ (syntax-rules ()
+ ((compare:if-rel? c-cases a-cases c consequence)
+ (compare:if-rel? c-cases a-cases c consequence (if #f #f)))
+ ((compare:if-rel? c-cases a-cases c consequence alternate)
+ (case c
+ (c-cases consequence)
+ (a-cases alternate)
+ (else (error "comparison value not in {-1,0,1}"))))))
+
+(define-syntax-rule (if=? arg ...)
+ (compare:if-rel? (0) (-1 1) arg ...))
+
+(define-syntax-rule (if<? arg ...)
+ (compare:if-rel? (-1) (0 1) arg ...))
+
+(define-syntax-rule (if>? arg ...)
+ (compare:if-rel? (1) (-1 0) arg ...))
+
+(define-syntax-rule (if<=? arg ...)
+ (compare:if-rel? (-1 0) (1) arg ...))
+
+(define-syntax-rule (if>=? arg ...)
+ (compare:if-rel? (0 1) (-1) arg ...))
+
+(define-syntax-rule (if-not=? arg ...)
+ (compare:if-rel? (-1 1) (0) arg ...))
+
+
+; predicates from compare procedures
+
+(define-syntax-rule (compare:define-rel? rel? if-rel?)
+ (define rel?
+ (case-lambda
+ (() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+ ((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
+ ((x y) (if-rel? (default-compare x y) #t #f))
+ ((compare x y)
+ (if (procedure? compare)
+ (if-rel? (compare x y) #t #f)
+ (error "not a procedure (Did you mean rel/rel??): " compare))))))
+
+(compare:define-rel? =? if=?)
+(compare:define-rel? <? if<?)
+(compare:define-rel? >? if>?)
+(compare:define-rel? <=? if<=?)
+(compare:define-rel? >=? if>=?)
+(compare:define-rel? not=? if-not=?)
+
+
+; chains of length 3
+
+(define-syntax-rule (compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
+ (define rel1/rel2?
+ (case-lambda
+ (()
+ (lambda (x y z)
+ (if-rel1? (default-compare x y)
+ (if-rel2? (default-compare y z) #t #f)
+ (compare:checked #f default-compare z))))
+ ((compare)
+ (lambda (x y z)
+ (if-rel1? (compare x y)
+ (if-rel2? (compare y z) #t #f)
+ (compare:checked #f compare z))))
+ ((x y z)
+ (if-rel1? (default-compare x y)
+ (if-rel2? (default-compare y z) #t #f)
+ (compare:checked #f default-compare z)))
+ ((compare x y z)
+ (if-rel1? (compare x y)
+ (if-rel2? (compare y z) #t #f)
+ (compare:checked #f compare z))))))
+
+(compare:define-rel1/rel2? </<? if<? if<?)
+(compare:define-rel1/rel2? </<=? if<? if<=?)
+(compare:define-rel1/rel2? <=/<? if<=? if<?)
+(compare:define-rel1/rel2? <=/<=? if<=? if<=?)
+(compare:define-rel1/rel2? >/>? if>? if>?)
+(compare:define-rel1/rel2? >/>=? if>? if>=?)
+(compare:define-rel1/rel2? >=/>? if>=? if>?)
+(compare:define-rel1/rel2? >=/>=? if>=? if>=?)
+
+
+; chains of arbitrary length
+
+(define-syntax-rule (compare:define-chain-rel? chain-rel? if-rel?)
+ (define chain-rel?
+ (case-lambda
+ ((compare)
+ #t)
+ ((compare x1)
+ (compare:checked #t compare x1))
+ ((compare x1 x2)
+ (if-rel? (compare x1 x2) #t #f))
+ ((compare x1 x2 x3)
+ (if-rel? (compare x1 x2)
+ (if-rel? (compare x2 x3) #t #f)
+ (compare:checked #f compare x3)))
+ ((compare x1 x2 . x3+)
+ (if-rel? (compare x1 x2)
+ (let chain? ((head x2) (tail x3+))
+ (if (null? tail)
+ #t
+ (if-rel? (compare head (car tail))
+ (chain? (car tail) (cdr tail))
+ (apply compare:checked #f
+ compare (cdr tail)))))
+ (apply compare:checked #f compare x3+))))))
+
+(compare:define-chain-rel? chain=? if=?)
+(compare:define-chain-rel? chain<? if<?)
+(compare:define-chain-rel? chain>? if>?)
+(compare:define-chain-rel? chain<=? if<=?)
+(compare:define-chain-rel? chain>=? if>=?)
+
+
+; pairwise inequality
+
+(define pairwise-not=?
+ (let ((= =) (<= <=))
+ (case-lambda
+ ((compare)
+ #t)
+ ((compare x1)
+ (compare:checked #t compare x1))
+ ((compare x1 x2)
+ (if-not=? (compare x1 x2) #t #f))
+ ((compare x1 x2 x3)
+ (if-not=? (compare x1 x2)
+ (if-not=? (compare x2 x3)
+ (if-not=? (compare x1 x3) #t #f)
+ #f)
+ (compare:checked #f compare x3)))
+ ((compare . x1+)
+ (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t))
+ (if (< n 2)
+ (if (and unchecked? (= n 1))
+ (compare:checked #t compare (car x))
+ #t)
+ (let* ((i-pivot (random-integer n))
+ (x-pivot (list-ref x i-pivot)))
+ (let split ((i 0) (x x) (x< '()) (x> '()))
+ (if (null? x)
+ (and (unequal? x< (length x<) #f)
+ (unequal? x> (length x>) #f))
+ (if (= i i-pivot)
+ (split (+ i 1) (cdr x) x< x>)
+ (if3 (compare (car x) x-pivot)
+ (split (+ i 1) (cdr x) (cons (car x) x<) x>)
+ (if unchecked?
+ (apply compare:checked #f compare (cdr x))
+ #f)
+ (split (+ i 1) (cdr x) x< (cons (car x) x>)))))))))))))
+
+
+; min/max
+
+(define min-compare
+ (case-lambda
+ ((compare x1)
+ (compare:checked x1 compare x1))
+ ((compare x1 x2)
+ (if<=? (compare x1 x2) x1 x2))
+ ((compare x1 x2 x3)
+ (if<=? (compare x1 x2)
+ (if<=? (compare x1 x3) x1 x3)
+ (if<=? (compare x2 x3) x2 x3)))
+ ((compare x1 x2 x3 x4)
+ (if<=? (compare x1 x2)
+ (if<=? (compare x1 x3)
+ (if<=? (compare x1 x4) x1 x4)
+ (if<=? (compare x3 x4) x3 x4))
+ (if<=? (compare x2 x3)
+ (if<=? (compare x2 x4) x2 x4)
+ (if<=? (compare x3 x4) x3 x4))))
+ ((compare x1 x2 . x3+)
+ (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+))
+ (if (null? xs)
+ xmin
+ (min (if<=? (compare xmin (car xs)) xmin (car xs))
+ (cdr xs)))))))
+
+(define max-compare
+ (case-lambda
+ ((compare x1)
+ (compare:checked x1 compare x1))
+ ((compare x1 x2)
+ (if>=? (compare x1 x2) x1 x2))
+ ((compare x1 x2 x3)
+ (if>=? (compare x1 x2)
+ (if>=? (compare x1 x3) x1 x3)
+ (if>=? (compare x2 x3) x2 x3)))
+ ((compare x1 x2 x3 x4)
+ (if>=? (compare x1 x2)
+ (if>=? (compare x1 x3)
+ (if>=? (compare x1 x4) x1 x4)
+ (if>=? (compare x3 x4) x3 x4))
+ (if>=? (compare x2 x3)
+ (if>=? (compare x2 x4) x2 x4)
+ (if>=? (compare x3 x4) x3 x4))))
+ ((compare x1 x2 . x3+)
+ (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+))
+ (if (null? xs)
+ xmax
+ (max (if>=? (compare xmax (car xs)) xmax (car xs))
+ (cdr xs)))))))
+
+
+; kth-largest
+
+(define kth-largest
+ (let ((= =) (< <))
+ (case-lambda
+ ((compare k x0)
+ (case (modulo k 1)
+ ((0) (compare:checked x0 compare x0))
+ (else (error "bad index" k))))
+ ((compare k x0 x1)
+ (case (modulo k 2)
+ ((0) (if<=? (compare x0 x1) x0 x1))
+ ((1) (if<=? (compare x0 x1) x1 x0))
+ (else (error "bad index" k))))
+ ((compare k x0 x1 x2)
+ (case (modulo k 3)
+ ((0) (if<=? (compare x0 x1)
+ (if<=? (compare x0 x2) x0 x2)
+ (if<=? (compare x1 x2) x1 x2)))
+ ((1) (if3 (compare x0 x1)
+ (if<=? (compare x1 x2)
+ x1
+ (if<=? (compare x0 x2) x2 x0))
+ (if<=? (compare x0 x2) x1 x0)
+ (if<=? (compare x0 x2)
+ x0
+ (if<=? (compare x1 x2) x2 x1))))
+ ((2) (if<=? (compare x0 x1)
+ (if<=? (compare x1 x2) x2 x1)
+ (if<=? (compare x0 x2) x2 x0)))
+ (else (error "bad index" k))))
+ ((compare k x0 . x1+) ; |x1+| >= 1
+ (if (not (and (integer? k) (exact? k)))
+ (error "bad index" k))
+ (let ((n (+ 1 (length x1+))))
+ (let kth ((k (modulo k n))
+ (n n) ; = |x|
+ (rev #t) ; are x<, x=, x> reversed?
+ (x (cons x0 x1+)))
+ (let ((pivot (list-ref x (random-integer n))))
+ (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0))
+ (if (null? x)
+ (cond
+ ((< k n<)
+ (kth k n< (not rev) x<))
+ ((< k (+ n< n=))
+ (if rev
+ (list-ref x= (- (- n= 1) (- k n<)))
+ (list-ref x= (- k n<))))
+ (else
+ (kth (- k (+ n< n=)) n> (not rev) x>)))
+ (if3 (compare (car x) pivot)
+ (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>)
+ (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>)
+ (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1))))))))))))
+
+
+; compare functions from predicates
+
+(define compare-by<
+ (case-lambda
+ ((lt) (lambda (x y) (if (lt x y) -1 (if (lt y x) 1 0))))
+ ((lt x y) (if (lt x y) -1 (if (lt y x) 1 0)))))
+
+(define compare-by>
+ (case-lambda
+ ((gt) (lambda (x y) (if (gt x y) 1 (if (gt y x) -1 0))))
+ ((gt x y) (if (gt x y) 1 (if (gt y x) -1 0)))))
+
+(define compare-by<=
+ (case-lambda
+ ((le) (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1)))
+ ((le x y) (if (le x y) (if (le y x) 0 -1) 1))))
+
+(define compare-by>=
+ (case-lambda
+ ((ge) (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1)))
+ ((ge x y) (if (ge x y) (if (ge y x) 0 1) -1))))
+
+(define compare-by=/<
+ (case-lambda
+ ((eq lt) (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1))))
+ ((eq lt x y) (if (eq x y) 0 (if (lt x y) -1 1)))))
+
+(define compare-by=/>
+ (case-lambda
+ ((eq gt) (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1))))
+ ((eq gt x y) (if (eq x y) 0 (if (gt x y) 1 -1)))))
+
+; refine and extend construction
+
+(define-syntax refine-compare
+ (syntax-rules ()
+ ((refine-compare)
+ 0)
+ ((refine-compare c1)
+ c1)
+ ((refine-compare c1 c2 cs ...)
+ (if3 c1 -1 (refine-compare c2 cs ...) 1))))
+
+(define-syntax select-compare
+ (syntax-rules (else)
+ ((select-compare x y clause ...)
+ (let ((x-val x) (y-val y))
+ (select-compare (x-val y-val clause ...))))
+ ; used internally: (select-compare (x y clause ...))
+ ((select-compare (x y))
+ 0)
+ ((select-compare (x y (else c ...)))
+ (refine-compare c ...))
+ ((select-compare (x y (t? c ...) clause ...))
+ (let ((t?-val t?))
+ (let ((tx (t?-val x)) (ty (t?-val y)))
+ (if tx
+ (if ty (refine-compare c ...) -1)
+ (if ty 1 (select-compare (x y clause ...)))))))))
+
+(define-syntax cond-compare
+ (syntax-rules (else)
+ ((cond-compare)
+ 0)
+ ((cond-compare (else cs ...))
+ (refine-compare cs ...))
+ ((cond-compare ((tx ty) cs ...) clause ...)
+ (let ((tx-val tx) (ty-val ty))
+ (if tx-val
+ (if ty-val (refine-compare cs ...) -1)
+ (if ty-val 1 (cond-compare clause ...)))))))
+
+
+; R5RS atomic types
+
+(define-syntax compare:type-check
+ (syntax-rules ()
+ ((compare:type-check type? type-name x)
+ (if (not (type? x))
+ (error (string-append "not " type-name ":") x)))
+ ((compare:type-check type? type-name x y)
+ (begin (compare:type-check type? type-name x)
+ (compare:type-check type? type-name y)))))
+
+(define-syntax-rule (compare:define-by=/< compare = < type? type-name)
+ (define compare
+ (let ((= =) (< <))
+ (lambda (x y)
+ (if (type? x)
+ (if (eq? x y)
+ 0
+ (if (type? y)
+ (if (= x y) 0 (if (< x y) -1 1))
+ (error (string-append "not " type-name ":") y)))
+ (error (string-append "not " type-name ":") x))))))
+
+(define (boolean-compare x y)
+ (compare:type-check boolean? "boolean" x y)
+ (if x (if y 0 1) (if y -1 0)))
+
+(compare:define-by=/< char-compare char=? char<? char? "char")
+
+(compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char")
+
+(compare:define-by=/< string-compare string=? string<? string? "string")
+
+(compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string")
+
+(define (symbol-compare x y)
+ (compare:type-check symbol? "symbol" x y)
+ (string-compare (symbol->string x) (symbol->string y)))
+
+(compare:define-by=/< integer-compare = < integer? "integer")
+
+(compare:define-by=/< rational-compare = < rational? "rational")
+
+(compare:define-by=/< real-compare = < real? "real")
+
+(define (complex-compare x y)
+ (compare:type-check complex? "complex" x y)
+ (if (and (real? x) (real? y))
+ (real-compare x y)
+ (refine-compare (real-compare (real-part x) (real-part y))
+ (real-compare (imag-part x) (imag-part y)))))
+
+(define (number-compare x y)
+ (compare:type-check number? "number" x y)
+ (complex-compare x y))
+
+
+; R5RS compound data structures: dotted pair, list, vector
+
+(define (pair-compare-car compare)
+ (lambda (x y)
+ (compare (car x) (car y))))
+
+(define (pair-compare-cdr compare)
+ (lambda (x y)
+ (compare (cdr x) (cdr y))))
+
+(define pair-compare
+ (case-lambda
+
+ ; dotted pair
+ ((pair-compare-car pair-compare-cdr x y)
+ (refine-compare (pair-compare-car (car x) (car y))
+ (pair-compare-cdr (cdr x) (cdr y))))
+
+ ; possibly improper lists
+ ((compare x y)
+ (cond-compare
+ (((null? x) (null? y)) 0)
+ (((pair? x) (pair? y)) (compare (car x) (car y))
+ (pair-compare compare (cdr x) (cdr y)))
+ (else (compare x y))))
+
+ ; for convenience
+ ((x y)
+ (pair-compare default-compare x y))))
+
+(define list-compare
+ (case-lambda
+ ((compare x y empty? head tail)
+ (cond-compare
+ (((empty? x) (empty? y)) 0)
+ (else (compare (head x) (head y))
+ (list-compare compare (tail x) (tail y) empty? head tail))))
+
+ ; for convenience
+ (( x y empty? head tail)
+ (list-compare default-compare x y empty? head tail))
+ ((compare x y )
+ (list-compare compare x y null? car cdr))
+ (( x y )
+ (list-compare default-compare x y null? car cdr))))
+
+(define list-compare-as-vector
+ (case-lambda
+ ((compare x y empty? head tail)
+ (refine-compare
+ (let compare-length ((x x) (y y))
+ (cond-compare
+ (((empty? x) (empty? y)) 0)
+ (else (compare-length (tail x) (tail y)))))
+ (list-compare compare x y empty? head tail)))
+
+ ; for convenience
+ (( x y empty? head tail)
+ (list-compare-as-vector default-compare x y empty? head tail))
+ ((compare x y )
+ (list-compare-as-vector compare x y null? car cdr))
+ (( x y )
+ (list-compare-as-vector default-compare x y null? car cdr))))
+
+(define vector-compare
+ (let ((= =))
+ (case-lambda
+ ((compare x y size ref)
+ (let ((n (size x)) (m (size y)))
+ (refine-compare
+ (integer-compare n m)
+ (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+ (if (= i n)
+ 0
+ (refine-compare (compare (ref x i) (ref y i))
+ (compare-rest (+ i 1))))))))
+
+ ; for convenience
+ (( x y size ref)
+ (vector-compare default-compare x y size ref))
+ ((compare x y )
+ (vector-compare compare x y vector-length vector-ref))
+ (( x y )
+ (vector-compare default-compare x y vector-length vector-ref)))))
+
+(define vector-compare-as-list
+ (let ((= =))
+ (case-lambda
+ ((compare x y size ref)
+ (let ((nx (size x)) (ny (size y)))
+ (let ((n (min nx ny)))
+ (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+ (if (= i n)
+ (integer-compare nx ny)
+ (refine-compare (compare (ref x i) (ref y i))
+ (compare-rest (+ i 1))))))))
+
+ ; for convenience
+ (( x y size ref)
+ (vector-compare-as-list default-compare x y size ref))
+ ((compare x y )
+ (vector-compare-as-list compare x y vector-length vector-ref))
+ (( x y )
+ (vector-compare-as-list default-compare x y vector-length vector-ref)))))
+
+
+; default compare
+
+(define (default-compare x y)
+ (select-compare
+ x y
+ (null? 0)
+ (pair? (default-compare (car x) (car y))
+ (default-compare (cdr x) (cdr y)))
+ (boolean? (boolean-compare x y))
+ (char? (char-compare x y))
+ (string? (string-compare x y))
+ (symbol? (symbol-compare x y))
+ (number? (number-compare x y))
+ (vector? (vector-compare default-compare x y))
+ (else (error "unrecognized type in default-compare" x y))))
+
+; Note that we pass default-compare to compare-{pair,vector} explictly.
+; This makes sure recursion proceeds with this default-compare, which
+; need not be the one in the lexical scope of compare-{pair,vector}.
+
+
+; debug compare
+
+(define (debug-compare c)
+
+ (define (checked-value c x y)
+ (let ((c-xy (c x y)))
+ (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1))
+ c-xy
+ (error "compare value not in {-1,0,1}" c-xy (list c x y)))))
+
+ (define (random-boolean)
+ (zero? (random-integer 2)))
+
+ (define q ; (u v w) such that u <= v, v <= w, and not u <= w
+ '#(
+ ;x < y x = y x > y [x < z]
+ 0 0 0 ; y < z
+ 0 (z y x) (z y x) ; y = z
+ 0 (z y x) (z y x) ; y > z
+
+ ;x < y x = y x > y [x = z]
+ (y z x) (z x y) 0 ; y < z
+ (y z x) 0 (x z y) ; y = z
+ 0 (y x z) (x z y) ; y > z
+
+ ;x < y x = y x > y [x > z]
+ (x y z) (x y z) 0 ; y < z
+ (x y z) (x y z) 0 ; y = z
+ 0 0 0 ; y > z
+ ))
+
+ (let ((z? #f) (z #f)) ; stored element from previous call
+ (lambda (x y)
+ (let ((c-xx (checked-value c x x))
+ (c-yy (checked-value c y y))
+ (c-xy (checked-value c x y))
+ (c-yx (checked-value c y x)))
+ (if (not (zero? c-xx))
+ (error "compare error: not reflexive" c x))
+ (if (not (zero? c-yy))
+ (error "compare error: not reflexive" c y))
+ (if (not (zero? (+ c-xy c-yx)))
+ (error "compare error: not anti-symmetric" c x y))
+ (if z?
+ (let ((c-xz (checked-value c x z))
+ (c-zx (checked-value c z x))
+ (c-yz (checked-value c y z))
+ (c-zy (checked-value c z y)))
+ (if (not (zero? (+ c-xz c-zx)))
+ (error "compare error: not anti-symmetric" c x z))
+ (if (not (zero? (+ c-yz c-zy)))
+ (error "compare error: not anti-symmetric" c y z))
+ (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13))))
+ (if (list? ijk)
+ (apply error
+ "compare error: not transitive"
+ c
+ (map (lambda (i) (case i ((x) x) ((y) y) ((z) z)))
+ ijk)))))
+ (set! z? #t))
+ (set! z (if (random-boolean) x y)) ; randomized testing
+ c-xy))))
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
new file mode 100644
index 000000000..b9486c465
--- /dev/null
+++ b/module/srfi/srfi-69.scm
@@ -0,0 +1,336 @@
+;;; srfi-69.scm --- Basic hash tables
+
+;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;;; Commentary:
+
+;; My `hash' is compatible with core `hash', so I replace it.
+;; However, my `hash-table?' and `make-hash-table' are different, so
+;; importing this module will warn about them. If you don't rename my
+;; imports, you shouldn't use both my hash tables and Guile's hash
+;; tables in the same module.
+;;
+;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
+;; are compatible with my `string-hash' and `string-ci-hash', and are
+;; furthermore primitive in Guile, so I use them as my own.
+;;
+;; I also have the extension of allowing hash functions that require a
+;; second argument to be used as the `hash-table-hash-function', and use
+;; these in defaults to avoid an indirection in the hashx functions. The
+;; only deviation this causes is:
+;;
+;; ((hash-table-hash-function (make-hash-table)) obj)
+;; error> Wrong number of arguments to #<primitive-procedure hash>
+;;
+;; I don't think that SRFI 69 actually specifies that I *can't* do this,
+;; because it only implies the signature of a hash function by way of the
+;; named, exported hash functions. However, if this matters enough I can
+;; add a private derivation of hash-function to the srfi-69:hash-table
+;; record type, like associator is to equivalence-function.
+;;
+;; Also, outside of the issue of how weak keys and values are referenced
+;; outside the table, I always interpret key equivalence to be that of
+;; the `hash-table-equivalence-function'. For example, given the
+;; requirement that `alist->hash-table' give earlier associations
+;; priority, what should these answer?
+;;
+;; (hash-table-keys
+;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
+;;
+;; (let ((ht (make-hash-table string-ci=?)))
+;; (hash-table-set! ht "xY" 2)
+;; (hash-table-set! ht "Xy" 1)
+;; (hash-table-keys ht))
+;;
+;; My interpretation is that they can answer either ("Xy") or ("xY"),
+;; where `hash-table-values' will of course always answer (1), because
+;; the keys are the same according to the equivalence function. In this
+;; implementation, both answer ("xY"). However, I don't guarantee that
+;; this won't change in the future.
+
+;;; Code:
+
+;;;; Module definition & exports
+
+(define-module (srfi srfi-69)
+ #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-13) ;string-hash,string-hash-ci
+ #:use-module (ice-9 optargs)
+ #:export (;; Type constructors & predicate
+ make-hash-table hash-table? alist->hash-table
+ ;; Reflective queries
+ hash-table-equivalence-function hash-table-hash-function
+ ;; Dealing with single elements
+ hash-table-ref hash-table-ref/default hash-table-set!
+ hash-table-delete! hash-table-exists? hash-table-update!
+ hash-table-update!/default
+ ;; Dealing with the whole contents
+ hash-table-size hash-table-keys hash-table-values
+ hash-table-walk hash-table-fold hash-table->alist
+ hash-table-copy hash-table-merge!
+ ;; Hashing
+ string-ci-hash hash-by-identity)
+ #:re-export (string-hash)
+ #:replace (hash make-hash-table hash-table?))
+
+(cond-expand-provide (current-module) '(srfi-69))
+
+;;;; Internal helper macros
+
+;; Define these first, so the compiler will pick them up.
+
+;; I am a macro only for efficiency, to avoid varargs/apply.
+(define-macro (hashx-invoke hashx-proc ht-var . args)
+ "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
+assoc-function, and the hash-table as first args."
+ `(,hashx-proc (hash-table-hash-function ,ht-var)
+ (ht-associator ,ht-var)
+ (ht-real-table ,ht-var)
+ . ,args))
+
+(define-macro (with-hashx-values bindings ht-var . body-forms)
+ "Bind BINDINGS to the hash-function, associator, and real-table of
+HT-VAR, while evaluating BODY-FORMS."
+ `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
+ (,(second bindings) (ht-associator ,ht-var))
+ (,(third bindings) (ht-real-table ,ht-var)))
+ . ,body-forms))
+
+
+;;;; Hashing
+
+;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
+;;; though not documented anywhere but libguile/numbers.c.
+
+(define (caller-with-default-size hash-fn)
+ "Answer a function that makes `most-positive-fixnum' the default
+second argument to HASH-FN, a 2-arg procedure."
+ (lambda* (obj #:optional (size most-positive-fixnum))
+ (hash-fn obj size)))
+
+(define hash (caller-with-default-size (@ (guile) hash)))
+
+(define string-ci-hash string-hash-ci)
+
+(define hash-by-identity (caller-with-default-size hashq))
+
+;;;; Reflective queries, construction, predicate
+
+(define-record-type srfi-69:hash-table
+ (make-srfi-69-hash-table real-table associator size weakness
+ equivalence-function hash-function)
+ hash-table?
+ (real-table ht-real-table)
+ (associator ht-associator)
+ ;; required for O(1) by SRFI-69. It really makes a mess of things,
+ ;; and I'd like to compute it in O(n) and memoize it because it
+ ;; doesn't seem terribly useful, but SRFI-69 is final.
+ (size ht-size ht-size!)
+ ;; required for `hash-table-copy'
+ (weakness ht-weakness)
+ ;; used only to implement hash-table-equivalence-function; I don't
+ ;; use it internally other than for `ht-associator'.
+ (equivalence-function hash-table-equivalence-function)
+ (hash-function hash-table-hash-function))
+
+(define (guess-hash-function equal-proc)
+ "Guess a hash function for EQUAL-PROC, falling back on `hash', as
+specified in SRFI-69 for `make-hash-table'."
+ (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
+ ((eq? eq? equal-proc) hashq)
+ ((eq? eqv? equal-proc) hashv)
+ ((eq? string=? equal-proc) string-hash)
+ ((eq? string-ci=? equal-proc) string-ci-hash)
+ (else (@ (guile) hash))))
+
+(define (without-keyword-args rest-list)
+ "Answer REST-LIST with all keywords removed along with items that
+follow them."
+ (let lp ((acc '()) (rest-list rest-list))
+ (cond ((null? rest-list) (reverse! acc))
+ ((keyword? (first rest-list))
+ (lp acc (cddr rest-list)))
+ (else (lp (cons (first rest-list) acc) (cdr rest-list))))))
+
+(define (guile-ht-ctor weakness)
+ "Answer the Guile HT constructor for the given WEAKNESS."
+ (case weakness
+ ((#f) (@ (guile) make-hash-table))
+ ((key) make-weak-key-hash-table)
+ ((value) make-weak-value-hash-table)
+ ((key-or-value) make-doubly-weak-hash-table)
+ (else (error "Invalid weak hash table type" weakness))))
+
+(define (equivalence-proc->associator equal-proc)
+ "Answer an `assoc'-like procedure that compares the argument key to
+alist keys with EQUAL-PROC."
+ (cond ((or (eq? equal? equal-proc)
+ (eq? string=? equal-proc)) (@ (guile) assoc))
+ ((eq? eq? equal-proc) assq)
+ ((eq? eqv? equal-proc) assv)
+ (else (lambda (item alist)
+ (assoc item alist equal-proc)))))
+
+(define* (make-hash-table
+ #:optional (equal-proc equal?)
+ (hash-proc (guess-hash-function equal-proc))
+ #:key (weak #f) #:rest guile-opts)
+ "Answer a new hash table using EQUAL-PROC as the comparison
+function, and HASH-PROC as the hash function. See the reference
+manual for specifics, of which there are many."
+ (make-srfi-69-hash-table
+ (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
+ (equivalence-proc->associator equal-proc)
+ 0 weak equal-proc hash-proc))
+
+(define (alist->hash-table alist . mht-args)
+ "Convert ALIST to a hash table created with MHT-ARGS."
+ (let* ((result (apply make-hash-table mht-args))
+ (size (ht-size result)))
+ (with-hashx-values (hash-proc associator real-table) result
+ (for-each (lambda (pair)
+ (let ((handle (hashx-get-handle hash-proc associator
+ real-table (car pair))))
+ (cond ((not handle)
+ (set! size (1+ size))
+ (hashx-set! hash-proc associator real-table
+ (car pair) (cdr pair))))))
+ alist))
+ (ht-size! result size)
+ result))
+
+;;;; Accessing table items
+
+;; We use this to denote missing or unspecified values to avoid
+;; possible collision with *unspecified*.
+(define ht-unspecified (cons *unspecified* "ht-value"))
+
+(define (hash-table-ref ht key . default-thunk-lst)
+ "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
+isn't present, or signal an error if DEFAULT-THUNK isn't provided."
+ (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
+ (if (eq? ht-unspecified result)
+ (if (pair? default-thunk-lst)
+ ((first default-thunk-lst))
+ (error "Key not in table" key ht))
+ result)))
+
+(define (hash-table-ref/default ht key default)
+ "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't
+present."
+ (hashx-invoke hashx-ref ht key default))
+
+(define (hash-table-set! ht key new-value)
+ "Set KEY to NEW-VALUE in HT."
+ (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (ht-size! ht (1+ (ht-size ht))))
+ (set-cdr! handle new-value))
+ *unspecified*)
+
+(define (hash-table-delete! ht key)
+ "Remove KEY's association in HT."
+ (with-hashx-values (h a real-ht) ht
+ (if (hashx-get-handle h a real-ht key)
+ (begin
+ (ht-size! ht (1- (ht-size ht)))
+ (hashx-remove! h a real-ht key))))
+ *unspecified*)
+
+(define (hash-table-exists? ht key)
+ "Return whether KEY is a key in HT."
+ (and (hashx-invoke hashx-get-handle ht key) #t))
+
+;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
+;;; avoid creating a handle in case DEFAULT-THUNK exits
+;;; `hash-table-update!' non-locally.
+(define (hash-table-update! ht key modifier . default-thunk-lst)
+ "Modify HT's value at KEY by passing its value to MODIFIER and
+setting it to the result thereof. Invoke DEFAULT-THUNK for the old
+value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
+provided."
+ (with-hashx-values (hash-proc associator real-table) ht
+ (let ((handle (hashx-get-handle hash-proc associator real-table key)))
+ (cond (handle
+ (set-cdr! handle (modifier (cdr handle))))
+ (else
+ (hashx-set! hash-proc associator real-table key
+ (if (pair? default-thunk-lst)
+ (modifier ((car default-thunk-lst)))
+ (error "Key not in table" key ht)))
+ (ht-size! ht (1+ (ht-size ht)))))))
+ *unspecified*)
+
+(define (hash-table-update!/default ht key modifier default)
+ "Modify HT's value at KEY by passing its old value, or DEFAULT if it
+doesn't have one, to MODIFIER, and setting it to the result thereof."
+ (hash-table-update! ht key modifier (lambda () default)))
+
+;;;; Accessing whole tables
+
+(define (hash-table-size ht)
+ "Return the number of associations in HT. This is guaranteed O(1)
+for tables where #:weak was #f or not specified at creation time."
+ (if (ht-weakness ht)
+ (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
+ (ht-size ht)))
+
+(define (hash-table-keys ht)
+ "Return a list of the keys in HT."
+ (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))
+
+(define (hash-table-values ht)
+ "Return a list of the values in HT."
+ (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))
+
+(define (hash-table-walk ht proc)
+ "Call PROC with each key and value as two arguments."
+ (hash-table-fold ht (lambda (k v unspec)
+ (call-with-values (lambda () (proc k v))
+ (lambda vals unspec)))
+ *unspecified*))
+
+(define (hash-table-fold ht f knil)
+ "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
+the result of the previous invocation, using KNIL as the first PREV.
+Answer the final F result."
+ (hash-fold f knil (ht-real-table ht)))
+
+(define (hash-table->alist ht)
+ "Return an alist for HT."
+ (hash-table-fold ht alist-cons '()))
+
+(define (hash-table-copy ht)
+ "Answer a copy of HT."
+ (with-hashx-values (h a real-ht) ht
+ (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
+ (new-real-ht ((guile-ht-ctor weak) size)))
+ (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
+ #f real-ht)
+ (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h
+ new-real-ht a size weak
+ (hash-table-equivalence-function ht) h))))
+
+(define (hash-table-merge! ht other-ht)
+ "Add all key/value pairs from OTHER-HT to HT, overriding HT's
+mappings where present. Return HT."
+ (hash-table-fold
+ ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
+ ht)
+
+;;; srfi-69.scm ends here
diff --git a/module/srfi/srfi-71.scm b/module/srfi/srfi-71.scm
new file mode 100644
index 000000000..16c8e7f9c
--- /dev/null
+++ b/module/srfi/srfi-71.scm
@@ -0,0 +1,267 @@
+;; Copyright (c) 2005 Sebastian Egner.
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the
+;; ``Software''), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be included
+;; in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;; Reference implementation of SRFI-71 using PLT 208's modules
+;; Sebastian.Egner@philips.com, 2005-04-29
+;;
+;; Adjusted for Guile module system by
+;; Christopher Allan Webber <cwebber@dustycloud.org>, 2017-06-29
+
+(define-module (srfi srfi-71)
+ #:export (uncons unlist unvector values->list
+ values->vector)
+ #:replace ((srfi-let . let)
+ (srfi-let* . let*)
+ (srfi-letrec . letrec)))
+
+(cond-expand-provide (current-module) '(srfi-71))
+
+(define-syntax r5rs-let
+ (syntax-rules ()
+ ((r5rs-let ((v x) ...) body1 body ...)
+ (let ((v x) ...) body1 body ...))
+ ((r5rs-let tag ((v x) ...) body1 body ...)
+ (let tag ((v x) ...) body1 body ...))))
+
+(define-syntax r5rs-let*
+ (syntax-rules ()
+ ((r5rs-let* ((v x) ...) body1 body ...)
+ (let* ((v x) ...) body1 body ...))))
+
+(define-syntax r5rs-letrec
+ (syntax-rules ()
+ ((r5rs-letrec ((v x) ...) body1 body ...)
+ (letrec ((v x) ...) body1 body ...))))
+
+; --- textual copy of 'letvalues.scm' starts here ---
+
+; Reference implementation of SRFI-71 (generic part)
+; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
+;
+; In order to avoid conflicts with the existing let etc.
+; the macros defined here are called srfi-let etc.,
+; and they are defined in terms of r5rs-let etc.
+; It is up to the actual implementation to save let/*/rec
+; in r5rs-let/*/rec first and redefine let/*/rec
+; by srfi-let/*/rec then.
+;
+; There is also a srfi-letrec* being defined (in view of R6RS.)
+;
+; Macros used internally are named i:<something>.
+;
+; Abbreviations for macro arguments:
+; bs - <binding spec>
+; b - component of a binding spec (values, <variable>, or <expression>)
+; v - <variable>
+; vr - <variable> for rest list
+; x - <expression>
+; t - newly introduced temporary variable
+; vx - (<variable> <expression>)
+; rec - flag if letrec is produced (and not let)
+; cwv - call-with-value skeleton of the form (x formals)
+; (call-with-values (lambda () x) (lambda formals /payload/))
+; where /payload/ is of the form (let (vx ...) body1 body ...).
+;
+; Remark (*):
+; We bind the variables of a letrec to i:undefined since there is
+; no portable (R5RS) way of binding a variable to a values that
+; raises an error when read uninitialized.
+
+(define i:undefined 'undefined)
+
+(define-syntax srfi-letrec* ; -> srfi-letrec
+ (syntax-rules ()
+ ((srfi-letrec* () body1 body ...)
+ (srfi-letrec () body1 body ...))
+ ((srfi-letrec* (bs) body1 body ...)
+ (srfi-letrec (bs) body1 body ...))
+ ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
+ (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
+
+(define-syntax srfi-letrec ; -> i:let
+ (syntax-rules ()
+ ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
+ (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
+
+(define-syntax srfi-let* ; -> srfi-let
+ (syntax-rules ()
+ ((srfi-let* () body1 body ...)
+ (srfi-let () body1 body ...))
+ ((srfi-let* (bs) body1 body ...)
+ (srfi-let (bs) body1 body ...))
+ ((srfi-let* (bs1 bs2 bs ...) body1 body ...)
+ (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
+
+(define-syntax srfi-let ; -> i:let or i:named-let
+ (syntax-rules ()
+ ((srfi-let ((b1 b2 b ...) ...) body1 body ...)
+ (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
+ ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
+ (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
+
+(define-syntax i:let
+ (syntax-rules (values)
+
+; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
+; processes the binding specs bs ... by adding call-with-values
+; skeletons to cwv ... and bindings to vx ..., and afterwards
+; wrapping the skeletons around the payload (let (vx ...) . body).
+
+ ; no more bs to process -> wrap call-with-values skeletons
+ ((i:let "bs" rec (cwv ...) vxs body ())
+ (i:let "wrap" rec vxs body cwv ...))
+
+ ; recognize form1 without variable -> dummy binding for side-effects
+ ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...))
+ (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...)))
+
+ ; recognize form1 with single variable -> just extend vx ...
+ ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...))
+ (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
+
+ ; recognize form1 without rest arg -> generate cwv
+ ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))
+ (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...)))
+
+ ; recognize form1 with rest arg -> generate cwv
+ ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...))
+ (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs)))
+
+ ; recognize form2 with single variable -> just extend vx ...
+ ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...))
+ (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
+
+ ; recognize form2 with >=2 variables -> transform to form1
+ ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...))
+ (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...)))
+
+; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...))
+; processes the variables in v1 v2 v ... adding them to (t ...)
+; and producing a cwv when finished. There is not rest argument.
+
+ ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values))
+ (i:let "bs" rec (cwv ... (x ts)) vxs body bss))
+ ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...))
+ (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...)))
+
+; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr))
+; processes the variables in v ... . vr adding them to (t ...)
+; and producing a cwv when finished. The rest arg is vr.
+
+ ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs))
+ (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs)))
+ ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr))
+ (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss))
+ ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr))
+ (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss))
+
+; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x))
+; processes the binding items (b ... x) from form2 as in
+; (v ... b ... x) into ((values v ... b ...) x), i.e. form1.
+; Then call "bs" recursively.
+
+ ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x))
+ (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)))
+ ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...))
+ (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...)))
+
+; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...)
+; wraps cwv ... around the payload generating the actual code.
+; For letrec this is of course different than for let.
+
+ ((i:let "wrap" #f vxs body)
+ (r5rs-let vxs . body))
+ ((i:let "wrap" #f vxs body (x formals) cwv ...)
+ (call-with-values
+ (lambda () x)
+ (lambda formals (i:let "wrap" #f vxs body cwv ...))))
+
+ ((i:let "wrap" #t vxs body)
+ (r5rs-letrec vxs . body))
+ ((i:let "wrap" #t ((v t) ...) body cwv ...)
+ (r5rs-let ((v i:undefined) ...) ; (*)
+ (i:let "wraprec" ((v t) ...) body cwv ...)))
+
+; (i:let "wraprec" ((v t) ...) body cwv ...)
+; generate the inner code for a letrec. The variables v ...
+; are the user-visible variables (bound outside), and t ...
+; are the temporary variables bound by the cwv consumers.
+
+ ((i:let "wraprec" ((v t) ...) (body ...))
+ (begin (set! v t) ... (r5rs-let () body ...)))
+ ((i:let "wraprec" vxs body (x formals) cwv ...)
+ (call-with-values
+ (lambda () x)
+ (lambda formals (i:let "wraprec" vxs body cwv ...))))
+
+ ))
+
+(define-syntax i:named-let
+ (syntax-rules (values)
+
+; (i:named-let tag (vx ...) body (bs ...))
+; processes the binding specs bs ... by extracting the variable
+; and expression, adding them to vx and turning the result into
+; an ordinary named let.
+
+ ((i:named-let tag vxs body ())
+ (r5rs-let tag vxs . body))
+ ((i:named-let tag (vx ...) body (((values v) x) bs ...))
+ (i:named-let tag (vx ... (v x)) body (bs ...)))
+ ((i:named-let tag (vx ...) body ((v x) bs ...))
+ (i:named-let tag (vx ... (v x)) body (bs ...)))))
+
+; --- standard procedures ---
+
+(define (uncons pair)
+ (values (car pair) (cdr pair)))
+
+(define (uncons-2 list)
+ (values (car list) (cadr list) (cddr list)))
+
+(define (uncons-3 list)
+ (values (car list) (cadr list) (caddr list) (cdddr list)))
+
+(define (uncons-4 list)
+ (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
+
+(define (uncons-cons alist)
+ (values (caar alist) (cdar alist) (cdr alist)))
+
+(define (unlist list)
+ (apply values list))
+
+(define (unvector vector)
+ (apply values (vector->list vector)))
+
+; --- standard macros ---
+
+(define-syntax values->list
+ (syntax-rules ()
+ ((values->list x)
+ (call-with-values (lambda () x) list))))
+
+(define-syntax values->vector
+ (syntax-rules ()
+ ((values->vector x)
+ (call-with-values (lambda () x) vector))))
+
+; --- textual copy of 'letvalues.scm' ends here ---
diff --git a/module/srfi/srfi-8.scm b/module/srfi/srfi-8.scm
new file mode 100644
index 000000000..ced123894
--- /dev/null
+++ b/module/srfi/srfi-8.scm
@@ -0,0 +1,31 @@
+;;; 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
diff --git a/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm
new file mode 100644
index 000000000..043a4a78f
--- /dev/null
+++ b/module/srfi/srfi-88.scm
@@ -0,0 +1,53 @@
+;;; srfi-88.scm --- Keyword Objects -*- coding: utf-8 -*-
+
+;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is a convenience module providing SRFI-88 "keyword object". All it
+;; does is setup the right reader option and export keyword-related
+;; convenience procedures.
+
+;;; Code:
+
+(define-module (srfi srfi-88)
+ #:re-export (keyword?)
+ #:export (keyword->string string->keyword))
+
+(cond-expand-provide (current-module) '(srfi-88))
+
+
+;; Change the keyword syntax both at compile time and run time; the latter is
+;; useful at the REPL.
+(eval-when (expand load eval)
+ (read-set! keywords 'postfix))
+
+(define (keyword->string k)
+ "Return the name of @var{k} as a string."
+ (symbol->string (keyword->symbol k)))
+
+(define (string->keyword s)
+ "Return the keyword object whose name is @var{s}."
+ (symbol->keyword (string->symbol s)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; srfi-88.scm ends here
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
new file mode 100644
index 000000000..aee8be01c
--- /dev/null
+++ b/module/srfi/srfi-9.scm
@@ -0,0 +1,348 @@
+;;; srfi-9.scm --- define-record-type
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
+;; 2013, 2014, 2018 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module exports the syntactic form `define-record-type', which
+;; is the means for creating record types defined in SRFI-9.
+;;
+;; The syntax of a record type definition is:
+;;
+;; <record type definition>
+;; -> (define-record-type <type name>
+;; (<constructor name> <field tag> ...)
+;; <predicate name>
+;; <field spec> ...)
+;;
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
+;;
+;; <field tag> -> <identifier>
+;; <... name> -> <identifier>
+;;
+;; Usage example:
+;;
+;; guile> (use-modules (srfi srfi-9))
+;; guile> (define-record-type :foo (make-foo x) foo?
+;; (x get-x) (y get-y set-y!))
+;; guile> (define f (make-foo 1))
+;; guile> f
+;; #<:foo x: 1 y: #f>
+;; guile> (get-x f)
+;; 1
+;; guile> (set-y! f 2)
+;; 2
+;; guile> (get-y f)
+;; 2
+;; guile> f
+;; #<:foo x: 1 y: 2>
+;; guile> (foo? f)
+;; #t
+;; guile> (foo? 1)
+;; #f
+
+;;; Code:
+
+(define-module (srfi srfi-9)
+ #:use-module (srfi srfi-1)
+ #:use-module (system base ck)
+ #:export (define-record-type))
+
+(cond-expand-provide (current-module) '(srfi-9))
+
+;; Roll our own instead of using the public `define-inlinable'. This is
+;; because the public one has a different `make-procedure-name', so
+;; using it would require users to recompile code that uses SRFI-9. See
+;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define-syntax-rule (%%on-error err) err)
+
+(define %%type #f) ; a private syntax literal
+(define-syntax getter-type
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%type s))))
+
+(define %%index #f) ; a private syntax literal
+(define-syntax getter-index
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%index s))))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax getter-copier
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%copier s))))
+
+(define-syntax define-tagged-inlinable
+ (lambda (x)
+ (define (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append '% (syntax->datum name)
+ '-procedure)))
+
+ (syntax-case x ()
+ ((_ ((key value) ...) (name formals ...) body ...)
+ (identifier? #'name)
+ (with-syntax ((proc-name (make-procedure-name #'name))
+ ((args ...) (generate-temporaries #'(formals ...))))
+ #`(begin
+ (define (proc-name formals ...)
+ body ...)
+ (define-syntax name
+ (lambda (x)
+ (syntax-case x (%%on-error key ...)
+ ((_ (%%on-error err) key s) #'(ck s 'value)) ...
+ ((_ args ...)
+ #'((lambda (formals ...)
+ body ...)
+ args ...))
+ ((_ a (... ...))
+ (syntax-violation 'name "Wrong number of arguments" x))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
+
+(define (default-record-printer s p)
+ (display "#<" p)
+ (display (record-type-name (record-type-descriptor s)) p)
+ (let loop ((fields (record-type-fields (record-type-descriptor s)))
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (write (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p))
+
+(define-syntax-rule (throw-bad-struct s who)
+ (let ((s* s))
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s*)
+ (list s*))))
+
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-set-fields)))
+
+(define-syntax %%set-fields
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...))
+ (nfields (length #'(getter-id ...))))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(make-struct/simple
+ type-name
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota nfields)))))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
+(define-syntax %define-record-type
+ (lambda (x)
+ (define (field-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'name)
+ ((name getter setter) #'name)))
+ field-specs))
+
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-ids)
+ (syntax-case constructor-spec ()
+ ((ctor field ...)
+ (every identifier? #'(field ...))
+ (letrec* ((id-list-contains?
+ (lambda (id-list id)
+ (and (not (null? id-list))
+ (or (free-identifier=? (car id-list) id)
+ (id-list-contains? (cdr id-list) id)))))
+ (inits (map (lambda (id)
+ (and (id-list-contains? #'(field ...) id) id))
+ field-ids)))
+ (for-each
+ (lambda (field)
+ (unless (id-list-contains? field-ids field)
+ (syntax-violation
+ (syntax-case form () ((macro . args) (syntax->datum #'macro)))
+ "unknown field in constructor spec"
+ form field)))
+ #'(field ...))
+ #`(define-inlinable #,constructor-spec
+ (make-struct/simple #,type-name #,@inits))))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
+
+ (define (copier type-name getter-ids copier-id)
+ #`(define-syntax-rule
+ (#,copier-id check? s (getter expr) (... ...))
+ (%%set-fields #,type-name #,getter-ids
+ check? s (getter expr) (... ...))))
+
+ (define (setters type-name field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s #,index val)
+ (throw-bad-struct s 'setter))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (functional-setters copier-id field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (#,copier-id #t s (getter val))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (record-layout immutable? count)
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
+
+ (syntax-case x ()
+ ((_ immutable? form type-name constructor-spec predicate-name
+ field-spec ...)
+ (let ()
+ (define (syntax-error message subform)
+ (syntax-violation (syntax-case #'form ()
+ ((macro . args) (syntax->datum #'macro)))
+ message #'form subform))
+ (and (boolean? (syntax->datum #'immutable?))
+ (or (identifier? #'type-name)
+ (syntax-error "expected type name" #'type-name))
+ (syntax-case #'constructor-spec ()
+ ((ctor args ...)
+ (every identifier? #'(ctor args ...))
+ #t)
+ (_ (syntax-error "invalid constructor spec"
+ #'constructor-spec)))
+ (or (identifier? #'predicate-name)
+ (syntax-error "expected predicate name" #'predicate-name))
+ (every (lambda (spec)
+ (syntax-case spec ()
+ ((field getter) #t)
+ ((field getter setter) #t)
+ (_ (syntax-error "invalid field spec" spec))))
+ #'(field-spec ...))))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
+ (immutable? (syntax->datum #'immutable?))
+ (layout (record-layout immutable? field-count))
+ (ctor-name (syntax-case #'constructor-spec ()
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
+ #`(begin
+ #,(constructor #'form #'type-name #'constructor-spec field-ids)
+
+ (define type-name
+ (let ((rtd (make-struct/no-tail
+ record-type-vtable
+ '#,(datum->syntax #'here (make-struct-layout layout))
+ default-record-printer
+ 'type-name
+ '#,field-ids)))
+ (set-struct-vtable-name! rtd 'type-name)
+ (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
+ rtd))
+
+ (define-inlinable (predicate-name obj)
+ (and (struct? obj)
+ (eq? (struct-vtable obj) type-name)))
+
+ #,@(getters #'type-name getter-ids copier-id)
+ #,(copier #'type-name getter-ids copier-id)
+ #,@(if immutable?
+ (functional-setters copier-id #'(field-spec ...))
+ (setters #'type-name #'(field-spec ...))))))
+ ((_ immutable? form . rest)
+ (syntax-violation
+ (syntax-case #'form ()
+ ((macro . args) (syntax->datum #'macro)))
+ "invalid record definition syntax"
+ #'form)))))
+
+(define-syntax-rule (define-record-type name ctor pred fields ...)
+ (%define-record-type #f (define-record-type name ctor pred fields ...)
+ name ctor pred fields ...))
+
+;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
new file mode 100644
index 000000000..219bcdebb
--- /dev/null
+++ b/module/srfi/srfi-9/gnu.scm
@@ -0,0 +1,168 @@
+;;; Extensions to SRFI-9
+
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-1)
+ #:use-module (system base ck)
+ #:export (set-record-type-printer!
+ define-immutable-record-type
+ set-field
+ set-fields))
+
+(define (set-record-type-printer! type proc)
+ "Set PROC as the custom printer for TYPE."
+ (struct-set! type vtable-index-printer proc))
+
+(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
+ ((@@ (srfi srfi-9) %define-record-type)
+ #t (define-immutable-record-type name ctor pred fields ...)
+ name ctor pred fields ...))
+
+(define-syntax-rule (set-field s (getter ...) expr)
+ (%set-fields #t (set-field s (getter ...) expr) ()
+ s ((getter ...) expr)))
+
+(define-syntax-rule (set-fields s . rest)
+ (%set-fields #t (set-fields s . rest) ()
+ s . rest))
+
+;;
+;; collate-set-field-specs is a helper for %set-fields
+;; thats combines all specs with the same head together.
+;;
+;; For example:
+;;
+;; SPECS: (((a b c) expr1)
+;; ((a d) expr2)
+;; ((b c) expr3)
+;; ((c) expr4))
+;;
+;; RESULT: ((a ((b c) expr1)
+;; ((d) expr2))
+;; (b ((c) expr3))
+;; (c (() expr4)))
+;;
+(define (collate-set-field-specs specs)
+ (define (insert head tail expr result)
+ (cond ((find (lambda (tree)
+ (free-identifier=? head (car tree)))
+ result)
+ => (lambda (tree)
+ `((,head (,tail ,expr)
+ ,@(cdr tree))
+ ,@(delq tree result))))
+ (else `((,head (,tail ,expr))
+ ,@result))))
+ (with-syntax (((((head . tail) expr) ...) specs))
+ (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
+
+(define-syntax unknown-getter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ orig-form getter)
+ (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
+
+(define-syntax c-list
+ (lambda (x)
+ (syntax-case x (quote)
+ ((_ s 'v ...)
+ #'(ck s '(v ...))))))
+
+(define-syntax c-same-type-check
+ (lambda (x)
+ (syntax-case x (quote)
+ ((_ s 'orig-form '(path ...)
+ '(getter0 getter ...)
+ '(type0 type ...)
+ 'on-success)
+ (every (lambda (t g)
+ (or (free-identifier=? t #'type0)
+ (syntax-violation
+ 'set-fields
+ (format #f
+ "\
+field paths ~a and ~a require one object to belong to two different record types (~a and ~a)"
+ (syntax->datum #`(path ... #,g))
+ (syntax->datum #'(path ... getter0))
+ (syntax->datum t)
+ (syntax->datum #'type0))
+ #'orig-form)))
+ #'(type ...)
+ #'(getter ...))
+ #'(ck s 'on-success)))))
+
+(define-syntax %set-fields
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? orig-form (path-so-far ...)
+ s)
+ #'s)
+ ((_ check? orig-form (path-so-far ...)
+ s (() e))
+ #'e)
+ ((_ check? orig-form (path-so-far ...)
+ struct-expr ((head . tail) expr) ...)
+ (let ((collated-specs (collate-set-field-specs
+ #'(((head . tail) expr) ...))))
+ (with-syntax (((getter0 getter ...)
+ (map car collated-specs)))
+ (with-syntax ((err #'(unknown-getter
+ orig-form getter0)))
+ #`(ck
+ ()
+ (c-same-type-check
+ 'orig-form
+ '(path-so-far ...)
+ '(getter0 getter ...)
+ (c-list (getter-type 'getter0 'err)
+ (getter-type 'getter 'err) ...)
+ '(let ((s struct-expr))
+ ((ck () (getter-copier 'getter0 'err))
+ check?
+ s
+ #,@(map (lambda (spec)
+ (with-syntax (((head (tail expr) ...) spec))
+ (with-syntax ((err #'(unknown-getter
+ orig-form head)))
+ #'(head (%set-fields
+ check?
+ orig-form
+ (path-so-far ... head)
+ (struct-ref s (ck () (getter-index
+ 'head 'err)))
+ (tail expr) ...)))))
+ collated-specs)))))))))
+ ((_ check? orig-form (path-so-far ...)
+ s (() e) (() e*) ...)
+ (syntax-violation 'set-fields "duplicate field path"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form (path-so-far ...)
+ s ((getter ...) expr) ...)
+ (syntax-violation 'set-fields "one field path is a prefix of another"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form . rest)
+ (syntax-violation 'set-fields "invalid syntax" #'orig-form))))))
diff --git a/module/srfi/srfi-98.scm b/module/srfi/srfi-98.scm
new file mode 100644
index 000000000..944f40261
--- /dev/null
+++ b/module/srfi/srfi-98.scm
@@ -0,0 +1,44 @@
+;;; 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)))