guile: tests: Add 'with-child-process'.

This makes sure that child processes always exit no matter what.

* guile/modules/gnutls/build/tests.scm (define-syntax-rule) [!guile-2]:
New macro.
(call-with-child-process): New procedure.
(with-child-process): New macro.
* guile/tests/anonymous-auth.scm, guile/tests/openpgp-auth.scm,
guile/tests/session-record-port.scm, guile/tests/x509-auth.scm: Use it
instead of an explicit 'primitive-fork' call.
* guile/.dir-locals.el: New file.
* guile/Makefile.am (EXTRA_DIST): New variable.

1 files changed, 39 insertions, 2 deletions

diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm
index f5e135b4f2..5a03ce7474 100644
--- a/guile/modules/gnutls/build/tests.scm
+++ b/guile/modules/gnutls/build/tests.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2011-2012, 2016 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
@@ -18,7 +18,8 @@
 ;;; Written by Ludovic Courtès <ludo@gnu.org>.
 
 (define-module (gnutls build tests)
-  #:export (run-test))
+  #:export (run-test
+            with-child-process))
 
 (define (run-test thunk)
   "Call `(exit (THUNK))'.  If THUNK raises an exception, then call `(exit 1)' and
@@ -39,3 +40,39 @@ display a backtrace.  Otherwise, return THUNK's return value."
          (lambda ()
            (exit 1)))
        (exit 1)))))
+
+(define (call-with-child-process child parent)
+  "Run thunk CHILD in a child process and invoke PARENT from the parent
+process, passing it the PID of the child process.  Make sure the child
+process exits upon failure."
+  (let ((pid (primitive-fork)))
+    (if (zero? pid)
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (primitive-exit (if (child) 0 1)))
+          (lambda ()
+            (primitive-exit 2)))
+        (parent pid))))
+
+(cond-expand
+  ((not guile-2)                                  ;1.8, yay!
+   (use-modules (ice-9 syncase))
+
+   (define-syntax define-syntax-rule
+     (syntax-rules ()
+       ((_ (name args ...) docstring body)
+        (define-syntax name
+          (syntax-rules ()
+            ((_ args ...) body))))))
+
+   (export define-syntax-rule))
+  (else
+   #t))
+
+(define-syntax-rule (with-child-process pid parent child)
+  "Fork and evaluate expression PARENT in the current process, with PID bound
+to the PID of its child process; the child process evaluated CHILD."
+  (call-with-child-process
+   (lambda () child)
+   (lambda (pid) parent)))