diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/standalone/Makefile.am | 7 | ||||
-rwxr-xr-x | test-suite/standalone/test-guile-snarf | 18 | ||||
-rw-r--r-- | test-suite/standalone/test-scm-values.c | 69 | ||||
-rw-r--r-- | test-suite/tests/i18n.test | 8 | ||||
-rw-r--r-- | test-suite/tests/statprof.test | 72 |
5 files changed, 144 insertions, 30 deletions
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 08d249c48..d8cfafa25 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -189,6 +189,13 @@ test_scm_to_latin1_string_LDADD = $(LIBGUILE_LDADD) check_PROGRAMS += test-scm-to-latin1-string TESTS += test-scm-to-latin1-string +# test-scm-values +test_scm_values_SOURCES = test-scm-values.c +test_scm_values_CFLAGS = ${test_cflags} +test_scm_values_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-values +TESTS += test-scm-values + if HAVE_SHARED_LIBRARIES # test-extensions diff --git a/test-suite/standalone/test-guile-snarf b/test-suite/standalone/test-guile-snarf index 41a9dc64a..e31479149 100755 --- a/test-suite/standalone/test-guile-snarf +++ b/test-suite/standalone/test-guile-snarf @@ -1,7 +1,23 @@ #!/bin/sh + +# Test the `guile-snarf' tool. + +# Strip the first line, like GNU `tail -n +2' does, but in a portable +# way (`tail' on Solaris 10 doesn't support `-n +2' for instance.) +strip_first_line () +{ + read line + while read line + do + echo "$line" + done +} + snarf () { - echo "$1" | guile-snarf - | tail -n +2 | tr -d ' \t\n' + # GNU cpp emits a comment on the first line, which shows what + # arguments it was passed. Strip this line. + echo "$1" | guile-snarf - | strip_first_line | tr -d ' \t\n' } snarf_test () diff --git a/test-suite/standalone/test-scm-values.c b/test-suite/standalone/test-scm-values.c new file mode 100644 index 000000000..ece62dab6 --- /dev/null +++ b/test-suite/standalone/test-scm-values.c @@ -0,0 +1,69 @@ +/* Copyright (C) 2012 Free Software Foundation, Inc. + * + * This library 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 of + * the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <assert.h> +#include <libguile.h> +#include <stdlib.h> +#include <string.h> + +static void +test_scm_c_value_ref_on_multiple_values () +{ + SCM values = scm_values (scm_list_3 (scm_from_latin1_string ("foo"), + scm_from_latin1_string ("bar"), + scm_from_latin1_string ("baz"))); + + char *foo = scm_to_latin1_string (scm_c_value_ref (values, 0)); + char *bar = scm_to_latin1_string (scm_c_value_ref (values, 1)); + char *baz = scm_to_latin1_string (scm_c_value_ref (values, 2)); + + assert (strcmp (foo, "foo") == 0); + assert (strcmp (bar, "bar") == 0); + assert (strcmp (baz, "baz") == 0); + + free (foo); + free (bar); + free (baz); +} + +static void +test_scm_c_value_ref_on_a_single_value () +{ + SCM value = scm_from_latin1_string ("foo"); + char *foo = scm_to_latin1_string (scm_c_value_ref (value, 0)); + assert (strcmp (foo, "foo") == 0); + free (foo); +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_value_ref_on_multiple_values (); + test_scm_c_value_ref_on_a_single_value (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 05670516d..da2308058 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -138,9 +138,11 @@ (under-locale-or-unresolved %french-utf8-locale thunk)) (define (under-turkish-utf8-locale-or-unresolved thunk) - ;; FreeBSD 8.2 has a broken tr_TR locale where `i' is mapped to - ;; uppercase `I' instead of `İ', so disable tests on that platform. - (if (string-contains %host-type "freebsd8") + ;; FreeBSD 8.2 and Solaris 2.10 have a broken tr_TR locale where `i' + ;; is mapped to uppercase `I' instead of `İ', so disable tests on that + ;; platform. + (if (or (string-contains %host-type "freebsd8") + (string-contains %host-type "solaris2.10")) (throw 'unresolved) (under-locale-or-unresolved %turkish-utf8-locale thunk))) diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index b2ee41e1b..1fec61765 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -31,8 +31,22 @@ #:use-module (srfi srfi-1) #:use-module (statprof)) +;; Throw `unresolved' upon ENOSYS. This is used to skip tests on +;; platforms such as GNU/Hurd where `ITIMER_PROF' is is currently +;; unimplemented. +(define-syntax-rule (when-implemented body ...) + (catch 'system-error + (lambda () + body ...) + (lambda args + (let ((errno (system-error-errno args))) + (false-if-exception (statprof-stop)) + (if (= errno ENOSYS) + (throw 'unresolved) + (apply throw args)))))) + (pass-if "statistical sample counts within expected range" - (let () + (when-implemented ;; test to see that if we call 3 identical functions equally, they ;; show up equally in the call count, +/- 30%. it's a big range, and ;; I tried to do something more statistically valid, but failed (for @@ -43,18 +57,18 @@ ;; Disable partial evaluation so that `(+ i i)' doesn't get ;; stripped. (compile '(lambda (n) - (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i))) - #:opts '(#:partial-eval? #f))) + (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i))) + #:opts '(#:partial-eval? #f))) (define run-test (compile '(lambda (num-calls funcs) - (let loop ((x num-calls) (funcs funcs)) - (cond - ((positive? x) - ((car funcs) x) - (loop (- x 1) (cdr funcs)))))))) - + (let loop ((x num-calls) (funcs funcs)) + (cond + ((positive? x) + ((car funcs) x) + (loop (- x 1) (cdr funcs)))))))) + (let ((num-calls 80000) - (funcs (circular-list (make-func) (make-func) (make-func)))) + (funcs (circular-list (make-func) (make-func) (make-func)))) ;; Run test. 20000 us == 200 Hz. (statprof-reset 0 20000 #f #f) @@ -62,25 +76,31 @@ (run-test num-calls funcs) (statprof-stop) - (let* ((a-data (statprof-proc-call-data (car funcs))) - (b-data (statprof-proc-call-data (cadr funcs))) - (c-data (statprof-proc-call-data (caddr funcs))) - (samples (map statprof-call-data-cum-samples - (list a-data b-data c-data))) - (average (/ (apply + samples) 3)) - (max-allowed-drift 0.30) ; 30% - (diffs (map (lambda (x) (abs (- x average))) - samples)) - (max-diff (apply max diffs))) + (let ((a-data (statprof-proc-call-data (car funcs))) + (b-data (statprof-proc-call-data (cadr funcs))) + (c-data (statprof-proc-call-data (caddr funcs)))) + (if (and a-data b-data c-data) + (let* ((samples (map statprof-call-data-cum-samples + (list a-data b-data c-data))) + (average (/ (apply + samples) 3)) + (max-allowed-drift 0.30) ; 30% + (diffs (map (lambda (x) (abs (- x average))) + samples)) + (max-diff (apply max diffs))) + + (let ((drift-fraction (/ max-diff average))) + (or (< drift-fraction max-allowed-drift) + ;; don't stop the test suite for what statistically is + ;; bound to happen. + (throw 'unresolved (pk average drift-fraction))))) - (let ((drift-fraction (/ max-diff average))) - (or (< drift-fraction max-allowed-drift) - ;; don't stop the test suite for what statistically is - ;; bound to happen. - (throw 'unresolved (pk average drift-fraction)))))))) + ;; Samples were not collected for at least one of the + ;; functions, possibly because NUM-CALLS is too low compared + ;; to the CPU speed. + (throw 'unresolved (pk (list a-data b-data c-data)))))))) (pass-if "accurate call counting" - (let () + (when-implemented ;; Test to see that if we call a function N times while the profiler ;; is active, it shows up N times. (let ((num-calls 200)) |