guile/modules/gnutls/build/tests.scm

   1 ;;; GnuTLS --- Guile bindings for GnuTLS.
   2 ;;; Copyright (C) 2011 Free Software Foundation, Inc.
   3 ;;;
   4 ;;; GnuTLS is free software; you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Lesser General Public
   6 ;;; License as published by the Free Software Foundation; either
   7 ;;; version 2.1 of the License, or (at your option) any later version.
   8 ;;;
   9 ;;; GnuTLS is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Lesser General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with GnuTLS; if not, write to the Free Software
  16 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  17
  18 ;;; Written by Ludovic Courtès <ludo@gnu.org>.
  19
  20 (define-module (gnutls build tests)
  21   #:export (run-test))
  22
  23 (define (run-test thunk)
  24   "Call `(exit (THUNK))'.  If THUNK raises an exception, then call `(exit 1)' and
  25 display a backtrace.  Otherwise, return THUNK's return value."
  26   (exit
  27    (catch #t
  28      thunk
  29      (lambda (key . args)
  30        ;; Never reached.
  31        (exit 1))
  32      (lambda (key . args)
  33        (dynamic-wind ;; to be on the safe side
  34          (lambda () #t)
  35          (lambda ()
  36            (format (current-error-port)
  37                    "~%throw to `~a' with args ~s~%" key args)
  38            (display-backtrace (make-stack #t) (current-output-port)))
  39          (lambda ()
  40            (exit 1)))
  41        (exit 1)))))