* guile-gnome, devel: fix make check
@ 2014-05-13 0:18 David Pirotte
0 siblings, 0 replies; only message in thread
From: David Pirotte @ 2014-05-13 0:18 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 84 bytes --]
Hello,
guile-gnome, devel: fix make check
Patch review solicited.
Thanks,
David
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0004-fix-make-check.patch --]
[-- Type: text/x-patch, Size: 20666 bytes --]
From 06ac149655c1f0aa864b948d009717ea7e75e3bc Mon Sep 17 00:00:00 2001
From: David PIROTTE <david@altosw.be>
Date: Mon, 12 May 2014 20:26:29 -0300
Subject: [PATCH 4/5] fix make check
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* tests.mk:
* glib/test-suite/Makefile.am: TESTS_ENVIRONMENT variable definition
split into TESTS_ENVIRONMENT, SCM_LOG_COMPILER and TEST_EXTENSIONS
has requested by recent automake versions.
* glib/test-suite/gobject.api: Removing unless from the (gnome gobject
utils) module api checks.
* glib/test-suite/guile-gobject-test: Use ${builddir:-.}, not
${srcdir:-.}.
* glib/test-suite/lib.scm: Copied from guile's latest stable
test-suite/test-suite/lib.scm file, as suggested by Ludovic Courtés
on irc, thanks for your help Ludovic!
---
glib/test-suite/Makefile.am | 7 +-
glib/test-suite/gobject.api | 1 -
glib/test-suite/guile-gobject-test | 2 +-
glib/test-suite/lib.scm | 334 ++++++++++++++++++++++++++++---------
tests.mk | 4 +-
5 files changed, 269 insertions(+), 79 deletions(-)
diff --git a/glib/test-suite/Makefile.am b/glib/test-suite/Makefile.am
index 651e14c..1ea349e 100644
--- a/glib/test-suite/Makefile.am
+++ b/glib/test-suite/Makefile.am
@@ -36,6 +36,9 @@ top_module_name = (gnome $(wrapset_stem))
gw_module_name = (gnome gw $(wrapset_stem))
extra_module_names =
wrapset_modules = ($(top_module_name) $(gw_module_name) $(extra_module_names))
+DEV_ENV = $(top_builddir)/dev-environ
+GUILE=guile
+
TESTS_ENVIRONMENT=\
API_FILE=$(srcdir)/gobject.api \
DOC_SCM=$(srcdir)/../doc/gobject/guile-gnome-gobject.scm \
@@ -43,7 +46,9 @@ TESTS_ENVIRONMENT=\
WRAPSET_API_FILE=$(srcdir)/wrapset.api \
LTDL_LIBRARY_PATH=.:${LTDL_LIBRARY_PATH} \
GUILE_LOAD_PATH=".:${srcdir:-.}/..:..:${GUILE_LOAD_PATH}" \
- $(top_builddir)/dev-environ guile --debug -e main -s
+ $(DEV_ENV)
+SCM_LOG_COMPILER = $(GUILE) $(GUILE_FLAGS) -e main -s
+TEST_EXTENSIONS = .scm
script := '(load (getenv "DOC_SCM"))\
(for-each \
diff --git a/glib/test-suite/gobject.api b/glib/test-suite/gobject.api
index 71a08a6..6eefc5e 100644
--- a/glib/test-suite/gobject.api
+++ b/glib/test-suite/gobject.api
@@ -190,7 +190,6 @@
(arity 1 0 #f))
(gtype-name->scheme-name-alist <pair>)
(re-export-modules macro)
- (unless macro)
(with-accessors macro)))
((gnome gw generics)
(uses-interfaces (gnome gobject generics))
diff --git a/glib/test-suite/guile-gobject-test b/glib/test-suite/guile-gobject-test
index c0c2a9e..0172204 100755
--- a/glib/test-suite/guile-gobject-test
+++ b/glib/test-suite/guile-gobject-test
@@ -1,5 +1,5 @@
#!/bin/sh
-exec ${srcdir:-.}/guile-test-env guile --debug -e main -s "$0" "$@"
+exec ${builddir:-.}/guile-test-env guile --debug -e main -s "$0" "$@"
!#
;;;; guile-gobject-test --- run the guile-gobject test suite
;;;;
diff --git a/glib/test-suite/lib.scm b/glib/test-suite/lib.scm
index 46da7e1..e25df78 100644
--- a/glib/test-suite/lib.scm
+++ b/glib/test-suite/lib.scm
@@ -1,41 +1,68 @@
;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
+;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
-;;;; This program 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 2, or (at your option)
-;;;; any later version.
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3, or (at your option) any later version.
;;;;
;;;; This program 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.
+;;;; GNU Lesser General Public License for more details.
;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this software; see the file COPYING.LESSER.
+;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
+;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite lib)
- :use-module (ice-9 stack-catch)
- :use-module (ice-9 regex)
- :export (
+ #:use-module (ice-9 stack-catch)
+ #:use-module (ice-9 regex)
+ #:autoload (srfi srfi-1) (append-map)
+ #:autoload (system base compile) (compile)
+ #:export (
;; Exceptions which are commonly being tested for.
+ exception:syntax-pattern-unmatched
exception:bad-variable
exception:missing-expression
exception:out-of-range exception:unbound-var
+ exception:used-before-defined
exception:wrong-num-args exception:wrong-type-arg
+ exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:system-error
+ exception:encoding-error
+ exception:miscellaneous-error
+ exception:string-contains-nul
+ exception:read-error
+ exception:null-pointer-error
+ exception:vm-error
;; Reporting passes and failures.
run-test
pass-if expect-fail
+ pass-if-equal
pass-if-exception expect-fail-exception
;; Naming groups of tests in a regular fashion.
- with-test-prefix with-test-prefix* current-test-prefix
+ with-test-prefix
+ with-test-prefix*
+ with-test-prefix/c&e
+ current-test-prefix
format-test-name
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
+
+ ;; Clearing stale references on the C stack for GC-sensitive tests.
+ clear-stale-stack-references
+
+ ;; Using a given locale
+ with-locale with-locale* with-latin1-locale with-latin1-locale*
+
;; Reporting results in various ways.
register-reporter unregister-reporter reporter-registered?
make-count-reporter print-counts
@@ -96,7 +123,7 @@
;;;;
;;;; * (pass-if-exception name exception body) will pass if the execution of
;;;; body causes the given exception to be thrown. If no exception is
-;;;; thrown, the test fails. If some other exception is thrown, is is an
+;;;; thrown, the test fails. If some other exception is thrown, it is an
;;;; error.
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
;;;; the execution of body causes the given exception to be thrown. If no
@@ -155,7 +182,7 @@
;;;; ("basic arithmetic" "subtraction"), and
;;;; ("multiplication").
;;;;
-;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
+;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends
;;;; a new element to the current prefix:
;;;;
;;;; (with-test-prefix "arithmetic"
@@ -234,18 +261,43 @@
;;;;
;;; Define some exceptions which are commonly being tested for.
+(define exception:syntax-pattern-unmatched
+ (cons 'syntax-error "source expression failed to match any pattern"))
(define exception:bad-variable
(cons 'syntax-error "Bad variable"))
(define exception:missing-expression
(cons 'misc-error "^missing or extra expression"))
(define exception:out-of-range
- (cons 'out-of-range "^Argument .*out of range"))
+ (cons 'out-of-range "^.*out of range"))
(define exception:unbound-var
(cons 'unbound-variable "^Unbound variable"))
+(define exception:used-before-defined
+ (cons 'unbound-variable "^Variable used before given a value"))
(define exception:wrong-num-args
(cons 'wrong-number-of-args "^Wrong number of arguments"))
(define exception:wrong-type-arg
- (cons 'wrong-type-arg "^Wrong type argument"))
+ (cons 'wrong-type-arg "^Wrong type"))
+(define exception:numerical-overflow
+ (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+ (cons 'misc-error "^set! denied for field"))
+(define exception:system-error
+ (cons 'system-error ".*"))
+(define exception:encoding-error
+ (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)"))
+(define exception:miscellaneous-error
+ (cons 'misc-error "^.*"))
+(define exception:read-error
+ (cons 'read-error "^.*$"))
+(define exception:null-pointer-error
+ (cons 'null-pointer-error "^.*$"))
+(define exception:vm-error
+ (cons 'vm-error "^.*$"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception:string-contains-nul
+ (cons 'misc-error "^string contains #\\\\nul character"))
+
;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs)
@@ -263,50 +315,71 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-test #f)
-(let ((test-running #f))
- (define (local-run-test name expect-pass thunk)
- (if test-running
- (error "Nested calls to run-test are not permitted.")
- (let ((test-name (full-name name)))
- (set! test-running #t)
- (catch #t
- (lambda ()
- (let ((result (thunk)))
- (if (eq? result #t) (throw 'pass))
- (if (eq? result #f) (throw 'fail))
- (throw 'unresolved)))
- (lambda (key . args)
- (case key
- ((pass)
- (report (if expect-pass 'pass 'upass) test-name))
- ((fail)
- (report (if expect-pass 'fail 'xfail) test-name))
- ((unresolved untested unsupported)
- (report key test-name))
- ((quit)
- (report 'unresolved test-name)
- (quit))
- (else
- (report 'error test-name (cons key args))))))
- (set! test-running #f))))
- (set! run-test local-run-test))
+(define run-test
+ (let ((test-running #f))
+ (lambda (name expect-pass thunk)
+ (if test-running
+ (error "Nested calls to run-test are not permitted."))
+ (let ((test-name (full-name name)))
+ (set! test-running #t)
+ (catch #t
+ (lambda ()
+ (let ((result (thunk)))
+ (if (eq? result #t) (throw 'pass))
+ (if (eq? result #f) (throw 'fail))
+ (throw 'unresolved)))
+ (lambda (key . args)
+ (case key
+ ((pass)
+ (report (if expect-pass 'pass 'upass) test-name))
+ ((fail)
+ ;; ARGS may contain extra info about the failure,
+ ;; such as the expected and actual value.
+ (apply report (if expect-pass 'fail 'xfail)
+ test-name
+ args))
+ ((unresolved untested unsupported)
+ (report key test-name))
+ ((quit)
+ (report 'unresolved test-name)
+ (quit))
+ (else
+ (report 'error test-name (cons key args))))))
+ (set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
-(defmacro pass-if (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (pass-if (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #t (lambda () ,name))
- `(run-test ,name #t (lambda () ,@rest))))
+(define-syntax pass-if
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (pass-if (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #t (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #t (lambda () rest ...)))))
+
+(define-syntax pass-if-equal
+ (syntax-rules ()
+ "Succeed if and only if BODY's return value is equal? to EXPECTED."
+ ((_ expected body)
+ (pass-if-equal 'body expected body))
+ ((_ name expected body ...)
+ (run-test name #t
+ (lambda ()
+ (let ((result (begin body ...)))
+ (or (equal? expected result)
+ (throw 'fail
+ 'expected-value expected
+ 'actual-value result))))))))
;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (expect-fail (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #f (lambda () ,name))
- `(run-test ,name #f (lambda () ,@rest))))
+(define-syntax expect-fail
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #f (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@@ -338,12 +411,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
-(defmacro pass-if-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+(define-syntax pass-if-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
-(defmacro expect-fail-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+(define-syntax expect-fail-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #f (lambda () body rest ...)))))
\f
;;;; TEST NAMES
@@ -351,23 +428,25 @@
;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": ")))))))
+ ;; Choose a Unicode-capable encoding so that the string port can contain any
+ ;; valid Unicode character.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": "))))))))
;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
(append (current-test-prefix) (list name)))
;;; A fluid containing the current test prefix, as a list.
-(define prefix-fluid (make-fluid))
-(fluid-set! prefix-fluid '())
+(define prefix-fluid (make-fluid '()))
(define (current-test-prefix)
(fluid-ref prefix-fluid))
@@ -384,8 +463,113 @@
;;; The name prefix is only changed within the dynamic scope of the
;;; with-test-prefix expression. Return the value returned by the last
;;; BODY expression.
-(defmacro with-test-prefix (prefix . body)
- `(with-test-prefix* ,prefix (lambda () ,@body)))
+(define-syntax with-test-prefix
+ (syntax-rules ()
+ ((_ prefix body ...)
+ (with-test-prefix* prefix (lambda () body ...)))))
+
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-equal pass-if-exception)
+ "Run the given tests both with the evaluator and the compiler/VM."
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-equal test-name val exp))
+ (begin (pass-if-equal (string-append test-name " (eval)") val
+ (primitive-eval 'exp))
+ (pass-if-equal (string-append test-name " (compile)") val
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
+
+;;; (with-test-prefix/c&e PREFIX BODY ...)
+;;; Same as `with-test-prefix', but the enclosed tests are run both with
+;;; the compiler/VM and the evaluator.
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
+
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+ (let ((dopts #f))
+ (dynamic-wind
+ (lambda ()
+ (set! dopts (debug-options)))
+ thunk
+ (lambda ()
+ (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+ `(with-debugging-evaluator* (lambda () ,@body)))
+
+;; Recurse through a C function that should clear any values that might
+;; have spilled on the stack temporarily. (The salient feature of
+;; with-continuation-barrier is that currently it is implemented as a C
+;; function that recursively calls the VM.)
+;;
+(define* (clear-stale-stack-references #:optional (n 10))
+ (if (positive? n)
+ (with-continuation-barrier
+ (lambda ()
+ (clear-stale-stack-references (1- n))))))
+
+;;; Call THUNK with a given locale
+(define (with-locale* nloc thunk)
+ (let ((loc #f))
+ (dynamic-wind
+ (lambda ()
+ (if (defined? 'setlocale)
+ (begin
+ (set! loc (false-if-exception (setlocale LC_ALL)))
+ (if (or (not loc)
+ (not (false-if-exception (setlocale LC_ALL nloc))))
+ (throw 'unresolved)))
+ (throw 'unresolved)))
+ thunk
+ (lambda ()
+ (if (and (defined? 'setlocale) loc)
+ (setlocale LC_ALL loc))))))
+
+;;; Evaluate BODY... using the given locale.
+(define-syntax with-locale
+ (syntax-rules ()
+ ((_ loc body ...)
+ (with-locale* loc (lambda () body ...)))))
+
+;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
+;;; (if any).
+(define (with-latin1-locale* thunk)
+ (define %locales
+ (append-map (lambda (name)
+ (list (string-append name ".ISO-8859-1")
+ (string-append name ".iso88591")
+ (string-append name ".ISO8859-1")))
+ '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
+ "fr_FR" "pt_PT" "nl_NL" "sv_SE")))
+
+ (let loop ((locales %locales))
+ (if (null? locales)
+ (throw 'unresolved)
+ (catch 'unresolved
+ (lambda ()
+ (with-locale* (car locales) thunk))
+ (lambda (key . args)
+ (loop (cdr locales)))))))
+
+;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
+;;; was found.
+(define-syntax with-latin1-locale
+ (syntax-rules ()
+ ((_ body ...)
+ (with-latin1-locale* (lambda () body ...)))))
\f
;;;; REPORTERS
diff --git a/tests.mk b/tests.mk
index 229f65b..017ca8c 100644
--- a/tests.mk
+++ b/tests.mk
@@ -34,7 +34,9 @@ WRAPSET_TESTS_ENV = WRAPSET_MODULES="$(wrapset_modules)" WRAPSET_API_FILE=$(srcd
DEV_ENV = $(top_builddir)/dev-environ
GUILE = guile
-TESTS_ENVIRONMENT=$(WRAPSET_TESTS_ENV) $(DEV_ENV) $(GUILE) $(GUILE_FLAGS) -e main -s
+TESTS_ENVIRONMENT=$(WRAPSET_TESTS_ENV) $(DEV_ENV)
+SCM_LOG_COMPILER = $(GUILE) $(GUILE_FLAGS) -e main -s
+TEST_EXTENSIONS = .scm
wrapset.api.update:
$(WRAPSET_TESTS_ENV) $(DEV_ENV) $(GUILE) -e update-api -s $(srcdir)/wrapset.scm
--
2.0.0.rc0
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2014-05-13 0:18 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-05-13 0:18 guile-gnome, devel: fix make check David Pirotte
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).