Merge branch 'master' into core-updates

Conflicts:
	gnu/packages/libwebsockets.scm

13 files changed, 404 insertions, 171 deletions

diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index 4b0a922bb0..4f6eaf78f2 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -66,7 +66,11 @@
     (long-description . ,(package-description package))
     (license . ,(package-license package))
     (home-page . ,(package-home-page package))
-    (maintainers . ("bug-guix@gnu.org"))))
+    (maintainers . ("bug-guix@gnu.org"))
+
+    ;; Work around versions of 'hydra-eval-guile-jobs' before Hydra commit
+    ;; 61448ca (27 Feb. 2014) which used a default timeout of 2h.
+    (timeout . 72000)))
 
 (define (package-job store job-name package system)
   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
diff --git a/gnu-system.am b/gnu-system.am
index 29103f9360..b5be893854 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -132,7 +132,6 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/libunistring.scm			\
   gnu/packages/libusb.scm			\
   gnu/packages/libunwind.scm			\
-  gnu/packages/libwebsockets.scm		\
   gnu/packages/lightning.scm			\
   gnu/packages/linux.scm			\
   gnu/packages/lout.scm				\
@@ -146,6 +145,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/maths.scm			\
   gnu/packages/mit-krb5.scm			\
   gnu/packages/moe.scm				\
+  gnu/packages/mpd.scm				\
   gnu/packages/mp3.scm				\
   gnu/packages/multiprecision.scm		\
   gnu/packages/mtools.scm			\
@@ -206,6 +206,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/tor.scm				\
   gnu/packages/uucp.scm				\
   gnu/packages/unrtf.scm			\
+  gnu/packages/upnp.scm				\
   gnu/packages/valgrind.scm			\
   gnu/packages/version-control.scm		\
   gnu/packages/video.scm			\
diff --git a/gnu/packages/gnunet.scm b/gnu/packages/gnunet.scm
index 7f7a6fd6f9..3b111fd27c 100644
--- a/gnu/packages/gnunet.scm
+++ b/gnu/packages/gnunet.scm
@@ -105,14 +105,14 @@ tool to extract metadata from a file and print the results.")
 (define-public libmicrohttpd
   (package
    (name "libmicrohttpd")
-   (version "0.9.32")
+   (version "0.9.34")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/libmicrohttpd/libmicrohttpd-"
                                 version ".tar.gz"))
             (sha256
              (base32
-              "176qf3xhpq1wa3fd9h8b6996bjf83yna1b30lhb6ccrv67hvhm75"))))
+              "122snbhhn10s8az46f0lrkirhj0k38lq7hmqav3n1prdzpabz8i9"))))
    (build-system gnu-build-system)
    (inputs
     `(("curl" ,curl)
diff --git a/gnu/packages/libwebsockets.scm b/gnu/packages/libwebsockets.scm
deleted file mode 100644
index 65aa174355..0000000000
--- a/gnu/packages/libwebsockets.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix 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.
-;;;
-;;; GNU Guix is distributed in the hope that 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu packages libwebsockets)
-  #:use-module (guix packages)
-  #:use-module (guix git-download)
-  #:use-module (guix build-system gnu)
-  #:use-module ((guix licenses)
-                #:select (lgpl2.1))
-  #:use-module (gnu packages autotools)
-  #:use-module ((gnu packages compression) #:select (zlib))
-  #:use-module (gnu packages perl)
-  #:use-module (gnu packages openssl))
-
-(define-public libwebsockets
-  (package
-    (name "libwebsockets")
-    (version "1.2")
-    (source (origin
-              ;; The project does not publish tarballs, so we have to take
-              ;; things from Git.
-              (method git-fetch)
-              (uri (git-reference
-                    (url "git://git.libwebsockets.org/libwebsockets")
-                    (commit (string-append "v" version
-                                           "-chrome26-firefox18"))))
-              (sha256
-               (base32
-                "1293hbz8qj4p27m1qjf8dn97r10xjyiwdpq491m87zi025s558cl"))
-              (file-name (string-append name "-" version))))
-
-    ;; The package has both CMake and GNU build systems, but the latter is
-    ;; apparently better supported (CMake-generated makefiles lack an
-    ;; 'install' target, for instance.)
-    (build-system gnu-build-system)
-
-    (arguments
-     '(#:phases (alist-cons-before
-                 'configure 'bootstrap
-                 (lambda _
-                   (chmod "libwebsockets-api-doc.html" #o666)
-                   (zero? (system* "./autogen.sh")))
-                 %standard-phases)))
-    (native-inputs `(("autoconf" ,autoconf)
-                     ("automake" ,automake)
-                     ("libtool" ,libtool "bin")
-                     ("perl" ,perl)))             ; to build the HTML doc
-    (inputs `(("zlib" ,zlib)
-              ("openssl" ,openssl)))
-    (synopsis "WebSockets library written in C")
-    (description
-     "libwebsockets is a library that allows C programs to establish client
-and server WebSockets connections---a protocol layered above HTTP that allows
-for efficient socket-like bidirectional reliable communication channels.")
-    (home-page "http://libwebsockets.org/")
-
-    ;; This is LGPLv2.1-only with extra exceptions specified in 'LICENSE'.
-    (license lgpl2.1)))
diff --git a/gnu/packages/mpd.scm b/gnu/packages/mpd.scm
new file mode 100644
index 0000000000..b2c5dec15b
--- /dev/null
+++ b/gnu/packages/mpd.scm
@@ -0,0 +1,123 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix is distributed in the hope that 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages mpd)
+  #:use-module (srfi srfi-1)
+  #:use-module (gnu packages)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (gnu packages avahi)
+  #:use-module (gnu packages compression)
+  #:use-module (gnu packages curl)
+  #:use-module (gnu packages glib)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages mp3)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (gnu packages pulseaudio)
+  #:use-module (gnu packages sqlite)
+  #:use-module (gnu packages video)
+  #:use-module (gnu packages xiph)
+  #:export (libmpdclient
+            mpd))
+
+(define libmpdclient
+  (package
+    (name "libmpdclient")
+    (version "2.9")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append "http://musicpd.org/download/libmpdclient/"
+                              (car (string-split version #\.))
+                              "/libmpdclient-" version ".tar.gz"))
+              (sha256
+               (base32
+                "0csb9r3nlmbwpiryixjr5k33x3zqd61xjhwmlps3a6prck1n1xw2"))))
+    (build-system gnu-build-system)
+    (arguments
+     ;; FIXME: Needs doxygen.
+     '(#:configure-flags '("--disable-documentation")))
+    (synopsis "Music Player Daemon client library")
+    (description "A stable, documented, asynchronous API library for
+interfacing MPD in the C, C++ & Objective C languages.")
+    (home-page "http://www.musicpd.org/libs/libmpdclient/")
+    (license license:bsd-3)))
+
+(define mpd
+  (package
+    (name "mpd")
+    (version "0.18.8")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append "http://musicpd.org/download/mpd/"
+                              (string-join (take (string-split
+                                                  version #\.) 2) ".")
+                              "/mpd-" version ".tar.gz"))
+              (sha256
+               (base32
+                "1ryqh0xf76xv4mpwy1gjwy275ar4wmbzifa9ccjim9r7lk2hgp5v"))))
+    (build-system gnu-build-system)
+    (inputs `(("ao" ,ao)
+              ("alsa-lib" ,alsa-lib)
+              ("avahi" ,avahi)
+              ("curl" ,curl)
+              ("ffmpeg" ,ffmpeg)
+              ("flac" ,flac)
+              ("glib" ,glib)
+              ("lame" ,lame)
+              ("libid3tag" ,libid3tag)
+              ("libmad" ,libmad)
+              ("libmpdclient" ,libmpdclient)
+              ("libsamplerate" ,libsamplerate)
+              ("libsndfile" ,libsndfile)
+              ("libvorbis" ,libvorbis)
+              ("opus" ,opus)
+              ("pkg-config" ,pkg-config)
+              ("pulseaudio" ,pulseaudio)
+              ("sqlite" ,sqlite)
+              ("zlib" ,zlib)))
+    ;; Missing optional inputs:
+    ;;   libyajl
+    ;;   libcdio_paranoia
+    ;;   libmms
+    ;;   libadplug
+    ;;   libaudiofile
+    ;;   faad2
+    ;;   fluidsynth
+    ;;   libgme
+    ;;   libshout
+    ;;   libmpg123
+    ;;   libmodplug
+    ;;   libmpcdec
+    ;;   libsidplay2
+    ;;   libwavpack
+    ;;   libwildmidi
+    ;;   libtwolame
+    ;;   libroar
+    ;;   libjack
+    ;;   OpenAL
+    (synopsis "Music Player Daemon")
+    (description "Music Player Daemon (MPD) is a flexible, powerful,
+server-side application for playing music.  Through plugins and libraries it
+can play a variety of sound files while being controlled by its network
+protocol.")
+    (home-page "http://www.musicpd.org/")
+    (license license:gpl2)))
diff --git a/gnu/packages/parallel.scm b/gnu/packages/parallel.scm
index 684ef1821e..175b066113 100644
--- a/gnu/packages/parallel.scm
+++ b/gnu/packages/parallel.scm
@@ -27,7 +27,7 @@
 (define-public parallel
   (package
     (name "parallel")
-    (version "20140122")
+    (version "20140222")
     (source
      (origin
       (method url-fetch)
@@ -35,7 +35,7 @@
                           version ".tar.bz2"))
       (sha256
        (base32
-        "17y72p7qwr7n0qy9nzxwhcn3q47829fd0d69gql2x6szlsxkk0xi"))))
+        "0zb3hg92br6a53jn0pzfl16ffc1hfw81jk7nzw5spkshsdrcqx3y"))))
     (build-system gnu-build-system)
     (inputs `(("perl" ,perl)))
     (home-page "http://www.gnu.org/software/parallel/")
diff --git a/gnu/packages/upnp.scm b/gnu/packages/upnp.scm
new file mode 100644
index 0000000000..a1a18d272c
--- /dev/null
+++ b/gnu/packages/upnp.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix is distributed in the hope that 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages upnp)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages python)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix download)
+  #:use-module (guix licenses)
+  #:use-module (guix packages))
+
+(define-public miniupnpc
+  (package
+    (name "miniupnpc")
+    (version "1.9")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "http://miniupnp.tuxfamily.org/files/miniupnpc-"
+             version ".tar.gz"))
+       (sha256
+        (base32 "0r24jdqcyf839n30ppimdna0hvybscyziaad7ng99fw0x19y88r9"))))
+    (build-system gnu-build-system)
+    (native-inputs
+     `(("python" ,python-2)))
+    (arguments
+     ;; The build system does not use a configure script but depends on
+     ;; `make'.  Hence we should pass parameters to `make' instead and remove
+     ;; the configure phase.
+     '(#:make-flags
+       (list
+        (string-append
+         "SH=" (assoc-ref %build-inputs "bash") "/bin/sh")
+        (string-append "INSTALLPREFIX=" (assoc-ref %outputs "out"))
+        "CC=gcc")
+       #:phases
+       (alist-delete 'configure %standard-phases)))
+    (home-page "http://miniupnp.free.fr/")
+    (synopsis "Library implementing the client side UPnP protocol")
+    (description
+     "MiniUPnPc is a library is useful whenever an application needs to listen
+for incoming connections but is run behind a UPnP enabled router or firewall.
+Examples for such applications include: P2P applications, FTP clients for
+active mode, IRC (for DCC) or IM applications, network games, any server
+software.")
+    (license
+     (x11-style "file://LICENSE" "See 'LICENSE' file in the distribution"))))
diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm
index 369f29f7ac..ab5033eb73 100644
--- a/gnu/packages/video.scm
+++ b/gnu/packages/video.scm
@@ -35,14 +35,14 @@
 (define-public ffmpeg
   (package
     (name "ffmpeg")
-    (version "2.1.3")
+    (version "2.1.4")
     (source (origin
              (method url-fetch)
              (uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-"
                                  version ".tar.bz2"))
              (sha256
               (base32
-               "18qkdpka94rp44x17q7d2bvmw26spxf41c69nvzy31szsdzjwcqx"))))
+               "00c1k84amgkc7vk5xkrg7z99q7jbfhbz3qk854cxnc38d2ynrd3z"))))
     (build-system gnu-build-system)
     (inputs
      `(("fontconfig" ,fontconfig)
diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm
index 350781b74b..4eb39069db 100644
--- a/gnu/packages/web.scm
+++ b/gnu/packages/web.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Aljosha Papsch <misc@rpapsch.de>
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,9 +23,12 @@
                 #:renamer (symbol-prefix-proc 'l:))
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix git-download)
   #:use-module (guix build-system perl)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages apr)
+  #:use-module (gnu packages autotools)
+  #:use-module ((gnu packages compression) #:select (zlib))
   #:use-module (gnu packages openssl)
   #:use-module (gnu packages pcre)
   #:use-module (gnu packages perl))
@@ -66,6 +70,52 @@ related documentation.")
     (license l:asl2.0)
     (home-page "https://httpd.apache.org/")))
 
+(define-public libwebsockets
+  (package
+    (name "libwebsockets")
+    (version "1.2")
+    (source (origin
+              ;; The project does not publish tarballs, so we have to take
+              ;; things from Git.
+              (method git-fetch)
+              (uri (git-reference
+                    (url "git://git.libwebsockets.org/libwebsockets")
+                    (commit (string-append "v" version
+                                           "-chrome26-firefox18"))))
+              (sha256
+               (base32
+                "1293hbz8qj4p27m1qjf8dn97r10xjyiwdpq491m87zi025s558cl"))
+              (file-name (string-append name "-" version))))
+
+    ;; The package has both CMake and GNU build systems, but the latter is
+    ;; apparently better supported (CMake-generated makefiles lack an
+    ;; 'install' target, for instance.)
+    (build-system gnu-build-system)
+
+    (arguments
+     '(#:phases (alist-cons-before
+                 'configure 'bootstrap
+                 (lambda _
+                   (chmod "libwebsockets-api-doc.html" #o666)
+                   (zero? (system* "./autogen.sh")))
+                 %standard-phases)))
+
+    (native-inputs `(("autoconf" ,autoconf)
+                     ("automake" ,automake)
+                     ("libtool" ,libtool "bin")
+                     ("perl" ,perl)))             ; to build the HTML doc
+    (inputs `(("zlib" ,zlib)
+              ("openssl" ,openssl)))
+    (synopsis "WebSockets library written in C")
+    (description
+     "libwebsockets is a library that allows C programs to establish client
+and server WebSockets connections---a protocol layered above HTTP that allows
+for efficient socket-like bidirectional reliable communication channels.")
+    (home-page "http://libwebsockets.org/")
+
+    ;; This is LGPLv2.1-only with extra exceptions specified in 'LICENSE'.
+    (license l:lgpl2.1)))
+
 (define-public perl-html-tagset
   (package
     (name "perl-html-tagset")
diff --git a/gnu/packages/zile.scm b/gnu/packages/zile.scm
index d9c66b4bc6..309344bcd6 100644
--- a/gnu/packages/zile.scm
+++ b/gnu/packages/zile.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,19 +26,20 @@
   #:use-module (gnu packages perl)
   #:use-module (gnu packages help2man)
   #:use-module (gnu packages ncurses)
-  #:use-module (gnu packages bash))
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages pkg-config))
 
 (define-public zile
   (package
     (name "zile")
-    (version "2.4.9")
+    (version "2.4.10")
     (source (origin
              (method url-fetch)
              (uri (string-append "mirror://gnu/zile/zile-"
                                  version ".tar.gz"))
              (sha256
               (base32
-               "0j801c28ypm924rw3lqyb6khxyslg6ycrv16wmmwcam0mk3mj6f7"))))
+               "1ca2bkhl8k4n7a5d8g33ccs603p83a4h3vz9bwxcqxq43jjnwddn"))))
     (build-system gnu-build-system)
     (arguments
      '(#:phases (alist-cons-before
@@ -55,7 +57,8 @@
        ("bash" ,bash)))
     (native-inputs
      `(("perl" ,perl)
-       ("help2man" ,help2man)))
+       ("help2man" ,help2man)
+       ("pkg-config" ,pkg-config)))
     (home-page "http://www.gnu.org/software/zile/")
     (synopsis "Zile is lossy Emacs, a lightweight Emacs clone")
     (description
diff --git a/guix/store.scm b/guix/store.scm
index 8e88c5f86d..54ed31cbbc 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -452,22 +452,22 @@ encoding conversion errors."
     (send (boolean keep-failed?) (boolean keep-going?)
           (boolean fallback?) (integer verbosity)
           (integer max-build-jobs) (integer max-silent-time))
-    (if (>= (nix-server-minor-version server) 2)
-        (send (boolean use-build-hook?)))
-    (if (>= (nix-server-minor-version server) 4)
-        (send (integer build-verbosity) (integer log-type)
-              (boolean print-build-trace)))
-    (if (>= (nix-server-minor-version server) 6)
-        (send (integer build-cores)))
-    (if (>= (nix-server-minor-version server) 10)
-        (send (boolean use-substitutes?)))
-    (if (>= (nix-server-minor-version server) 12)
-        (send (string-list (fold-right (lambda (pair result)
-                                         (match pair
-                                           ((h . t)
-                                            (cons* h t result))))
-                                       '()
-                                       binary-caches))))
+    (when (>= (nix-server-minor-version server) 2)
+      (send (boolean use-build-hook?)))
+    (when (>= (nix-server-minor-version server) 4)
+      (send (integer build-verbosity) (integer log-type)
+            (boolean print-build-trace)))
+    (when (>= (nix-server-minor-version server) 6)
+      (send (integer build-cores)))
+    (when (>= (nix-server-minor-version server) 10)
+      (send (boolean use-substitutes?)))
+    (when (>= (nix-server-minor-version server) 12)
+      (send (string-list (fold-right (lambda (pair result)
+                                       (match pair
+                                         ((h . t)
+                                          (cons* h t result))))
+                                     '()
+                                     binary-caches))))
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))
 
diff --git a/srfi/srfi-64.scm b/srfi/srfi-64.scm
index 03a1c0c1d5..f053443b39 100644
--- a/srfi/srfi-64.scm
+++ b/srfi/srfi-64.scm
@@ -4,7 +4,7 @@
             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-with-cleanup
+            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
@@ -35,5 +35,7 @@
             test-on-final-simple test-on-test-end-simple
             test-on-final-simple))
 
+(cond-expand-provide (current-module) '(srfi-64))
+
 ;; Load Per Bothner's original SRFI-64 implementation.
 (load-from-path "srfi/srfi-64.upstream.scm")
diff --git a/srfi/srfi-64.upstream.scm b/srfi/srfi-64.upstream.scm
index 45a7af3785..d686662bfd 100644
--- a/srfi/srfi-64.upstream.scm
+++ b/srfi/srfi-64.upstream.scm
@@ -1,4 +1,8 @@
-;; Copyright (c) 2005, 2006 Per Bothner
+;; 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
@@ -23,8 +27,14 @@
 (cond-expand
  (chicken
   (require-extension syntax-case))
- (guile
+ (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
@@ -57,7 +67,7 @@
  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-with-cleanup
+ 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
@@ -108,7 +118,7 @@
 		(> (vector-length obj) 1)
 		(eq (vector-ref obj 0) %test-runner-cookie)))
 	 (define (alloc)
-	   (let ((runner (make-vector 22)))
+	   (let ((runner (make-vector 23)))
 	     (vector-set! runner 0 %test-runner-cookie)
 	     runner))
 	 (begin
@@ -156,19 +166,20 @@
 )
 
 (define (test-runner-reset 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 '()))
+  (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)))
@@ -232,7 +243,7 @@
 	 (else #t)))
     r))
 
-(define (%test-specificier-matches spec runner)
+(define (%test-specifier-matches spec runner)
   (spec runner))
 
 (define (test-runner-create)
@@ -243,7 +254,7 @@
     (let loop ((l list))
       (cond ((null? l) result)
 	    (else
-	     (if (%test-specificier-matches (car l) runner)
+	     (if (%test-specifier-matches (car l) runner)
 		 (set! result #t))
 	     (loop (cdr l)))))))
 
@@ -311,12 +322,6 @@
 		   (log-file
 		    (cond-expand (mzscheme
 				  (open-output-file log-file-name 'truncate/replace))
-                                 (guile-2
-                                  (with-fluids ((%default-port-encoding
-                                                 "UTF-8"))
-                                    (let ((p (open-output-file log-file-name)))
-                                      (setvbuf p _IOLBF)
-                                      p)))
 				 (else (open-output-file log-file-name)))))
 	      (display "%%%% Starting test " log-file)
 	      (display suite-name log-file)
@@ -469,7 +474,7 @@
 	  (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-file (%test-write-result1 source-form log))))))
+	  (if source-form (%test-write-result1 source-form log))))))
 
 (define-syntax test-result-ref
   (syntax-rules ()
@@ -570,9 +575,10 @@
       ((%test-evaluate-with-catch test-expression)
        (catch #t
          (lambda () test-expression)
-         (lambda (key . args) #f)
          (lambda (key . args)
-           (display-backtrace (make-stack #t) (current-error-port))))))))
+           (test-result-set! (test-runner-current) 'actual-error
+                             (cons key args))
+           #f))))))
  (kawa
   (define-syntax %test-evaluate-with-catch
     (syntax-rules ()
@@ -609,12 +615,27 @@
    (kawa
     (define (%test-syntax-file form)
       (syntax-source form))))
-  (define-for-syntax (%test-source-line2 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)
     '())))
@@ -645,10 +666,16 @@
 			   (%test-on-test-end r (comp exp res)))))
 		   (%test-report-result)))))
 
-(define (%test-approximimate= error)
+(define (%test-approximate= error)
   (lambda (value expected)
-    (and (>= value (- expected error))
-         (<= value (+ expected error)))))
+    (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 ()
@@ -662,12 +689,12 @@
        (%test-report-result)))))
 
 (cond-expand
- ((or kawa mzscheme)
+ ((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 'quote (%test-source-line2 x))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac suite-name) line)
 	 (syntax
 	  (%test-end suite-name line)))
@@ -676,7 +703,7 @@
 	  (%test-end #f line))))))
   (define-syntax test-assert
     (lambda (x)
-      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac tname expr) line)
 	 (syntax
 	  (let* ((r (test-runner-get))
@@ -688,8 +715,8 @@
 	  (let* ((r (test-runner-get)))
 	    (test-result-alist! r line)
 	    (%test-comp1body r expr)))))))
-  (define-for-syntax (%test-comp2 comp x)
-    (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) ()
+  (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))
@@ -709,18 +736,18 @@
     (lambda (x) (%test-comp2 (syntax equal?) x)))
   (define-syntax test-approximate ;; FIXME - needed for non-Kawa
     (lambda (x)
-      (syntax-case (list x (list 'quote (%test-source-line2 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-approximimate= error) expected expr))))
+	  (%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-approximimate= error) expected expr))))))))
+	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
  (else
   (define-syntax test-end
     (syntax-rules ()
@@ -765,16 +792,30 @@
   (define-syntax test-approximate
     (syntax-rules ()
       ((test-approximate tname expected expr error)
-       (%test-comp2 (%test-approximimate= error) tname expected expr))
+       (%test-comp2 (%test-approximate= error) tname expected expr))
       ((test-approximate expected expr error)
-       (%test-comp2 (%test-approximimate= error) expected expr))))))
+       (%test-comp2 (%test-approximate= error) expected expr))))))
 
 (cond-expand
  (guile
   (define-syntax %test-error
     (syntax-rules ()
       ((%test-error r etype expr)
-       (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t)))))))
+       (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 ()
@@ -791,23 +832,34 @@
  (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)
-       (let ()
-	 (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))))))))
+       (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 ()
@@ -816,15 +868,15 @@
 		   (and (condition? ex) (condition-has-type? ex etype)))
 		  ((procedure? etype)
 		   (etype ex))
-		  ((equal? type #t)
+		  ((equal? etype #t)
 		   #t)
 		  (else #t))
-	      expr))))))
+	      expr #f))))))
  (srfi-34
   (define-syntax %test-error
     (syntax-rules ()
       ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex (else #t)) expr))))))
+       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
  (else
   (define-syntax %test-error
     (syntax-rules ()
@@ -835,11 +887,11 @@
 	 (%test-report-result)))))))
 
 (cond-expand
- ((or kawa mzscheme)
+ ((or kawa mzscheme guile-2)
 
   (define-syntax test-error
     (lambda (x)
-      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac tname etype expr) line)
 	 (syntax
 	  (let* ((r (test-runner-get))
@@ -860,11 +912,17 @@
   (define-syntax test-error
     (syntax-rules ()
       ((test-error name etype expr)
-       (test-assert name (%test-error etype expr)))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r `((test-name . ,name)))
+         (%test-error r etype expr)))
       ((test-error etype expr)
-       (test-assert (%test-error etype expr)))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r etype expr)))
       ((test-error expr)
-       (test-assert (%test-error #t expr)))))))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r #t expr)))))))
 
 (define (test-apply first . rest)
   (if (test-runner? first)
@@ -873,7 +931,7 @@
 	(if r
 	    (let ((run-list (%test-runner-run-list r)))
 	      (cond ((null? rest)
-		     (%test-runner-run-list! r (reverse! run-list))
+		     (%test-runner-run-list! r (reverse run-list))
 		     (first)) ;; actually apply procedure thunk
 		    (else
 		     (%test-runner-run-list!
@@ -973,7 +1031,9 @@
   (let* ((port (open-input-string string))
 	 (form (read port)))
     (if (eof-object? (read-char port))
-	(eval form)
+	(cond-expand
+	 (guile (eval form (current-module)))
+	 (else (eval form)))
 	(cond-expand
 	 (srfi-23 (error "(not at eof)"))
 	 (else "error")))))