diff --git a/lib.scm b/lib.scm
index 4e19eae..fabbef8 100644
--- a/lib.scm
+++ b/lib.scm
@@ -1,234 +1,285 @@
 ;; Additional library functions for TinySCHEME.
 ;;
 ;; Copyright (C) 2016 g10 Code GmbH
 ;;
 ;; This file is part of GnuPG.
 ;;
 ;; GnuPG is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 3 of the License, or
 ;; (at your option) any later version.
 ;;
 ;; GnuPG is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
 
 (macro (assert form)
   `(if (not ,(cadr form))
        (begin
 	 (display "Assertion failed: ")
 	 (write (quote ,(cadr form)))
 	 (newline)
 	 (exit 1))))
 (assert #t)
 
 (define (filter pred lst)
   (cond ((null? lst) '())
         ((pred (car lst))
          (cons (car lst) (filter pred (cdr lst))))
         (else (filter pred (cdr lst)))))
 
 (define (any p l)
   (cond ((null? l) #f)
         ((p (car l)) #t)
         (else (any p (cdr l)))))
 
 (define (all p l)
   (cond ((null? l) #t)
         ((not (p (car l))) #f)
         (else (all p (cdr l)))))
 
 ;; Return the first element of a list.
 (define first car)
 
 ;; Return the last element of a list.
 (define (last lst)
   (if (null? (cdr lst))
       (car lst)
       (last (cdr lst))))
 
 ;; Compute the powerset of a list.
 (define (powerset set)
   (if (null? set)
       '(())
       (let ((rst (powerset (cdr set))))
         (append (map (lambda (x) (cons (car set) x))
                      rst)
                 rst))))
 
 ;; Is PREFIX a prefix of S?
 (define (string-prefix? s prefix)
   (and (>= (string-length s) (string-length prefix))
        (string=? prefix (substring s 0 (string-length prefix)))))
 (assert (string-prefix? "Scheme" "Sch"))
 
 ;; Is SUFFIX a suffix of S?
 (define (string-suffix? s suffix)
   (and (>= (string-length s) (string-length suffix))
        (string=? suffix (substring s (- (string-length s)
 					(string-length suffix))
 				   (string-length s)))))
 (assert (string-suffix? "Scheme" "eme"))
 
 ;; Locate the first occurrence of needle in haystack starting at offset.
 (ffi-define (string-index haystack needle [offset]))
 (assert (= 2 (string-index "Hallo" #\l)))
 (assert (= 3 (string-index "Hallo" #\l 3)))
 (assert (equal? #f (string-index "Hallo" #\.)))
 
 ;; Locate the last occurrence of needle in haystack starting at offset.
 (ffi-define (string-rindex haystack needle [offset]))
 (assert (= 3 (string-rindex "Hallo" #\l)))
 (assert (equal? #f (string-rindex "Hallo" #\a 2)))
 (assert (equal? #f (string-rindex "Hallo" #\.)))
 
-;; Split haystack at delimiter at most n times.
-(define (string-splitn haystack delimiter n)
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-split-pln haystack predicate lookahead n)
   (let ((length (string-length haystack)))
-    (define (split acc delimiter offset n)
+    (define (split acc offset n)
       (if (>= offset length)
 	  (reverse acc)
-	  (let ((i (string-index haystack delimiter offset)))
+	  (let ((i (lookahead haystack offset)))
 	    (if (or (eq? i #f) (= 0 n))
 		(reverse (cons (substring haystack offset length) acc))
 		(split (cons (substring haystack offset i) acc)
-		       delimiter (+ i 1) (- n 1))))))
-    (split '() delimiter 0 n)))
+		       (+ i 1) (- n 1))))))
+    (split '() 0 n)))
+
+(define (string-indexp haystack offset predicate)
+  (cond
+   ((= (string-length haystack) offset)
+    #f)
+   ((predicate (string-ref haystack offset))
+    offset)
+   (else
+    (string-indexp haystack (+ 1 offset) predicate))))
+
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-splitp haystack predicate n)
+  (string-split-pln haystack predicate
+		    (lambda (haystack offset)
+		      (string-indexp haystack offset predicate))
+		    n))
+(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
+(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
+(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
+
+;; Split haystack at delimiter at most n times.
+(define (string-splitn haystack delimiter n)
+  (string-split-pln haystack
+		    (lambda (c) (char=? c delimiter))
+		    (lambda (haystack offset)
+		      (string-index haystack delimiter offset))
+		    n))
 (assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
 (assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
 (assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
 
 ;; Split haystack at delimiter.
 (define (string-split haystack delimiter)
   (string-splitn haystack delimiter -1))
 (assert (= 3 (length (string-split "foo:bar:baz" #\:))))
 (assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
 (assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
 (assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
 
 ;; Split haystack at newlines.
 (define (string-split-newlines haystack)
   (if *win32*
       (map (lambda (line) (if (string-suffix? line "\r")
 			      (substring line 0 (- (string-length line) 1))
 			      line))
 	   (string-split haystack #\newline))
       (string-split haystack #\newline)))
 
 ;; Trim the prefix of S containing only characters that make PREDICATE
 ;; true.
 (define (string-ltrim predicate s)
-  (let loop ((s' (string->list s)))
-    (if (predicate (car s'))
-	(loop (cdr s'))
-	(list->string s'))))
+  (if (string=? s "")
+      ""
+      (let loop ((s' (string->list s)))
+	(if (predicate (car s'))
+	    (loop (cdr s'))
+	    (list->string s')))))
+(assert (string=? "" (string-ltrim char-whitespace? "")))
 (assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
 
 ;; Trim the suffix of S containing only characters that make PREDICATE
 ;; true.
 (define (string-rtrim predicate s)
-  (let loop ((s' (reverse (string->list s))))
-    (if (predicate (car s'))
-	(loop (cdr s'))
-	(list->string (reverse s')))))
+  (if (string=? s "")
+      ""
+      (let loop ((s' (reverse (string->list s))))
+	(if (predicate (car s'))
+	    (loop (cdr s'))
+	    (list->string (reverse s'))))))
+(assert (string=? "" (string-rtrim char-whitespace? "")))
 (assert (string=? "foo" (string-rtrim char-whitespace? "foo 	")))
 
 ;; Trim both the prefix and suffix of S containing only characters
 ;; that make PREDICATE true.
 (define (string-trim predicate s)
   (string-ltrim predicate (string-rtrim predicate s)))
+(assert (string=? "" (string-trim char-whitespace? "")))
 (assert (string=? "foo" (string-trim char-whitespace? " 	foo 	")))
 
 ;; Check if needle is contained in haystack.
 (ffi-define (string-contains? haystack needle))
 (assert (string-contains? "Hallo" "llo"))
 (assert (not (string-contains? "Hallo" "olla")))
 
 ;; Read a word from port P.
 (define (read-word . p)
   (list->string
    (let f ()
      (let ((c (apply peek-char p)))
        (cond
 	((eof-object? c) '())
 	((char-alphabetic? c)
 	 (apply read-char p)
 	 (cons c (f)))
 	(else
 	 (apply read-char p)
 	 '()))))))
 
+(define (list->string-reversed lst)
+  (let* ((len (length lst))
+	 (str (make-string len)))
+    (let loop ((i (- len 1))
+	       (l lst))
+      (if (< i 0)
+	  (begin
+	    (assert (null? l))
+	    str)
+	  (begin
+	    (string-set! str i (car l))
+	    (loop (- i 1) (cdr l)))))))
+
 ;; Read a line from port P.
 (define (read-line . p)
-  (list->string
-   (let f ()
-     (let ((c (apply peek-char p)))
-       (cond
-	((eof-object? c) '())
-	((char=? c #\newline)
-	 (apply read-char p)
-	 '())
-	(else
-	 (apply read-char p)
-	 (cons c (f))))))))
+  (let loop ((acc '()))
+    (let ((c (apply peek-char p)))
+      (cond
+       ((eof-object? c)
+	(if (null? acc)
+	    c ;; #eof
+	    (list->string-reversed acc)))
+       ((char=? c #\newline)
+	(apply read-char p)
+	(list->string-reversed acc))
+       (else
+	(apply read-char p)
+	(loop (cons c acc)))))))
 
 ;; Read everything from port P.
 (define (read-all . p)
   (let loop ((acc (open-output-string)))
     (let ((c (apply peek-char p)))
       (cond
        ((eof-object? c) (get-output-string acc))
        (else
 	(write-char (apply read-char p) acc)
 	(loop acc))))))
 
 ;;
 ;; Windows support.
 ;;
 
 ;; Like call-with-input-file but opens the file in 'binary' mode.
 (define (call-with-binary-input-file filename proc)
   (letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
 	 (proc (fdopen fd "rb"))))
 
 ;; Like call-with-output-file but opens the file in 'binary' mode.
 (define (call-with-binary-output-file filename proc)
   (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
 	 (proc (fdopen fd "wb"))))
 
 ;;
 ;; Libc functions.
 ;;
 
 ;; Change the read/write offset.
 (ffi-define (seek fd offset whence))
 
 ;; Constants for WHENCE.
 (ffi-define SEEK_SET)
 (ffi-define SEEK_CUR)
 (ffi-define SEEK_END)
 
 ;; Get our process id.
 (ffi-define (getpid))
 
 ;; Copy data from file descriptor SOURCE to every file descriptor in
 ;; SINKS.
 (ffi-define (splice source . sinks))
 
 ;;
 ;; Random numbers.
 ;;
 
 ;; Seed the random number generator.
 (ffi-define (srandom seed))
 
 ;; Get a pseudo-random number between 0 (inclusive) and SCALE
 ;; (exclusive).
 (ffi-define (random scale))
 
 ;; Create a string of the given SIZE containing pseudo-random data.
 (ffi-define (make-random-string size))
diff --git a/tests.scm b/tests.scm
index bec1922..d360272 100644
--- a/tests.scm
+++ b/tests.scm
@@ -1,497 +1,500 @@
 ;; Common definitions for writing tests.
 ;;
 ;; Copyright (C) 2016 g10 Code GmbH
 ;;
 ;; This file is part of GnuPG.
 ;;
 ;; GnuPG is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 3 of the License, or
 ;; (at your option) any later version.
 ;;
 ;; GnuPG is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
 ;;
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
 
 ;; Trace displays and returns the given value.  A debugging aid.
 (define (trace x)
   (display x)
   (newline)
   x)
 
 ;; Stringification.
 (define (stringify expression)
   (let ((p (open-output-string)))
     (write expression p)
     (get-output-string p)))
 
 ;; Reporting.
 (define (echo . msg)
   (for-each (lambda (x) (display x) (display " ")) msg)
   (newline))
 
 (define (info . msg)
   (apply echo msg)
   (flush-stdio))
 
 (define (log . msg)
   (if (> (*verbose*) 0)
       (apply info msg)))
 
 (define (fail . msg)
   (apply info msg)
   (exit 1))
 
 (define (skip . msg)
   (apply info msg)
   (exit 77))
 
 (define (make-counter)
   (let ((c 0))
     (lambda ()
       (let ((r c))
 	(set! c (+ 1 c))
 	r))))
 
 (define *progress-nesting* 0)
 
 (define (call-with-progress msg what)
   (set! *progress-nesting* (+ 1 *progress-nesting*))
   (if (= 1 *progress-nesting*)
       (begin
 	(info msg)
 	(display "    > ")
 	(flush-stdio)
 	(what (lambda (item)
 	      (display item)
 	      (display " ")
 	      (flush-stdio)))
 	(info "< "))
       (begin
 	(what (lambda (item) (display ".") (flush-stdio)))
 	(display " ")
 	(flush-stdio)))
   (set! *progress-nesting* (- *progress-nesting* 1)))
 
 (define (for-each-p msg proc lst . lsts)
   (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
 
 (define (for-each-p' msg proc fmt lst . lsts)
   (call-with-progress
    msg
    (lambda (progress)
      (apply for-each
 	    `(,(lambda args
 		 (progress (apply fmt args))
 		 (apply proc args))
 	      ,lst ,@lsts)))))
 
 ;; Process management.
 (define CLOSED_FD -1)
 (define (call-with-fds what infd outfd errfd)
   (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
 (define (call what)
   (call-with-fds what
 		 CLOSED_FD
 		 (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
 		 (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
 
 ;; Accessor functions for the results of 'spawn-process'.
 (define :stdin car)
 (define :stdout cadr)
 (define :stderr caddr)
 (define :pid cadddr)
 
 (define (call-with-io what in)
   (let ((h (spawn-process what 0)))
     (es-write (:stdin h) in)
     (es-fclose (:stdin h))
     (let* ((out (es-read-all (:stdout h)))
 	   (err (es-read-all (:stderr h)))
 	   (result (wait-process (car what) (:pid h) #t)))
       (es-fclose (:stdout h))
       (es-fclose (:stderr h))
       (if (> (*verbose*) 2)
 	  (begin
 	    (echo (stringify what) "returned:" result)
 	    (echo (stringify what) "wrote to stdout:" out)
 	    (echo (stringify what) "wrote to stderr:" err)))
       (list result out err))))
 
 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
 ;; ':stderr' can also be used.
 (define :retcode car)
 
 (define (call-check what)
   (let ((result (call-with-io what "")))
     (if (= 0 (:retcode result))
 	(:stdout result)
 	(throw (string-append (stringify what) " failed")
 	       (:stderr result)))))
 
 (define (call-popen command input-string)
   (let ((result (call-with-io command input-string)))
     (if (= 0 (:retcode result))
 	(:stdout result)
 	(throw (:stderr result)))))
 
 ;;
 ;; estream helpers.
 ;;
 
 (define (es-read-all stream)
   (let loop
       ((acc ""))
     (if (es-feof stream)
 	acc
 	(loop (string-append acc (es-read stream 4096))))))
 
 ;;
 ;; File management.
 ;;
 (define (file-exists? name)
   (call-with-input-file name (lambda (port) #t)))
 
 (define (file=? a b)
   (file-equal a b #t))
 
 (define (text-file=? a b)
   (file-equal a b #f))
 
 (define (file-copy from to)
   (catch '() (unlink to))
   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
 	  (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
     (splice source sink)))
 
 (define (text-file-copy from to)
   (catch '() (unlink to))
   (letfd ((source (open from O_RDONLY))
 	  (sink (open to (logior O_WRONLY O_CREAT) #o600)))
     (splice source sink)))
 
 (define (path-join . components)
   (let loop ((acc #f) (rest (filter (lambda (s)
 				      (not (string=? "" s))) components)))
     (if (null? rest)
 	acc
 	(loop (if (string? acc)
 		  (string-append acc "/" (car rest))
 		  (car rest))
 	      (cdr rest)))))
 (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
 (assert (string=? (path-join "" "bar" "baz") "bar/baz"))
 
+;; Is PATH an absolute path?
+(define (absolute-path? path)
+  (or (char=? #\/ (string-ref path 0))
+      (and *win32* (char=? #\\ (string-ref path 0)))
+      (and *win32*
+	   (char-alphabetic? (string-ref path 0))
+	   (char=? #\: (string-ref path 1))
+	   (or (char=? #\/ (string-ref path 2))
+	       (char=? #\\ (string-ref path 2))))))
+
+;; Make PATH absolute.
 (define (canonical-path path)
-  (if (or (char=? #\/ (string-ref path 0))
-	  (and *win32* (char=? #\\ (string-ref path 0)))
-	  (and *win32*
-	       (char-alphabetic? (string-ref path 0))
-	       (char=? #\: (string-ref path 1))
-	       (or (char=? #\/ (string-ref path 2))
-		   (char=? #\\ (string-ref path 2)))))
-      path
-      (path-join (getcwd) path)))
+  (if (absolute-path? path) path (path-join (getcwd) path)))
 
 (define (in-srcdir . names)
   (canonical-path (apply path-join (cons (getenv "srcdir") names))))
 
 ;; Try to find NAME in PATHS.  Returns the full path name on success,
 ;; or raises an error.
 (define (path-expand name paths)
   (let loop ((path paths))
     (if (null? path)
 	(throw "Could not find" name "in" paths)
 	(let* ((qualified-name (path-join (car path) name))
 	       (file-exists (call-with-input-file qualified-name
 			      (lambda (x) #t))))
 	  (if file-exists
 	      qualified-name
 	      (loop (cdr path)))))))
 
 ;; Expand NAME using the gpgscm load path.  Use like this:
 ;;   (load (with-path "library.scm"))
 (define (with-path name)
   (catch name
 	 (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
 
 (define (basename path)
   (let ((i (string-index path #\/)))
     (if (equal? i #f)
 	path
 	(basename (substring path (+ 1 i) (string-length path))))))
 
 (define (basename-suffix path suffix)
   (basename
    (if (string-suffix? path suffix)
        (substring path 0 (- (string-length path) (string-length suffix)))
        path)))
 
 ;; Helper for (pipe).
 (define :read-end car)
 (define :write-end cadr)
 
 ;; let-like macro that manages file descriptors.
 ;;
 ;; (letfd <bindings> <body>)
 ;;
 ;; Bind all variables given in <bindings> and initialize each of them
 ;; to the given initial value, and close them after evaluting <body>.
 (macro (letfd form)
   (let ((result-sym (gensym)))
     `((lambda (,(caaadr form))
 	(let ((,result-sym
 	       ,(if (= 1 (length (cadr form)))
 		    `(catch (begin (close ,(caaadr form))
 				   (rethrow *error*))
 			    ,@(cddr form))
 		    `(letfd ,(cdadr form) ,@(cddr form)))))
 	  (close ,(caaadr form))
 	  ,result-sym)) ,@(cdaadr form))))
 
 (macro (with-working-directory form)
   (let ((result-sym (gensym)) (cwd-sym (gensym)))
     `(let* ((,cwd-sym (getcwd))
 	    (_ (if ,(cadr form) (chdir ,(cadr form))))
 	    (,result-sym (catch (begin (chdir ,cwd-sym)
 				       (rethrow *error*))
 				,@(cddr form))))
        (chdir ,cwd-sym)
        ,result-sym)))
 
 ;; Make a temporary directory.  If arguments are given, they are
 ;; joined using path-join, and must end in a component ending in
 ;; "XXXXXX".  If no arguments are given, a suitable location and
 ;; generic name is used.
 (define (mkdtemp . components)
   (_mkdtemp (if (null? components)
 		(path-join (getenv "TMP")
 			   (string-append "gpgscm-" (get-isotime) "-"
 					  (basename-suffix *scriptname* ".scm")
 					  "-XXXXXX"))
 		(apply path-join components))))
 
 (macro (with-temporary-working-directory form)
   (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
     `(let* ((,cwd-sym (getcwd))
 	    (,tmp-sym (mkdtemp))
 	    (_ (chdir ,tmp-sym))
 	    (,result-sym (catch (begin (chdir ,cwd-sym)
 				       (unlink-recursively ,tmp-sym)
 				       (rethrow *error*))
 				,@(cdr form))))
        (chdir ,cwd-sym)
        (unlink-recursively ,tmp-sym)
        ,result-sym)))
 
 (define (make-temporary-file . args)
   (canonical-path (path-join
 		   (mkdtemp)
 		   (if (null? args) "a" (car args)))))
 
 (define (remove-temporary-file filename)
   (catch '()
     (unlink filename))
   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
     (catch (echo "removing temporary directory" dirname "failed")
       (rmdir dirname))))
 
 ;; let-like macro that manages temporary files.
 ;;
 ;; (lettmp <bindings> <body>)
 ;;
 ;; Bind all variables given in <bindings>, initialize each of them to
 ;; a string representing an unique path in the filesystem, and delete
 ;; them after evaluting <body>.
 (macro (lettmp form)
   (let ((result-sym (gensym)))
     `((lambda (,(caadr form))
 	(let ((,result-sym
 	       ,(if (= 1 (length (cadr form)))
 		    `(catch (begin (remove-temporary-file ,(caadr form))
 				   (rethrow *error*))
 			    ,@(cddr form))
 		    `(lettmp ,(cdadr form) ,@(cddr form)))))
 	  (remove-temporary-file ,(caadr form))
 	  ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
 
 (define (check-execution source transformer)
   (lettmp (sink)
 	  (transformer source sink)))
 
 (define (check-identity source transformer)
   (lettmp (sink)
 	  (transformer source sink)
 	  (if (not (file=? source sink))
 	      (fail "mismatch"))))
 
 ;;
 ;; Monadic pipe support.
 ;;
 
 (define pipeM
   (package
    (define (new procs source sink producer)
      (package
       (define (dump)
 	(write (list procs source sink producer))
 	(newline))
       (define (add-proc command pid)
 	(new (cons (list command pid) procs) source sink producer))
       (define (commands)
 	(map car procs))
       (define (pids)
 	(map cadr procs))
       (define (set-source source')
 	(new procs source' sink producer))
       (define (set-sink sink')
 	(new procs source sink' producer))
       (define (set-producer producer')
 	(if producer
 	    (throw "producer already set"))
 	(new procs source sink producer'))))))
 
 
 (define (pipe:do . commands)
   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
     (if (null? cmds)
 	(begin
 	  (if M::producer (M::producer))
 	  (if (not (null? M::procs))
 	      (let* ((retcodes (wait-processes (map stringify (M::commands))
 					       (M::pids) #t))
 		     (results (map (lambda (p r) (append p (list r)))
 				   M::procs retcodes))
 		     (failed (filter (lambda (x) (not (= 0 (caddr x))))
 				     results)))
 		(if (not (null? failed))
 		    (throw failed))))) ; xxx nicer reporting
 	(if (and (= 2 (length cmds)) (number? (cadr cmds)))
 	    ;; hack: if it's an fd, use it as sink
 	    (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
 	      (if (> M::source 2) (close M::source))
 	      (if (> (cadr cmds) 2) (close (cadr cmds)))
 	      (loop M' '()))
 	    (let ((M' ((car cmds) M)))
 	      (if (> M::source 2) (close M::source))
 	      (loop M' (cdr cmds)))))))
 
 (define (pipe:open pathname flags)
   (lambda (M)
     (M::set-source (open pathname flags))))
 
 (define (pipe:defer producer)
   (lambda (M)
     (let* ((p (outbound-pipe))
 	   (M' (M::set-source (:read-end p))))
       (M'::set-producer (lambda ()
 			  (producer (:write-end p))
 			  (close (:write-end p)))))))
 (define (pipe:echo data)
  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
 
 (define (pipe:spawn command)
   (lambda (M)
     (define (do-spawn M new-source)
       (let ((pid (spawn-process-fd command M::source M::sink
 				   (if (> (*verbose*) 0)
 				       STDERR_FILENO CLOSED_FD)))
 	    (M' (M::set-source new-source)))
 	(M'::add-proc command pid)))
     (if (= CLOSED_FD M::sink)
 	(let* ((p (pipe))
 	       (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
 	  (close (:write-end p))
 	  (M'::set-sink CLOSED_FD))
 	(do-spawn M CLOSED_FD))))
 
 (define (pipe:splice sink)
   (lambda (M)
     (splice M::source sink)
     (M::set-source CLOSED_FD)))
 
 (define (pipe:write-to pathname flags mode)
   (open pathname flags mode))
 
 ;;
 ;; Monadic transformer support.
 ;;
 
 (define (tr:do . commands)
   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
     (if (null? cmds)
 	(for-each remove-temporary-file tmpfiles)
 	(let* ((v ((car cmds) tmpfiles source))
 	       (tmpfiles' (car v))
 	       (sink (cadr v))
 	       (error (caddr v)))
 	  (if error
 	      (begin
 		(for-each remove-temporary-file tmpfiles')
 		(apply throw error)))
 	  (loop tmpfiles' sink (cdr cmds))))))
 
 (define (tr:open pathname)
   (lambda (tmpfiles source)
     (list tmpfiles pathname #f)))
 
 (define (tr:spawn input command)
   (lambda (tmpfiles source)
     (if (and (member '**in** command) (not source))
 	(fail (string-append (stringify cmd) " needs an input")))
     (let* ((t (make-temporary-file))
 	   (cmd (map (lambda (x)
 		       (cond
 			((equal? '**in** x) source)
 			((equal? '**out** x) t)
 			(else x))) command)))
       (catch (list (cons t tmpfiles) t *error*)
 	     (call-popen cmd input)
 	     (if (and (member '**out** command) (not (file-exists? t)))
 		 (fail (string-append (stringify cmd)
 				       " did not produce '" t "'.")))
 	     (list (cons t tmpfiles) t #f)))))
 
 (define (tr:write-to pathname)
   (lambda (tmpfiles source)
     (rename source pathname)
     (list tmpfiles pathname #f)))
 
 (define (tr:pipe-do . commands)
   (lambda (tmpfiles source)
     (let ((t (make-temporary-file)))
       (apply pipe:do
         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
 	  ,@commands
 	  ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
       (list (cons t tmpfiles) t #f))))
 
 (define (tr:assert-identity reference)
   (lambda (tmpfiles source)
     (if (not (file=? source reference))
 	(fail "mismatch"))
     (list tmpfiles source #f)))
 
 (define (tr:assert-weak-identity reference)
   (lambda (tmpfiles source)
     (if (not (text-file=? source reference))
 	(fail "mismatch"))
     (list tmpfiles source #f)))
 
 (define (tr:call-with-content function . args)
   (lambda (tmpfiles source)
     (catch (list tmpfiles source *error*)
 	   (apply function `(,(call-with-input-file source read-all) ,@args)))
     (list tmpfiles source #f)))
 
 ;;
 ;; Developing and debugging tests.
 ;;
 
 ;; Spawn an os shell.
 (define (interactive-shell)
   (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))