me/guix
Archived
1
0
Fork 0
Code Activity

Merge branch 'master' into core-updates

Browse source 
Conflicts:
	gnu/packages/libwebsockets.scm
This commit is contained in:
Ludovic Courtès 2014-02-27 23:49:30 +01:00
commit 829ecd002e
13 changed files with 404 additions and 171 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
build-aux/hydra/gnu-system.scm
View file

@ -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."

3
gnu-system.am
View file

@ -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 \

4
gnu/packages/gnunet.scm
View file

@ -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)

73
gnu/packages/libwebsockets.scm
View file

@ -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)))

123
gnu/packages/mpd.scm Normal file
View file

@ -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)))

4
gnu/packages/parallel.scm
View file

@ -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/")

63
gnu/packages/upnp.scm Normal file
View file

@ -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"))))

4
gnu/packages/video.scm
View file

@ -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)

50
gnu/packages/web.scm
View file

@ -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")

11
gnu/packages/zile.scm
View file

@ -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

32
guix/store.scm
View file

@ -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)))))

4
srfi/srfi-64.scm
View file

@ -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")

198
srfi/srfi-64.upstream.scm
View file

@ -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")))))