diff options
| -rw-r--r-- | build-aux/hydra/gnu-system.scm | 6 | ||||
| -rw-r--r-- | gnu-system.am | 3 | ||||
| -rw-r--r-- | gnu/packages/gnunet.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/libwebsockets.scm | 73 | ||||
| -rw-r--r-- | gnu/packages/mpd.scm | 123 | ||||
| -rw-r--r-- | gnu/packages/parallel.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/upnp.scm | 63 | ||||
| -rw-r--r-- | gnu/packages/video.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/web.scm | 50 | ||||
| -rw-r--r-- | gnu/packages/zile.scm | 11 | ||||
| -rw-r--r-- | guix/store.scm | 32 | ||||
| -rw-r--r-- | srfi/srfi-64.scm | 4 | ||||
| -rw-r--r-- | srfi/srfi-64.upstream.scm | 198 |
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"))))) |