M build-aux/hydra/gnu-system.scm => build-aux/hydra/gnu-system.scm +5 -1
@@ 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."
M gnu-system.am => gnu-system.am +2 -1
@@ 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 \
M gnu/packages/gnunet.scm => gnu/packages/gnunet.scm +2 -2
@@ 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)
D gnu/packages/libwebsockets.scm => gnu/packages/libwebsockets.scm +0 -73
@@ 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)))
A gnu/packages/mpd.scm => gnu/packages/mpd.scm +123 -0
@@ 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)))
M gnu/packages/parallel.scm => gnu/packages/parallel.scm +2 -2
@@ 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/")
A gnu/packages/upnp.scm => gnu/packages/upnp.scm +63 -0
@@ 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"))))
M gnu/packages/video.scm => gnu/packages/video.scm +2 -2
@@ 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)
M gnu/packages/web.scm => gnu/packages/web.scm +50 -0
@@ 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")
M gnu/packages/zile.scm => gnu/packages/zile.scm +7 -4
@@ 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
M guix/store.scm => guix/store.scm +16 -16
@@ 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)))))
M srfi/srfi-64.scm => srfi/srfi-64.scm +3 -1
@@ 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")
M srfi/srfi-64.upstream.scm => srfi/srfi-64.upstream.scm +129 -69
@@ 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")))))