code:
;;; srfi-1.scm --- List Library

;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; 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 "libguile-srfi-srfi-1-v-4" "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))

;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller)
  (if (pred arg)
      arg
      (scm-error 'wrong-type-arg caller
		 "Wrong type argument: ~S" (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-type 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-type 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)))))))
  (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 (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)

(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 (map1 cdr l) (cons (map1 car l) acc)))))

(define (unzip1 l)
  (map1 first l))
(define (unzip2 l)
  (values (map1 first l) (map1 second l)))
(define (unzip3 l)
  (values (map1 first l) (map1 second l) (map1 third l)))
(define (unzip4 l)
  (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
(define (unzip5 l)
  (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
	  (map1 fifth l)))

;;; Fold, unfold & map

(define (fold kons knil list1 . rest)
  "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
that result.  See the manual for details."
  (if (null? rest)
      (let f ((knil knil) (list1 list1))
	(if (null? list1)
	    knil
	    (f (kons (car list1) knil) (cdr list1))))
      (let f ((knil knil) (lists (cons list1 rest)))
	(if (any null? lists)
	    knil
	    (let ((cars (map1 car lists))
		  (cdrs (map1 cdr lists)))
	      (f (apply kons (append! cars (list knil))) cdrs))))))

(define (fold-right kons knil clist1 . rest)
  (if (null? rest)
    (let f ((list1 clist1))
      (if (null? list1)
	knil
	(kons (car list1) (f (cdr list1)))))
    (let f ((lists (cons clist1 rest)))
      (if (any null? lists)
	knil
	(apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))

(define (pair-fold kons knil clist1 . rest)
  (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 (map1 cdr lists)))
	      (f (apply kons (append! lists (list knil))) tails))))))

(define (pair-fold-right kons knil clist1 . rest)
  (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 (map1 cdr lists)))))))))

(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
  (let uf ((seed seed))
    (if (p seed)
        (tail-gen seed)
        (cons (f seed)
              (uf (g seed))))))

(define* (unfold-right p f g seed #:optional (tail '()))
  (let uf ((seed seed) (lis tail))
    (if (p seed)
        lis
        (uf (g seed) (cons (f seed) lis)))))

;; Internal helper procedure.  Map `f' over the single list `ls'.
;;
(define map1 map)

(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 (pair-for-each f clist1 . rest)
  (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 (map1 cdr l)))))))

;;; Searching

(define (any pred ls . lists)
  (if (null? lists)
      (any1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #f)
	      ((any1 null? (map1 cdr lists))
	       (apply pred (map1 car lists)))
	      (else
	       (or (apply pred (map1 car lists)) (lp (map1 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)
  (if (null? lists)
      (every1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #t)
	      ((any1 null? (map1 cdr lists))
	       (apply pred (map1 car lists)))
	      (else
	       (and (apply pred (map1 car lists)) (lp (map1 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."
  (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 (map1 car lists)) i)
	    (else
	     (lp (map1 cdr lists) (+ i 1)))))))

;;; Association lists

(define alist-cons acons)

(define* (alist-delete key alist #:optional (k= equal?))
  (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

;;; Set operations on lists

(define (lset<= = . rest)
  (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)
  (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)))))))

(define (lset-union = . rest)
  (let ((acc '()))
    (for-each (lambda (lst)
		(if (null? acc)
		    (set! acc lst)
		    (for-each (lambda (elem)
				(if (not (member elem acc
						 (lambda (x y) (= y x))))
				    (set! acc (cons elem acc))))
			      lst)))
	      rest)
    acc))

(define (lset-intersection = list1 . rest)
  (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)
  (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)
  (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)
  (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)
  (apply lset-union = rest))		; XXX:optimize

(define (lset-intersection! = list1 . rest)
  (apply lset-intersection = list1 rest)) ; XXX:optimize

(define (lset-xor! = . rest)
  (apply lset-xor = rest))		; XXX:optimize

(define (lset-diff+intersection! = list1 . rest)
  (apply lset-diff+intersection = list1 rest)) ; XXX:optimize

;;; srfi-1.scm ends here


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

license: mit


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


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


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


code:
;;; srfi-16.scm --- case-lambda

;; Copyright (C) 2001, 2002, 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

;;; 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 code psyntax.

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


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


code:
;;; srfi-18.scm --- Multithreading support

;; 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: Julian Graham <julian.graham@aya.yale.edu>
;;; Date: 2008-04-11

;;; Commentary:

;; This is an implementation of SRFI-18 (Multithreading support).
;;
;; All procedures defined in SRFI-18, which are not already defined in
;; the Guile core library, are exported.
;;
;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-18)
  :use-module (srfi srfi-34)
  :export (

;;; Threads
 ;; current-thread			<= in the core
 ;; thread?				<= in the core
 make-thread
 thread-name
 thread-specific
 thread-specific-set!
 thread-start!
 thread-yield!
 thread-sleep!
 thread-terminate!
 thread-join!

;;; Mutexes
 ;; mutex?				<= in the core
 make-mutex
 mutex-name
 mutex-specific
 mutex-specific-set!
 mutex-state
 mutex-lock!
 mutex-unlock!

;;; Condition variables
 ;; condition-variable?			<= in the core
 make-condition-variable
 condition-variable-name
 condition-variable-specific
 condition-variable-specific-set!
 condition-variable-signal!
 condition-variable-broadcast!
 condition-variable-wait!

;;; Time
 current-time
 time?
 time->seconds
 seconds->time

 current-exception-handler
 with-exception-handler
 raise
 join-timeout-exception?
 abandoned-mutex-exception?
 terminated-thread-exception?
 uncaught-exception?
 uncaught-exception-reason
 )
  :re-export (thread? mutex? condition-variable?)
  :replace (current-time
	    make-thread
	    make-mutex
	    make-condition-variable
	    raise))

(if (not (provided? 'threads))
    (error "SRFI-18 requires Guile with threads support"))

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

(define (check-arg-type pred arg caller)
  (if (pred arg)
      arg
      (scm-error 'wrong-type-arg caller
		 "Wrong type argument: ~S" (list arg) '())))

(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
(define join-timeout-exception (list 'join-timeout-exception))
(define terminated-thread-exception (list 'terminated-thread-exception))
(define uncaught-exception (list 'uncaught-exception))

(define object-names (make-weak-key-hash-table))
(define object-specifics (make-weak-key-hash-table))
(define thread-start-conds (make-weak-key-hash-table))
(define thread-exception-handlers (make-weak-key-hash-table))

;; EXCEPTIONS

(define raise (@ (srfi srfi-34) raise))
(define (initial-handler obj)
  (srfi-18-exception-preserver (cons uncaught-exception obj)))

(define thread->exception (make-object-property))

(define (srfi-18-exception-preserver obj)
  (if (or (terminated-thread-exception? obj)
          (uncaught-exception? obj))
      (set! (thread->exception (current-thread)) obj)))

(define (srfi-18-exception-handler key . args)

  ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
  ;; if one is caught at this level, it has already been taken care of by
  ;; `initial-handler'.

  (and (not (eq? key 'srfi-34))
       (srfi-18-exception-preserver (if (null? args)
					(cons uncaught-exception key)
					(cons* uncaught-exception key args)))))

(define (current-handler-stack)
  (let ((ct (current-thread)))
    (or (hashq-ref thread-exception-handlers ct)
	(hashq-set! thread-exception-handlers ct (list initial-handler)))))

(define (with-exception-handler handler thunk)
  (let ((ct (current-thread))
        (hl (current-handler-stack)))
    (check-arg-type procedure? handler "with-exception-handler")
    (check-arg-type thunk? thunk "with-exception-handler")
    (hashq-set! thread-exception-handlers ct (cons handler hl))
    (apply (@ (srfi srfi-34) with-exception-handler)
           (list (lambda (obj)
                   (hashq-set! thread-exception-handlers ct hl)
                   (handler obj))
                 (lambda ()
                   (call-with-values thunk
                     (lambda res
                       (hashq-set! thread-exception-handlers ct hl)
                       (apply values res))))))))

(define (current-exception-handler)
  (car (current-handler-stack)))

(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
(define (uncaught-exception? obj)
  (and (pair? obj) (eq? (car obj) uncaught-exception)))
(define (uncaught-exception-reason exc)
  (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
(define (terminated-thread-exception? obj)
  (eq? obj terminated-thread-exception))

;; THREADS

;; Create a new thread and prevent it from starting using a condition variable.
;; Once started, install a top-level exception handler that rethrows any
;; exceptions wrapped in an uncaught-exception wrapper.

(define make-thread
  (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
			     (lambda ()
			       (lock-mutex lmutex)
			       (signal-condition-variable lcond)
			       (lock-mutex smutex)
			       (unlock-mutex lmutex)
			       (wait-condition-variable scond smutex)
			       (unlock-mutex smutex)
			       (with-exception-handler initial-handler
						       thunk)))))
    (lambda (thunk . name)
      (let ((n (and (pair? name) (car name)))

	    (lm (make-mutex 'launch-mutex))
	    (lc (make-condition-variable 'launch-condition-variable))
	    (sm (make-mutex 'start-mutex))
	    (sc (make-condition-variable 'start-condition-variable)))

	(lock-mutex lm)
	(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
				       srfi-18-exception-handler)))
	  (hashq-set! thread-start-conds t (cons sm sc))
	  (and n (hashq-set! object-names t n))
	  (wait-condition-variable lc lm)
	  (unlock-mutex lm)
	  t)))))

(define (thread-name thread)
  (hashq-ref object-names (check-arg-type thread? thread "thread-name")))

(define (thread-specific thread)
  (hashq-ref object-specifics
	     (check-arg-type thread? thread "thread-specific")))

(define (thread-specific-set! thread obj)
  (hashq-set! object-specifics
	      (check-arg-type thread? thread "thread-specific-set!")
	      obj)
  *unspecified*)

(define (thread-start! thread)
  (let ((x (hashq-ref thread-start-conds
		      (check-arg-type thread? thread "thread-start!"))))
    (and x (let ((smutex (car x))
		 (scond (cdr x)))
	     (hashq-remove! thread-start-conds thread)
	     (lock-mutex smutex)
	     (signal-condition-variable scond)
	     (unlock-mutex smutex)))
    thread))

(define (thread-yield!) (yield) *unspecified*)

(define (thread-sleep! timeout)
  (let* ((ct (time->seconds (current-time)))
	 (t (cond ((time? timeout) (- (time->seconds timeout) ct))
		  ((number? timeout) (- timeout ct))
		  (else (scm-error 'wrong-type-arg "thread-sleep!"
				   "Wrong type argument: ~S"
				   (list timeout)
				   '()))))
	 (secs (inexact->exact (truncate t)))
	 (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
    (and (> secs 0) (sleep secs))
    (and (> usecs 0) (usleep usecs))
    *unspecified*))

;; A convenience function for installing exception handlers on SRFI-18
;; primitives that resume the calling continuation after the handler is
;; invoked -- this resolves a behavioral incompatibility with Guile's
;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
;; exceptions.  (SRFI-18, "Primitives and exceptions")

(define (wrap thunk)
  (lambda (continuation)
    (with-exception-handler (lambda (obj)
			      ((current-exception-handler) obj)
			      (continuation))
			    thunk)))

;; A pass-thru to cancel-thread that first installs a handler that throws
;; terminated-thread exception, as per SRFI-18,

(define (thread-terminate! thread)
  (define (thread-terminate-inner!)
    (let ((current-handler (thread-cleanup thread)))
      (if (thunk? current-handler)
	  (set-thread-cleanup! thread
			       (lambda ()
				 (with-exception-handler initial-handler
							 current-handler)
				 (srfi-18-exception-preserver
				  terminated-thread-exception)))
	  (set-thread-cleanup! thread
			       (lambda () (srfi-18-exception-preserver
					   terminated-thread-exception))))
      (cancel-thread thread)
      *unspecified*))
  (thread-terminate-inner!))

(define (thread-join! thread . args)
  (define thread-join-inner!
    (wrap (lambda ()
	    (let ((v (apply join-thread (cons thread args)))
		  (e (thread->exception thread)))
	      (if (and (= (length args) 1) (not v))
		  (raise join-timeout-exception))
	      (if e (raise e))
	      v))))
  (call/cc thread-join-inner!))

;; MUTEXES
;; These functions are all pass-thrus to the existing Guile implementations.

(define make-mutex
  (lambda name
    (let ((n (and (pair? name) (car name)))
	  (m ((@ (guile) make-mutex)
	      'unchecked-unlock
	      'allow-external-unlock
	      'recursive)))
      (and n (hashq-set! object-names m n)) m)))

(define (mutex-name mutex)
  (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))

(define (mutex-specific mutex)
  (hashq-ref object-specifics
	     (check-arg-type mutex? mutex "mutex-specific")))

(define (mutex-specific-set! mutex obj)
  (hashq-set! object-specifics
	      (check-arg-type mutex? mutex "mutex-specific-set!")
	      obj)
  *unspecified*)

(define (mutex-state mutex)
  (let ((owner (mutex-owner mutex)))
    (if owner
	(if (thread-exited? owner) 'abandoned owner)
	(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))

(define (mutex-lock! mutex . args)
  (define mutex-lock-inner!
    (wrap (lambda ()
	    (catch 'abandoned-mutex-error
		   (lambda () (apply lock-mutex (cons mutex args)))
		   (lambda (key . args) (raise abandoned-mutex-exception))))))
  (call/cc mutex-lock-inner!))

(define (mutex-unlock! mutex . args)
  (apply unlock-mutex (cons mutex args)))

;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.

(define make-condition-variable
  (lambda name
    (let ((n (and (pair? name) (car name)))
	  (m ((@ (guile) make-condition-variable))))
      (and n (hashq-set! object-names m n)) m)))

(define (condition-variable-name condition-variable)
  (hashq-ref object-names (check-arg-type condition-variable?
					  condition-variable
					  "condition-variable-name")))

(define (condition-variable-specific condition-variable)
  (hashq-ref object-specifics (check-arg-type condition-variable?
					      condition-variable
					      "condition-variable-specific")))

(define (condition-variable-specific-set! condition-variable obj)
  (hashq-set! object-specifics
	      (check-arg-type condition-variable?
			      condition-variable
			      "condition-variable-specific-set!")
	      obj)
  *unspecified*)

(define (condition-variable-signal! cond)
  (signal-condition-variable cond)
  *unspecified*)

(define (condition-variable-broadcast! cond)
  (broadcast-condition-variable cond)
  *unspecified*)

;; TIME

(define current-time gettimeofday)
(define (time? obj)
  (and (pair? obj)
       (let ((co (car obj))) (and (integer? co) (>= co 0)))
       (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))

(define (time->seconds time)
  (and (check-arg-type time? time "time->seconds")
       (+ (car time) (/ (cdr time) 1000000))))

(define (seconds->time x)
  (and (check-arg-type number? x "seconds->time")
       (let ((fx (truncate x)))
	 (cons (inexact->exact fx)
	       (inexact->exact (truncate (* (- x fx) 1000000)))))))

;; srfi-18.scm ends here