guile: Fix tests to match the `exit' behavior introduced in Guile 2.0.1.

This fix makes tests behave correctly wrt. to the Guile bug fix at
<http://git.sv.gnu.org/cgit/guile.git/commit/?id=e309f3bf9ee910c4772353ca3ff95f6f4ef466b5>.

12 files changed, 137 insertions, 152 deletions

diff --git a/guile/modules/Makefile.am b/guile/modules/Makefile.am
index c1829ed553..d1b1cac840 100644
--- a/guile/modules/Makefile.am
+++ b/guile/modules/Makefile.am
@@ -1,5 +1,5 @@
 #  GnuTLS --- Guile bindings for GnuTLS.
-#  Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+#  Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 #
 #  GnuTLS is free software; you can redistribute it and/or
 #  modify it under the terms of the GNU Lesser General Public
@@ -25,4 +25,5 @@ documentation_modules = system/documentation/README		\
 
 EXTRA_DIST = gnutls/build/enums.scm gnutls/build/smobs.scm	\
 	     gnutls/build/utils.scm gnutls/build/priorities.scm	\
+	     gnutls/build/tests.scm				\
              $(documentation_modules)
diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm
new file mode 100644
index 0000000000..ca3985f12b
--- /dev/null
+++ b/guile/modules/gnutls/build/tests.scm
@@ -0,0 +1,41 @@
+;;; GnuTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;
+;;; GnuTLS is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+;;;
+;;; GnuTLS is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with GnuTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+
+;;; Written by Ludovic Courtès <ludo@gnu.org>.
+
+(define-module (gnutls build tests)
+  #:export (run-test))
+
+(define (run-test thunk)
+  "Call `(exit (THUNK))'.  If THUNK raises an exception, then call `(exit 1)' and
+display a backtrace.  Otherwise, return THUNK's return value."
+  (exit
+   (catch #t
+     thunk
+     (lambda (key . args)
+       ;; Never reached.
+       (exit 1))
+     (lambda (key . args)
+       (dynamic-wind ;; to be on the safe side
+         (lambda () #t)
+         (lambda ()
+           (format (current-error-port)
+                   "~%throw to `~a' with args ~s~%" key args)
+           (display-backtrace (make-stack #t) (current-output-port)))
+         (lambda ()
+           (exit 1)))
+       (exit 1)))))
diff --git a/guile/tests/anonymous-auth.scm b/guile/tests/anonymous-auth.scm
index be04fcdeeb..8f5e5ae3a8 100644
--- a/guile/tests/anonymous-auth.scm
+++ b/guile/tests/anonymous-auth.scm
@@ -24,6 +24,7 @@
 ;;;
 
 (use-modules (gnutls)
+             (gnutls build tests)
              (srfi srfi-4))
 
 
@@ -50,10 +51,7 @@
 ;; (set-log-procedure! (lambda (level str)
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
-(dynamic-wind
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
             (pid         (primitive-fork)))
@@ -71,7 +69,7 @@
               (record-send client %message)
               (bye client close-request/rdwr)
 
-              (exit))
+              (primitive-exit))
 
             (let ((server (make-session connection-end/server)))
               ;; server-side
@@ -89,11 +87,7 @@
               (let* ((buf (make-u8vector (u8vector-length %message)))
                      (amount (record-receive! server buf)))
                 (bye server close-request/rdwr)
-                (exit (= amount (u8vector-length %message))
-                      (equal? buf %message)))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+                (and (= amount (u8vector-length %message))
+                     (equal? buf %message))))))))
 
 ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0
diff --git a/guile/tests/errors.scm b/guile/tests/errors.scm
index cec6491649..65b4ae9fa6 100644
--- a/guile/tests/errors.scm
+++ b/guile/tests/errors.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -22,25 +22,19 @@
 ;;; Test the error/exception mechanism.
 ;;;
 
-(use-modules (gnutls))
-
-(dynamic-wind
-    (lambda ()
-      #t)
+(use-modules (gnutls)
+             (gnutls build tests))
 
+(run-test
     (lambda ()
       (let ((s (make-session connection-end/server)))
         (catch 'gnutls-error
           (lambda ()
             (handshake s))
           (lambda (key err function . currently-unused)
-            (exit (and (eq? key 'gnutls-error)
-                       err
-                       (string? (error->string err))
-                       (eq? function 'handshake)))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+            (and (eq? key 'gnutls-error)
+                 err
+                 (string? (error->string err))
+                 (eq? function 'handshake)))))))
 
 ;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2
diff --git a/guile/tests/openpgp-auth.scm b/guile/tests/openpgp-auth.scm
index 61481830eb..9e3a3e49c7 100644
--- a/guile/tests/openpgp-auth.scm
+++ b/guile/tests/openpgp-auth.scm
@@ -25,6 +25,7 @@
 
 (use-modules (gnutls)
              (gnutls extra)
+             (gnutls build tests)
              (srfi srfi-4))
 
 
@@ -59,10 +60,7 @@
 ;; (set-log-procedure! (lambda (level str)
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
-(dynamic-wind
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
             (pub         (import-key import-openpgp-certificate
@@ -87,7 +85,7 @@
                 (write %message (session-record-port client))
                 (bye client close-request/rdwr)
 
-                (exit))
+                (primitive-exit))
 
               (let ((server (make-session connection-end/server))
                     (rsa    (import-rsa-params "rsa-parameters.pem"))
@@ -109,11 +107,7 @@
                 (let ((msg (read (session-record-port server)))
                       (auth-type (session-authentication-type server)))
                   (bye server close-request/rdwr)
-                  (exit (and (eq? auth-type credentials/certificate)
-                             (equal? msg %message)))))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+                  (and (eq? auth-type credentials/certificate)
+                       (equal? msg %message)))))))))
 
 ;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff
diff --git a/guile/tests/openpgp-keyring.scm b/guile/tests/openpgp-keyring.scm
index e5cffc5d87..576a9db977 100644
--- a/guile/tests/openpgp-keyring.scm
+++ b/guile/tests/openpgp-keyring.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS-extra is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -24,6 +24,7 @@
 ;;;
 
 (use-modules (gnutls extra) (gnutls)
+             (gnutls build tests)
              (srfi srfi-1)
              (srfi srfi-4))
 
@@ -59,21 +60,12 @@
                     (openpgp-keyring-contains-key-id? keyring id))
                   %ids-in-keyring)))))
 
-(dynamic-wind
-
-    (lambda ()
-      #t)
-
-    (lambda ()
-      (exit
-       (every valid-keyring?
-              (list %raw-keyring-file
-                    %ascii-keyring-file)
-              (list openpgp-certificate-format/raw
-                    openpgp-certificate-format/base64))))
-
+(run-test
     (lambda ()
-      ;; failure
-      (exit 1)))
+      (every valid-keyring?
+             (list %raw-keyring-file
+                   %ascii-keyring-file)
+             (list openpgp-certificate-format/raw
+                   openpgp-certificate-format/base64))))
 
 ;;; arch-tag: 516bf608-5c8b-4787-abe9-5f7b6e6d660b
diff --git a/guile/tests/openpgp-keys.scm b/guile/tests/openpgp-keys.scm
index 6049984336..2ded32da54 100644
--- a/guile/tests/openpgp-keys.scm
+++ b/guile/tests/openpgp-keys.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS-extra is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -25,6 +25,7 @@
 
 (use-modules (gnutls)
              (gnutls extra)
+             (gnutls build tests)
              (srfi srfi-1)
              (srfi srfi-4)
              (srfi srfi-11))
@@ -43,11 +44,7 @@
   (stat:size (stat file)))
 
 
-(dynamic-wind
-
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       (let ((raw-pubkey  (make-u8vector (file-size %certificate-file)))
             (raw-privkey (make-u8vector (file-size %private-key-file))))
@@ -60,20 +57,16 @@
               (sec (import-openpgp-private-key raw-privkey
                                            openpgp-certificate-format/base64)))
 
-          (exit (and (openpgp-certificate? pub)
-                     (openpgp-private-key? sec)
-                     (equal? (openpgp-certificate-id pub) %key-id)
-                     (u8vector? (openpgp-certificate-fingerprint pub))
-                     (every string? (openpgp-certificate-names pub))
-                     (member (openpgp-certificate-version pub) '(3 4))
-                     (list? (openpgp-certificate-usage pub))
-                     (let-values (((pk bits)
-                                   (openpgp-certificate-algorithm pub)))
-                       (and (string? (pk-algorithm->string pk))
-                            (number? bits))))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+          (and (openpgp-certificate? pub)
+               (openpgp-private-key? sec)
+               (equal? (openpgp-certificate-id pub) %key-id)
+               (u8vector? (openpgp-certificate-fingerprint pub))
+               (every string? (openpgp-certificate-names pub))
+               (member (openpgp-certificate-version pub) '(3 4))
+               (list? (openpgp-certificate-usage pub))
+               (let-values (((pk bits)
+                             (openpgp-certificate-algorithm pub)))
+                 (and (string? (pk-algorithm->string pk))
+                      (number? bits))))))))
 
 ;;; arch-tag: 2ee2a377-7f4d-4031-92a8-275090e4f83d
diff --git a/guile/tests/pkcs-import-export.scm b/guile/tests/pkcs-import-export.scm
index 8900f15992..4121b1822c 100644
--- a/guile/tests/pkcs-import-export.scm
+++ b/guile/tests/pkcs-import-export.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
 ;;;
 
 (use-modules (gnutls)
+             (gnutls build tests)
              (srfi srfi-4))
 
 (define (import-something import-proc file fmt)
@@ -36,25 +37,16 @@
   (import-something pkcs3-import-dh-parameters file
                     x509-certificate-format/pem))
 
-(dynamic-wind
-
-    (lambda ()
-      #t)
-
-    (lambda ()
-      (exit
-       (let* ((dh-params (import-dh-params "dh-parameters.pem"))
-              (export
-               (pkcs3-export-dh-parameters dh-params
-                                           x509-certificate-format/pem)))
-         (and (u8vector? export)
-              (let ((import
-                     (pkcs3-import-dh-parameters export
-                                                 x509-certificate-format/pem)))
-                (dh-parameters? import))))))
-
+(run-test
     (lambda ()
-      ;; failure
-      (exit 1)))
+      (let* ((dh-params (import-dh-params "dh-parameters.pem"))
+             (export
+              (pkcs3-export-dh-parameters dh-params
+                                          x509-certificate-format/pem)))
+        (and (u8vector? export)
+             (let ((import
+                    (pkcs3-import-dh-parameters export
+                                                x509-certificate-format/pem)))
+               (dh-parameters? import))))))
 
 ;;; arch-tag: adff0f07-479e-421e-b47f-8956e06b9902
diff --git a/guile/tests/session-record-port.scm b/guile/tests/session-record-port.scm
index a41ea2cd63..1d53d9b264 100644
--- a/guile/tests/session-record-port.scm
+++ b/guile/tests/session-record-port.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -24,6 +24,7 @@
 ;;;
 
 (use-modules (gnutls)
+             (gnutls build tests)
              (srfi srfi-4))
 
 
@@ -54,10 +55,7 @@
 ;; (set-log-procedure! (lambda (level str)
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
-(dynamic-wind
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       ;; Stress the GC.  In 0.0, this triggered an abort due to
       ;; "scm_unprotect_object called during GC".
@@ -104,7 +102,7 @@
               (uniform-vector-write %message (session-record-port client))
               (bye client close-request/rdwr)
 
-              (exit))
+              (primitive-exit))
 
             (let ((server (make-session connection-end/server)))
               ;; server-side
@@ -130,15 +128,11 @@
                 (bye server close-request/rdwr)
 
                 ;; Make sure we got everything right.
-                (exit (eq? (session-record-port server)
-                           (session-record-port server))
-                      (= amount (u8vector-length %message))
-                      (equal? buf %message)
-                      (eof-object?
-                       (read-char (session-record-port server)))))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+                (and (eq? (session-record-port server)
+                          (session-record-port server))
+                     (= amount (u8vector-length %message))
+                     (equal? buf %message)
+                     (eof-object?
+                      (read-char (session-record-port server))))))))))
 
 ;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2
diff --git a/guile/tests/srp-base64.scm b/guile/tests/srp-base64.scm
index c928f25306..484288a50f 100644
--- a/guile/tests/srp-base64.scm
+++ b/guile/tests/srp-base64.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -22,7 +22,8 @@
 ;;; Test SRP base64 encoding and decoding.
 ;;;
 
-(use-modules (gnutls))
+(use-modules (gnutls)
+             (gnutls build tests))
 
 (define %message
   "GnuTLS is free software; you can redistribute it and/or
@@ -30,10 +31,12 @@ modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2.1 of the License, or (at your option) any later version.")
 
-(exit (let ((encoded (srp-base64-encode %message)))
-        (and (string? encoded)
-             (string=? (srp-base64-decode encoded)
-                       %message))))
+(run-test
+ (lambda ()
+   (let ((encoded (srp-base64-encode %message)))
+     (and (string? encoded)
+          (string=? (srp-base64-decode encoded)
+                    %message)))))
 
 
 ;;; arch-tag: ea1534a5-d513-4208-9a75-54bd4710f915
diff --git a/guile/tests/x509-auth.scm b/guile/tests/x509-auth.scm
index 5e0663298a..433b745504 100644
--- a/guile/tests/x509-auth.scm
+++ b/guile/tests/x509-auth.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -24,6 +24,7 @@
 ;;;
 
 (use-modules (gnutls)
+             (gnutls build tests)
              (srfi srfi-4))
 
 
@@ -62,10 +63,7 @@
 ;; (set-log-procedure! (lambda (level str)
 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
 
-(dynamic-wind
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
             (pub         (import-key import-x509-certificate
@@ -95,7 +93,7 @@
                 (write %message (session-record-port client))
                 (bye client close-request/rdwr)
 
-                (exit))
+                (primitive-exit))
 
               (let ((server (make-session connection-end/server))
                     (rsa    (import-rsa-params "rsa-parameters.pem"))
@@ -128,11 +126,7 @@
                 (let ((msg (read (session-record-port server)))
                       (auth-type (session-authentication-type server)))
                   (bye server close-request/rdwr)
-                  (exit (and (eq? auth-type credentials/certificate)
-                             (equal? msg %message)))))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+                  (and (eq? auth-type credentials/certificate)
+                       (equal? msg %message)))))))))
 
 ;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d
diff --git a/guile/tests/x509-certificates.scm b/guile/tests/x509-certificates.scm
index fda227bbaa..67c1885b62 100644
--- a/guile/tests/x509-certificates.scm
+++ b/guile/tests/x509-certificates.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; GnuTLS is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
 ;;;
 
 (use-modules (gnutls)
+             (gnutls build tests)
              (srfi srfi-4)
              (srfi srfi-11))
 
@@ -45,11 +46,7 @@
   (stat:size (stat file)))
 
 
-(dynamic-wind
-
-    (lambda ()
-      #t)
-
+(run-test
     (lambda ()
       (let ((raw-certificate (make-u8vector (file-size %certificate-file)))
             (raw-privkey     (make-u8vector (file-size %private-key-file))))
@@ -64,23 +61,19 @@
               (sec  (import-x509-private-key raw-privkey
                                              x509-certificate-format/pem)))
 
-          (exit (and (x509-certificate? cert)
-                     (x509-private-key? sec)
-                     (string? (x509-certificate-dn cert))
-                     (string? (x509-certificate-issuer-dn cert))
-                     (string=? (x509-certificate-dn-oid cert 0) %first-oid)
-                     (eq? (x509-certificate-signature-algorithm cert)
-                          %signature-algorithm)
-                     (x509-certificate-matches-hostname? cert "localhost")
-                     (let-values (((type name)
-                                   (x509-certificate-subject-alternative-name
-                                    cert 0)))
-                       (and (string? name)
-                            (string?
-                             (x509-subject-alternative-name->string type)))))))))
-
-    (lambda ()
-      ;; failure
-      (exit 1)))
+          (and (x509-certificate? cert)
+               (x509-private-key? sec)
+               (string? (x509-certificate-dn cert))
+               (string? (x509-certificate-issuer-dn cert))
+               (string=? (x509-certificate-dn-oid cert 0) %first-oid)
+               (eq? (x509-certificate-signature-algorithm cert)
+                    %signature-algorithm)
+               (x509-certificate-matches-hostname? cert "localhost")
+               (let-values (((type name)
+                             (x509-certificate-subject-alternative-name
+                              cert 0)))
+                 (and (string? name)
+                      (string?
+                       (x509-subject-alternative-name->string type)))))))))
 
 ;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb