diff options
| author | DongHun Kwak <dh0128.kwak@samsung.com> | 2021-02-09 16:00:21 +0900 |
|---|---|---|
| committer | DongHun Kwak <dh0128.kwak@samsung.com> | 2021-02-09 16:00:21 +0900 |
| commit | d9f0d99e31569835e295b990029c6dd19554299c (patch) | |
| tree | ecdcc994cad9a9b8a35e7ac495bd77eadf87a622 /tests | |
| parent | e28f2fa5b31e90be72c2276f8cea3b22d309d406 (diff) | |
| download | gpg2-d9f0d99e31569835e295b990029c6dd19554299c.tar.gz gpg2-d9f0d99e31569835e295b990029c6dd19554299c.tar.bz2 gpg2-d9f0d99e31569835e295b990029c6dd19554299c.zip | |
Imported Upstream version 2.1.21upstream/2.1.21
Diffstat (limited to 'tests')
114 files changed, 2855 insertions, 1373 deletions
diff --git a/tests/Makefile.am b/tests/Makefile.am index bb75c97..b9be6aa 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -44,7 +44,8 @@ EXTRA_DIST = runtest inittests $(testscripts) ChangeLog-2011 \ samplekeys/32100C27173EF6E9C4E9A25D3D69F86D37A4F939.key \ samplekeys/cert_g10code_pete1.pem \ samplekeys/cert_g10code_test1.pem \ - samplekeys/cert_g10code_theo1.pem + samplekeys/cert_g10code_theo1.pem \ + run-tests.scm # We used to run $(testscripts) here but these asschk scripts are not # completely reliable in all environments and thus we better disable diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am index 0d0edc0..f1c19eb 100644 --- a/tests/gpgme/Makefile.am +++ b/tests/gpgme/Makefile.am @@ -31,9 +31,9 @@ AM_CFLAGS = TESTS_ENVIRONMENT = LC_ALL=C \ EXEEXT=$(EXEEXT) \ PATH=../gpgscm:$(PATH) \ - srcdir=$(abs_srcdir) \ + abs_top_srcdir=$(abs_top_srcdir) \ objdir=$(abs_top_builddir) \ - GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgme + GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm # XXX: Currently, one cannot override automake's 'check' target. As a # workaround, we avoid defining 'TESTS', thus automake will not emit @@ -46,11 +46,11 @@ check: xcheck .PHONY: xcheck xcheck: $(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \ - $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS) + $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS) -EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm +EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm all-tests.scm -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/gpgme/all-tests.scm b/tests/gpgme/all-tests.scm new file mode 100644 index 0000000..f72f8af --- /dev/null +++ b/tests/gpgme/all-tests.scm @@ -0,0 +1,86 @@ +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(export all-tests + ;; Parse GPGME's makefiles to find all tests. + + (load (in-srcdir "tests" "gpgme" "gpgme-defs.scm")) + (load (with-path "makefile.scm")) + + (define (expander filename port key) + ;;(interactive-repl (current-environment)) + (cond + ((string=? key "tests_unix") + (if *win32* + (parse-makefile port key) ;; Use win32 definition. + (begin + (parse-makefile port key) ;; Skip win32 definition. + (parse-makefile port key)))) + (else + (parse-makefile port key)))) + + (define (parse filename key) + (parse-makefile-expand filename expander key)) + + (define setup-c + (make-environment-cache + (test::scm + #f + (path-join "tests" "gpgme" "setup.scm" "tests" "gpg") + (in-srcdir "tests" "gpgme" "setup.scm") + "--" "tests" "gpg"))) + (define setup-py + (make-environment-cache + (test::scm + #f + (path-join "tests" "gpgme" "setup.scm" "lang" "python" "tests") + (in-srcdir "tests" "gpgme" "setup.scm") + "--" "lang" "python" "tests"))) + + (define (compiled? name) + (not (or (string-suffix? name ".py") + (string-suffix? name ".test")))) + (define :path car) + (define :key cadr) + (define :setup caddr) + + (if (have-gpgme?) + (apply append + (map (lambda (cmpnts) + (define (find-test name) + (apply path-join + `(,(if (compiled? name) + gpgme-builddir + gpgme-srcdir) ,@(:path cmpnts) ,(qualify name)))) + (let ((makefile (apply path-join `(,gpgme-srcdir ,@(:path cmpnts) + "Makefile.am")))) + (map (lambda (name) + (apply test::scm + `(,(:setup cmpnts) + ,(apply path-join + `("tests" "gpgme" ,@(:path cmpnts) ,name)) + ,(in-srcdir "tests" "gpgme" "wrap.scm") + --executable + ,(find-test name) + -- ,@(:path cmpnts)))) + (parse makefile (:key cmpnts))))) + `((("tests" "gpg") "c_tests" ,setup-c) + ,@(if (run-python-tests?) + `((("lang" "python" "tests") "py_tests" ,setup-py)) + '()) + (("lang" "qt" "tests") "TESTS" ,setup-c)))) + '())) diff --git a/tests/gpgme/gpgme-defs.scm b/tests/gpgme/gpgme-defs.scm index 486d1a1..e24db25 100644 --- a/tests/gpgme/gpgme-defs.scm +++ b/tests/gpgme/gpgme-defs.scm @@ -17,24 +17,29 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (define gpgme-srcdir (getenv "XTEST_GPGME_SRCDIR")) -(when (string=? "" gpgme-srcdir) - (info - "SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set. Please" - "point it to a recent GPGME source tree to run the GPGME test suite.") - (exit 0)) (define (in-gpgme-srcdir . names) (canonical-path (apply path-join (cons gpgme-srcdir names)))) (define gpgme-builddir (getenv "XTEST_GPGME_BUILDDIR")) -(when (string=? "" gpgme-builddir) + +(define (have-gpgme?) + (cond + ((string=? "" gpgme-srcdir) + (info + "SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set. Please" + "point it to a recent GPGME source tree to run the GPGME test suite.") + #f) + ((string=? "" gpgme-builddir) (info "SKIP: Environment variable 'XTEST_GPGME_BUILDDIR' not set. Please" "point it to a recent GPGME build tree to run the GPGME test suite.") - (exit 0)) + #f) + (else + #t))) ;; Make sure that GPGME picks up our gpgconf. This makes GPGME use ;; and thus executes the tests with GnuPG components from the build @@ -45,11 +50,6 @@ ;; The tests expect the pinentry to return the passphrase "abc". (setenv "PINENTRY_USER_DATA" "abc" #t) -(define (create-file name . lines) - (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (let ((port (fdopen fd "wb"))) - (for-each (lambda (line) (display line port) (newline port)) lines)))) - (define (create-gpgmehome . path) ;; Support for various environments. (define mode @@ -114,71 +114,15 @@ (start-agent)) (apply create-gpgme-gpghome path))) -(define (parse-makefile port key) - (define (is-continuation? tokens) - (string=? (last tokens) "\\")) - (define (valid-token? s) - (< 0 (string-length s))) - (define (drop-continuations tokens) - (let loop ((acc '()) (tks tokens)) - (if (null? tks) - (reverse acc) - (loop (if (string=? "\\" (car tks)) - acc - (cons (car tks) acc)) (cdr tks))))) - (let next ((acc '()) (found #f)) - (let ((line (read-line port))) - (if (eof-object? line) - acc - (let ((tokens (filter valid-token? - (string-splitp (string-trim char-whitespace? - line) - char-whitespace? -1)))) - (cond - ((or (null? tokens) - (string-prefix? (car tokens) "#") - (and (not found) (not (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))))) - (next acc found)) - ((not found) - (assert (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))) - (if (is-continuation? tokens) - (next (drop-continuations (cddr tokens)) #t) - (drop-continuations (cddr tokens)))) - (else - (assert found) - (if (is-continuation? tokens) - (next (append acc (drop-continuations tokens)) found) - (append acc (drop-continuations tokens)))))))))) - -(define (parse-makefile-expand filename expand key) - (define (variable? v) - (and (string-prefix? v "$(") (string-suffix? v ")"))) - - (let expand-all ((values (parse-makefile (open-input-file filename) key))) - (if (any variable? values) - (expand-all - (let expand-one ((acc '()) (v values)) - (cond - ((null? v) - acc) - ((variable? (car v)) - (let ((makefile (open-input-file filename)) - (key (substring (car v) 2 (- (string-length (car v)) 1)))) - (expand-one (append acc (expand filename makefile key)) - (cdr v)))) - (else - (expand-one (append acc (list (car v))) (cdr v)))))) - values))) - -(define python (catch #f - (path-expand "python" (string-split (getenv "PATH") *pathsep*)))) +(define python + (let loop ((pythons (list "python" "python2" "python3"))) + (if (null? pythons) + #f + (catch (loop (cdr pythons)) + (unless (file-exists? (path-join gpgme-builddir "lang" "python" + (string-append (car pythons) "-gpg"))) + (throw "next please")) + (path-expand (car pythons) (string-split (getenv "PATH") *pathsep*)))))) + (define (run-python-tests?) - (and python - (let* ((python-version - (string-trim char-whitespace? - (call-popen `(,python -c "import sys; print('{0}.{1}'.format(sys.version_info[0], sys.version_info[1]))") ""))) - (build-path (path-join gpgme-builddir "lang" "python" - (string-append "python" python-version "-gpg")))) - (file-exists? build-path)))) + (not (not python))) diff --git a/tests/gpgme/run-tests.scm b/tests/gpgme/run-tests.scm index be70f17..e81c9e9 100644 --- a/tests/gpgme/run-tests.scm +++ b/tests/gpgme/run-tests.scm @@ -17,61 +17,4 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgme-defs.scm")) - -(info "Running GPGME's test suite...") - -(define (gpgme-makefile-expand filename port key) - ;;(interactive-repl (current-environment)) - (cond - ((string=? key "tests_unix") - (if *win32* - (parse-makefile port key) ;; Use win32 definition. - (begin - (parse-makefile port key) ;; Skip win32 definition. - (parse-makefile port key)))) - (else - (parse-makefile port key)))) - -(define (all-tests filename key) - (parse-makefile-expand filename gpgme-makefile-expand key)) - -(let* ((runner (if (member "--parallel" *args*) - run-tests-parallel - run-tests-sequential)) - (setup-c (make-environment-cache - (test::scm #f "setup.scm (tests/gpg)" (in-srcdir "setup.scm") - "--" "tests" "gpg"))) - (setup-py (make-environment-cache - (test::scm #f "setup.scm (lang/python/tests)" (in-srcdir "setup.scm") - "--" "lang" "python" "tests"))) - (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))) - (runner - (apply - append - (map (lambda (cmpnts) - (define (compiled? name) - (not (or (string-suffix? name ".py") - (string-suffix? name ".test")))) - (define :path car) - (define :key cadr) - (define :setup caddr) - (define (find-test name) - (apply path-join - `(,(if (compiled? name) - gpgme-builddir - gpgme-srcdir) ,@(:path cmpnts) ,(qualify name)))) - (let ((makefile (apply path-join `(,gpgme-srcdir ,@(:path cmpnts) - "Makefile.am")))) - (map (lambda (name) - (apply test::scm - `(,(:setup cmpnts) - ,name ,(in-srcdir "wrap.scm") --executable - ,(find-test name) - -- ,@(:path cmpnts)))) - (if (null? tests) (all-tests makefile (:key cmpnts)) tests)))) - `((("tests" "gpg") "c_tests" ,setup-c) - ,@(if (run-python-tests?) - `((("lang" "python" "tests") "py_tests" ,setup-py)) - '()) - (("lang" "qt" "tests") "TESTS" ,setup-c)))))) +(run-tests (load-tests "tests" "gpgme")) diff --git a/tests/gpgme/setup.scm b/tests/gpgme/setup.scm index 0116a74..d1173d8 100644 --- a/tests/gpgme/setup.scm +++ b/tests/gpgme/setup.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgme-defs.scm")) +(load (in-srcdir "tests" "gpgme" "gpgme-defs.scm")) (define tarball (flag "--create-tarball" *args*)) (unless (and tarball (not (null? tarball))) diff --git a/tests/gpgme/wrap.scm b/tests/gpgme/wrap.scm index eb416f4..9a20d50 100644 --- a/tests/gpgme/wrap.scm +++ b/tests/gpgme/wrap.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgme-defs.scm")) +(load (in-srcdir "tests" "gpgme" "gpgme-defs.scm")) (define executable (flag "--executable" *args*)) (unless (and executable (not (null? executable))) @@ -28,6 +28,7 @@ (setenv "abs_builddir" (getcwd) #t) (setenv "top_srcdir" gpgme-srcdir #t) (setenv "srcdir" (path-join gpgme-srcdir "tests" "gpg") #t) +(setenv "abs_top_srcdir" (path-join gpgme-srcdir "tests" "gpg") #t) (define (run what) (if (string-suffix? (car what) ".py") diff --git a/tests/gpgscm/Makefile.am b/tests/gpgscm/Makefile.am index 8942c7c..44d7b3f 100644 --- a/tests/gpgscm/Makefile.am +++ b/tests/gpgscm/Makefile.am @@ -23,9 +23,12 @@ EXTRA_DIST = \ ffi.scm \ init.scm \ lib.scm \ + makefile.scm \ repl.scm \ t-child.scm \ + xml.scm \ tests.scm \ + gnupg.scm \ time.scm AM_CPPFLAGS = -I$(top_srcdir)/common @@ -44,7 +47,8 @@ commonpth_libs = ../$(libcommonpth) gpgscm_CFLAGS = -imacros scheme-config.h \ $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ - scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h + scheme-config.h scheme.c scheme.h scheme-private.h \ + opdefines.h small-integers.h gpgscm_LDADD = $(LDADD) $(common_libs) \ $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) diff --git a/tests/gpgscm/gnupg.scm b/tests/gpgscm/gnupg.scm new file mode 100644 index 0000000..5fcf9fd --- /dev/null +++ b/tests/gpgscm/gnupg.scm @@ -0,0 +1,44 @@ +;; Common definitions for executing gpg and related tools. +;; +;; Copyright (C) 2016, 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +;; Evaluate a sequence of expressions with the given home directory. +(define-macro (with-home-directory gnupghome . expressions) + (let ((original-home-directory (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME"))) + (dynamic-wind + (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) + +;; Evaluate a sequence of expressions with an ephemeral home +;; directory. +(define-macro (with-ephemeral-home-directory setup-fn . expressions) + (let ((original-home-directory (gensym)) + (ephemeral-home-directory (gensym)) + (setup (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME")) + (,ephemeral-home-directory (mkdtemp)) + (,setup (delay (,setup-fn)))) + (finally (unlink-recursively ,ephemeral-home-directory) + (dynamic-wind + (lambda () + (setenv "GNUPGHOME" ,ephemeral-home-directory #t) + (with-working-directory ,ephemeral-home-directory (force ,setup))) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm index 87d3c88..3769ed0 100644 --- a/tests/gpgscm/init.scm +++ b/tests/gpgscm/init.scm @@ -613,8 +613,13 @@ (quit (cadr args))) (else (display message) - (if args (begin - (display ": ") + (when (and args (not (null? args))) + (display ": ") + (if (string? (car args)) + (begin (display (car args)) + (unless (null? (cdr args)) + (newline) + (write (cdr args)))) (write args))) (newline) (vm-history-print history) @@ -696,6 +701,11 @@ ,@(cdr form) (current-environment)))) +(define-macro (export name . expressions) + `(define ,name + (begin + ,@expressions))) + ;;;;; I/O (define (input-output-port? p) diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm index 2cfe725..258f692 100644 --- a/tests/gpgscm/lib.scm +++ b/tests/gpgscm/lib.scm @@ -29,6 +29,18 @@ (assert #t) (assert (not #f)) +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + (define (filter pred lst) (cond ((null? lst) '()) ((pred (car lst)) @@ -95,10 +107,10 @@ (let ((length (string-length haystack))) (define (split acc offset n) (if (>= offset length) - (reverse acc) + (reverse! acc) (let ((i (lookahead haystack offset))) (if (or (eq? i #f) (= 0 n)) - (reverse (cons (substring haystack offset length) acc)) + (reverse! (cons (substring haystack offset length) acc)) (split (cons (substring haystack offset i) acc) (+ i 1) (- n 1)))))) (split '() 0 n))) @@ -168,10 +180,10 @@ (define (string-rtrim predicate s) (if (string=? s "") "" - (let loop ((s' (reverse (string->list s)))) + (let loop ((s' (reverse! (string->list s)))) (if (predicate (car s')) (loop (cdr s')) - (list->string (reverse s')))))) + (list->string (reverse! s')))))) (assert (string=? "" (string-rtrim char-whitespace? ""))) (assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) @@ -187,6 +199,13 @@ (assert (string-contains? "Hallo" "llo")) (assert (not (string-contains? "Hallo" "olla"))) +;; Translate characters. +(define (string-translate s from to) + (list->string (map (lambda (c) + (let ((i (string-index from c))) + (if i (string-ref to i) c))) (string->list s)))) +(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) + ;; Read a word from port P. (define (read-word . p) (list->string diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c index 65929f0..e4b535e 100644 --- a/tests/gpgscm/main.c +++ b/tests/gpgscm/main.c @@ -23,13 +23,20 @@ #include <assert.h> #include <ctype.h> #include <errno.h> +#include <fcntl.h> #include <gcrypt.h> #include <gpg-error.h> #include <stdio.h> #include <stdlib.h> #include <string.h> +#include <sys/types.h> +#include <sys/stat.h> #include <unistd.h> +#if HAVE_MMAP +#include <sys/mman.h> +#endif + #include "private.h" #include "scheme.h" #include "scheme-private.h" @@ -177,7 +184,39 @@ load (scheme *sc, char *file_name, } if (verbose > 1) fprintf (stderr, "Loading %s...\n", qualified_name); - scheme_load_named_file (sc, h, qualified_name); + +#if HAVE_MMAP + /* Always try to mmap the file. This allows the pages to be shared + * between processes. If anything fails, we fall back to using + * buffered streams. */ + if (1) + { + struct stat st; + void *map; + size_t len; + int fd = fileno (h); + + if (fd < 0) + goto fallback; + + if (fstat (fd, &st)) + goto fallback; + + len = (size_t) st.st_size; + if ((off_t) len != st.st_size) + goto fallback; /* Truncated. */ + + map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); + if (map == MAP_FAILED) + goto fallback; + + scheme_load_memory (sc, map, len, qualified_name); + munmap (map, len); + } + else + fallback: +#endif + scheme_load_named_file (sc, h, qualified_name); fclose (h); if (sc->retcode && sc->nesting) @@ -274,7 +313,11 @@ main (int argc, char **argv) if (! err) err = load (sc, "repl.scm", 0, 1); if (! err) + err = load (sc, "xml.scm", 0, 1); + if (! err) err = load (sc, "tests.scm", 0, 1); + if (! err) + err = load (sc, "gnupg.scm", 0, 1); if (err) { fprintf (stderr, "Error initializing gpgscm: %s.\n", diff --git a/tests/gpgscm/makefile.scm b/tests/gpgscm/makefile.scm new file mode 100644 index 0000000..32fae3a --- /dev/null +++ b/tests/gpgscm/makefile.scm @@ -0,0 +1,76 @@ +;; Support for parsing Makefiles +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(define (parse-makefile port key) + (define (is-continuation? tokens) + (string=? (last tokens) "\\")) + (define (valid-token? s) + (< 0 (string-length s))) + (define (drop-continuations tokens) + (let loop ((acc '()) (tks tokens)) + (if (null? tks) + (reverse acc) + (loop (if (string=? "\\" (car tks)) + acc + (cons (car tks) acc)) (cdr tks))))) + (let next ((acc '()) (found #f)) + (let ((line (read-line port))) + (if (eof-object? line) + acc + (let ((tokens (filter valid-token? + (string-splitp (string-trim char-whitespace? + line) + char-whitespace? -1)))) + (cond + ((or (null? tokens) + (string-prefix? (car tokens) "#") + (and (not found) (not (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))))) + (next acc found)) + ((not found) + (assert (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))) + (if (is-continuation? tokens) + (next (drop-continuations (cddr tokens)) #t) + (drop-continuations (cddr tokens)))) + (else + (assert found) + (if (is-continuation? tokens) + (next (append acc (drop-continuations tokens)) found) + (append acc (drop-continuations tokens)))))))))) + +(define (parse-makefile-expand filename expand key) + (define (variable? v) + (and (string-prefix? v "$(") (string-suffix? v ")"))) + + (let expand-all ((values (parse-makefile (open-input-file filename) key))) + (if (any variable? values) + (expand-all + (let expand-one ((acc '()) (v values)) + (cond + ((null? v) + acc) + ((variable? (car v)) + (let ((makefile (open-input-file filename)) + (key (substring (car v) 2 (- (string-length (car v)) 1)))) + (expand-one (append acc (expand filename makefile key)) + (cdr v)))) + (else + (expand-one (append acc (list (car v))) (cdr v)))))) + values))) diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h index 2d17720..61f7971 100644 --- a/tests/gpgscm/opdefines.h +++ b/tests/gpgscm/opdefines.h @@ -1,206 +1,205 @@ - _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) - _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) +_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) +_OP_DEF(0, 0, 0, 0, OP_T0LVL ) +_OP_DEF(0, 0, 0, 0, OP_T1LVL ) +_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) +_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) +_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) +_OP_DEF(0, 0, 0, 0, OP_EVAL ) #if USE_TRACING - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) +_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL ) #endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) +_OP_DEF(0, 0, 0, 0, OP_E0ARGS ) +_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) #if USE_HISTORY - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CALLSTACK_POP ) +_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) #endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY_CODE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) +_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) +_OP_DEF(0, 0, 0, 0, OP_APPLY ) #if USE_TRACING - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) - _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) +_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) +_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING ) #endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 ) - _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) - _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) - _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) - _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) - _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) - _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) +_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) +_OP_DEF(0, 0, 0, 0, OP_QUOTE ) +_OP_DEF(0, 0, 0, 0, OP_DEF0 ) +_OP_DEF(0, 0, 0, 0, OP_DEF1 ) +_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) +_OP_DEF(0, 0, 0, 0, OP_BEGIN ) +_OP_DEF(0, 0, 0, 0, OP_IF0 ) +_OP_DEF(0, 0, 0, 0, OP_IF1 ) +_OP_DEF(0, 0, 0, 0, OP_SET0 ) +_OP_DEF(0, 0, 0, 0, OP_SET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET0 ) +_OP_DEF(0, 0, 0, 0, OP_LET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET2 ) +_OP_DEF(0, 0, 0, 0, OP_LET0AST ) +_OP_DEF(0, 0, 0, 0, OP_LET1AST ) +_OP_DEF(0, 0, 0, 0, OP_LET2AST ) +_OP_DEF(0, 0, 0, 0, OP_LET0REC ) +_OP_DEF(0, 0, 0, 0, OP_LET1REC ) +_OP_DEF(0, 0, 0, 0, OP_LET2REC ) +_OP_DEF(0, 0, 0, 0, OP_COND0 ) +_OP_DEF(0, 0, 0, 0, OP_COND1 ) +_OP_DEF(0, 0, 0, 0, OP_DELAY ) +_OP_DEF(0, 0, 0, 0, OP_AND0 ) +_OP_DEF(0, 0, 0, 0, OP_AND1 ) +_OP_DEF(0, 0, 0, 0, OP_OR0 ) +_OP_DEF(0, 0, 0, 0, OP_OR1 ) +_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) +_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) +_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) +_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE0 ) +_OP_DEF(0, 0, 0, 0, OP_CASE1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE2 ) +_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) +_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) +_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) #if USE_MATH - _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) - _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) - _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) - _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) - _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) - _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) - _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) - _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) - _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) - _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) - _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) - _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) - _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) - _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) - _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) +_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) +_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) +_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) +_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) +_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) +_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) +_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) +_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) +_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) +_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) +_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) +_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) +_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) +_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) +_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) #endif - _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) - _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) - _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) - _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) - _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) - _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) - _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) - _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) - _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) - _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) - _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) - _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) - _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) - _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) - _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) - _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) - _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) - _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) - _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) - _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) - _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) - _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) - _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) - _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) - _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) - _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) - _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) - _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) - _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) - _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) - _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) - _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) - _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) - _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) - _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) - _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) - _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) - _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) - _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) - _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) - _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) - _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) - _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) - _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) - _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) - _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) +_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) +_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) +_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) +_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) +_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) +_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) +_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) +_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) +_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) +_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) +_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) +_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) +_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) +_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) +_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) +_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) +_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) +_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) +_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) +_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) +_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) +_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) +_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) +_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) +_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) +_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) +_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) +_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) +_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) +_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) +_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) +_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) +_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) +_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) +_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) +_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) +_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) +_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) +_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) +_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) +_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) +_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) +_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) +_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) +_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) +_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) #if USE_CHAR_CLASSIFIERS - _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) - _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) - _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) - _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) - _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) +_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) +_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) +_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) +_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) #endif - _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) - _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) - _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) - _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) - _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) - _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) - _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) - _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) - _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) - _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) - _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) - _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) - _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) - _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) - _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) - _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) - _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) - _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) - _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE ) - _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) - _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) +_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) +_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) +_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) +_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) +_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) +_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) +_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) +_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) +_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) +_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) +_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) +_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) +_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) +_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) +_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) +_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) +_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) +_OP_DEF(0, 0, 0, 0, OP_ERR1 ) +_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) +_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) +_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) +_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) #if USE_PLIST - _OP_DEF(opexe_4, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) - _OP_DEF(opexe_4, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) +_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) +_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif -#if USE_TAGS - _OP_DEF(opexe_4, NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) - _OP_DEF(opexe_4, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) - _OP_DEF(opexe_4, "get-tag", 1, 1, TST_ANY, OP_GET_TAG ) -#endif - _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) - _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) - _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) - _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) - _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) - _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) - _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) - _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) - _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) - _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) +_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) +_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) +_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) +_OP_DEF("gc", 0, 0, 0, OP_GC ) +_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) +_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) +_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) +_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) +_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) +_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) +_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) +_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) #if USE_STRING_PORTS - _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) - _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) - _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) - _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) +_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) +_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) +_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) #endif - _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) - _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) - _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) - _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) - _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) - _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) - _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) - _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) - _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) - _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) - _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) - _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) - _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) - _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) - _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) - _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) - _OP_DEF(opexe_6, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) +_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) +_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) +_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) +_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) +_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) +_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) +_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) +_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) +_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) +_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) +_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) +_OP_DEF(0, 0, 0, 0, OP_RDLIST ) +_OP_DEF(0, 0, 0, 0, OP_RDDOT ) +_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) +_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) +_OP_DEF(0, 0, 0, 0, OP_RDVEC ) +_OP_DEF(0, 0, 0, 0, OP_P0LIST ) +_OP_DEF(0, 0, 0, 0, OP_P1LIST ) +_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) +_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) +_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) +_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) +_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) +_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) +_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) #undef _OP_DEF diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h index abd89e8..7f92bda 100644 --- a/tests/gpgscm/scheme-private.h +++ b/tests/gpgscm/scheme-private.h @@ -3,6 +3,7 @@ #ifndef _SCHEME_PRIVATE_H #define _SCHEME_PRIVATE_H +#include <stdint.h> #include "scheme.h" /*------------------ Ugly internals -----------------------------------*/ /*------------------ Of interest only to FFI users --------------------*/ @@ -42,13 +43,13 @@ typedef struct port { /* cell structure */ struct cell { - unsigned int _flag; + uintptr_t _flag; union { + num _number; struct { char *_svalue; int _length; } _string; - num _number; port *_port; foreign_func _ff; struct { @@ -107,18 +108,21 @@ int tracing; #ifndef CELL_SEGSIZE #define CELL_SEGSIZE 5000 /* # of cells in one segment */ #endif -#ifndef CELL_NSEGMENT -#define CELL_NSEGMENT 10 /* # of segments for cells */ + +/* If less than # of cells are recovered in a garbage collector run, + * allocate a new cell segment to avoid fruitless collection cycles in + * the near future. */ +#ifndef CELL_MINRECOVER +#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) #endif -void *alloc_seg[CELL_NSEGMENT]; -pointer cell_seg[CELL_NSEGMENT]; -int last_cell_seg; +struct cell_segment *cell_segments; /* We use 4 registers. */ pointer args; /* register for arguments of function */ pointer envir; /* stack register for current environment */ pointer code; /* register for current code */ pointer dump; /* stack register for next evaluation */ +pointer frame_freelist; #if USE_HISTORY struct history history; /* we keep track of the call history for @@ -156,12 +160,6 @@ pointer SHARP_HOOK; /* *sharp-hook* */ pointer COMPILE_HOOK; /* *compile-hook* */ #endif -#if USE_SMALL_INTEGERS -/* A fixed allocation of small integers. */ -void *integer_alloc; -pointer integer_cells; -#endif - pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ size_t inhibit_gc; /* nesting of gc_disable */ @@ -199,18 +197,17 @@ FILE *tmpfp; int tok; int print_flag; pointer value; -int op; unsigned int flags; void *ext_data; /* For the benefit of foreign functions */ long gensym_cnt; -struct scheme_interface *vptr; +const struct scheme_interface *vptr; }; /* operator code */ enum scheme_opcodes { -#define _OP_DEF(A,B,C,D,E,OP) OP, +#define _OP_DEF(A,B,C,D,OP) OP, #include "opdefines.h" OP_MAXDEFINED }; diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c index fbc562d..26bb5a5 100644 --- a/tests/gpgscm/scheme.c +++ b/tests/gpgscm/scheme.c @@ -139,7 +139,8 @@ enum scheme_types { T_NIL = 17 << 1 | 1, T_EOF_OBJ = 18 << 1 | 1, T_SINK = 19 << 1 | 1, - T_LAST_SYSTEM_TYPE = 19 << 1 | 1 + T_FRAME = 20 << 1 | 1, + T_LAST_SYSTEM_TYPE = 20 << 1 | 1 }; static const char * @@ -166,6 +167,7 @@ type_to_string (enum scheme_types typ) case T_NIL: return "nil"; case T_EOF_OBJ: return "eof object"; case T_SINK: return "sink"; + case T_FRAME: return "frame"; } assert (! "not reached"); } @@ -174,6 +176,7 @@ type_to_string (enum scheme_types typ) #define TYPE_BITS 6 #define ADJ (1 << TYPE_BITS) #define T_MASKTYPE (ADJ - 1) + /* 0000000000111111 */ #define T_TAGGED 1024 /* 0000010000000000 */ #define T_FINALIZE 2048 /* 0000100000000000 */ #define T_SYNTAX 4096 /* 0001000000000000 */ @@ -205,12 +208,13 @@ static INLINE int num_is_integer(pointer p) { return ((p)->_object._number.is_fixnum); } -static num num_zero; -static num num_one; +static const struct num num_zero = { 1, {0} }; +static const struct num num_one = { 1, {1} }; /* macros for cell operations */ #define typeflag(p) ((p)->_flag) #define type(p) (typeflag(p)&T_MASKTYPE) +#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } #define strvalue(p) ((p)->_object._string._svalue) @@ -299,6 +303,9 @@ INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } #define setenvironment(p) typeflag(p) = T_ENVIRONMENT +INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } +#define setframe(p) settype(p, T_FRAME) + #define is_atom(p) (typeflag(p)&T_ATOM) #define setatom(p) typeflag(p) |= T_ATOM #define clratom(p) typeflag(p) &= CLRATOM @@ -339,7 +346,7 @@ static INLINE int Cislower(int c) { return isascii(c) && islower(c); } #endif #if USE_ASCII_NAMES -static const char *charnames[32]={ +static const char charnames[32][3]={ "nul", "soh", "stx", @@ -377,12 +384,12 @@ static const char *charnames[32]={ static int is_ascii_name(const char *name, int *pc) { int i; for(i=0; i<32; i++) { - if(stricmp(name,charnames[i])==0) { + if (strncasecmp(name, charnames[i], 3) == 0) { *pc=i; return 1; } } - if(stricmp(name,"del")==0) { + if (strcasecmp(name, "del") == 0) { *pc=127; return 1; } @@ -402,7 +409,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b); static pointer reserve_cells(scheme *sc, int n); static pointer get_consecutive_cells(scheme *sc, int n); static pointer find_consecutive_cells(scheme *sc, int n); -static void finalize_cell(scheme *sc, pointer a); +static int finalize_cell(scheme *sc, pointer a); static int count_consecutive_cells(pointer x, int needed); static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); static pointer mk_number(scheme *sc, num n); @@ -436,18 +443,20 @@ static pointer mk_continuation(scheme *sc, pointer d); static pointer reverse(scheme *sc, pointer term, pointer list); static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_preallocate_frame(scheme *sc); static void dump_stack_mark(scheme *); -static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_1(scheme *sc, enum scheme_opcodes op); -static pointer opexe_2(scheme *sc, enum scheme_opcodes op); -static pointer opexe_3(scheme *sc, enum scheme_opcodes op); -static pointer opexe_4(scheme *sc, enum scheme_opcodes op); -static pointer opexe_5(scheme *sc, enum scheme_opcodes op); -static pointer opexe_6(scheme *sc, enum scheme_opcodes op); +struct op_code_info { + char name[31]; /* strlen ("call-with-current-continuation") + 1 */ + unsigned char min_arity; + unsigned char max_arity; + char arg_tests_encoding[3]; +}; +static const struct op_code_info dispatch_table[]; +static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, char *name); -static int syntaxnum(pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); +static int syntaxnum(scheme *sc, pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) @@ -624,11 +633,59 @@ static long binary_decode(const char *s) { +/* + * Copying values. + * + * Occasionally, we need to copy a value from one location in the + * storage to another. Scheme objects are fine. Some primitive + * objects, however, require finalization, usually to free resources. + * + * For these values, we either make a copy or acquire a reference. + */ + +/* + * Copy SRC to DST. + * + * Copies the representation of SRC to DST. This makes SRC + * indistinguishable from DST from the perspective of a Scheme + * expression modulo the fact that they reside at a different location + * in the store. + * + * Conditions: + * + * - SRC must not be a vector. + * - Caller must ensure that any resources associated with the + * value currently stored in DST is accounted for. + */ +static void +copy_value(scheme *sc, pointer dst, pointer src) +{ + memcpy(dst, src, sizeof *src); + + /* We may need to make a copy or acquire a reference. */ + if (typeflag(dst) & T_FINALIZE) + switch (type(dst)) { + case T_STRING: + strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); + break; + case T_PORT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_FOREIGN_OBJECT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_VECTOR: + assert (!"vectors cannot be copied"); + } +} + + + /* Tags are like property lists, but can be attached to arbitrary * values. */ -#if USE_TAGS - static pointer mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) { @@ -640,7 +697,7 @@ mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) if (r == sc->sink) return sc->sink; - memcpy(r, v, sizeof *v); + copy_value(sc, r, v); typeflag(r) |= T_TAGGED; t = r + 1; @@ -665,19 +722,28 @@ get_tag(scheme *sc, pointer v) return sc->NIL; } -#else - -#define mk_tagged_value(SC, X, A, B) (X) -#define has_tag(V) 0 -#define get_tag(SC, V) (SC)->NIL + -#endif +/* Low-level allocator. + * + * Memory is allocated in segments. Every segment holds a fixed + * number of cells. Segments are linked into a list, sorted in + * reverse address order (i.e. those with a higher address first). + * This is used in the garbage collector to build the freelist in + * address order. + */ - +struct cell_segment +{ + struct cell_segment *next; + void *alloc; + pointer cells; + size_t cells_len; +}; /* Allocate a new cell segment but do not make it available yet. */ static int -_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) +_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) { int adj = ADJ; void *cp; @@ -685,46 +751,64 @@ _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) if (adj < sizeof(struct cell)) adj = sizeof(struct cell); - cp = sc->malloc(len * sizeof(struct cell) + adj); + /* The segment header is conveniently allocated with the cells. */ + cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); if (cp == NULL) return 1; - *alloc = cp; + *segment = cp; + (*segment)->next = NULL; + (*segment)->alloc = cp; + cp = (void *) ((uintptr_t) cp + sizeof **segment); /* adjust in TYPE_BITS-bit boundary */ if (((uintptr_t) cp) % adj != 0) cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); - *cells = cp; + (*segment)->cells = cp; + (*segment)->cells_len = len; return 0; } +/* Deallocate a cell segment. Returns the next cell segment. + * Convenient for deallocation in a loop. */ +static struct cell_segment * +_dealloc_cellseg(scheme *sc, struct cell_segment *segment) +{ + + struct cell_segment *next; + + if (segment == NULL) + return NULL; + + next = segment->next; + sc->free(segment->alloc); + return next; +} + /* allocate new cell segment */ static int alloc_cellseg(scheme *sc, int n) { - pointer newp; pointer last; pointer p; - long i; int k; for (k = 0; k < n; k++) { - if (sc->last_cell_seg >= CELL_NSEGMENT - 1) - return k; - i = ++sc->last_cell_seg; - if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) { - sc->last_cell_seg--; + struct cell_segment *new, **s; + if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { return k; } - /* insert new segment in address order */ - sc->cell_seg[i] = newp; - while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { - p = sc->cell_seg[i]; - sc->cell_seg[i] = sc->cell_seg[i - 1]; - sc->cell_seg[--i] = p; - } - sc->fcells += CELL_SEGSIZE; - last = newp + CELL_SEGSIZE - 1; - for (p = newp; p <= last; p++) { + /* insert new segment in reverse address order */ + for (s = &sc->cell_segments; + *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; + s = &(*s)->next) { + /* walk */ + } + new->next = *s; + *s = new; + + sc->fcells += new->cells_len; + last = new->cells + new->cells_len - 1; + for (p = new->cells; p <= last; p++) { typeflag(p) = 0; cdr(p) = p + 1; car(p) = sc->NIL; @@ -732,13 +816,13 @@ static int alloc_cellseg(scheme *sc, int n) { /* insert new cells in address order on free list */ if (sc->free_cell == sc->NIL || p < sc->free_cell) { cdr(last) = sc->free_cell; - sc->free_cell = newp; + sc->free_cell = new->cells; } else { p = sc->free_cell; - while (cdr(p) != sc->NIL && newp > cdr(p)) + while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) p = cdr(p); cdr(last) = cdr(p); - cdr(p) = newp; + cdr(p) = new->cells; } } return n; @@ -791,7 +875,8 @@ gc_reservation_failure(struct scheme *sc) "insufficient reservation\n") #else fprintf(stderr, - "insufficient reservation in line %d\n", + "insufficient %s reservation in line %d\n", + sc->frame_freelist == sc->NIL ? "frame" : "cell", sc->reserved_lineno); #endif abort(); @@ -817,7 +902,15 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno) sc->inhibit_gc += 1; } #define gc_disable(sc, reserve) \ - _gc_disable (sc, reserve, __LINE__) + do { \ + if (sc->frame_freelist == sc->NIL) { \ + if (gc_enabled(sc)) \ + dump_stack_preallocate_frame(sc); \ + else \ + gc_reservation_failure(sc); \ + } \ + _gc_disable (sc, reserve, __LINE__); \ + } while (0) /* Enable the garbage collector. */ #define gc_enable(sc) \ @@ -841,7 +934,12 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno) #else /* USE_GC_LOCKING */ -#define gc_disable(sc, reserve) (void) 0 +#define gc_reservation_failure(sc) (void) 0 +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) \ + dump_stack_preallocate_frame(sc); \ + } while (0) #define gc_enable(sc) (void) 0 #define gc_enabled(sc) 1 #define gc_consume(sc) (void) 0 @@ -872,15 +970,10 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) { assert (gc_enabled (sc)); if (sc->free_cell == sc->NIL) { - const int min_to_be_recovered = sc->last_cell_seg*8; gc(sc,a, b); - if (sc->fcells < min_to_be_recovered - || sc->free_cell == sc->NIL) { - /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } + if (sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; } } x = sc->free_cell; @@ -1033,11 +1126,19 @@ static pointer get_cell(scheme *sc, pointer a, pointer b) static pointer get_vector_object(scheme *sc, int len, pointer init) { pointer cells = get_consecutive_cells(sc, vector_size(len)); + int i; + int alloc_len = 1 + 3 * (vector_size(len) - 1); if(sc->no_memory) { return sc->sink; } /* Record it as a vector so that gc understands it. */ typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); vector_length(cells) = len; fill_vector(cells,init); + + /* Initialize the unused slots at the end. */ + assert (alloc_len - len < 3); + for (i = len; i < alloc_len; i++) + cells->_object._vector._elements[i] = sc->NIL; + if (gc_enabled (sc)) push_recent_alloc(sc, cells, sc->NIL); return cells; @@ -1058,6 +1159,7 @@ pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { return (x); } + /* ========== oblist implementation ========== */ #ifndef USE_OBJECT_LIST @@ -1071,24 +1173,6 @@ static pointer oblist_initial_value(scheme *sc) return mk_vector(sc, 1009); } -/* Add a new symbol NAME at SLOT. SLOT must be obtained using - * oblist_find_by_name, and no insertion must be done between - * obtaining the SLOT and calling this function. Returns the new - * symbol. */ -static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) -{ -#define oblist_add_by_name_allocates 3 - pointer x; - - gc_disable(sc, gc_reservations (oblist_add_by_name)); - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - *slot = immutable_cons(sc, x, *slot); - gc_enable(sc); - return x; -} - /* Lookup the symbol NAME. Returns the symbol, or NIL if it does not * exist. In that case, SLOT points to the point where the new symbol * is to be inserted. */ @@ -1157,6 +1241,13 @@ oblist_find_by_name(scheme *sc, const char *name, pointer **slot) return sc->NIL; } +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + /* Add a new symbol NAME at SLOT. SLOT must be obtained using * oblist_find_by_name, and no insertion must be done between * obtaining the SLOT and calling this function. Returns the new @@ -1166,18 +1257,16 @@ static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) #define oblist_add_by_name_allocates 3 pointer x; + gc_disable(sc, gc_reservations (oblist_add_by_name)); x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); *slot = immutable_cons(sc, x, *slot); + gc_enable(sc); return x; } -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} -#endif + static pointer mk_port(scheme *sc, port *p) { pointer x = get_cell(sc, sc->NIL, sc->NIL); @@ -1217,34 +1306,22 @@ INTERFACE pointer mk_character(scheme *sc, int c) { #if USE_SMALL_INTEGERS -/* s_save assumes that all opcodes can be expressed as a small - * integer. */ -#define MAX_SMALL_INTEGER OP_MAXDEFINED - -static int -initialize_small_integers(scheme *sc) -{ - int i; - if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc, - &sc->integer_cells)) - return 1; - - for (i = 0; i < MAX_SMALL_INTEGER; i++) { - pointer x = &sc->integer_cells[i]; - typeflag(x) = T_NUMBER | T_ATOM | MARK; - ivalue_unchecked(x) = i; - set_num_integer(x); - } +static const struct cell small_integers[] = { +#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, +#include "small-integers.h" +#undef DEFINE_INTEGER + {0} +}; - return 0; -} +#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) static INLINE pointer mk_small_integer(scheme *sc, long n) { #define mk_small_integer_allocates 0 + (void) sc; assert(0 <= n && n < MAX_SMALL_INTEGER); - return &sc->integer_cells[n]; + return (pointer) &small_integers[n]; } #else @@ -1542,6 +1619,9 @@ static pointer mk_sharp_const(scheme *sc, char *name) { /* ========== garbage collector ========== */ +const int frame_length; +static void dump_stack_deallocate_frame(scheme *sc, pointer frame); + /*-- * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, @@ -1552,10 +1632,12 @@ static void mark(pointer a) { t = (pointer) 0; p = a; -E2: setmark(p); - if(is_vector(p)) { +E2: if (! is_mark(p)) + setmark(p); + if (is_vector(p) || is_frame(p)) { int i; - for (i = 0; i < vector_length(p); i++) { + int len = is_vector(p) ? vector_length(p) : frame_length; + for (i = 0; i < len; i++) { mark(p->_object._vector._elements[i]); } } @@ -1608,6 +1690,7 @@ E6: /* up. Undo the link switching from steps E4 and E5. */ /* garbage collection. parameter a, b is marked. */ static void gc(scheme *sc, pointer a, pointer b) { pointer p; + struct cell_segment *s; int i; assert (gc_enabled (sc)); @@ -1654,24 +1737,25 @@ static void gc(scheme *sc, pointer a, pointer b) { (which are also kept sorted by address) downwards to build the free-list in sorted order. */ - for (i = sc->last_cell_seg; i >= 0; i--) { - p = sc->cell_seg[i] + CELL_SEGSIZE; - while (--p >= sc->cell_seg[i]) { + for (s = sc->cell_segments; s; s = s->next) { + p = s->cells + s->cells_len; + while (--p >= s->cells) { if ((typeflag(p) & 1) == 0) /* All types have the LSB set. This is not a typeflag. */ continue; if (is_mark(p)) { clrmark(p); } else { - /* reclaim cell */ - if (typeflag(p) & T_FINALIZE) { - finalize_cell(sc, p); - } - ++sc->fcells; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; + /* reclaim cell */ + if ((typeflag(p) & T_FINALIZE) == 0 + || finalize_cell(sc, p)) { + /* Reclaim cell. */ + ++sc->fcells; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } } } } @@ -1681,12 +1765,24 @@ static void gc(scheme *sc, pointer a, pointer b) { snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); putstr(sc,msg); } + + /* if only a few recovered, get more to avoid fruitless gc's */ + if (sc->fcells < CELL_MINRECOVER + && alloc_cellseg(sc, 1) == 0) + sc->no_memory = 1; } -static void finalize_cell(scheme *sc, pointer a) { - if(is_string(a)) { +/* Finalize A. Returns true if a can be added to the list of free + * cells. */ +static int +finalize_cell(scheme *sc, pointer a) +{ + switch (type(a)) { + case T_STRING: sc->free(strvalue(a)); - } else if(is_port(a)) { + break; + + case T_PORT: if(a->_object._port->kind&port_file && a->_object._port->rep.stdio.closeit) { port_close(sc,a,port_input|port_output); @@ -1694,19 +1790,32 @@ static void finalize_cell(scheme *sc, pointer a) { sc->free(a->_object._port->rep.string.start); } sc->free(a->_object._port); - } else if(is_foreign_object(a)) { + break; + + case T_FOREIGN_OBJECT: a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); - } else if (is_vector(a)) { - int i; - for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { - pointer p = a + i; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - sc->fcells += 1; - } + break; + + case T_VECTOR: + do { + int i; + for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { + pointer p = a + i; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + sc->fcells += 1; + } + } while (0); + break; + + case T_FRAME: + dump_stack_deallocate_frame(sc, a); + return 0; /* Do not free cell. */ } + + return 1; /* Free cell. */ } #if SHOW_ERROR_LINE @@ -2564,6 +2673,7 @@ int eqv(pointer a, pointer b) { #define is_true(p) ((p) != sc->F) #define is_false(p) ((p) == sc->F) + /* ========== Environment implementation ========== */ #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) @@ -2626,21 +2736,6 @@ static void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - pointer slot; - gc_disable(sc, gc_reservations (new_slot_spec_in_env)); - slot = immutable_cons(sc, variable, value); - *sslot = immutable_cons(sc, slot, *sslot); - gc_enable(sc); -} - /* Find the slot in ENV under the key HDL. If ALL is given, look in * all environments enclosing ENV. If the lookup fails, and SSLOT is * given, the position where the new slot has to be inserted is stored @@ -2687,18 +2782,6 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - assert(is_symbol(variable)); - *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot); -} - /* Find the slot in ENV under the key HDL. If ALL is given, look in * all environments enclosing ENV. If the lookup fails, and SSLOT is * given, the position where the new slot has to be inserted is stored @@ -2737,6 +2820,21 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) return find_slot_spec_in_env(sc, env, hdl, all, NULL); } +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. */ +static INLINE void new_slot_spec_in_env(scheme *sc, + pointer variable, pointer value, + pointer *sslot) +{ +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); + *sslot = immutable_cons(sc, slot, *sslot); + gc_enable(sc); +} + static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) { #define new_slot_in_env_allocates new_slot_spec_in_env_allocates @@ -2759,10 +2857,12 @@ static INLINE pointer slot_value_in_env(pointer slot) return cdr(slot); } + /* ========== Evaluation Cycle ========== */ -static pointer _Error_1(scheme *sc, const char *s, pointer a) { +static enum scheme_opcodes +_Error_1(scheme *sc, const char *s, pointer a) { const char *str = s; pointer history; #if USE_ERROR_HOOK @@ -2820,8 +2920,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { sc->code = cons(sc, mk_string(sc, str), sc->code); setimmutable(car(sc->code)); sc->code = cons(sc, slot_value_in_env(x), sc->code); - sc->op = (int)OP_EVAL; - return sc->T; + return OP_EVAL; } #endif @@ -2832,11 +2931,10 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { } sc->args = cons(sc, mk_string(sc, str), sc->args); setimmutable(car(sc->args)); - sc->op = (int)OP_ERR0; - return sc->T; + return OP_ERR0; } -#define Error_1(sc,s, a) return _Error_1(sc,s,a) -#define Error_0(sc,s) return _Error_1(sc,s,0) +#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } +#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } /* Too small to turn into function */ # define BEGIN do { @@ -2877,23 +2975,20 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { /* Bounce back to Eval_Cycle and execute A. */ -#define s_goto(sc,a) BEGIN \ - sc->op = (int)(a); \ - return sc->T; END +#define s_goto(sc, a) { op = (a); goto dispatch; } #if USE_THREADED_CODE /* Do not bounce back to Eval_Cycle but execute A by jumping directly - * to it. Only applicable if A is part of the same dispatch - * function. */ + * to it. */ #define s_thread_to(sc, a) \ BEGIN \ - op = (int) (a); \ + op = (a); \ goto a; \ END /* Define a label OP and emit a case statement for OP. For use in the - * dispatch functions. The slightly peculiar goto that is never + * dispatch function. The slightly peculiar goto that is never * executed avoids warnings about unused labels. */ #define CASE(OP) if (0) goto OP; OP: case OP @@ -2904,11 +2999,11 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { /* Return to the previous frame on the dump stack, setting the current * value to A. */ -#define s_return(sc, a) return _s_return(sc, a, 0) +#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) /* Return to the previous frame on the dump stack, setting the current * value to A, and re-enable the garbage collector. */ -#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1) +#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) static INLINE void dump_stack_reset(scheme *sc) { @@ -2918,53 +3013,112 @@ static INLINE void dump_stack_reset(scheme *sc) static INLINE void dump_stack_initialize(scheme *sc) { dump_stack_reset(sc); + sc->frame_freelist = sc->NIL; } static void dump_stack_free(scheme *sc) { - sc->dump = sc->NIL; + dump_stack_initialize(sc); +} + +const int frame_length = 4; + +static pointer +dump_stack_make_frame(scheme *sc) +{ + pointer frame; + + frame = mk_vector(sc, frame_length); + if (! sc->no_memory) + setframe(frame); + + return frame; +} + +static INLINE pointer * +frame_slots(pointer frame) +{ + return &frame->_object._vector._elements[0]; +} + +#define frame_payload vector_length + +static pointer +dump_stack_allocate_frame(scheme *sc) +{ + pointer frame = sc->frame_freelist; + if (frame == sc->NIL) { + if (gc_enabled(sc)) + frame = dump_stack_make_frame(sc); + else + gc_reservation_failure(sc); + } else + sc->frame_freelist = *frame_slots(frame); + return frame; +} + +static void +dump_stack_deallocate_frame(scheme *sc, pointer frame) +{ + pointer *p = frame_slots(frame); + *p++ = sc->frame_freelist; + *p++ = sc->NIL; + *p++ = sc->NIL; + *p++ = sc->NIL; + sc->frame_freelist = frame; +} + +static void +dump_stack_preallocate_frame(scheme *sc) +{ + pointer frame = dump_stack_make_frame(sc); + if (! sc->no_memory) + dump_stack_deallocate_frame(sc, frame); } -static pointer _s_return(scheme *sc, pointer a, int enable_gc) { +static enum scheme_opcodes +_s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; - pointer op; + pointer *p; unsigned long v; + enum scheme_opcodes next_op; sc->value = (a); if (enable_gc) gc_enable(sc); if (dump == sc->NIL) - return sc->NIL; - free_cons(sc, dump, &op, &dump); - v = (unsigned long) ivalue_unchecked(op); - sc->op = (int) (v & S_OP_MASK); + return OP_QUIT; + v = frame_payload(dump); + next_op = (int) (v & S_OP_MASK); sc->flags = v & S_FLAG_MASK; -#ifdef USE_SMALL_INTEGERS - if (v < MAX_SMALL_INTEGER) { - /* This is a small integer, we must not free it. */ - } else - /* Normal integer. Recover the cell. */ -#endif - free_cell(sc, op); - free_cons(sc, dump, &sc->args, &dump); - free_cons(sc, dump, &sc->envir, &dump); - free_cons(sc, dump, &sc->code, &sc->dump); - return sc->T; + p = frame_slots(dump); + sc->args = *p++; + sc->envir = *p++; + sc->code = *p++; + sc->dump = *p++; + dump_stack_deallocate_frame(sc, dump); + return next_op; } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates 5 +#define s_save_allocates 0 pointer dump; - unsigned long v = sc->flags | ((unsigned long) op); + pointer *p; gc_disable(sc, gc_reservations (s_save)); - dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - dump = cons(sc, (args), dump); - sc->dump = cons(sc, mk_integer(sc, (long) v), dump); + dump = dump_stack_allocate_frame(sc); + frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); + p = frame_slots(dump); + *p++ = args; + *p++ = sc->envir; + *p++ = code; + *p++ = sc->dump; + sc->dump = dump; gc_enable(sc); } static INLINE void dump_stack_mark(scheme *sc) { mark(sc->dump); + mark(sc->frame_freelist); } @@ -3192,11 +3346,126 @@ history_flatten(scheme *sc) +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + + + +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) -static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { +/* kernel of this interpreter */ +static void +Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + for (;;) { pointer x, y; pointer callsite; + num v; +#if USE_MATH + double dd; +#endif + int (*comp_func)(num, num) = NULL; + const struct op_code_info *pcd = &dispatch_table[op]; + + dispatch: + if (pcd->name[0] != 0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + if (! check_arguments (sc, pcd, msg, sizeof msg)) { + s_goto(sc, _Error_1(sc, msg, 0)); + } + } + + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + exit(1); + } + ok_to_freely_gc(sc); switch (op) { CASE(OP_LOAD): /* load */ @@ -3221,7 +3490,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { { sc->args=sc->NIL; sc->nesting = sc->nesting_stack[0]; - s_goto(sc,OP_QUIT); + s_thread_to(sc,OP_QUIT); } else { @@ -3258,7 +3527,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->tok = token(sc); if(sc->tok==TOK_EOF) { s_return(sc,sc->EOF_OBJ); } - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); CASE(OP_GENSYM): s_return(sc, gensym(sc)); @@ -3273,7 +3542,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(file_interactive(sc)) { sc->print_flag = 1; sc->args = sc->value; - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { s_return(sc,sc->value); } @@ -3285,7 +3554,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_REAL_EVAL,sc->args,sc->code); sc->args=sc->code; putstr(sc,"\nEval: "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } /* fall through */ CASE(OP_REAL_EVAL): @@ -3300,7 +3569,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else if (is_pair(sc->code)) { if (is_syntax(x = car(sc->code))) { /* SYNTAX */ sc->code = cdr(sc->code); - s_goto(sc,syntaxnum(x)); + s_goto(sc, syntaxnum(sc, x)); } else {/* first, eval top element and eval arguments */ s_save(sc,OP_E0ARGS, sc->NIL, sc->code); /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ @@ -3374,7 +3643,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->print_flag = 1; /* sc->args=cons(sc,sc->code,sc->args);*/ putstr(sc,"\nApply to: "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } /* fall through */ CASE(OP_REAL_APPLY): @@ -3408,10 +3677,13 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { is_pair(x); x = cdr(x), y = cdr(y)) { if (y == sc->NIL) { Error_1(sc, "not enough arguments, missing:", x); - } else { + } else if (is_symbol(car(x))) { new_slot_in_env(sc, car(x), car(y)); - } + } else { + Error_1(sc, "syntax error in closure: not a symbol", car(x)); + } } + if (x == sc->NIL) { if (y != sc->NIL) { Error_0(sc, "too many arguments"); @@ -3659,17 +3931,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->args = sc->NIL; s_thread_to(sc,OP_BEGIN); } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} -static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { CASE(OP_LET0REC): /* letrec */ new_frame_in_env(sc, sc->envir); sc->args = sc->NIL; @@ -3690,7 +3952,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->code = cadar(sc->code); sc->args = sc->NIL; s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); @@ -3704,7 +3966,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } sc->code = cdr(sc->code); sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); CASE(OP_COND0): /* cond */ if (!is_pair(sc->code)) { @@ -3713,7 +3975,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_COND1): /* cond */ if (is_true(sc->value)) { @@ -3728,9 +3990,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); gc_enable(sc); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else { if ((sc->code = cdr(sc->code)) == sc->NIL) { s_return(sc,sc->NIL); @@ -3738,7 +4000,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } @@ -3756,7 +4018,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_AND1): /* and */ if (is_false(sc->value)) { @@ -3768,7 +4030,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } CASE(OP_OR0): /* or */ @@ -3779,7 +4041,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_OR1): /* or */ if (is_true(sc->value)) { @@ -3791,13 +4053,13 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } CASE(OP_C0STREAM): /* cons-stream */ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_C1STREAM): /* cons-stream */ sc->args = sc->value; /* save sc->value to register sc->args for gc */ @@ -3820,7 +4082,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"variable is not a symbol"); } s_save(sc,OP_MACRO1, sc->NIL, x); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_MACRO1): { /* macro */ pointer *sslot; @@ -3838,7 +4100,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_CASE1): /* case */ for (x = sc->code; x != sc->NIL; x = cdr(x)) { @@ -3857,11 +4119,11 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (x != sc->NIL) { if (is_pair(caar(x))) { sc->code = cdar(x); - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else {/* else */ s_save(sc,OP_CASE2, sc->NIL, cdar(x)); sc->code = caar(x); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } else { s_return(sc,sc->NIL); @@ -3869,7 +4131,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_CASE2): /* case */ if (is_true(sc->value)) { - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else { s_return(sc,sc->NIL); } @@ -3878,83 +4140,22 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->code = car(sc->args); sc->args = list_star(sc,cdr(sc->args)); /*sc->args = cadr(sc->args);*/ - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); CASE(OP_PEVAL): /* eval */ if(cdr(sc->args)!=sc->NIL) { sc->envir=cadr(sc->args); } sc->code = car(sc->args); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_CONTINUATION): /* call-with-current-continuation */ sc->code = car(sc->args); gc_disable(sc, 2); sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); gc_enable(sc); - s_goto(sc,OP_APPLY); - - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} + s_thread_to(sc,OP_APPLY); -#if USE_PLIST -static pointer -get_property(scheme *sc, pointer obj, pointer key) -{ - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - return cdar(x); - - return sc->NIL; -} - -static pointer -set_property(scheme *sc, pointer obj, pointer key, pointer value) -{ -#define set_property_allocates 2 - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - cdar(x) = value; - else { - gc_disable(sc, gc_reservations(set_property)); - symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); - gc_enable(sc); - } - - return sc->T; -} -#endif - -static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; -#if USE_MATH - double dd; -#endif - - switch (op) { #if USE_MATH CASE(OP_INEX2EX): /* inexact->exact */ x=car(sc->args); @@ -4355,7 +4556,6 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { char *str; int index0; int index1; - int len; str=strvalue(car(sc->args)); @@ -4374,13 +4574,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { index1=strlength(car(sc->args)); } - len=index1-index0; gc_disable(sc, 1); - x=mk_empty_string(sc,len,' '); - memcpy(strvalue(x),str+index0,len); - strvalue(x)[len]=0; - - s_return_enable_gc(sc, x); + s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); } CASE(OP_VECTOR): { /* vector */ @@ -4448,61 +4643,6 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,car(sc->args)); } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static int is_list(scheme *sc, pointer a) -{ return list_length(sc,a) >= 0; } - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -int list_length(scheme *sc, pointer a) { - int i=0; - pointer slow, fast; - - slow = fast = a; - while (1) - { - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - fast = cdr(fast); - ++i; - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - ++i; - fast = cdr(fast); - - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr(slow); - if (fast == slow) - { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; - } - } -} - -static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func)(num,num)=0; - - switch (op) { CASE(OP_NOT): /* not */ s_retbool(is_false(car(sc->args))); CASE(OP_BOOLP): /* boolean? */ @@ -4586,30 +4726,20 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { s_retbool(car(sc->args) == cadr(sc->args)); CASE(OP_EQV): /* eqv? */ s_retbool(eqv(car(sc->args), cadr(sc->args))); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - switch (op) { CASE(OP_FORCE): /* force */ sc->code = car(sc->args); if (is_promise(sc->code)) { /* Should change type to closure here */ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); sc->args = sc->NIL; - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); } else { s_return(sc,sc->code); } CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ - memcpy(sc->code,sc->value,sizeof(struct cell)); + copy_value(sc, sc->code, sc->value); s_return(sc,sc->value); CASE(OP_WRITE): /* write */ @@ -4628,7 +4758,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } else { sc->print_flag = 0; } - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); CASE(OP_NEWLINE): /* newline */ if(is_pair(sc->args)) { @@ -4658,19 +4788,22 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); sc->args = car(sc->args); sc->print_flag = 1; - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { putstr(sc, "\n"); if(sc->interactive_repl) { - s_goto(sc,OP_T0LVL); + s_thread_to(sc,OP_T0LVL); } else { - return sc->NIL; + return; } } CASE(OP_REVERSE): /* reverse */ s_return(sc,reverse(sc, sc->NIL, car(sc->args))); + CASE(OP_REVERSE_IN_PLACE): /* reverse! */ + s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); + CASE(OP_LIST_STAR): /* list* */ s_return(sc,list_star(sc,sc->args)); @@ -4704,7 +4837,6 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); #endif /* USE_PLIST */ -#if USE_TAGS CASE(OP_TAG_VALUE): { /* not exposed */ /* This tags sc->value with car(sc->args). Useful to tag * results of opcode evaluations. */ @@ -4724,13 +4856,12 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { CASE(OP_GET_TAG): /* get-tag */ s_return(sc, get_tag(sc, car(sc->args))); -#endif /* USE_TAGS */ CASE(OP_QUIT): /* quit */ if(is_pair(sc->args)) { sc->retcode=ivalue(car(sc->args)); } - return (sc->NIL); + return; CASE(OP_GC): /* gc */ gc(sc, sc->NIL, sc->NIL); @@ -4776,7 +4907,6 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } s_return(sc,p); break; - default: assert (! "reached"); } #if USE_STRING_PORTS @@ -4817,20 +4947,12 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { port *p; if ((p=car(sc->args)->_object._port)->kind&port_string) { - off_t size; - char *str; - - size=p->rep.string.curr-p->rep.string.start+1; - str=sc->malloc(size); - if(str != NULL) { - pointer s; - - memcpy(str,p->rep.string.start,size-1); - str[size-1]='\0'; - s=mk_string(sc,str); - sc->free(str); - s_return(sc,s); - } + gc_disable(sc, 1); + s_return_enable_gc( + sc, + mk_counted_string(sc, + p->rep.string.start, + p->rep.string.curr - p->rep.string.start)); } s_return(sc,sc->F); } @@ -4850,37 +4972,23 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { CASE(OP_CURR_ENV): /* current-environment */ s_return(sc,sc->envir); - } - return sc->T; -} - -static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { - pointer x; - - if(sc->nesting!=0) { - int n=sc->nesting; - sc->nesting=0; - sc->retcode=-1; - Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); - } - switch (op) { /* ========== reading part ========== */ CASE(OP_READ): if(!is_pair(sc->args)) { - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); } if(!is_inport(car(sc->args))) { Error_1(sc,"read: not an input port:",car(sc->args)); } if(car(sc->args)==sc->inport) { - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); } x=sc->inport; sc->inport=car(sc->args); x=cons(sc,x,sc->NIL); s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); CASE(OP_READ_CHAR): /* read-char */ CASE(OP_PEEK_CHAR): /* peek-char */ { @@ -4897,7 +5005,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { if(c==EOF) { s_return(sc,sc->EOF_OBJ); } - if(sc->op==OP_PEEK_CHAR) { + if(op==OP_PEEK_CHAR) { backchar(sc,c); } s_return(sc,mk_character(sc,c)); @@ -4936,12 +5044,12 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else if (sc->tok == TOK_DOT) { Error_0(sc,"syntax error: illegal dot expression"); } else { -#if USE_TAGS && SHOW_ERROR_LINE +#if SHOW_ERROR_LINE pointer filename; pointer lineno; #endif sc->nesting_stack[sc->file_i]++; -#if USE_TAGS && SHOW_ERROR_LINE +#if SHOW_ERROR_LINE filename = sc->load_stack[sc->file_i].filename; lineno = sc->load_stack[sc->file_i].curr_line; @@ -4989,7 +5097,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"undefined sharp expression"); } else { sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } case TOK_SHARP_CONST: @@ -5066,14 +5174,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { CASE(OP_RDVEC): /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_goto(sc,OP_EVAL); Cannot be quoted*/ + s_thread_to(sc,OP_EVAL); Cannot be quoted*/ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); s_return(sc,x); Cannot be part of pairs*/ /*sc->code=mk_proc(sc,OP_VECTOR); sc->args=sc->value; - s_goto(sc,OP_APPLY);*/ + s_thread_to(sc,OP_APPLY);*/ sc->args=sc->value; - s_goto(sc,OP_VECTOR); + s_thread_to(sc,OP_VECTOR); /* ========== printing part ========== */ CASE(OP_P0LIST): @@ -5137,7 +5245,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->T); } else { pointer elem=vector_elem(vec,i); - ivalue_unchecked(cdr(sc->args))=i+1; + cdr(sc->args) = mk_integer(sc, i + 1); s_save(sc,OP_PVECFROM, sc->args, sc->NIL); sc->args=elem; if (i > 0) @@ -5146,27 +5254,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - - } - return sc->T; -} - -static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - long v; - - switch (op) { - CASE(OP_LIST_LENGTH): /* length */ /* a.k */ - v=list_length(sc,car(sc->args)); - if(v<0) { + CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ + long l = list_length(sc, car(sc->args)); + if(l<0) { Error_1(sc,"length: not a list:",car(sc->args)); } gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, v)); - + s_return_enable_gc(sc, mk_integer(sc, l)); + } CASE(OP_ASSQ): /* assq */ /* a.k */ x = car(sc->args); for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { @@ -5209,14 +5304,12 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { CASE(OP_VM_HISTORY): /* *vm-history* */ s_return(sc, history_flatten(sc)); default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); Error_0(sc,sc->strbuff); } - return sc->T; /* NOTREACHED */ + } } -typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); - typedef int (*test_predicate)(pointer); static int is_any(pointer p) { @@ -5229,7 +5322,7 @@ static int is_nonneg(pointer p) { } /* Correspond carefully with following defines! */ -static struct { +static const struct { test_predicate fct; const char *kind; } tests[]={ @@ -5266,119 +5359,110 @@ static struct { #define TST_INTEGER "\015" #define TST_NATURAL "\016" -typedef struct { - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char *arg_tests_encoding; -} op_code_info; - -#define INF_ARG 0xffff +#define INF_ARG 0xff -static op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, +static const struct op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, #include "opdefines.h" - { 0 } +#undef _OP_DEF + {{0},0,0,{0}}, }; static const char *procname(pointer x) { int n=procnum(x); const char *name=dispatch_table[n].name; - if(name==0) { + if (name[0] == 0) { name="ILLEGAL!"; } return name; } -/* kernel of this interpreter */ -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - sc->op = op; - for (;;) { - op_code_info *pcd=dispatch_table+sc->op; - if (pcd->name!=0) { /* if built-in function, check arguments */ - char msg[STRBUFFSIZE]; - int ok=1; - int n=list_length(sc,sc->args); - - /* Check number of arguments */ - if(n<pcd->min_arity) { - ok=0; - snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at least", - pcd->min_arity); - } - if(ok && n>pcd->max_arity) { - ok=0; - snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at most", - pcd->max_arity); - } - if(ok) { - if(pcd->arg_tests_encoding!=0) { - int i=0; - int j; - const char *t=pcd->arg_tests_encoding; - pointer arglist=sc->args; - do { - pointer arg=car(arglist); - j=(int)t[0]; - if(j==TST_LIST[0]) { - if(arg!=sc->NIL && !is_pair(arg)) break; - } else { - if(!tests[j].fct(arg)) break; - } +static int +check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) +{ + int ok = 1; + int n = list_length(sc, sc->args); + + /* Check number of arguments */ + if (n < pcd->min_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at least", + pcd->min_arity); + } + if (ok && n>pcd->max_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at most", + pcd->max_arity); + } + if (ok) { + if (pcd->arg_tests_encoding[0] != 0) { + int i = 0; + int j; + const char *t = pcd->arg_tests_encoding; + pointer arglist = sc->args; + + do { + pointer arg = car(arglist); + j = (int)t[0]; + if (j == TST_LIST[0]) { + if (arg != sc->NIL && !is_pair(arg)) break; + } else { + if (!tests[j].fct(arg)) break; + } - if(t[1]!=0) {/* last test is replicated as necessary */ - t++; - } - arglist=cdr(arglist); - i++; - } while(i<n); - if(i<n) { - ok=0; - snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s", - pcd->name, - i+1, - tests[j].kind, - type_to_string(type(car(arglist)))); - } - } - } - if(!ok) { - if(_Error_1(sc,msg,0)==sc->NIL) { - return; - } - pcd=dispatch_table+sc->op; + if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { + /* last test is replicated as necessary */ + t++; + } + arglist = cdr(arglist); + i++; + } while (i < n); + + if (i < n) { + ok = 0; + snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", + pcd->name, + i + 1, + tests[j].kind, + type_to_string(type(car(arglist)))); } } - ok_to_freely_gc(sc); - if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { - return; - } - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - exit(1); - } } + + return ok; } /* ========== Initialization of internal keywords ========== */ -static void assign_syntax(scheme *sc, char *name) { - pointer x; +/* Symbols representing syntax are tagged with (OP . '()). */ +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; pointer *slot; x = oblist_find_by_name(sc, name, &slot); assert (x == sc->NIL); - x = oblist_add_by_name(sc, name, slot); - typeflag(x) |= T_SYNTAX; + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL | T_SYNTAX; + setimmutable(car(x)); + y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); + free_cell(sc, x); + setimmutable(get_tag(sc, y)); + *slot = immutable_cons(sc, y, *slot); +} + +/* Returns the opcode for the syntax represented by P. */ +static int syntaxnum(scheme *sc, pointer p) { + int op = ivalue_unchecked(car(get_tag(sc, p))); + assert (op < OP_MAXDEFINED); + return op; } -static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { +static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { pointer x, y; x = mk_symbol(sc, name); @@ -5396,41 +5480,6 @@ static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { return y; } -/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ -static int syntaxnum(pointer p) { - const char *s=strvalue(car(p)); - switch(strlength(car(p))) { - case 2: - if(s[0]=='i') return OP_IF0; /* if */ - else return OP_OR0; /* or */ - case 3: - if(s[0]=='a') return OP_AND0; /* and */ - else return OP_LET0; /* let */ - case 4: - switch(s[3]) { - case 'e': return OP_CASE0; /* case */ - case 'd': return OP_COND0; /* cond */ - case '*': return OP_LET0AST; /* let* */ - default: return OP_SET0; /* set! */ - } - case 5: - switch(s[2]) { - case 'g': return OP_BEGIN; /* begin */ - case 'l': return OP_DELAY; /* delay */ - case 'c': return OP_MACRO0; /* macro */ - default: return OP_QUOTE; /* quote */ - } - case 6: - switch(s[2]) { - case 'm': return OP_LAMBDA; /* lambda */ - case 'f': return OP_DEF0; /* define */ - default: return OP_LET0REC; /* letrec */ - } - default: - return OP_C0STREAM; /* cons-stream */ - } -} - /* initialization of TinyScheme */ #if USE_INTERFACE INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { @@ -5440,7 +5489,7 @@ INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { return immutable_cons(sc,a,b); } -static struct scheme_interface vtbl ={ +static const struct scheme_interface vtbl = { scheme_define, s_cons, s_immutable_cons, @@ -5537,31 +5586,18 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); pointer x; - num_zero.is_fixnum=1; - num_zero.value.ivalue=0; - num_one.is_fixnum=1; - num_one.value.ivalue=1; - #if USE_INTERFACE sc->vptr=&vtbl; #endif sc->gensym_cnt=0; sc->malloc=malloc; sc->free=free; - sc->last_cell_seg = -1; sc->sink = &sc->_sink; sc->NIL = &sc->_NIL; sc->T = &sc->_HASHT; sc->F = &sc->_HASHF; sc->EOF_OBJ=&sc->_EOF_OBJ; -#if USE_SMALL_INTEGERS - if (initialize_small_integers(sc)) { - sc->no_memory=1; - return 0; - } -#endif - sc->free_cell = &sc->_NIL; sc->fcells = 0; sc->inhibit_gc = GC_ENABLED; @@ -5582,6 +5618,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { } sc->strbuff_size = STRBUFFSIZE; + sc->cell_segments = NULL; if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { sc->no_memory=1; return 0; @@ -5590,7 +5627,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { dump_stack_initialize(sc); sc->code = sc->NIL; sc->tracing=0; - sc->op = -1; sc->flags = 0; /* init sc->NIL */ @@ -5619,25 +5655,25 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { x = mk_symbol(sc,"else"); new_slot_in_env(sc, x, sc->T); - assign_syntax(sc, "lambda"); - assign_syntax(sc, "quote"); - assign_syntax(sc, "define"); - assign_syntax(sc, "if"); - assign_syntax(sc, "begin"); - assign_syntax(sc, "set!"); - assign_syntax(sc, "let"); - assign_syntax(sc, "let*"); - assign_syntax(sc, "letrec"); - assign_syntax(sc, "cond"); - assign_syntax(sc, "delay"); - assign_syntax(sc, "and"); - assign_syntax(sc, "or"); - assign_syntax(sc, "cons-stream"); - assign_syntax(sc, "macro"); - assign_syntax(sc, "case"); + assign_syntax(sc, OP_LAMBDA, "lambda"); + assign_syntax(sc, OP_QUOTE, "quote"); + assign_syntax(sc, OP_DEF0, "define"); + assign_syntax(sc, OP_IF0, "if"); + assign_syntax(sc, OP_BEGIN, "begin"); + assign_syntax(sc, OP_SET0, "set!"); + assign_syntax(sc, OP_LET0, "let"); + assign_syntax(sc, OP_LET0AST, "let*"); + assign_syntax(sc, OP_LET0REC, "letrec"); + assign_syntax(sc, OP_COND0, "cond"); + assign_syntax(sc, OP_DELAY, "delay"); + assign_syntax(sc, OP_AND0, "and"); + assign_syntax(sc, OP_OR0, "or"); + assign_syntax(sc, OP_C0STREAM, "cons-stream"); + assign_syntax(sc, OP_MACRO0, "macro"); + assign_syntax(sc, OP_CASE0, "case"); for(i=0; i<n; i++) { - if(dispatch_table[i].name!=0) { + if (dispatch_table[i].name[0] != 0) { assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name); } } @@ -5682,6 +5718,7 @@ void scheme_set_external_data(scheme *sc, void *p) { } void scheme_deinit(scheme *sc) { + struct cell_segment *s; int i; sc->oblist=sc->NIL; @@ -5713,12 +5750,8 @@ void scheme_deinit(scheme *sc) { sc->gc_verbose=0; gc(sc,sc->NIL,sc->NIL); -#if USE_SMALL_INTEGERS - sc->free(sc->integer_alloc); -#endif - - for(i=0; i<=sc->last_cell_seg; i++) { - sc->free(sc->alloc_seg[i]); + for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { + /* nop */ } sc->free(sc->strbuff); } @@ -5755,14 +5788,18 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { } void scheme_load_string(scheme *sc, const char *cmd) { + scheme_load_memory(sc, cmd, strlen(cmd), NULL); +} + +void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { dump_stack_reset(sc); sc->envir = sc->global_env; sc->file_i=0; sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); - sc->load_stack[0].rep.string.curr=(char*)cmd; - port_init_location(sc, &sc->load_stack[0], NULL); + sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; + sc->load_stack[0].rep.string.curr = (char *) buf; + port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); sc->loadport=mk_port(sc,sc->load_stack); sc->retcode=0; sc->interactive_repl=0; diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h index 8560f7d..6f917da 100644 --- a/tests/gpgscm/scheme.h +++ b/tests/gpgscm/scheme.h @@ -44,7 +44,6 @@ extern "C" { # define USE_DL 0 # define USE_PLIST 0 # define USE_SMALL_INTEGERS 0 -# define USE_TAGS 0 # define USE_HISTORY 0 #endif @@ -78,11 +77,6 @@ extern "C" { # define USE_PLIST 0 #endif -/* If set, then every object can be tagged. */ -#ifndef USE_TAGS -# define USE_TAGS 1 -#endif - /* Keep a history of function calls. This enables a feature similar * to stack traces. */ #ifndef USE_HISTORY @@ -173,6 +167,8 @@ void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); +SCHEME_EXPORT void scheme_load_memory(scheme *sc, const char *buf, size_t len, + const char *filename); SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); diff --git a/tests/gpgscm/small-integers.h b/tests/gpgscm/small-integers.h new file mode 100644 index 0000000..46eda34 --- /dev/null +++ b/tests/gpgscm/small-integers.h @@ -0,0 +1,847 @@ +/* Constant integer objects for TinySCHEME. + * + * Copyright (C) 2017 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG 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. + * + * GnuPG 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 this program; if not, see <https://www.gnu.org/licenses/>. + */ + +/* + * Ohne Worte. Generated using: + * + * $ n=0; while read line ; do \ + * echo "DEFINE_INTEGER($n)" ; \ + * n="$(expr $n + 1)" ; \ + * done <./init.scm >> small-integers.h + */ + +DEFINE_INTEGER(0) +DEFINE_INTEGER(1) +DEFINE_INTEGER(2) +DEFINE_INTEGER(3) +DEFINE_INTEGER(4) +DEFINE_INTEGER(5) +DEFINE_INTEGER(6) +DEFINE_INTEGER(7) +DEFINE_INTEGER(8) +DEFINE_INTEGER(9) +DEFINE_INTEGER(10) +DEFINE_INTEGER(11) +DEFINE_INTEGER(12) +DEFINE_INTEGER(13) +DEFINE_INTEGER(14) +DEFINE_INTEGER(15) +DEFINE_INTEGER(16) +DEFINE_INTEGER(17) +DEFINE_INTEGER(18) +DEFINE_INTEGER(19) +DEFINE_INTEGER(20) +DEFINE_INTEGER(21) +DEFINE_INTEGER(22) +DEFINE_INTEGER(23) +DEFINE_INTEGER(24) +DEFINE_INTEGER(25) +DEFINE_INTEGER(26) +DEFINE_INTEGER(27) +DEFINE_INTEGER(28) +DEFINE_INTEGER(29) +DEFINE_INTEGER(30) +DEFINE_INTEGER(31) +DEFINE_INTEGER(32) +DEFINE_INTEGER(33) +DEFINE_INTEGER(34) +DEFINE_INTEGER(35) +DEFINE_INTEGER(36) +DEFINE_INTEGER(37) +DEFINE_INTEGER(38) +DEFINE_INTEGER(39) +DEFINE_INTEGER(40) +DEFINE_INTEGER(41) +DEFINE_INTEGER(42) +DEFINE_INTEGER(43) +DEFINE_INTEGER(44) +DEFINE_INTEGER(45) +DEFINE_INTEGER(46) +DEFINE_INTEGER(47) +DEFINE_INTEGER(48) +DEFINE_INTEGER(49) +DEFINE_INTEGER(50) +DEFINE_INTEGER(51) +DEFINE_INTEGER(52) +DEFINE_INTEGER(53) +DEFINE_INTEGER(54) +DEFINE_INTEGER(55) +DEFINE_INTEGER(56) +DEFINE_INTEGER(57) +DEFINE_INTEGER(58) +DEFINE_INTEGER(59) +DEFINE_INTEGER(60) +DEFINE_INTEGER(61) +DEFINE_INTEGER(62) +DEFINE_INTEGER(63) +DEFINE_INTEGER(64) +DEFINE_INTEGER(65) +DEFINE_INTEGER(66) +DEFINE_INTEGER(67) +DEFINE_INTEGER(68) +DEFINE_INTEGER(69) +DEFINE_INTEGER(70) +DEFINE_INTEGER(71) +DEFINE_INTEGER(72) +DEFINE_INTEGER(73) +DEFINE_INTEGER(74) +DEFINE_INTEGER(75) +DEFINE_INTEGER(76) +DEFINE_INTEGER(77) +DEFINE_INTEGER(78) +DEFINE_INTEGER(79) +DEFINE_INTEGER(80) +DEFINE_INTEGER(81) +DEFINE_INTEGER(82) +DEFINE_INTEGER(83) +DEFINE_INTEGER(84) +DEFINE_INTEGER(85) +DEFINE_INTEGER(86) +DEFINE_INTEGER(87) +DEFINE_INTEGER(88) +DEFINE_INTEGER(89) +DEFINE_INTEGER(90) +DEFINE_INTEGER(91) +DEFINE_INTEGER(92) +DEFINE_INTEGER(93) +DEFINE_INTEGER(94) +DEFINE_INTEGER(95) +DEFINE_INTEGER(96) +DEFINE_INTEGER(97) +DEFINE_INTEGER(98) +DEFINE_INTEGER(99) +DEFINE_INTEGER(100) +DEFINE_INTEGER(101) +DEFINE_INTEGER(102) +DEFINE_INTEGER(103) +DEFINE_INTEGER(104) +DEFINE_INTEGER(105) +DEFINE_INTEGER(106) +DEFINE_INTEGER(107) +DEFINE_INTEGER(108) +DEFINE_INTEGER(109) +DEFINE_INTEGER(110) +DEFINE_INTEGER(111) +DEFINE_INTEGER(112) +DEFINE_INTEGER(113) +DEFINE_INTEGER(114) +DEFINE_INTEGER(115) +DEFINE_INTEGER(116) +DEFINE_INTEGER(117) +DEFINE_INTEGER(118) +DEFINE_INTEGER(119) +DEFINE_INTEGER(120) +DEFINE_INTEGER(121) +DEFINE_INTEGER(122) +DEFINE_INTEGER(123) +DEFINE_INTEGER(124) +DEFINE_INTEGER(125) +DEFINE_INTEGER(126) +DEFINE_INTEGER(127) +DEFINE_INTEGER(128) +DEFINE_INTEGER(129) +DEFINE_INTEGER(130) +DEFINE_INTEGER(131) +DEFINE_INTEGER(132) +DEFINE_INTEGER(133) +DEFINE_INTEGER(134) +DEFINE_INTEGER(135) +DEFINE_INTEGER(136) +DEFINE_INTEGER(137) +DEFINE_INTEGER(138) +DEFINE_INTEGER(139) +DEFINE_INTEGER(140) +DEFINE_INTEGER(141) +DEFINE_INTEGER(142) +DEFINE_INTEGER(143) +DEFINE_INTEGER(144) +DEFINE_INTEGER(145) +DEFINE_INTEGER(146) +DEFINE_INTEGER(147) +DEFINE_INTEGER(148) +DEFINE_INTEGER(149) +DEFINE_INTEGER(150) +DEFINE_INTEGER(151) +DEFINE_INTEGER(152) +DEFINE_INTEGER(153) +DEFINE_INTEGER(154) +DEFINE_INTEGER(155) +DEFINE_INTEGER(156) +DEFINE_INTEGER(157) +DEFINE_INTEGER(158) +DEFINE_INTEGER(159) +DEFINE_INTEGER(160) +DEFINE_INTEGER(161) +DEFINE_INTEGER(162) +DEFINE_INTEGER(163) +DEFINE_INTEGER(164) +DEFINE_INTEGER(165) +DEFINE_INTEGER(166) +DEFINE_INTEGER(167) +DEFINE_INTEGER(168) +DEFINE_INTEGER(169) +DEFINE_INTEGER(170) +DEFINE_INTEGER(171) +DEFINE_INTEGER(172) +DEFINE_INTEGER(173) +DEFINE_INTEGER(174) +DEFINE_INTEGER(175) +DEFINE_INTEGER(176) +DEFINE_INTEGER(177) +DEFINE_INTEGER(178) +DEFINE_INTEGER(179) +DEFINE_INTEGER(180) +DEFINE_INTEGER(181) +DEFINE_INTEGER(182) +DEFINE_INTEGER(183) +DEFINE_INTEGER(184) +DEFINE_INTEGER(185) +DEFINE_INTEGER(186) +DEFINE_INTEGER(187) +DEFINE_INTEGER(188) +DEFINE_INTEGER(189) +DEFINE_INTEGER(190) +DEFINE_INTEGER(191) +DEFINE_INTEGER(192) +DEFINE_INTEGER(193) +DEFINE_INTEGER(194) +DEFINE_INTEGER(195) +DEFINE_INTEGER(196) +DEFINE_INTEGER(197) +DEFINE_INTEGER(198) +DEFINE_INTEGER(199) +DEFINE_INTEGER(200) +DEFINE_INTEGER(201) +DEFINE_INTEGER(202) +DEFINE_INTEGER(203) +DEFINE_INTEGER(204) +DEFINE_INTEGER(205) +DEFINE_INTEGER(206) +DEFINE_INTEGER(207) +DEFINE_INTEGER(208) +DEFINE_INTEGER(209) +DEFINE_INTEGER(210) +DEFINE_INTEGER(211) +DEFINE_INTEGER(212) +DEFINE_INTEGER(213) +DEFINE_INTEGER(214) +DEFINE_INTEGER(215) +DEFINE_INTEGER(216) +DEFINE_INTEGER(217) +DEFINE_INTEGER(218) +DEFINE_INTEGER(219) +DEFINE_INTEGER(220) +DEFINE_INTEGER(221) +DEFINE_INTEGER(222) +DEFINE_INTEGER(223) +DEFINE_INTEGER(224) +DEFINE_INTEGER(225) +DEFINE_INTEGER(226) +DEFINE_INTEGER(227) +DEFINE_INTEGER(228) +DEFINE_INTEGER(229) +DEFINE_INTEGER(230) +DEFINE_INTEGER(231) +DEFINE_INTEGER(232) +DEFINE_INTEGER(233) +DEFINE_INTEGER(234) +DEFINE_INTEGER(235) +DEFINE_INTEGER(236) +DEFINE_INTEGER(237) +DEFINE_INTEGER(238) +DEFINE_INTEGER(239) +DEFINE_INTEGER(240) +DEFINE_INTEGER(241) +DEFINE_INTEGER(242) +DEFINE_INTEGER(243) +DEFINE_INTEGER(244) +DEFINE_INTEGER(245) +DEFINE_INTEGER(246) +DEFINE_INTEGER(247) +DEFINE_INTEGER(248) +DEFINE_INTEGER(249) +DEFINE_INTEGER(250) +DEFINE_INTEGER(251) +DEFINE_INTEGER(252) +DEFINE_INTEGER(253) +DEFINE_INTEGER(254) +DEFINE_INTEGER(255) +DEFINE_INTEGER(256) +DEFINE_INTEGER(257) +DEFINE_INTEGER(258) +DEFINE_INTEGER(259) +DEFINE_INTEGER(260) +DEFINE_INTEGER(261) +DEFINE_INTEGER(262) +DEFINE_INTEGER(263) +DEFINE_INTEGER(264) +DEFINE_INTEGER(265) +DEFINE_INTEGER(266) +DEFINE_INTEGER(267) +DEFINE_INTEGER(268) +DEFINE_INTEGER(269) +DEFINE_INTEGER(270) +DEFINE_INTEGER(271) +DEFINE_INTEGER(272) +DEFINE_INTEGER(273) +DEFINE_INTEGER(274) +DEFINE_INTEGER(275) +DEFINE_INTEGER(276) +DEFINE_INTEGER(277) +DEFINE_INTEGER(278) +DEFINE_INTEGER(279) +DEFINE_INTEGER(280) +DEFINE_INTEGER(281) +DEFINE_INTEGER(282) +DEFINE_INTEGER(283) +DEFINE_INTEGER(284) +DEFINE_INTEGER(285) +DEFINE_INTEGER(286) +DEFINE_INTEGER(287) +DEFINE_INTEGER(288) +DEFINE_INTEGER(289) +DEFINE_INTEGER(290) +DEFINE_INTEGER(291) +DEFINE_INTEGER(292) +DEFINE_INTEGER(293) +DEFINE_INTEGER(294) +DEFINE_INTEGER(295) +DEFINE_INTEGER(296) +DEFINE_INTEGER(297) +DEFINE_INTEGER(298) +DEFINE_INTEGER(299) +DEFINE_INTEGER(300) +DEFINE_INTEGER(301) +DEFINE_INTEGER(302) +DEFINE_INTEGER(303) +DEFINE_INTEGER(304) +DEFINE_INTEGER(305) +DEFINE_INTEGER(306) +DEFINE_INTEGER(307) +DEFINE_INTEGER(308) +DEFINE_INTEGER(309) +DEFINE_INTEGER(310) +DEFINE_INTEGER(311) +DEFINE_INTEGER(312) +DEFINE_INTEGER(313) +DEFINE_INTEGER(314) +DEFINE_INTEGER(315) +DEFINE_INTEGER(316) +DEFINE_INTEGER(317) +DEFINE_INTEGER(318) +DEFINE_INTEGER(319) +DEFINE_INTEGER(320) +DEFINE_INTEGER(321) +DEFINE_INTEGER(322) +DEFINE_INTEGER(323) +DEFINE_INTEGER(324) +DEFINE_INTEGER(325) +DEFINE_INTEGER(326) +DEFINE_INTEGER(327) +DEFINE_INTEGER(328) +DEFINE_INTEGER(329) +DEFINE_INTEGER(330) +DEFINE_INTEGER(331) +DEFINE_INTEGER(332) +DEFINE_INTEGER(333) +DEFINE_INTEGER(334) +DEFINE_INTEGER(335) +DEFINE_INTEGER(336) +DEFINE_INTEGER(337) +DEFINE_INTEGER(338) +DEFINE_INTEGER(339) +DEFINE_INTEGER(340) +DEFINE_INTEGER(341) +DEFINE_INTEGER(342) +DEFINE_INTEGER(343) +DEFINE_INTEGER(344) +DEFINE_INTEGER(345) +DEFINE_INTEGER(346) +DEFINE_INTEGER(347) +DEFINE_INTEGER(348) +DEFINE_INTEGER(349) +DEFINE_INTEGER(350) +DEFINE_INTEGER(351) +DEFINE_INTEGER(352) +DEFINE_INTEGER(353) +DEFINE_INTEGER(354) +DEFINE_INTEGER(355) +DEFINE_INTEGER(356) +DEFINE_INTEGER(357) +DEFINE_INTEGER(358) +DEFINE_INTEGER(359) +DEFINE_INTEGER(360) +DEFINE_INTEGER(361) +DEFINE_INTEGER(362) +DEFINE_INTEGER(363) +DEFINE_INTEGER(364) +DEFINE_INTEGER(365) +DEFINE_INTEGER(366) +DEFINE_INTEGER(367) +DEFINE_INTEGER(368) +DEFINE_INTEGER(369) +DEFINE_INTEGER(370) +DEFINE_INTEGER(371) +DEFINE_INTEGER(372) +DEFINE_INTEGER(373) +DEFINE_INTEGER(374) +DEFINE_INTEGER(375) +DEFINE_INTEGER(376) +DEFINE_INTEGER(377) +DEFINE_INTEGER(378) +DEFINE_INTEGER(379) +DEFINE_INTEGER(380) +DEFINE_INTEGER(381) +DEFINE_INTEGER(382) +DEFINE_INTEGER(383) +DEFINE_INTEGER(384) +DEFINE_INTEGER(385) +DEFINE_INTEGER(386) +DEFINE_INTEGER(387) +DEFINE_INTEGER(388) +DEFINE_INTEGER(389) +DEFINE_INTEGER(390) +DEFINE_INTEGER(391) +DEFINE_INTEGER(392) +DEFINE_INTEGER(393) +DEFINE_INTEGER(394) +DEFINE_INTEGER(395) +DEFINE_INTEGER(396) +DEFINE_INTEGER(397) +DEFINE_INTEGER(398) +DEFINE_INTEGER(399) +DEFINE_INTEGER(400) +DEFINE_INTEGER(401) +DEFINE_INTEGER(402) +DEFINE_INTEGER(403) +DEFINE_INTEGER(404) +DEFINE_INTEGER(405) +DEFINE_INTEGER(406) +DEFINE_INTEGER(407) +DEFINE_INTEGER(408) +DEFINE_INTEGER(409) +DEFINE_INTEGER(410) +DEFINE_INTEGER(411) +DEFINE_INTEGER(412) +DEFINE_INTEGER(413) +DEFINE_INTEGER(414) +DEFINE_INTEGER(415) +DEFINE_INTEGER(416) +DEFINE_INTEGER(417) +DEFINE_INTEGER(418) +DEFINE_INTEGER(419) +DEFINE_INTEGER(420) +DEFINE_INTEGER(421) +DEFINE_INTEGER(422) +DEFINE_INTEGER(423) +DEFINE_INTEGER(424) +DEFINE_INTEGER(425) +DEFINE_INTEGER(426) +DEFINE_INTEGER(427) +DEFINE_INTEGER(428) +DEFINE_INTEGER(429) +DEFINE_INTEGER(430) +DEFINE_INTEGER(431) +DEFINE_INTEGER(432) +DEFINE_INTEGER(433) +DEFINE_INTEGER(434) +DEFINE_INTEGER(435) +DEFINE_INTEGER(436) +DEFINE_INTEGER(437) +DEFINE_INTEGER(438) +DEFINE_INTEGER(439) +DEFINE_INTEGER(440) +DEFINE_INTEGER(441) +DEFINE_INTEGER(442) +DEFINE_INTEGER(443) +DEFINE_INTEGER(444) +DEFINE_INTEGER(445) +DEFINE_INTEGER(446) +DEFINE_INTEGER(447) +DEFINE_INTEGER(448) +DEFINE_INTEGER(449) +DEFINE_INTEGER(450) +DEFINE_INTEGER(451) +DEFINE_INTEGER(452) +DEFINE_INTEGER(453) +DEFINE_INTEGER(454) +DEFINE_INTEGER(455) +DEFINE_INTEGER(456) +DEFINE_INTEGER(457) +DEFINE_INTEGER(458) +DEFINE_INTEGER(459) +DEFINE_INTEGER(460) +DEFINE_INTEGER(461) +DEFINE_INTEGER(462) +DEFINE_INTEGER(463) +DEFINE_INTEGER(464) +DEFINE_INTEGER(465) +DEFINE_INTEGER(466) +DEFINE_INTEGER(467) +DEFINE_INTEGER(468) +DEFINE_INTEGER(469) +DEFINE_INTEGER(470) +DEFINE_INTEGER(471) +DEFINE_INTEGER(472) +DEFINE_INTEGER(473) +DEFINE_INTEGER(474) +DEFINE_INTEGER(475) +DEFINE_INTEGER(476) +DEFINE_INTEGER(477) +DEFINE_INTEGER(478) +DEFINE_INTEGER(479) +DEFINE_INTEGER(480) +DEFINE_INTEGER(481) +DEFINE_INTEGER(482) +DEFINE_INTEGER(483) +DEFINE_INTEGER(484) +DEFINE_INTEGER(485) +DEFINE_INTEGER(486) +DEFINE_INTEGER(487) +DEFINE_INTEGER(488) +DEFINE_INTEGER(489) +DEFINE_INTEGER(490) +DEFINE_INTEGER(491) +DEFINE_INTEGER(492) +DEFINE_INTEGER(493) +DEFINE_INTEGER(494) +DEFINE_INTEGER(495) +DEFINE_INTEGER(496) +DEFINE_INTEGER(497) +DEFINE_INTEGER(498) +DEFINE_INTEGER(499) +DEFINE_INTEGER(500) +DEFINE_INTEGER(501) +DEFINE_INTEGER(502) +DEFINE_INTEGER(503) +DEFINE_INTEGER(504) +DEFINE_INTEGER(505) +DEFINE_INTEGER(506) +DEFINE_INTEGER(507) +DEFINE_INTEGER(508) +DEFINE_INTEGER(509) +DEFINE_INTEGER(510) +DEFINE_INTEGER(511) +DEFINE_INTEGER(512) +DEFINE_INTEGER(513) +DEFINE_INTEGER(514) +DEFINE_INTEGER(515) +DEFINE_INTEGER(516) +DEFINE_INTEGER(517) +DEFINE_INTEGER(518) +DEFINE_INTEGER(519) +DEFINE_INTEGER(520) +DEFINE_INTEGER(521) +DEFINE_INTEGER(522) +DEFINE_INTEGER(523) +DEFINE_INTEGER(524) +DEFINE_INTEGER(525) +DEFINE_INTEGER(526) +DEFINE_INTEGER(527) +DEFINE_INTEGER(528) +DEFINE_INTEGER(529) +DEFINE_INTEGER(530) +DEFINE_INTEGER(531) +DEFINE_INTEGER(532) +DEFINE_INTEGER(533) +DEFINE_INTEGER(534) +DEFINE_INTEGER(535) +DEFINE_INTEGER(536) +DEFINE_INTEGER(537) +DEFINE_INTEGER(538) +DEFINE_INTEGER(539) +DEFINE_INTEGER(540) +DEFINE_INTEGER(541) +DEFINE_INTEGER(542) +DEFINE_INTEGER(543) +DEFINE_INTEGER(544) +DEFINE_INTEGER(545) +DEFINE_INTEGER(546) +DEFINE_INTEGER(547) +DEFINE_INTEGER(548) +DEFINE_INTEGER(549) +DEFINE_INTEGER(550) +DEFINE_INTEGER(551) +DEFINE_INTEGER(552) +DEFINE_INTEGER(553) +DEFINE_INTEGER(554) +DEFINE_INTEGER(555) +DEFINE_INTEGER(556) +DEFINE_INTEGER(557) +DEFINE_INTEGER(558) +DEFINE_INTEGER(559) +DEFINE_INTEGER(560) +DEFINE_INTEGER(561) +DEFINE_INTEGER(562) +DEFINE_INTEGER(563) +DEFINE_INTEGER(564) +DEFINE_INTEGER(565) +DEFINE_INTEGER(566) +DEFINE_INTEGER(567) +DEFINE_INTEGER(568) +DEFINE_INTEGER(569) +DEFINE_INTEGER(570) +DEFINE_INTEGER(571) +DEFINE_INTEGER(572) +DEFINE_INTEGER(573) +DEFINE_INTEGER(574) +DEFINE_INTEGER(575) +DEFINE_INTEGER(576) +DEFINE_INTEGER(577) +DEFINE_INTEGER(578) +DEFINE_INTEGER(579) +DEFINE_INTEGER(580) +DEFINE_INTEGER(581) +DEFINE_INTEGER(582) +DEFINE_INTEGER(583) +DEFINE_INTEGER(584) +DEFINE_INTEGER(585) +DEFINE_INTEGER(586) +DEFINE_INTEGER(587) +DEFINE_INTEGER(588) +DEFINE_INTEGER(589) +DEFINE_INTEGER(590) +DEFINE_INTEGER(591) +DEFINE_INTEGER(592) +DEFINE_INTEGER(593) +DEFINE_INTEGER(594) +DEFINE_INTEGER(595) +DEFINE_INTEGER(596) +DEFINE_INTEGER(597) +DEFINE_INTEGER(598) +DEFINE_INTEGER(599) +DEFINE_INTEGER(600) +DEFINE_INTEGER(601) +DEFINE_INTEGER(602) +DEFINE_INTEGER(603) +DEFINE_INTEGER(604) +DEFINE_INTEGER(605) +DEFINE_INTEGER(606) +DEFINE_INTEGER(607) +DEFINE_INTEGER(608) +DEFINE_INTEGER(609) +DEFINE_INTEGER(610) +DEFINE_INTEGER(611) +DEFINE_INTEGER(612) +DEFINE_INTEGER(613) +DEFINE_INTEGER(614) +DEFINE_INTEGER(615) +DEFINE_INTEGER(616) +DEFINE_INTEGER(617) +DEFINE_INTEGER(618) +DEFINE_INTEGER(619) +DEFINE_INTEGER(620) +DEFINE_INTEGER(621) +DEFINE_INTEGER(622) +DEFINE_INTEGER(623) +DEFINE_INTEGER(624) +DEFINE_INTEGER(625) +DEFINE_INTEGER(626) +DEFINE_INTEGER(627) +DEFINE_INTEGER(628) +DEFINE_INTEGER(629) +DEFINE_INTEGER(630) +DEFINE_INTEGER(631) +DEFINE_INTEGER(632) +DEFINE_INTEGER(633) +DEFINE_INTEGER(634) +DEFINE_INTEGER(635) +DEFINE_INTEGER(636) +DEFINE_INTEGER(637) +DEFINE_INTEGER(638) +DEFINE_INTEGER(639) +DEFINE_INTEGER(640) +DEFINE_INTEGER(641) +DEFINE_INTEGER(642) +DEFINE_INTEGER(643) +DEFINE_INTEGER(644) +DEFINE_INTEGER(645) +DEFINE_INTEGER(646) +DEFINE_INTEGER(647) +DEFINE_INTEGER(648) +DEFINE_INTEGER(649) +DEFINE_INTEGER(650) +DEFINE_INTEGER(651) +DEFINE_INTEGER(652) +DEFINE_INTEGER(653) +DEFINE_INTEGER(654) +DEFINE_INTEGER(655) +DEFINE_INTEGER(656) +DEFINE_INTEGER(657) +DEFINE_INTEGER(658) +DEFINE_INTEGER(659) +DEFINE_INTEGER(660) +DEFINE_INTEGER(661) +DEFINE_INTEGER(662) +DEFINE_INTEGER(663) +DEFINE_INTEGER(664) +DEFINE_INTEGER(665) +DEFINE_INTEGER(666) +DEFINE_INTEGER(667) +DEFINE_INTEGER(668) +DEFINE_INTEGER(669) +DEFINE_INTEGER(670) +DEFINE_INTEGER(671) +DEFINE_INTEGER(672) +DEFINE_INTEGER(673) +DEFINE_INTEGER(674) +DEFINE_INTEGER(675) +DEFINE_INTEGER(676) +DEFINE_INTEGER(677) +DEFINE_INTEGER(678) +DEFINE_INTEGER(679) +DEFINE_INTEGER(680) +DEFINE_INTEGER(681) +DEFINE_INTEGER(682) +DEFINE_INTEGER(683) +DEFINE_INTEGER(684) +DEFINE_INTEGER(685) +DEFINE_INTEGER(686) +DEFINE_INTEGER(687) +DEFINE_INTEGER(688) +DEFINE_INTEGER(689) +DEFINE_INTEGER(690) +DEFINE_INTEGER(691) +DEFINE_INTEGER(692) +DEFINE_INTEGER(693) +DEFINE_INTEGER(694) +DEFINE_INTEGER(695) +DEFINE_INTEGER(696) +DEFINE_INTEGER(697) +DEFINE_INTEGER(698) +DEFINE_INTEGER(699) +DEFINE_INTEGER(700) +DEFINE_INTEGER(701) +DEFINE_INTEGER(702) +DEFINE_INTEGER(703) +DEFINE_INTEGER(704) +DEFINE_INTEGER(705) +DEFINE_INTEGER(706) +DEFINE_INTEGER(707) +DEFINE_INTEGER(708) +DEFINE_INTEGER(709) +DEFINE_INTEGER(710) +DEFINE_INTEGER(711) +DEFINE_INTEGER(712) +DEFINE_INTEGER(713) +DEFINE_INTEGER(714) +DEFINE_INTEGER(715) +DEFINE_INTEGER(716) +DEFINE_INTEGER(717) +DEFINE_INTEGER(718) +DEFINE_INTEGER(719) +DEFINE_INTEGER(720) +DEFINE_INTEGER(721) +DEFINE_INTEGER(722) +DEFINE_INTEGER(723) +DEFINE_INTEGER(724) +DEFINE_INTEGER(725) +DEFINE_INTEGER(726) +DEFINE_INTEGER(727) +DEFINE_INTEGER(728) +DEFINE_INTEGER(729) +DEFINE_INTEGER(730) +DEFINE_INTEGER(731) +DEFINE_INTEGER(732) +DEFINE_INTEGER(733) +DEFINE_INTEGER(734) +DEFINE_INTEGER(735) +DEFINE_INTEGER(736) +DEFINE_INTEGER(737) +DEFINE_INTEGER(738) +DEFINE_INTEGER(739) +DEFINE_INTEGER(740) +DEFINE_INTEGER(741) +DEFINE_INTEGER(742) +DEFINE_INTEGER(743) +DEFINE_INTEGER(744) +DEFINE_INTEGER(745) +DEFINE_INTEGER(746) +DEFINE_INTEGER(747) +DEFINE_INTEGER(748) +DEFINE_INTEGER(749) +DEFINE_INTEGER(750) +DEFINE_INTEGER(751) +DEFINE_INTEGER(752) +DEFINE_INTEGER(753) +DEFINE_INTEGER(754) +DEFINE_INTEGER(755) +DEFINE_INTEGER(756) +DEFINE_INTEGER(757) +DEFINE_INTEGER(758) +DEFINE_INTEGER(759) +DEFINE_INTEGER(760) +DEFINE_INTEGER(761) +DEFINE_INTEGER(762) +DEFINE_INTEGER(763) +DEFINE_INTEGER(764) +DEFINE_INTEGER(765) +DEFINE_INTEGER(766) +DEFINE_INTEGER(767) +DEFINE_INTEGER(768) +DEFINE_INTEGER(769) +DEFINE_INTEGER(770) +DEFINE_INTEGER(771) +DEFINE_INTEGER(772) +DEFINE_INTEGER(773) +DEFINE_INTEGER(774) +DEFINE_INTEGER(775) +DEFINE_INTEGER(776) +DEFINE_INTEGER(777) +DEFINE_INTEGER(778) +DEFINE_INTEGER(779) +DEFINE_INTEGER(780) +DEFINE_INTEGER(781) +DEFINE_INTEGER(782) +DEFINE_INTEGER(783) +DEFINE_INTEGER(784) +DEFINE_INTEGER(785) +DEFINE_INTEGER(786) +DEFINE_INTEGER(787) +DEFINE_INTEGER(788) +DEFINE_INTEGER(789) +DEFINE_INTEGER(790) +DEFINE_INTEGER(791) +DEFINE_INTEGER(792) +DEFINE_INTEGER(793) +DEFINE_INTEGER(794) +DEFINE_INTEGER(795) +DEFINE_INTEGER(796) +DEFINE_INTEGER(797) +DEFINE_INTEGER(798) +DEFINE_INTEGER(799) +DEFINE_INTEGER(800) +DEFINE_INTEGER(801) +DEFINE_INTEGER(802) +DEFINE_INTEGER(803) +DEFINE_INTEGER(804) +DEFINE_INTEGER(805) +DEFINE_INTEGER(806) +DEFINE_INTEGER(807) +DEFINE_INTEGER(808) +DEFINE_INTEGER(809) +DEFINE_INTEGER(810) +DEFINE_INTEGER(811) +DEFINE_INTEGER(812) +DEFINE_INTEGER(813) +DEFINE_INTEGER(814) +DEFINE_INTEGER(815) +DEFINE_INTEGER(816) +DEFINE_INTEGER(817) diff --git a/tests/gpgscm/t-child.c b/tests/gpgscm/t-child.c index 547eb17..f4e3a04 100644 --- a/tests/gpgscm/t-child.c +++ b/tests/gpgscm/t-child.c @@ -33,9 +33,9 @@ main (int argc, char **argv) char buffer[4096]; memset (buffer, 'A', sizeof buffer); #if _WIN32 - if (! setmode (stdin, O_BINARY)) + if (! setmode (fileno (stdin), O_BINARY)) return 23; - if (! setmode (stdout, O_BINARY)) + if (! setmode (fileno (stdout), O_BINARY)) return 23; #endif diff --git a/tests/gpgscm/t-child.scm b/tests/gpgscm/t-child.scm index 93208f4..fd1dcc3 100644 --- a/tests/gpgscm/t-child.scm +++ b/tests/gpgscm/t-child.scm @@ -107,12 +107,12 @@ (pipe:spawn `(,child stdout4096)) (pipe:spawn `(,child cat))) (tr:call-with-content (lambda (c) - (assert (= 4096 (length c)))))) + (assert (= 4096 (string-length c)))))) (tr:do (tr:pipe-do (pipe:spawn `(,child stdout8192)) (pipe:spawn `(,child cat))) (tr:call-with-content (lambda (c) - (assert (= 8192 (length c)))))) + (assert (= 8192 (string-length c)))))) (echo "All good.") diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm index 592b36f..eee8ce5 100644 --- a/tests/gpgscm/tests.scm +++ b/tests/gpgscm/tests.scm @@ -17,18 +17,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -;; Trace displays and returns the given value. A debugging aid. -(define (trace x) - (display x) - (newline) - x) - -;; Stringification. -(define (stringify expression) - (let ((p (open-output-string))) - (write expression p) - (get-output-string p))) - ;; Reporting. (define (echo . msg) (for-each (lambda (x) (display x) (display " ")) msg) @@ -116,10 +104,11 @@ (es-fclose (:stdout h)) (es-fclose (:stderr h)) (if (> (*verbose*) 2) - (begin - (echo (stringify what) "returned:" result) - (echo (stringify what) "wrote to stdout:" out) - (echo (stringify what) "wrote to stderr:" err))) + (info "Child" (:pid h) "returned:" + `((command ,(stringify what)) + (status ,result) + (stdout ,out) + (stderr ,err)))) (list result out err)))) ;; Accessor function for the results of 'call-with-io'. ':stdout' and @@ -201,7 +190,7 @@ (if (absolute-path? path) path (path-join (getcwd) path))) (define (in-srcdir . names) - (canonical-path (apply path-join (cons (getenv "srcdir") names)))) + (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) ;; Try to find NAME in PATHS. Returns the full path name on success, ;; or raises an error. @@ -234,6 +223,11 @@ (substring path 0 (- (string-length path) (string-length suffix))) path))) +(define (dirname path) + (let ((i (string-rindex path #\/))) + (if i (substring path 0 i) "."))) +(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) + ;; Helper for (pipe). (define :read-end car) (define :write-end cadr) @@ -243,7 +237,7 @@ ;; (letfd <bindings> <body>) ;; ;; Bind all variables given in <bindings> and initialize each of them -;; to the given initial value, and close them after evaluting <body>. +;; to the given initial value, and close them after evaluating <body>. (define-macro (letfd bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') @@ -312,7 +306,7 @@ ;; ;; Bind all variables given in <bindings>, initialize each of them to ;; a string representing an unique path in the filesystem, and delete -;; them after evaluting <body>. +;; them after evaluating <body>. (define-macro (lettmp bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') @@ -510,48 +504,55 @@ (define (new procs) (package (define (add test) - (new (cons test procs))) + (set! procs (cons test procs)) + (current-environment)) + (define (pid->test pid) + (let ((t (filter (lambda (x) (= pid x::pid)) procs))) + (if (null? t) #f (car t)))) (define (wait) (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) (if (null? unfinished) - (package) - (let* ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished)) - (results - (map (lambda (pid retcode) (list pid retcode)) - pids - (wait-processes (map stringify names) pids #t)))) - (new - (map (lambda (t) - (if t::retcode - t - (t::set-retcode (cadr (assoc t::pid results))))) - procs)))))) - (define (passed) - (filter (lambda (p) (= 0 p::retcode)) procs)) - (define (skipped) - (filter (lambda (p) (= 77 p::retcode)) procs)) - (define (hard-errored) - (filter (lambda (p) (= 99 p::retcode)) procs)) - (define (failed) - (filter (lambda (p) - (not (or (= 0 p::retcode) (= 77 p::retcode) - (= 99 p::retcode)))) - procs)) + (current-environment) + (let ((names (map (lambda (t) t::name) unfinished)) + (pids (map (lambda (t) t::pid) unfinished))) + (for-each + (lambda (test retcode) + (test::set-end-time!) + (test:::set! 'retcode retcode)) + (map pid->test pids) + (wait-processes (map stringify names) pids #t))))) + (current-environment)) + (define (filter-tests status) + (filter (lambda (p) (eq? status (p::status))) procs)) (define (report) (define (print-tests tests message) (unless (null? tests) (apply echo (cons message (map (lambda (t) t::name) tests))))) - (let ((failed' (failed)) (skipped' (skipped))) + (let ((failed (filter-tests 'FAIL)) + (xfailed (filter-tests 'XFAIL)) + (xpassed (filter-tests 'XPASS)) + (skipped (filter-tests 'SKIP))) (echo (length procs) "tests run," - (length (passed)) "succeeded," - (length failed') "failed," - (length skipped') "skipped.") - (print-tests failed' "Failed tests:") - (print-tests skipped' "Skipped tests:") - (length failed'))))))) + (length (filter-tests 'PASS)) "succeeded," + (length failed) "failed," + (length xfailed) "failed expectedly," + (length xpassed) "succeeded unexpectedly," + (length skipped) "skipped.") + (print-tests failed "Failed tests:") + (print-tests xfailed "Expectedly failed tests:") + (print-tests xpassed "Unexpectedly passed tests:") + (print-tests skipped "Skipped tests:") + (+ (length failed) (length xpassed)))) + + (define (xml) + (xx::document + (xx::tag 'testsuites + `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + ("xsi:noNamespaceSchemaLocation" + "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) + (map (lambda (t) (t::xml)) procs)))))))) (define (verbosity n) (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) @@ -561,68 +562,154 @@ ;; A single test. (define test + (begin + + ;; Private definitions. + + (define (isotime->junit t) + "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" + "20170418T145809" + (string-append (substring t 0 4) + "-" + (substring t 4 6) + "-" + (substring t 6 11) + ":" + (substring t 11 13) + ":" + (substring t 13 15))) + + ;; If a tests name ends with a bang (!), it is expected to fail. + (define (expect-failure? name) + (string-suffix? name "!")) + ;; Strips the bang (if any). + (define (test-name name) + (if (expect-failure? name) + (substring name 0 (- (string-length name) 1)) + name)) + (package (define (scm setup name path . args) ;; Start the process. (define (spawn-scm args' in out err) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) - ,(locate-test path) + ,(locate-test (test-name path)) ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) - (new name #f spawn-scm #f #f CLOSED_FD)) + (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) (define (binary setup name path . args) ;; Start the process. (define (spawn-binary args' in out err) - (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args) + (spawn-process-fd `(,(test-name path) + ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) - (new name #f spawn-binary #f #f CLOSED_FD)) + (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) - (define (new name directory spawn pid retcode logfd) + (define (new name directory spawn pid retcode logfd expect-failure) (package - (define (set-directory x) - (new name x spawn pid retcode logfd)) - (define (set-retcode x) - (new name directory spawn pid x logfd)) - (define (set-pid x) - (new name directory spawn x retcode logfd)) - (define (set-logfd x) - (new name directory spawn pid retcode x)) + + ;; XXX: OO glue. + (define self (current-environment)) + (define (:set! key value) + (eval `(set! ,key ,value) (current-environment)) + (current-environment)) + + ;; The log is written here. + (define log-file-name #f) + + ;; Record time stamps. + (define timestamp #f) + (define start-time 0) + (define end-time 0) + + (define (set-start-time!) + (set! timestamp (isotime->junit (get-isotime))) + (set! start-time (get-time))) + (define (set-end-time!) + (set! end-time (get-time))) + (define (open-log-file) - (let ((filename (string-append (basename name) ".log"))) - (catch '() (unlink filename)) - (open filename (logior O_RDWR O_BINARY O_CREAT) #o600))) + (unless log-file-name + (set! log-file-name (string-append (basename name) ".log"))) + (catch '() (unlink log-file-name)) + (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) + (define (run-sync . args) + (set-start-time!) (letfd ((log (open-log-file))) (with-working-directory directory (let* ((p (inbound-pipe)) - (pid (spawn args 0 (:write-end p) (:write-end p)))) + (pid' (spawn args 0 (:write-end p) (:write-end p)))) (close (:write-end p)) (splice (:read-end p) STDERR_FILENO log) (close (:read-end p)) - (let ((t' (set-retcode (wait-process name pid #t)))) - (t'::report) - t'))))) + (set! pid pid') + (set! retcode (wait-process name pid' #t))))) + (report) + (current-environment)) (define (run-sync-quiet . args) + (set-start-time!) (with-working-directory directory - (set-retcode - (wait-process - name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) + (set! retcode (wait-process name pid #t)) + (set-end-time!) + (current-environment)) (define (run-async . args) + (set-start-time!) (let ((log (open-log-file))) (with-working-directory directory - (new name directory spawn - (spawn args CLOSED_FD log log) - retcode log)))) + (set! pid (spawn args CLOSED_FD log log))) + (set! logfd log)) + (current-environment)) (define (status) - (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) - (if (not t) "FAIL" (cadr t)))) + (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) + (t (if (not t') 'FAIL (cadr t')))) + (if expect-failure + (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) + t))) + (define (status-string) + (cadr (assoc (status) '((PASS "PASS") + (SKIP "SKIP") + (ERROR "ERROR") + (FAIL "FAIL") + (XPASS "XPASS") + (XFAIL "XFAIL"))))) (define (report) (unless (= logfd CLOSED_FD) (seek logfd 0 SEEK_SET) (splice logfd STDERR_FILENO) (close logfd)) - (echo (string-append (status) ":") name)))))) + (echo (string-append (status-string) ":") name)) + + (define (xml) + (xx::tag + 'testsuite + `((name ,name) + (time ,(- end-time start-time)) + (package ,(dirname name)) + (id 0) + (timestamp ,timestamp) + (hostname "unknown") + (tests 1) + (failures ,(if (eq? FAIL (status)) 1 0)) + (errors ,(if (eq? ERROR (status)) 1 0))) + (list + (xx::tag 'properties) + (xx::tag 'testcase + `((name ,(basename name)) + (classname ,(string-translate (dirname name) "/" ".")) + (time ,(- end-time start-time))) + `(,@(case (status) + ((PASS XFAIL) '()) + ((SKIP) (list (xx::tag 'skipped))) + ((ERROR) (list + (xx::tag 'error '((message "Unknown error."))))) + (else + (list (xx::tag 'failure '((message "Unknown error.")))))))) + (xx::tag 'system-out '() + (list (xx::textnode (read-all (open-input-file log-file-name))))) + (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) ;; Run the setup target to create an environment, then run all given ;; tests in parallel. @@ -631,11 +718,12 @@ (if (null? tests') (let ((results (pool::wait))) (for-each (lambda (t) (t::report)) (reverse results::procs)) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) - (let* ((wd (mkdtemp-autoremove)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-async)) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-async)) (cdr tests')))))) ;; Run the setup target to create an environment, then run all given @@ -644,13 +732,27 @@ (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) - (let* ((wd (mkdtemp-autoremove)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-sync)) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-sync)) (cdr tests')))))) +;; Run tests either in sequence or in parallel, depending on the +;; number of tests and the command line flags. +(define (run-tests tests) + (if (and (flag "--parallel" *args*) + (> (length tests) 1)) + (run-tests-parallel tests) + (run-tests-sequential tests))) + +;; Load all tests from the given path. +(define (load-tests . path) + (load (apply in-srcdir `(,@path "all-tests.scm"))) + all-tests) + ;; Helper to create environment caches from test functions. SETUP ;; must be a test implementing the producer side cache protocol. ;; Returns a promise containing the arguments that must be passed to a diff --git a/tests/gpgscm/xml.scm b/tests/gpgscm/xml.scm new file mode 100644 index 0000000..771ec36 --- /dev/null +++ b/tests/gpgscm/xml.scm @@ -0,0 +1,142 @@ +;; A tiny XML library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(define xx + (begin + + ;; Private declarations. + (define quote-text + '((#\< "<") + (#\> ">") + (#\& "&"))) + + (define quote-attribute-' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\' "'"))) + + (define quote-attribute-'' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))) + + (define (escape-string quotation string sink) + ;; This implementation is a bit awkward because iteration is so + ;; slow in TinySCHEME. We rely on string-index to skip to the + ;; next character we need to escape. We also avoid allocations + ;; wherever possible. + + ;; Given a list of integers or #f, return the sublist that + ;; starts with the lowest integer. + (define (min* x) + (let loop ((lowest x) (rest x)) + (if (null? rest) + lowest + (loop (if (or (null? lowest) (not (car lowest)) + (and (car rest) (> (car lowest) (car rest)))) rest lowest) + (cdr rest))))) + + (let ((i 0) (start 0) (len (string-length string)) + (indices (map (lambda (x) (string-index string (car x))) quotation)) + (next #f) (c #f)) + + ;; Set 'i' to the index of the next character that needs + ;; escaping, 'c' to the character that needs to be escaped, + ;; and update 'indices'. + (define (skip!) + (set! next (min* indices)) + (set! i (if (null? next) #f (car next))) + (if i + (begin + (set! c (string-ref string i)) + (set-car! next (string-index string c (+ 1 i)))) + (set! i (string-length string)))) + + (let loop () + (skip!) + (if (< i len) + (begin + (display (substring string start i) sink) + (display (cadr (assv c quotation)) sink) + (set! i (+ 1 i)) + (set! start i) + (loop)) + (display (substring string start len) sink))))) + + (let ((escape-string-s (lambda (quotation string) + (let ((sink (open-output-string))) + (escape-string quotation string sink) + (get-output-string sink))))) + (assert (equal? (escape-string-s quote-text "foo") "foo")) + (assert (equal? (escape-string-s quote-text "foo&") "foo&")) + (assert (equal? (escape-string-s quote-text "&foo") "&foo")) + (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) + (assert (equal? (escape-string-s quote-text "foo<bar") "foo<bar")) + (assert (equal? (escape-string-s quote-text "foo>bar") "foo>bar"))) + + (define (escape quotation datum sink) + (cond + ((string? datum) (escape-string quotation datum sink)) + ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) + ((number? datum) (display (number->string datum) sink)) + (else + (throw "Do not know how to encode" datum)))) + + (define (name->string name) + (cond + ((symbol? name) (symbol->string name)) + (else name))) + + (package + + (define (textnode string) + (lambda (sink) + (escape quote-text string sink))) + + (define (tag name . rest) + (let ((attributes (if (null? rest) '() (car rest))) + (children (if (> (length rest) 1) (cadr rest) '()))) + (lambda (sink) + (display "<" sink) + (display (name->string name) sink) + (unless (null? attributes) + (display " " sink) + (for-each (lambda (a) + (display (car a) sink) + (display "=\"" sink) + (escape quote-attribute-'' (cadr a) sink) + (display "\" " sink)) attributes)) + (if (null? children) + (display "/>\n" sink) + (begin + (display ">\n" sink) + (for-each (lambda (c) (c sink)) children) + (display "</" sink) + (display (name->string name) sink) + (display ">\n" sink)))))) + + (define (document root . rest) + (let ((attributes (if (null? rest) '() (car rest)))) + (lambda (sink) + ;; xxx ignores attributes + (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink) + (root sink) + (newline sink))))))) diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am index 28db501..e54db78 100644 --- a/tests/gpgsm/Makefile.am +++ b/tests/gpgsm/Makefile.am @@ -31,9 +31,9 @@ AM_CFLAGS = TESTS_ENVIRONMENT = LC_ALL=C \ EXEEXT=$(EXEEXT) \ PATH=../gpgscm:$(PATH) \ - srcdir=$(abs_srcdir) \ + abs_top_srcdir=$(abs_top_srcdir) \ objdir=$(abs_top_builddir) \ - GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgsm + GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm XTESTS = \ import.scm \ @@ -54,7 +54,7 @@ check: xcheck .PHONY: xcheck xcheck: $(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \ - $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS) + $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS) KEYS = 32100C27173EF6E9C4E9A25D3D69F86D37A4F939 CERTS = cert_g10code_test1.der \ @@ -66,9 +66,9 @@ TEST_FILES = plain-1.cms.asc \ plain-large.cms.asc EXTRA_DIST = $(XTESTS) $(KEYS) $(CERTS) $(TEST_FILES) \ - gpgsm-defs.scm run-tests.scm setup.scm + gpgsm-defs.scm run-tests.scm setup.scm all-tests.scm -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/gpgsm/all-tests.scm b/tests/gpgsm/all-tests.scm new file mode 100644 index 0000000..1baa924 --- /dev/null +++ b/tests/gpgsm/all-tests.scm @@ -0,0 +1,43 @@ +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(export all-tests + ;; Parse the Makefile.am to find all tests. + + (load (with-path "makefile.scm")) + + (define (expander filename port key) + (parse-makefile port key)) + + (define (parse filename key) + (parse-makefile-expand filename expander key)) + + (define setup + (make-environment-cache + (test::scm + #f + (path-join "tests" "gpgsm" "setup.scm") + (in-srcdir "tests" "gpgsm" "setup.scm") + "--" "tests" "gpg"))) + + (map (lambda (name) + (test::scm setup + (path-join "tests" "gpgsm" name) + (in-srcdir "tests" "gpgsm" name))) + (parse-makefile-expand (in-srcdir "tests" "gpgsm" "Makefile.am") + (lambda (filename port key) (parse-makefile port key)) + "XTESTS"))) diff --git a/tests/gpgsm/decrypt.scm b/tests/gpgsm/decrypt.scm index e7f3baa..c328ba8 100644 --- a/tests/gpgsm/decrypt.scm +++ b/tests/gpgsm/decrypt.scm @@ -17,14 +17,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) (for-each-p "Checking decryption of supplied files." (lambda (name) (tr:do - (tr:open (in-srcdir (string-append name ".cms.asc"))) + (tr:open (in-srcdir "tests" "gpgsm" (string-append name ".cms.asc"))) (tr:gpgsm "" '(--decrypt)) (tr:assert-identity name))) plain-files) diff --git a/tests/gpgsm/encrypt.scm b/tests/gpgsm/encrypt.scm index fd23ac5..bb90c8e 100644 --- a/tests/gpgsm/encrypt.scm +++ b/tests/gpgsm/encrypt.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) (for-each-p diff --git a/tests/gpgsm/export.scm b/tests/gpgsm/export.scm index 1ee91e4..d29b6cc 100644 --- a/tests/gpgsm/export.scm +++ b/tests/gpgsm/export.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) (for-each-p' @@ -25,7 +25,7 @@ (lambda (cert) (lettmp (exported) (call-check `(,@gpgsm --output ,exported --export ,cert::uid::CN)) - (with-ephemeral-home-directory + (with-ephemeral-home-directory setup-gpgsm-environment (call-check `(,@gpgsm --import ,exported)) (assert (sm-have-public-key? cert))))) (lambda (cert) cert::uid::CN) diff --git a/tests/gpgsm/gpgsm-defs.scm b/tests/gpgsm/gpgsm-defs.scm index 5f9be7f..711922a 100644 --- a/tests/gpgsm/gpgsm-defs.scm +++ b/tests/gpgsm/gpgsm-defs.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) ;; This is the list of certificates that we install in the test ;; environment. @@ -61,12 +61,6 @@ (equal? key::fpr (:fpr l)))) (gpgsm-with-colons `(--list-secret-keys ,key::fpr)))))) -(define (create-file name . lines) - (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (let ((port (fdopen fd "wb"))) - (for-each (lambda (line) (display line port) (newline port)) - lines)))) - (define (create-gpgsmhome) (create-file "gpgsm.conf" "disable-crl-checks" @@ -83,13 +77,13 @@ (log "Storing private keys") (for-each (lambda (name) - (file-copy (in-srcdir name) + (file-copy (in-srcdir "tests" "gpgsm" name) (path-join "private-keys-v1.d" (string-append name ".key")))) '("32100C27173EF6E9C4E9A25D3D69F86D37A4F939")) (log "Importing public demo and test keys") - (call-check `(,@gpgsm --import ,(in-srcdir "cert_g10code_test1.der"))) + (call-check `(,@gpgsm --import ,(in-srcdir "tests" "gpgsm" "cert_g10code_test1.der"))) (create-sample-files) (stop-agent)) diff --git a/tests/gpgsm/import.scm b/tests/gpgsm/import.scm index 85e5107..be555da 100644 --- a/tests/gpgsm/import.scm +++ b/tests/gpgsm/import.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) (define certs-for-import @@ -47,7 +47,7 @@ "Checking certificate import." (lambda (test) (assert (not (sm-have-public-key? (:cert test)))) - (call-check `(,@gpgsm --import ,(in-srcdir (:name test)))) + (call-check `(,@gpgsm --import ,(in-srcdir "tests" "gpgsm" (:name test)))) (assert (sm-have-public-key? (:cert test)))) (lambda (test) (:name test)) certs-for-import) diff --git a/tests/gpgsm/run-tests.scm b/tests/gpgsm/run-tests.scm index e444245..6b460b1 100644 --- a/tests/gpgsm/run-tests.scm +++ b/tests/gpgsm/run-tests.scm @@ -17,16 +17,23 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(if (string=? "" (getenv "srcdir")) +(if (string=? "" (getenv "abs_top_srcdir")) (begin - (echo "Environment variable 'srcdir' not set. Please point it to" + (echo "Environment variable 'abs_top_srcdir' not set. Please point it to" "tests/gpgsm.") (exit 2))) -(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) - (setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm"))) - (runner (if (and (member "--parallel" *args*) - (> (length tests) 1)) - run-tests-parallel - run-tests-sequential))) - (runner (map (lambda (t) (test::scm setup t t)) tests))) +(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) + +(define setup + (make-environment-cache (test::scm + #f + (path-join "tests" "gpgsm" "setup.scm") + (in-srcdir "tests" "gpgsm" "setup.scm")))) + +(run-tests (if (null? tests) + (load-tests "tests" "gpgsm") + (map (lambda (name) + (test::scm setup + (path-join "tests" "gpgsm" name) + (in-srcdir "tests" "gpgsm" name))) tests))) diff --git a/tests/gpgsm/setup.scm b/tests/gpgsm/setup.scm index 91821a0..c241b38 100644 --- a/tests/gpgsm/setup.scm +++ b/tests/gpgsm/setup.scm @@ -17,14 +17,12 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (define tarball (flag "--create-tarball" *args*)) (unless (and tarball (not (null? tarball))) (error "Usage: setup.scm --create-tarball <file> ...")) -(with-ephemeral-home-directory - (chdir (getenv "GNUPGHOME")) - (create-gpgsmhome) - (stop-agent) - (call-check `(,(tool 'gpgtar) --create --output ,(car tarball) "."))) +(setenv "GNUPGHOME" (getcwd) #t) +(create-gpgsmhome) +(call-check `(,(tool 'gpgtar) --create --output ,(car tarball) ".")) diff --git a/tests/gpgsm/shell.scm b/tests/gpgsm/shell.scm index fe39fec..606e388 100644 --- a/tests/gpgsm/shell.scm +++ b/tests/gpgsm/shell.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) ;; This is not a test, but can be used to inspect the test diff --git a/tests/gpgsm/sign.scm b/tests/gpgsm/sign.scm index 9b4f7fe..48b7b06 100644 --- a/tests/gpgsm/sign.scm +++ b/tests/gpgsm/sign.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) (for-each-p diff --git a/tests/gpgsm/verify.scm b/tests/gpgsm/verify.scm index 28210a9..40dbd48 100644 --- a/tests/gpgsm/verify.scm +++ b/tests/gpgsm/verify.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "gpgsm-defs.scm")) +(load (in-srcdir "tests" "gpgsm" "gpgsm-defs.scm")) (setup-gpgsm-environment) ;; diff --git a/tests/inittests b/tests/inittests index 1a51bdf..6fbccfb 100755 --- a/tests/inittests +++ b/tests/inittests @@ -65,10 +65,10 @@ fi echo gnupg-test-directory > testdir.stamp -# Create the private key directy if it does not exists and copy +# Create the private key directly if it does not exists and copy # the sample keys. [ -d private-keys-v1.d ] || mkdir private-keys-v1.d -for i in ${private_keys}; do +for i in ${private_keys}; do cat ${srcdir}/samplekeys/$i.key >private-keys-v1.d/$i.key done @@ -94,6 +94,6 @@ EOF # Make sure that the sample certs are available but ignore errors here # because we are not a test script. -for i in ${sample_certs}; do +for i in ${sample_certs}; do $GPGSM --import ${srcdir}/samplekeys/$i || true done diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am index 0895aff..d90c9c7 100644 --- a/tests/migrations/Makefile.am +++ b/tests/migrations/Makefile.am @@ -31,9 +31,9 @@ AM_CFLAGS = TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C \ EXEEXT=$(EXEEXT) \ PATH=../gpgscm:$(PATH) \ - srcdir=$(abs_srcdir) \ + abs_top_srcdir=$(abs_top_srcdir) \ objdir=$(abs_top_builddir) \ - GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/migrations + GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm XTESTS = from-classic.scm \ extended-pkf.scm \ @@ -54,11 +54,12 @@ check: xcheck .PHONY: xcheck xcheck: $(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \ - run-tests.scm $(TESTFLAGS) $(XTESTS) + $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS) -EXTRA_DIST = common.scm run-tests.scm setup.scm $(XTESTS) $(TEST_FILES) +EXTRA_DIST = common.scm run-tests.scm setup.scm all-tests.scm \ + $(XTESTS) $(TEST_FILES) -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/migrations/all-tests.scm b/tests/migrations/all-tests.scm new file mode 100644 index 0000000..421f696 --- /dev/null +++ b/tests/migrations/all-tests.scm @@ -0,0 +1,35 @@ +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(export all-tests + ;; Parse the Makefile.am to find all tests. + + (load (with-path "makefile.scm")) + + (define (expander filename port key) + (parse-makefile port key)) + + (define (parse filename key) + (parse-makefile-expand filename expander key)) + + (map (lambda (name) + (test::scm #f + (path-join "tests" "migrations" name) + (in-srcdir "tests" "migrations" name))) + (parse-makefile-expand (in-srcdir "tests" "migrations" "Makefile.am") + (lambda (filename port key) (parse-makefile port key)) + "XTESTS"))) diff --git a/tests/migrations/common.scm b/tests/migrations/common.scm index fa8f129..54d33b9 100644 --- a/tests/migrations/common.scm +++ b/tests/migrations/common.scm @@ -15,7 +15,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(if (string=? "" (getenv "srcdir")) +(if (string=? "" (getenv "abs_top_srcdir")) (error "not called from make")) (let ((verbose (string->number (getenv "verbose")))) @@ -39,10 +39,11 @@ (define GPGTAR (path-join (getenv "objdir") "tools" (qualify "gpgtar"))) (define (untar-armored source-name) - (pipe:do - (pipe:open source-name (logior O_RDONLY O_BINARY)) - (pipe:spawn `(,@GPG --dearmor)) - (pipe:spawn `(,GPGTAR --extract --directory=. -)))) + (with-ephemeral-home-directory (lambda ()) + (pipe:do + (pipe:open source-name (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --dearmor)) + (pipe:spawn `(,GPGTAR --extract --directory=. -))))) (define (run-test message src-tarball test) (catch (skip "gpgtar not built") diff --git a/tests/migrations/extended-pkf.scm b/tests/migrations/extended-pkf.scm index 1317cd4..cc1a074 100755 --- a/tests/migrations/extended-pkf.scm +++ b/tests/migrations/extended-pkf.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "common.scm")) +(load (in-srcdir "tests" "migrations" "common.scm")) (catch (skip "gpgtar not built") (call-check `(,GPGTAR --help))) @@ -31,7 +31,7 @@ (run-test "Testing the extended private key format ..." - (in-srcdir "extended-pkf.tar.asc") + (in-srcdir "tests" "migrations" "extended-pkf.tar.asc") (lambda (gpghome) (assert-keys-usable))) diff --git a/tests/migrations/from-classic.scm b/tests/migrations/from-classic.scm index ace458e..b473d70 100755 --- a/tests/migrations/from-classic.scm +++ b/tests/migrations/from-classic.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "common.scm")) +(load (in-srcdir "tests" "migrations" "common.scm")) (catch (skip "gpgtar not built") (call-check `(,GPGTAR --help))) @@ -37,14 +37,14 @@ (run-test "Testing a clean migration ..." - (in-srcdir "from-classic.tar.asc") + (in-srcdir "tests" "migrations" "from-classic.tar.asc") (lambda (gpghome) (trigger-migration) (assert-migrated))) (run-test "Testing a migration with existing private-keys-v1.d ..." - (in-srcdir "from-classic.tar.asc") + (in-srcdir "tests" "migrations" "from-classic.tar.asc") (lambda (gpghome) (mkdir "private-keys-v1.d" "-rwx") (trigger-migration) @@ -52,7 +52,7 @@ (run-test "Testing a migration with existing but weird private-keys-v1.d ..." - (in-srcdir "from-classic.tar.asc") + (in-srcdir "tests" "migrations" "from-classic.tar.asc") (lambda (gpghome) (mkdir "private-keys-v1.d" "") (trigger-migration) diff --git a/tests/migrations/issue2276.scm b/tests/migrations/issue2276.scm index 9a0c160..8ea3f43 100755 --- a/tests/migrations/issue2276.scm +++ b/tests/migrations/issue2276.scm @@ -17,12 +17,12 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "common.scm")) +(load (in-srcdir "tests" "migrations" "common.scm")) (run-test "Checking migration with legacy key (issue2276)..." ;; This tarball contains a keyring with a legacy key. - (in-srcdir "issue2276.tar.asc") + (in-srcdir "tests" "migrations" "issue2276.tar.asc") (lambda (gpghome) ;; GnuPG up to 2.1.14 failed to skip the legacy key when updating ;; the trust database and thereby rebuilding the keyring cache. diff --git a/tests/migrations/run-tests.scm b/tests/migrations/run-tests.scm index b4ad260..f44334c 100644 --- a/tests/migrations/run-tests.scm +++ b/tests/migrations/run-tests.scm @@ -17,9 +17,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) - (runner (if (and (member "--parallel" *args*) - (> (length tests) 1)) - run-tests-parallel - run-tests-sequential))) - (runner (map (lambda (t) (test::scm #f t t)) tests))) +(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) + +(run-tests (if (null? tests) + (load-tests "tests" "migrations") + (map (lambda (name) + (test::scm #f + (path-join "tests" "migrations" name) + (in-srcdir "tests" "migrations" name))) tests))) diff --git a/tests/openpgp/4gb-packet.scm b/tests/openpgp/4gb-packet.scm index b827181..e1c5ba5 100755 --- a/tests/openpgp/4gb-packet.scm +++ b/tests/openpgp/4gb-packet.scm @@ -20,9 +20,10 @@ ;; GnuPG through 2.1.7 would incorrect mark packets whose size is ;; 2^32-1 as invalid and exit with status code 2. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) -(if (= 0 (call `(,@GPG --list-packets ,(in-srcdir "4gb-packet.asc")))) - (info "Can parse 4GB packets.") - (fail "Failed to parse 4GB packet.")) +(unless (have-compression-algo? "BZIP2") + (skip "BZIP2 support not compiled in.")) + +(call-check `(,@GPG --list-packets ,(in-srcdir "tests" "openpgp" "4gb-packet.asc"))) diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am index 40f947b..bf9673f 100644 --- a/tests/openpgp/Makefile.am +++ b/tests/openpgp/Makefile.am @@ -36,9 +36,9 @@ fake_pinentry_SOURCES = fake-pinentry.c TESTS_ENVIRONMENT = LC_ALL=C \ EXEEXT=$(EXEEXT) \ PATH=../gpgscm:$(PATH) \ - srcdir=$(abs_srcdir) \ + abs_top_srcdir=$(abs_top_srcdir) \ objdir=$(abs_top_builddir) \ - GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp + GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm XTESTS = \ version.scm \ @@ -109,13 +109,12 @@ check: xcheck .PHONY: xcheck xcheck: $(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \ - run-tests.scm $(TESTFLAGS) $(XTESTS) + $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS) TEST_FILES = pubring.asc secring.asc plain-1o.asc plain-2o.asc plain-3o.asc \ plain-1.asc plain-2.asc plain-3.asc plain-1-pgp.asc \ plain-largeo.asc plain-large.asc \ pubring.pkr.asc secring.skr.asc secdemo.asc pubdemo.asc \ - gpg.conf.tmpl gpg-agent.conf.tmpl \ bug537-test.data.asc bug894-test.asc \ bug1223-good.asc bug1223-bogus.asc 4gb-packet.asc \ tofu/conflicting/1C005AF3.gpg \ @@ -251,7 +250,7 @@ sample_msgs = samplemsgs/clearsig-1-key-1.asc \ EXTRA_DIST = defs.scm $(XTESTS) $(TEST_FILES) \ mkdemodirs signdemokey $(priv_keys) $(sample_keys) \ $(sample_msgs) ChangeLog-2011 run-tests.scm \ - setup.scm shell.scm + setup.scm shell.scm all-tests.scm CLEANFILES = prepared.stamp x y yy z out err $(data_files) \ plain-1 plain-2 plain-3 trustdb.gpg *.lock .\#lk* \ @@ -259,7 +258,7 @@ CLEANFILES = prepared.stamp x y yy z out err $(data_files) \ pubring.gpg pubring.gpg~ pubring.kbx pubring.kbx~ \ secring.gpg pubring.pkr secring.skr \ gnupg-test.stop random_seed gpg-agent.log tofu.db \ - passphrases sshcontrol S.gpg-agent.ssh + passphrases sshcontrol S.gpg-agent.ssh report.xml clean-local: -rm -rf private-keys-v1.d openpgp-revocs.d tofu.d gpgtar.d diff --git a/tests/openpgp/README b/tests/openpgp/README index b9d5607..42e78ae 100644 --- a/tests/openpgp/README +++ b/tests/openpgp/README @@ -7,7 +7,7 @@ From your build directory, run to run all tests or - obj $ make -C tests/openpgp check XTESTS=your-test.scm + obj $ make -C tests/openpgp check TESTS=your-test.scm to run a specific test (or any number of tests separated by spaces). @@ -89,7 +89,7 @@ the inner progress indicator will be abbreviated using '.'. Say you are working on a new test called 'your-test.scm', you can run it on its own using - obj $ make -C tests/openpgp check XTESTS=your-test.scm + obj $ make -C tests/openpgp check TESTS=your-test.scm but something isn't working as expected. There are several little gadgets that might help. The first one is 'trace', a function that diff --git a/tests/openpgp/all-tests.scm b/tests/openpgp/all-tests.scm new file mode 100644 index 0000000..6584df2 --- /dev/null +++ b/tests/openpgp/all-tests.scm @@ -0,0 +1,58 @@ +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(export all-tests + ;; Parse the Makefile.am to find all tests. + + (load (with-path "makefile.scm")) + + (define (expander filename port key) + (parse-makefile port key)) + + (define (parse filename key) + (parse-makefile-expand filename expander key)) + + (define setup + (make-environment-cache + (test::scm + #f + (path-join "tests" "openpgp" "setup.scm") + (in-srcdir "tests" "openpgp" "setup.scm")))) + + (define setup-use-keyring + (make-environment-cache + (test::scm + #f + (string-append "<use-keyring>" (path-join "tests" "openpgp" "setup.scm")) + (in-srcdir "tests" "openpgp" "setup.scm") + "--use-keyring"))) + + (define all-tests + (parse-makefile-expand (in-srcdir "tests" "openpgp" "Makefile.am") + (lambda (filename port key) (parse-makefile port key)) + "XTESTS")) + (append + (map (lambda (name) + (test::scm setup + (path-join "tests" "openpgp" name) + (in-srcdir "tests" "openpgp" name))) all-tests) + (map (lambda (name) + (test::scm setup-use-keyring + (string-append "<use-keyring>" + (path-join "tests" "openpgp" name)) + (in-srcdir "tests" "openpgp" name) + "--use-keyring")) all-tests))) diff --git a/tests/openpgp/armdetach.scm b/tests/openpgp/armdetach.scm index f458441..105f52d 100755 --- a/tests/openpgp/armdetach.scm +++ b/tests/openpgp/armdetach.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -28,5 +28,5 @@ --output ,tmp ,source ) usrpass1) (pipe:do (pipe:open source (logior O_RDONLY O_BINARY)) - (pipe:spawn `(,@GPG --yes ,tmp))))) + (pipe:spawn `(,@GPG --yes --verify ,tmp -))))) (append plain-files data-files)) diff --git a/tests/openpgp/armdetachm.scm b/tests/openpgp/armdetachm.scm index 8d30fd3..27038a0 100755 --- a/tests/openpgp/armdetachm.scm +++ b/tests/openpgp/armdetachm.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define files (append plain-files data-files)) @@ -33,4 +33,4 @@ (pipe:open file (logior O_RDONLY O_BINARY)) (pipe:splice sink))) files))) - (pipe:spawn `(,@GPG --yes ,tmp)))) + (pipe:spawn `(,@GPG --yes --verify ,tmp -)))) diff --git a/tests/openpgp/armencrypt.scm b/tests/openpgp/armencrypt.scm index b9dfc1e..6d6ec4d 100755 --- a/tests/openpgp/armencrypt.scm +++ b/tests/openpgp/armencrypt.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,6 +26,6 @@ (tr:do (tr:open source) (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -ea --recipient ,usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/armencryptp.scm b/tests/openpgp/armencryptp.scm index d280902..4bcc058 100755 --- a/tests/openpgp/armencryptp.scm +++ b/tests/openpgp/armencryptp.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -27,6 +27,6 @@ (tr:open source) (tr:pipe-do (pipe:gpg `(--yes -ea --recipient ,usrname2)) - (pipe:gpg '(--yes))) + (pipe:gpg '(--yes --decrypt))) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/armor.scm b/tests/openpgp/armor.scm index 7498ba7..3c117dd 100755 --- a/tests/openpgp/armor.scm +++ b/tests/openpgp/armor.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define armored_key_8192 "-----BEGIN PGP PUBLIC KEY BLOCK----- @@ -764,4 +764,4 @@ wg7Md81a5RI3F2FG8747t9gX (tr:do (tr:pipe-do (pipe:echo nopad_armored_msg) - (pipe:gpg '()))) + (pipe:gpg '(--decrypt)))) diff --git a/tests/openpgp/armsignencrypt.scm b/tests/openpgp/armsignencrypt.scm index 18178f1..97595f0 100755 --- a/tests/openpgp/armsignencrypt.scm +++ b/tests/openpgp/armsignencrypt.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,6 +26,6 @@ (tr:do (tr:open source) (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -sea --recipient ,usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/armsigs.scm b/tests/openpgp/armsigs.scm index 6e5d056..ccab816 100755 --- a/tests/openpgp/armsigs.scm +++ b/tests/openpgp/armsigs.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,6 +26,6 @@ (tr:do (tr:open source) (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -sa --recipient ,usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/bug537-test.data.asc b/tests/openpgp/bug537-test.data.asc index 130dd5b..b6b02e9 100644 --- a/tests/openpgp/bug537-test.data.asc +++ b/tests/openpgp/bug537-test.data.asc @@ -1,5 +1,5 @@ This is a binary (gzip compressed) file which exhibits a problem with -the zlib decryptor. See encr-data.c:decrypt_data for a decription of +the zlib decryptor. See encr-data.c:decrypt_data for a description of the problem we solved with 1.9.92 (1.4.6). It is not easy to produce such files, but this one works. The source file is also in the BTS under the name check-data-410-1.data. The result of the decryption diff --git a/tests/openpgp/clearsig.scm b/tests/openpgp/clearsig.scm index cdbf603..b1c72c2 100755 --- a/tests/openpgp/clearsig.scm +++ b/tests/openpgp/clearsig.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define (check-signing args input) @@ -25,7 +25,7 @@ (lettmp (signed) (call-popen `(,@GPG --output ,signed --yes ,@args ,source) input) - (call-popen `(,@GPG --output ,sink --yes ,signed) "")))) + (call-popen `(,@GPG --output ,sink --yes --verify ,signed) "")))) (for-each-p "Checking signing and verifying plain text messages" diff --git a/tests/openpgp/compression.scm b/tests/openpgp/compression.scm index f39c132..d2e46cc 100755 --- a/tests/openpgp/compression.scm +++ b/tests/openpgp/compression.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -30,7 +30,7 @@ (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,usrname2 --compress-algo ,compression)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files))) (force all-compression-algos)) diff --git a/tests/openpgp/conventional-mdc.scm b/tests/openpgp/conventional-mdc.scm index 5b009ae..bb8327a 100755 --- a/tests/openpgp/conventional-mdc.scm +++ b/tests/openpgp/conventional-mdc.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define s2k '--s2k-count=65536) @@ -34,7 +34,7 @@ (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k --force-mdc -c --cipher-algo ,algo)) - (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" --decrypt ,s2k)) (tr:assert-identity source))) '("plain-1" "data-80000"))) (force all-cipher-algos)) @@ -45,6 +45,6 @@ (tr:do (tr:open source) (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -cs)) - (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" --decrypt ,s2k)) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/conventional.scm b/tests/openpgp/conventional.scm index 612b992..c480400 100755 --- a/tests/openpgp/conventional.scm +++ b/tests/openpgp/conventional.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define s2k '--s2k-count=65536) @@ -29,7 +29,7 @@ (tr:do (tr:open source) (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -c)) - (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" --decrypt ,s2k)) (tr:assert-identity source))) '("plain-2" "data-32000")) @@ -43,7 +43,7 @@ (tr:open source) (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -c --cipher-algo ,algo)) - (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" --decrypt ,s2k)) (tr:assert-identity source))) '("plain-1" "data-80000"))) (force all-cipher-algos)) diff --git a/tests/openpgp/decrypt-dsa.scm b/tests/openpgp/decrypt-dsa.scm index 49f9534..9f39732 100755 --- a/tests/openpgp/decrypt-dsa.scm +++ b/tests/openpgp/decrypt-dsa.scm @@ -17,14 +17,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p "Checking decryption of supplied DSA encrypted file" (lambda (name) (tr:do - (tr:open (in-srcdir (string-append name "-pgp.asc"))) - (tr:gpg "" '(--yes)) + (tr:open (in-srcdir "tests" "openpgp" (string-append name "-pgp.asc"))) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity name))) (list (car plain-files))) diff --git a/tests/openpgp/decrypt-multifile.scm b/tests/openpgp/decrypt-multifile.scm index a7695b1..304ca49 100755 --- a/tests/openpgp/decrypt-multifile.scm +++ b/tests/openpgp/decrypt-multifile.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (info "Checking decryption of supplied files using --multifile.") @@ -31,7 +31,7 @@ ;; First, copy the files so that GnuPG writes the decrypted files here ;; and not into the source directory. (for-each (lambda (name) - (file-copy (in-srcdir name) name)) + (file-copy (in-srcdir "tests" "openpgp" name) name)) encrypted-files) ;; Now decrypt all files. diff --git a/tests/openpgp/decrypt-session-key.scm b/tests/openpgp/decrypt-session-key.scm index 771b53d..35aa7f3 100755 --- a/tests/openpgp/decrypt-session-key.scm +++ b/tests/openpgp/decrypt-session-key.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define (get-session-key filename) @@ -35,9 +35,9 @@ (for-each-p "Checking decryption of supplied files using the session key." (lambda (name) - (let* ((source (in-srcdir (string-append name ".asc"))) + (let* ((source (in-srcdir "tests" "openpgp" (string-append name ".asc"))) (key (get-session-key source))) - (with-ephemeral-home-directory + (with-ephemeral-home-directory setup-environment (tr:do (tr:open source) (tr:gpg "" `(--yes --decrypt --override-session-key ,key)) diff --git a/tests/openpgp/decrypt-unwrap-verify.scm b/tests/openpgp/decrypt-unwrap-verify.scm index 97a72e4..bf7d14d 100755 --- a/tests/openpgp/decrypt-unwrap-verify.scm +++ b/tests/openpgp/decrypt-unwrap-verify.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (lettmp (steve's-key) @@ -29,13 +29,13 @@ ;; First, unwrap the encrypted message using Steve's secret key. (lettmp (unwrapped) (tr:do - (tr:open (in-srcdir "samplemsgs" (string-append name ".asc"))) + (tr:open (in-srcdir "tests" "openpgp" "samplemsgs" (string-append name ".asc"))) (tr:gpg "" `(--yes --decrypt --unwrap)) (tr:write-to unwrapped)) ;; Then, verify the signature with a clean working directory ;; containing only Steve's public key. - (with-ephemeral-home-directory + (with-ephemeral-home-directory setup-environment (call-check `(,@gpg --import ,steve's-key)) (call-check `(,@gpg --verify ,unwrapped))))) '("encsig-2-keys-3" "encsig-2-keys-4"))) diff --git a/tests/openpgp/decrypt.scm b/tests/openpgp/decrypt.scm index ba8bcee..aae4c96 100755 --- a/tests/openpgp/decrypt.scm +++ b/tests/openpgp/decrypt.scm @@ -17,14 +17,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p "Checking decryption of supplied files" (lambda (name) (tr:do - (tr:open (in-srcdir (string-append name ".asc"))) - (tr:gpg "" '(--yes)) + (tr:open (in-srcdir "tests" "openpgp" (string-append name ".asc"))) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity name))) plain-files) diff --git a/tests/openpgp/default-key.scm b/tests/openpgp/default-key.scm index a90cca8..3580cad 100755 --- a/tests/openpgp/default-key.scm +++ b/tests/openpgp/default-key.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) ;; Import the sample key @@ -33,7 +33,7 @@ (info "Importing public key.") (call-check `(,(tool 'gpg) --import - ,(in-srcdir "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) + ,(in-srcdir "tests" "openpgp" "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) ;; By default, the most recent, valid signing subkey (1EA97479). (for-each-p diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm index e8d06c0..1531dc1 100644 --- a/tests/openpgp/defs.scm +++ b/tests/openpgp/defs.scm @@ -201,7 +201,8 @@ (define have-opt-always-trust (catch #f - (call-check `(,(tool 'gpg) --gpgconf-test --always-trust)) + (with-ephemeral-home-directory (lambda ()) + (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))) #t)) (define GPG `(,(tool 'gpg) --no-permission-warning @@ -258,6 +259,8 @@ (not (not (member x (force all-hash-algos))))) (define (have-cipher-algo? x) (not (not (member x (force all-cipher-algos))))) +(define (have-compression-algo? x) + (not (not (member x (force all-compression-algos))))) (define (gpg-pipe args0 args1 errfd) (lambda (source sink) @@ -278,28 +281,6 @@ ;; GnuPG helper. ;; -;; Evaluate a sequence of expressions with the given home directory. -(define-macro (with-home-directory gnupghome . expressions) - (let ((original-home-directory (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME"))) - (dynamic-wind - (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) - -;; Evaluate a sequence of expressions with an ephemeral home -;; directory. -(define-macro (with-ephemeral-home-directory . expressions) - (let ((original-home-directory (gensym)) - (ephemeral-home-directory (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME")) - (,ephemeral-home-directory (mkdtemp))) - (finally (unlink-recursively ,ephemeral-home-directory) - (dynamic-wind - (lambda () (setenv "GNUPGHOME" ,ephemeral-home-directory #t)) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) - ;; Call GPG to obtain the hash sums. Either specify an input file in ;; ARGS, or an string in INPUT. Returns a list of (<algo> ;; "<hashsum>") lists. @@ -318,6 +299,12 @@ (pipe:spawn `(,@GPG --dearmor)) (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600))) +(define (gpg-dump-packets source-name sink-name) + (pipe:do + (pipe:open source-name (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --list-packets)) + (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600))) + ;; ;; Support for test environment creation and teardown. ;; @@ -328,6 +315,12 @@ (lambda (port) (display (make-random-string size) port)))) +(define (create-file name . lines) + (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (let ((port (fdopen fd "wb"))) + (for-each (lambda (line) (display line port) (newline port)) + lines)))) + (define (create-gpghome) (log "Creating test environment...") @@ -335,21 +328,28 @@ (make-test-data "random_seed" 600) (log "Creating configuration files") - (for-each - (lambda (name) - (file-copy (in-srcdir (string-append name ".tmpl")) name) - (let ((p (open-input-output-file name))) - (cond - ((string=? "gpg.conf" name) - (if have-opt-always-trust - (display "no-auto-check-trustdb\n" p)) - (display (string-append "agent-program " - (tool 'gpg-agent) - "|--debug-quick-random\n") p) - (display "allow-weak-digest-algos\n" p)) - ((string=? "gpg-agent.conf" name) - (display (string-append "pinentry-program " PINENTRY "\n") p))))) - '("gpg.conf" "gpg-agent.conf"))) + + (if (flag "--use-keyring" *args*) + (create-file "pubring.gpg")) + + (create-file "gpg.conf" + "no-greeting" + "no-secmem-warning" + "no-permission-warning" + "batch" + "allow-weak-digest-algos" + (if have-opt-always-trust + "no-auto-check-trustdb" "#no-auto-check-trustdb") + (string-append "agent-program " + (tool 'gpg-agent) + "|--debug-quick-random\n") + ) + (create-file "gpg-agent.conf" + "allow-preset-passphrase" + "no-grab" + "enable-ssh-support" + (string-append "pinentry-program " (tool 'pinentry)) + )) ;; Initialize the test environment, install appropriate configuration ;; and start the agent, without any keys. @@ -368,7 +368,7 @@ (log "Unpacking samples") (for-each (lambda (name) - (dearmor (in-srcdir ".." "openpgp" (string-append name "o.asc")) name)) + (dearmor (in-srcdir "tests" "openpgp" (string-append name "o.asc")) name)) plain-files)) (define (create-legacy-gpghome) @@ -377,7 +377,7 @@ (log "Storing private keys") (for-each (lambda (name) - (dearmor (in-srcdir (string-append "/privkeys/" name ".asc")) + (dearmor (in-srcdir "tests" "openpgp" "privkeys" (string-append name ".asc")) (string-append "private-keys-v1.d/" name ".key"))) '("50B2D4FA4122C212611048BC5FC31BD44393626E" "7E201E28B6FEB2927B321F443205F4724EBE637E" @@ -401,11 +401,11 @@ (log "Importing public demo and test keys") (for-each (lambda (file) - (call-check `(,@GPG --yes --import ,(in-srcdir file)))) + (call-check `(,@GPG --yes --import ,(in-srcdir "tests" "openpgp" file)))) (list "pubdemo.asc" "pubring.asc" key-file1)) (pipe:do - (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY)) + (pipe:open (in-srcdir "tests" "openpgp" "pubring.pkr.asc") (logior O_RDONLY O_BINARY)) (pipe:spawn `(,@GPG --dearmor)) (pipe:spawn `(,@GPG --yes --import)))) diff --git a/tests/openpgp/delete-keys.scm b/tests/openpgp/delete-keys.scm index 9a187a2..16bde5f 100755 --- a/tests/openpgp/delete-keys.scm +++ b/tests/openpgp/delete-keys.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (let* ((key keys::alfa) @@ -58,13 +58,16 @@ (call-check `(,@gpg --delete-secret-keys ,subkey::fpr)) (assert (have-public-key? key)) (assert (have-public-key? subkey)) - ;; JW: Deleting the secret subkey also deletes the secret key. + ;; JW: Deleting the secret subkey also deletes the secret key. This + ;; is a deliberate design choice, and currently there is no way to + ;; delete the subkey without using --edit-key. ;; XXX (assert (have-secret-key? key)) ;; XXX (assert (have-secret-key-file? key)) (assert (not (have-secret-key? subkey))) (assert (not (have-secret-key-file? subkey))) ;; Then, delete the secret key. + ;; JW: We already deleted the key. See above. ;; XXX (call-check `(,@gpg --delete-secret-keys ,key::fpr)) (assert (have-public-key? key)) (assert (have-public-key? subkey)) @@ -75,11 +78,14 @@ ;; Now, delete the public subkey. (call-check `(,@gpg --delete-keys ,subkey::fpr)) - ;; JW: Deleting the subkey also deletes the key. + ;; JW: Deleting the subkey also deletes the key. This + ;; is a deliberate design choice, and currently there is no way to + ;; delete the subkey without using --edit-key. ;; XXX (assert (have-public-key? key)) (assert (not (have-public-key? subkey))) ;; Now, delete the public key. + ;; JW: We already deleted the key. See above. ;; XXX (call-check `(,@gpg --delete-keys ,key::fpr)) (assert (not (have-public-key? key))) (assert (not (have-public-key? subkey)))) diff --git a/tests/openpgp/detach.scm b/tests/openpgp/detach.scm index 2180f78..12ed167 100755 --- a/tests/openpgp/detach.scm +++ b/tests/openpgp/detach.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -28,5 +28,5 @@ --output ,tmp ,source ) usrpass1) (pipe:do (pipe:open source (logior O_RDONLY O_BINARY)) - (pipe:spawn `(,@GPG --yes ,tmp))))) + (pipe:spawn `(,@GPG --yes --verify ,tmp -))))) (append plain-files data-files)) diff --git a/tests/openpgp/detachm.scm b/tests/openpgp/detachm.scm index 1de8da9..75faab7 100755 --- a/tests/openpgp/detachm.scm +++ b/tests/openpgp/detachm.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define files (append plain-files data-files)) @@ -33,4 +33,4 @@ (pipe:open file (logior O_RDONLY O_BINARY)) (pipe:splice sink))) files))) - (pipe:spawn `(,@GPG --yes ,tmp)))) + (pipe:spawn `(,@GPG --yes --verify ,tmp -)))) diff --git a/tests/openpgp/ecc.scm b/tests/openpgp/ecc.scm index a40869d..d7c02a5 100755 --- a/tests/openpgp/ecc.scm +++ b/tests/openpgp/ecc.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define keygrips '("8E06A180EFFE4C65B812150CAF19BF30C0689A4C" @@ -48,7 +48,7 @@ (for-each (lambda (n) (call-check `(,(tool 'gpg) --import - ,(in-srcdir (string-append + ,(in-srcdir "tests" "openpgp" (string-append "samplekeys/ecc-sample-" (number->string n) "-pub.asc"))))) @@ -101,8 +101,7 @@ Ic1RdzgeCfosMF+l/zVRchcLKzenEQA= (lettmp (x y) (call-with-output-file x (lambda (p) (display (eval test (current-environment)) p))) - (call-check `(,(tool 'gpg) --verify ,x)) - (call-check `(,(tool 'gpg) --output ,y ,x)) + (call-check `(,(tool 'gpg) --output ,y --verify ,x)) (unless (file=? y z) (fail "mismatch")))) '(msg_opaque_signed_256 msg_opaque_signed_384 msg_opaque_signed_521))) @@ -118,7 +117,7 @@ Ic1RdzgeCfosMF+l/zVRchcLKzenEQA= (lambda (n) (call-check `(,(tool 'gpg) --import ,@(if (> n 1) '(--allow-non-selfsigned-uid) '()) - ,(in-srcdir (string-append + ,(in-srcdir "tests" "openpgp" (string-append "samplekeys/ecc-sample-" (number->string n) "-sec.asc"))))) @@ -181,7 +180,7 @@ Rg== (lettmp (x y) (call-with-output-file x (lambda (p) (display (eval test (current-environment)) p))) - (call-check `(,@GPG --yes --output ,y ,x)) + (call-check `(,@GPG --yes --output ,y --decrypt ,x)) (unless (file=? y z) (fail "mismatch")))) '(msg_encrypted_256 msg_encrypted_384 msg_encrypted_521))) @@ -200,7 +199,7 @@ Rg== (tr:do (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,keyid)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) mainkeyids)) (append plain-files data-files)) @@ -217,7 +216,7 @@ Rg== (tr:do (tr:open source) (tr:gpg "" `(--yes --sign --local-user ,keyid)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) mainkeyids)) (append plain-files data-files)) @@ -243,7 +242,7 @@ Rg== (lambda (n) (call-check `(,(tool 'gpg) --import ,@(if (> n 1) '(--allow-non-selfsigned-uid) '()) - ,(in-srcdir (string-append + ,(in-srcdir "tests" "openpgp" (string-append "samplekeys/ecc-sample-" (number->string n) "-sec.asc"))))) diff --git a/tests/openpgp/enarmor.scm b/tests/openpgp/enarmor.scm index a301ccd..1fe3256 100755 --- a/tests/openpgp/enarmor.scm +++ b/tests/openpgp/enarmor.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p diff --git a/tests/openpgp/encrypt-dsa.scm b/tests/openpgp/encrypt-dsa.scm index 7ac1916..1658973 100755 --- a/tests/openpgp/encrypt-dsa.scm +++ b/tests/openpgp/encrypt-dsa.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,7 +26,7 @@ (tr:do (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,dsa-usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) @@ -40,7 +40,7 @@ (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,dsa-usrname2 --cipher-algo ,cipher)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files))) (force all-cipher-algos)) diff --git a/tests/openpgp/encrypt-multifile.scm b/tests/openpgp/encrypt-multifile.scm index 4b76ff0..1b69ff5 100755 --- a/tests/openpgp/encrypt-multifile.scm +++ b/tests/openpgp/encrypt-multifile.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define files (append plain-files data-files)) @@ -34,6 +34,6 @@ (lambda (source) (tr:do (tr:open (string-append source ".gpg")) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) files) diff --git a/tests/openpgp/encrypt.scm b/tests/openpgp/encrypt.scm index 4247aa8..f59a1f0 100755 --- a/tests/openpgp/encrypt.scm +++ b/tests/openpgp/encrypt.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,7 +26,7 @@ (tr:do (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) @@ -40,7 +40,7 @@ (tr:open source) (tr:gpg "" `(--yes --encrypt --recipient ,usrname2 --cipher-algo ,cipher)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files))) (force all-cipher-algos)) @@ -54,8 +54,8 @@ (tr:do (tr:open source) (tr:gpg "" `(--yes -v --no-keyring --encrypt - --recipient-file ,(in-srcdir key-file1) - --hidden-recipient-file ,(in-srcdir key-file2))) - (tr:gpg "" '(--yes)) + --recipient-file ,(in-srcdir "tests" "openpgp" key-file1) + --hidden-recipient-file ,(in-srcdir "tests" "openpgp" key-file2))) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) plain-files) diff --git a/tests/openpgp/encryptp.scm b/tests/openpgp/encryptp.scm index d939190..0f09a1e 100755 --- a/tests/openpgp/encryptp.scm +++ b/tests/openpgp/encryptp.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -27,6 +27,6 @@ (tr:open source) (tr:pipe-do (pipe:gpg `(--yes --encrypt --recipient ,usrname2)) - (pipe:gpg '(--yes))) + (pipe:gpg '(--yes --decrypt))) (tr:assert-identity source))) (append plain-files data-files)) diff --git a/tests/openpgp/export.scm b/tests/openpgp/export.scm index c10fc81..aa6fa78 100755 --- a/tests/openpgp/export.scm +++ b/tests/openpgp/export.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define (check-for predicate lines message) diff --git a/tests/openpgp/fake-pinentry.c b/tests/openpgp/fake-pinentry.c index 6585b01..fb0c6ae 100644 --- a/tests/openpgp/fake-pinentry.c +++ b/tests/openpgp/fake-pinentry.c @@ -126,6 +126,8 @@ get_passphrase (const char *fname) fname, fname_new, strerror (errno)); exit (1); } + + free (fname_new); return passphrase; } diff --git a/tests/openpgp/genkey1024.scm b/tests/openpgp/genkey1024.scm index 60eba0b..4edf490 100755 --- a/tests/openpgp/genkey1024.scm +++ b/tests/openpgp/genkey1024.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (define (genkey config) diff --git a/tests/openpgp/gpg-agent.conf.tmpl b/tests/openpgp/gpg-agent.conf.tmpl deleted file mode 100644 index 3559150..0000000 --- a/tests/openpgp/gpg-agent.conf.tmpl +++ /dev/null @@ -1,3 +0,0 @@ -allow-preset-passphrase -no-grab -enable-ssh-support diff --git a/tests/openpgp/gpg.conf.tmpl b/tests/openpgp/gpg.conf.tmpl deleted file mode 100644 index 19f3180..0000000 --- a/tests/openpgp/gpg.conf.tmpl +++ /dev/null @@ -1,4 +0,0 @@ -no-greeting -no-secmem-warning -no-permission-warning -batch diff --git a/tests/openpgp/gpgconf.scm b/tests/openpgp/gpgconf.scm index 33d04d8..a940b45 100644 --- a/tests/openpgp/gpgconf.scm +++ b/tests/openpgp/gpgconf.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (for-each-p' diff --git a/tests/openpgp/gpgtar.scm b/tests/openpgp/gpgtar.scm index c88589f..906707f 100755 --- a/tests/openpgp/gpgtar.scm +++ b/tests/openpgp/gpgtar.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (catch (skip "gpgtar not built") diff --git a/tests/openpgp/gpgv-forged-keyring.scm b/tests/openpgp/gpgv-forged-keyring.scm index 6885cd9..886d265 100755 --- a/tests/openpgp/gpgv-forged-keyring.scm +++ b/tests/openpgp/gpgv-forged-keyring.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define msg_signed_asc " @@ -63,6 +63,6 @@ N1Glbw1OJfP1q+QFPMPKoCsTYmZpuugq2b5gV/eH0Abvk2pG4Fo/YTDPHhec7Jk= (catch '() (pipe:do (pipe:echo (eval armored-file (current-environment))) - (pipe:spawn `(,@GPGV --keyring ,(in-srcdir "forged-keyring.gpg")))) + (pipe:spawn `(,@GPGV --keyring ,(in-srcdir "tests" "openpgp" "forged-keyring.gpg")))) (fail "verification succeeded but should not"))) '(msg_signed_asc)) diff --git a/tests/openpgp/import-revocation-certificate.scm b/tests/openpgp/import-revocation-certificate.scm index 9231afc..c685dc5 100644 --- a/tests/openpgp/import-revocation-certificate.scm +++ b/tests/openpgp/import-revocation-certificate.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) ;; XXX because of --always-trust, the trustdb is not created. @@ -25,7 +25,7 @@ (define gpg `(,(tool 'gpg) --no-permission-warning)) (info "Checking key revocation.") -(call-check `(,@gpg --import ,(in-srcdir "samplemsgs" +(call-check `(,@gpg --import ,(in-srcdir "tests" "openpgp" "samplemsgs" "revoke-2D727CC768697734.asc"))) (let loop ((output (gpg-with-colons '(--list-secret-keys "2D727CC768697734")))) (unless (null? output) diff --git a/tests/openpgp/import.scm b/tests/openpgp/import.scm index 3b41746..1f4cb2e 100755 --- a/tests/openpgp/import.scm +++ b/tests/openpgp/import.scm @@ -17,17 +17,17 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (info "Checking bug 894: segv importing certain keys.") -(call-check `(,(tool 'gpg) --import ,(in-srcdir "bug894-test.asc"))) +(call-check `(,(tool 'gpg) --import ,(in-srcdir "tests" "openpgp" "bug894-test.asc"))) (define keyid "0xC108E83A") (info "Checking bug 1223: designated revoker sigs are not properly merged.") (call `(,(tool 'gpg) --delete-key --batch --yes ,keyid)) -(call `(,(tool 'gpg) --import ,(in-srcdir "bug1223-bogus.asc"))) -(call `(,(tool 'gpg) --import ,(in-srcdir "bug1223-good.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "tests" "openpgp" "bug1223-bogus.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "tests" "openpgp" "bug1223-good.asc"))) (tr:do (tr:pipe-do (pipe:gpg `(--list-keys --with-colons ,keyid))) @@ -44,8 +44,8 @@ (define fpr2 "A55120427374F3F7AA5F1166DDA252EBB8EBE1AF") (info "Checking import of two keys with colliding long key ids.") (call `(,(tool 'gpg) --delete-key --batch --yes ,fpr1 ,fpr2)) -(call `(,(tool 'gpg) --import ,(in-srcdir "samplekeys/dda252ebb8ebe1af-1.asc"))) -(call `(,(tool 'gpg) --import ,(in-srcdir "samplekeys/dda252ebb8ebe1af-2.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "tests" "openpgp" "samplekeys/dda252ebb8ebe1af-1.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "tests" "openpgp" "samplekeys/dda252ebb8ebe1af-2.asc"))) (tr:do (tr:pipe-do (pipe:gpg `(--list-keys --with-colons ,fpr1 ,fpr2))) diff --git a/tests/openpgp/issue2015.scm b/tests/openpgp/issue2015.scm index 39df333..2f0672d 100755 --- a/tests/openpgp/issue2015.scm +++ b/tests/openpgp/issue2015.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (info "Checking passphrase cache (issue2015)...") diff --git a/tests/openpgp/issue2346.scm b/tests/openpgp/issue2346.scm index 9765453..9c29516 100755 --- a/tests/openpgp/issue2346.scm +++ b/tests/openpgp/issue2346.scm @@ -17,10 +17,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) -(define key (in-srcdir "samplekeys/issue2346.gpg")) +(define key (in-srcdir "tests" "openpgp" "samplekeys/issue2346.gpg")) (info "Checking import statistics (issue2346)...") (let ((status (call-popen `(,@GPG --status-fd=1 --import ,key) ""))) diff --git a/tests/openpgp/issue2417.scm b/tests/openpgp/issue2417.scm index f584000..32fe47f 100755 --- a/tests/openpgp/issue2417.scm +++ b/tests/openpgp/issue2417.scm @@ -17,10 +17,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) -(define keyfile (in-srcdir "samplekeys" "rsa-rsa-sample-1.asc")) +(define keyfile (in-srcdir "tests" "openpgp" "samplekeys" "rsa-rsa-sample-1.asc")) (define (touch file-name) (close (open file-name (logior O_WRONLY O_BINARY O_CREAT) #o600))) diff --git a/tests/openpgp/issue2419.scm b/tests/openpgp/issue2419.scm index e397a88..641fb32 100755 --- a/tests/openpgp/issue2419.scm +++ b/tests/openpgp/issue2419.scm @@ -17,13 +17,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (info "Checking iobuf_peek corner case (issue2419)...") (lettmp (onebyte) - (dearmor (in-srcdir "samplemsgs/issue2419.asc") onebyte) + (dearmor (in-srcdir "tests" "openpgp" "samplemsgs/issue2419.asc") onebyte) (catch (assert (string-contains? (car *error*) "invalid packet")) (call-popen `(,@GPG --list-packets ,onebyte) "") (fail "Expected an error but got none"))) diff --git a/tests/openpgp/issue2929.scm b/tests/openpgp/issue2929.scm index 121103b..d5c94cf 100644 --- a/tests/openpgp/issue2929.scm +++ b/tests/openpgp/issue2929.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (catch (skip "Tofu not supported") diff --git a/tests/openpgp/issue2941.scm b/tests/openpgp/issue2941.scm index d7220e0..8f625eb 100755 --- a/tests/openpgp/issue2941.scm +++ b/tests/openpgp/issue2941.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define (check-failure options) diff --git a/tests/openpgp/key-selection.scm b/tests/openpgp/key-selection.scm index 020c9b4..511c2e2 100644 --- a/tests/openpgp/key-selection.scm +++ b/tests/openpgp/key-selection.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) ;; This test assumes a fixed time of 2004-01-01. @@ -52,7 +52,7 @@ (define :comment cadr) (define :number caddr) (define (:filename key) - (in-srcdir "key-selection" + (in-srcdir "tests" "openpgp" "key-selection" (string-append (number->string (:number key)) ".asc"))) (define (delete-keys which) diff --git a/tests/openpgp/mds.scm b/tests/openpgp/mds.scm index fb468e5..50761d0 100755 --- a/tests/openpgp/mds.scm +++ b/tests/openpgp/mds.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (define empty-string-hashes diff --git a/tests/openpgp/multisig.scm b/tests/openpgp/multisig.scm index c643ac8..75682eb 100755 --- a/tests/openpgp/multisig.scm +++ b/tests/openpgp/multisig.scm @@ -23,7 +23,7 @@ ;; Note: We do not support multiple signatures anymore thus this test is ;; not really needed because verify could do the same. We keep it anyway. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define sig-1ls1ls-valid " diff --git a/tests/openpgp/quick-key-manipulation.scm b/tests/openpgp/quick-key-manipulation.scm index 85e56ca..c21abfe 100755 --- a/tests/openpgp/quick-key-manipulation.scm +++ b/tests/openpgp/quick-key-manipulation.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (load (with-path "time.scm")) (setup-environment) @@ -79,7 +79,7 @@ ;; XXX I don't know how to verify this. The keylisting does not seem ;; to indicate the primary UID. -(info "Checking that we get an error making non-existant user ID the primary one.") +(info "Checking that we get an error making non-existent user ID the primary one.") (catch '() (call-check `(,@GPG --quick-set-primary-uid ,(exact alpha) ,charlie)) (error "Expected an error, but get none.")) @@ -87,7 +87,7 @@ (info "Checking that we can revoke a user ID...") (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,alpha)) -(info "Checking that we get an error revoking a non-existant user ID.") +(info "Checking that we get an error revoking a non-existent user ID.") (catch '() (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,charlie)) (error "Expected an error, but get none.")) diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm index 139f618..d4914bd 100644 --- a/tests/openpgp/run-tests.scm +++ b/tests/openpgp/run-tests.scm @@ -17,19 +17,26 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(if (string=? "" (getenv "srcdir")) +(if (string=? "" (getenv "abs_top_srcdir")) (begin - (echo "Environment variable 'srcdir' not set. Please point it to" + (echo "Environment variable 'abs_top_srcdir' not set. Please point it to" "tests/openpgp.") (exit 2))) ;; Set objdir so that the tests can locate built programs. (setenv "objdir" (getcwd) #f) -(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) - (setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm"))) - (runner (if (and (member "--parallel" *args*) - (> (length tests) 1)) - run-tests-parallel - run-tests-sequential))) - (runner (map (lambda (t) (test::scm setup t t)) tests)))) +(define setup + (make-environment-cache (test::scm + #f + (path-join "tests" "openpgp" "setup.scm") + (in-srcdir "tests" "openpgp" "setup.scm")))) + +(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) + +(run-tests (if (null? tests) + (load-tests "tests" "openpgp") + (map (lambda (name) + (test::scm setup + (path-join "tests" "openpgp" name) + (in-srcdir "tests" "openpgp" name))) tests))) diff --git a/tests/openpgp/seat.scm b/tests/openpgp/seat.scm index 22a5a67..5cbfbe1 100755 --- a/tests/openpgp/seat.scm +++ b/tests/openpgp/seat.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,6 +26,6 @@ (tr:do (tr:open source) (tr:gpg usrpass1 '(--yes -seat -r two@example.com --passphrase-fd "0")) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-weak-identity source))) plain-files) diff --git a/tests/openpgp/setup.scm b/tests/openpgp/setup.scm index 4b3bfcb..22c89a3 100755 --- a/tests/openpgp/setup.scm +++ b/tests/openpgp/setup.scm @@ -17,10 +17,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) -(unless (member "--create-tarball" *args*) - (fail "Usage: setup.scm --create-tarball <file>")) +(define cache (flag "--create-tarball" *args*)) +(unless (and cache (= 1 (length cache))) + (fail "Usage: setup.scm --create-tarball <file> [--use-keyring]")) (when (> (*verbose*) 0) (define (pad symbol length) @@ -40,10 +41,9 @@ '(gpgconf gpg gpg-agent scdaemon gpgsm dirmngr gpg-connect-agent gpg-preset-passphrase gpgtar pinentry))) -(with-ephemeral-home-directory - (chdir (getenv "GNUPGHOME")) - (create-gpghome) - (start-agent) - (create-legacy-gpghome) - (stop-agent) - (call-check `(,(tool 'gpgtar) --create --output ,(cadr *args*) "."))) +(setenv "GNUPGHOME" (getcwd) #t) +(create-gpghome) +(start-agent) +(create-legacy-gpghome) +(stop-agent) +(call-check `(,(tool 'gpgtar) --create --output ,(car cache) ".")) diff --git a/tests/openpgp/shell.scm b/tests/openpgp/shell.scm index ea4b540..bd6059a 100644 --- a/tests/openpgp/shell.scm +++ b/tests/openpgp/shell.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) ;; This is not a test, but can be used to inspect the test diff --git a/tests/openpgp/signencrypt-dsa.scm b/tests/openpgp/signencrypt-dsa.scm index c969d2f..1a8f9df 100755 --- a/tests/openpgp/signencrypt-dsa.scm +++ b/tests/openpgp/signencrypt-dsa.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -28,7 +28,7 @@ (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -se -u ,dsa-usrname1 --recipient ,dsa-usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) @@ -44,6 +44,6 @@ -u ,dsa-usrname1 --recipient ,dsa-usrname2 --digest-algo ,hash)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity (car plain-files)))) algos) diff --git a/tests/openpgp/signencrypt.scm b/tests/openpgp/signencrypt.scm index 35ac89a..c00e370 100755 --- a/tests/openpgp/signencrypt.scm +++ b/tests/openpgp/signencrypt.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,14 +26,15 @@ (tr:do (tr:open source) (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -se --recipient ,usrname2)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) (info "Checking bug 537: MDC problem with old style compressed packets.") (lettmp (tmp) (call-popen `(,@GPG --yes --passphrase-fd "0" - --output ,tmp ,(in-srcdir "bug537-test.data.asc")) + --output ,tmp --decrypt ,(in-srcdir "tests" "openpgp" + "bug537-test.data.asc")) usrpass1) (if (not (string=? "4336AE2A528FAE091E73E59E325B588FEE795F9B" (cadar (gpg-hash-string `(--print-md SHA1 ,tmp) "")))) diff --git a/tests/openpgp/sigs-dsa.scm b/tests/openpgp/sigs-dsa.scm index f909078..82dc624 100755 --- a/tests/openpgp/sigs-dsa.scm +++ b/tests/openpgp/sigs-dsa.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,7 +26,7 @@ (tr:do (tr:open source) (tr:gpg "" `(--yes --sign --user ,dsa-usrname1)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) @@ -39,6 +39,6 @@ (tr:do (tr:open (car plain-files)) (tr:gpg "" `(--yes --sign --user ,dsa-usrname1 --digest-algo ,hash)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity (car plain-files)))) algos) diff --git a/tests/openpgp/sigs.scm b/tests/openpgp/sigs.scm index 5a1efa7..2b1cf3c 100755 --- a/tests/openpgp/sigs.scm +++ b/tests/openpgp/sigs.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (for-each-p @@ -26,7 +26,7 @@ (tr:do (tr:open source) (tr:gpg "" '(--yes --sign)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity source))) (append plain-files data-files)) @@ -38,7 +38,7 @@ (tr:do (tr:open (car plain-files)) (tr:gpg "" `(--yes --sign --user ,usrname3 --digest-algo ,hash)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity (car plain-files)))) (if (not (equal? "MD5" hash)) ;; Using the DSA sig key - only 160 bit or larger hashes @@ -46,6 +46,6 @@ (tr:open (car plain-files)) (tr:gpg usrpass1 `(--yes --sign --passphrase-fd "0" --digest-algo ,hash)) - (tr:gpg "" '(--yes)) + (tr:gpg "" '(--yes --decrypt)) (tr:assert-identity (car plain-files))))) (force all-hash-algos)) diff --git a/tests/openpgp/ssh-export.scm b/tests/openpgp/ssh-export.scm index 322620e..7f51447 100755 --- a/tests/openpgp/ssh-export.scm +++ b/tests/openpgp/ssh-export.scm @@ -17,11 +17,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (define key - `(,(in-srcdir "samplekeys" "authenticate-only.sec.asc") + `(,(in-srcdir "tests" "openpgp" "samplekeys" "authenticate-only.sec.asc") "927EF377FD1A1B6F795E40C02A87917D8FFBA49F" "72360FDB6380212D5DAF2FA9E51185A9253C496D" "ssh-rsa")) diff --git a/tests/openpgp/ssh-import.scm b/tests/openpgp/ssh-import.scm index d210056..555f198 100755 --- a/tests/openpgp/ssh-import.scm +++ b/tests/openpgp/ssh-import.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (setenv "SSH_AUTH_SOCK" @@ -76,7 +76,7 @@ (for-each-p' "Importing ssh keys..." (lambda (key) - (let ((file (path-join (in-srcdir "samplekeys") + (let ((file (path-join (in-srcdir "tests" "openpgp" "samplekeys") (string-append "ssh-" (car key) ".key"))) (hash (cadr key))) ;; We pipe the key to ssh-add so that it won't complain about @@ -91,7 +91,7 @@ (info "Checking for issue2316...") (unlink (path-join GNUPGHOME "sshcontrol")) (pipe:do - (pipe:open (path-join (in-srcdir "samplekeys") + (pipe:open (path-join (in-srcdir "tests" "openpgp" "samplekeys") (string-append "ssh-rsa.key")) (logior O_RDONLY O_BINARY)) (pipe:spawn `(,SSH-ADD -))) diff --git a/tests/openpgp/tofu.scm b/tests/openpgp/tofu.scm index aeeef07..58b2a03 100755 --- a/tests/openpgp/tofu.scm +++ b/tests/openpgp/tofu.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (load (with-path "time.scm")) (setup-environment) @@ -41,7 +41,7 @@ ;; Import the test keys. (for-each (lambda (keyid) (call-check `(,@GPG --import - ,(in-srcdir "tofu/conflicting/" + ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" (string-append keyid ".gpg")))) (catch (fail "Missing key" keyid) (call-check `(,@GPG --list-keys ,keyid)))) @@ -108,7 +108,7 @@ ;; Verify a message. There should be no conflict and the trust ;; policy should be set to auto. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/1C005AF3-1.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-1.txt"))) (checkpolicy "1C005AF3" "auto") ;; Check default trust. @@ -163,7 +163,7 @@ ;; auto), but not affect 1C005AF3's policy. (setpolicy "BE04EB2B" "auto") (checkpolicy "BE04EB2B" "ask") -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/B662E42F-1.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "B662E42F-1.txt"))) (checkpolicy "BE04EB2B" "ask") (checkpolicy "1C005AF3" "bad") (checkpolicy "B662E42F" "ask") @@ -208,26 +208,26 @@ (check-counts "B662E42F" 0 0 0 0) ;; Verify a message. The signature count should increase by 1. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/1C005AF3-1.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-1.txt"))) (check-counts "1C005AF3" 1 1 0 0) ;; Verify the same message. The signature count should remain the ;; same. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/1C005AF3-1.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-1.txt"))) (check-counts "1C005AF3" 1 1 0 0) ;; Verify another message. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/1C005AF3-2.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-2.txt"))) (check-counts "1C005AF3" 2 1 0 0) ;; Verify another message. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/1C005AF3-3.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-3.txt"))) (check-counts "1C005AF3" 3 1 0 0) ;; Verify a message from a different sender. The signature count ;; should increase by 1 for that key. -(call-check `(,@GPG --verify ,(in-srcdir "tofu/conflicting/BE04EB2B-1.txt"))) +(call-check `(,@GPG --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "BE04EB2B-1.txt"))) (check-counts "1C005AF3" 3 1 0 0) (check-counts "BE04EB2B" 1 1 0 0) (check-counts "B662E42F" 0 0 0 0) @@ -236,34 +236,34 @@ ;; when the message was first verified, not when the signer claimed ;; that it was signed.) (call-check `(,@GPG ,(faketime (days->seconds 2)) - --verify ,(in-srcdir "tofu/conflicting/1C005AF3-4.txt"))) + --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-4.txt"))) (check-counts "1C005AF3" 4 2 0 0) (check-counts "BE04EB2B" 1 1 0 0) (check-counts "B662E42F" 0 0 0 0) ;; And another. (call-check `(,@GPG ,(faketime (days->seconds 2)) - --verify ,(in-srcdir "tofu/conflicting/1C005AF3-5.txt"))) + --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "1C005AF3-5.txt"))) (check-counts "1C005AF3" 5 2 0 0) (check-counts "BE04EB2B" 1 1 0 0) (check-counts "B662E42F" 0 0 0 0) ;; Another, but for a different key. (call-check `(,@GPG ,(faketime (days->seconds 2)) - --verify ,(in-srcdir "tofu/conflicting/BE04EB2B-2.txt"))) + --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "BE04EB2B-2.txt"))) (check-counts "1C005AF3" 5 2 0 0) (check-counts "BE04EB2B" 2 2 0 0) (check-counts "B662E42F" 0 0 0 0) ;; And add a third day. (call-check `(,@GPG ,(faketime (days->seconds 4)) - --verify ,(in-srcdir "tofu/conflicting/BE04EB2B-3.txt"))) + --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "BE04EB2B-3.txt"))) (check-counts "1C005AF3" 5 2 0 0) (check-counts "BE04EB2B" 3 3 0 0) (check-counts "B662E42F" 0 0 0 0) (call-check `(,@GPG ,(faketime (days->seconds 4)) - --verify ,(in-srcdir "tofu/conflicting/BE04EB2B-4.txt"))) + --verify ,(in-srcdir "tests" "openpgp" "tofu" "conflicting" "BE04EB2B-4.txt"))) (check-counts "1C005AF3" 5 2 0 0) (check-counts "BE04EB2B" 4 3 0 0) (check-counts "B662E42F" 0 0 0 0) @@ -293,15 +293,15 @@ (lambda (key) (for-each (lambda (i) - (let ((fn (in-srcdir DIR (string-append key "-" i ".txt")))) + (let ((fn (in-srcdir "tests" "openpgp" DIR (string-append key "-" i ".txt")))) (call-check `(,@GPG --verify ,fn)))) (list "1" "2"))) (list KEYIDA KEYIDB))) ;; Import the public keys. (display " > Two keys. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDA "-1.gpg")))) -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-1.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDA "-1.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-1.gpg")))) ;; Make sure the tofu engine registers the keys. (verify-messages) (display "<\n") @@ -312,8 +312,8 @@ ;; Import the cross sigs. (display " > Adding cross signatures. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDA "-2.gpg")))) -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-2.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDA "-2.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-2.gpg")))) (verify-messages) (display "<\n") @@ -323,7 +323,7 @@ ;; Import the conflicting user id. (display " > Adding conflicting user id. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-3.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-3.gpg")))) (verify-messages) (display "<\n") @@ -333,7 +333,7 @@ ;; Import Alice's signature on the conflicting user id. Since there ;; is now a cross signature, we should revert to the default policy. (display " > Adding cross signature on user id. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-4.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-4.gpg")))) (verify-messages) (display "<\n") @@ -385,15 +385,15 @@ (lambda (key) (for-each (lambda (i) - (let ((fn (in-srcdir DIR (string-append key "-" i ".txt")))) + (let ((fn (in-srcdir "tests" "openpgp" DIR (string-append key "-" i ".txt")))) (call-check `(,@GPG --verify ,fn)))) (list "1" "2"))) (list KEYIDA KEYIDB))) ;; Import the public keys. (display " > Two keys. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDA "-1.gpg")))) -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-1.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDA "-1.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-1.gpg")))) (display "<\n") (checkpolicy KEYA "auto") @@ -401,8 +401,8 @@ ;; Import the cross sigs. (display " > Adding cross signatures. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDA "-2.gpg")))) -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-2.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDA "-2.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-2.gpg")))) (display "<\n") (checkpolicy KEYA "auto") @@ -423,7 +423,7 @@ ;; Import the conflicting user id. (display " > Adding conflicting user id. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-3.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-3.gpg")))) (verify-messages) (display "<\n") @@ -432,7 +432,7 @@ ;; Import Alice's signature on the conflicting user id. (display " > Adding cross signature on user id. ") -(call-check `(,@GPG --import ,(in-srcdir DIR (string-append KEYIDB "-4.gpg")))) +(call-check `(,@GPG --import ,(in-srcdir "tests" "openpgp" DIR (string-append KEYIDB "-4.gpg")))) (verify-messages) (display "<\n") diff --git a/tests/openpgp/use-exact-key.scm b/tests/openpgp/use-exact-key.scm index 18851da..8bff9af 100755 --- a/tests/openpgp/use-exact-key.scm +++ b/tests/openpgp/use-exact-key.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) ;; Import the sample key @@ -33,7 +33,7 @@ (info "Importing public key.") (call-check `(,(tool 'gpg) --import - ,(in-srcdir "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) + ,(in-srcdir "tests" "openpgp" "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) ;; By default, the most recent, valid signing subkey (1EA97479). (for-each-p diff --git a/tests/openpgp/verify-multifile.scm b/tests/openpgp/verify-multifile.scm index f1cbe99..9ebb672 100755 --- a/tests/openpgp/verify-multifile.scm +++ b/tests/openpgp/verify-multifile.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) (define files '("clearsig-1-key-1.asc" "signed-1-key-1.asc")) @@ -27,7 +27,7 @@ (let* ((status (call-popen `(,@gpg --verify --multifile --status-fd=1 - ,@(map (lambda (name) (in-srcdir "samplemsgs" name)) files)) + ,@(map (lambda (name) (in-srcdir "tests" "openpgp" "samplemsgs" name)) files)) "")) (lines (map (lambda (l) (assert (string-prefix? l "[GNUPG:] ")) diff --git a/tests/openpgp/verify.scm b/tests/openpgp/verify.scm index d3bd763..cb6eb59 100755 --- a/tests/openpgp/verify.scm +++ b/tests/openpgp/verify.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-legacy-environment) ;; @@ -343,7 +343,7 @@ GisM ;;; Need to import the ed25519 sample key used for ;;; the next two tests. -(call-check `(,@GPG --quiet --yes --import ,(in-srcdir key-file2))) +(call-check `(,@GPG --quiet --yes --import ,(in-srcdir "tests" "openpgp" key-file2))) (for-each-p "Checking that a valid Ed25519 signature is verified as such" (lambda (armored-file) diff --git a/tests/openpgp/version.scm b/tests/openpgp/version.scm index 2b211d8..c2252c5 100755 --- a/tests/openpgp/version.scm +++ b/tests/openpgp/version.scm @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see <http://www.gnu.org/licenses/>. -(load (with-path "defs.scm")) +(load (in-srcdir "tests" "openpgp" "defs.scm")) (setup-environment) (info "Printing the GPG version") diff --git a/tests/pkits/Makefile.am b/tests/pkits/Makefile.am index 9de1f8c..3dc2f16 100644 --- a/tests/pkits/Makefile.am +++ b/tests/pkits/Makefile.am @@ -46,7 +46,7 @@ testscripts = import-all-certs validate-all-certs \ EXTRA_DIST = inittests runtest common.sh $(testscripts) ChangeLog-2011 \ import-all-certs.data -TESTS = $(testscripts) +TESTS = CLEANFILES = inittests.stamp scratch.*.tmp x y z out err *.lock .\#lk* *.log diff --git a/tests/pkits/README b/tests/pkits/README index 17f03ea..06aa97b 100644 --- a/tests/pkits/README +++ b/tests/pkits/README @@ -7,7 +7,7 @@ http://csrc.nist.gov/pki/testing/x509paths.html . README - this file. PKITS_data.tar.bz2 - the original ZIP file, repackaged as a tarball. Makefile.am - Part of our build system. -import-all-certs - Run a simple import test on all certifcates +import-all-certs - Run a simple import test on all certificates validate-all-certs - Run an import and validate test on all certificates signature-verification - PKITS test 4.1 validity-periods - PKITS test 4.2 diff --git a/tests/pkits/common.sh b/tests/pkits/common.sh index ca18b95..697f28f 100644 --- a/tests/pkits/common.sh +++ b/tests/pkits/common.sh @@ -52,7 +52,7 @@ if [ -n "$GPG_AGENT_INFO" ]; then exit 1 fi -if [ -f PKITS_data.tar.bz2 ]; then +if [ -f "$srcdir/PKITS_data.tar.bz2" ]; then : else if [ "$pgmname" = "import-all-certs" ]; then diff --git a/tests/pkits/inittests b/tests/pkits/inittests index 5c29bdc..4bff0a8 100755 --- a/tests/pkits/inittests +++ b/tests/pkits/inittests @@ -58,8 +58,8 @@ if [ -n "$GPG_AGENT_INFO" ]; then exit 1 fi -if test -f PKITS_data.tar.bz2; then - if ! bunzip2 -c PKITS_data.tar.bz2 | tar xf - ; then +if test -f "$srcdir/PKITS_data.tar.bz2"; then + if ! bunzip2 -c "$srcdir/PKITS_data.tar.bz2" | tar xf - ; then echo "inittests: failed to untar the test data" >&2 exit 1 fi diff --git a/tests/run-tests.scm b/tests/run-tests.scm new file mode 100644 index 0000000..d3ebba0 --- /dev/null +++ b/tests/run-tests.scm @@ -0,0 +1,44 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG 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. +;; +;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>. + +(info "Running all tests...") + +(define (load-tests-with-log . path) + (map (lambda (test) + (test:::set! 'log-file-name + (apply path-join `(,@path + ,(string-append (basename test::name) + ".log"))))) + (apply load-tests path))) + +(let ((prefix (flag "--prefix" *args*)) + (all-tests (append + (load-tests-with-log "common") + (load-tests-with-log "g10") + (load-tests-with-log "g13") + (load-tests-with-log "agent") + (load-tests-with-log "tests" "openpgp") + (load-tests-with-log "tests" "migrations") + (load-tests-with-log "tests" "gpgsm") + (load-tests-with-log "tests" "gpgme")))) + (run-tests (if prefix + (filter + (lambda (t) (string-prefix? t::name (apply path-join prefix))) + all-tests) + all-tests))) |