gpgscm: Make test framework less functional.

* tests/gpgscm/tests.scm (test-pool, tests): Previously, these methods
updated objects by creating new updated copies of the object being
manipulated.  This made the code awkward without any benefit,
therefore I change it to just update the object.

Signed-off-by: Justus Winter <justus@g10code.com>

tests/gpgscm/tests.scm

@@ -498,23 +498,22 @@
    (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)
+	      (current-environment)
-	      (let* ((names (map (lambda (t) t::name) unfinished))
+	      (let ((names (map (lambda (t) t::name) unfinished))
-		     (pids (map (lambda (t) t::pid) unfinished))
+		    (pids (map (lambda (t) t::pid) unfinished)))
-		     (results
+		(for-each
-		      (map (lambda (pid retcode) (list pid retcode))
+		 (lambda (test retcode) (test:::set! 'retcode retcode))
-			   pids
+		 (map pid->test pids)
-			   (wait-processes (map stringify names) pids #t))))
+		 (wait-processes (map stringify names) pids #t)))))
-		(new
+	(current-environment))
-		 (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)
@@ -568,14 +567,9 @@
 
    (define (new name directory spawn pid retcode logfd)
      (package
-      (define (set-directory x)
+      (define (:set! key value)
-	(new name x spawn pid retcode logfd))
+	(eval `(set! ,key ,value) (current-environment))
-      (define (set-retcode x)
+	(current-environment))
-	(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))
       (define (open-log-file)
 	(let ((filename (string-append (basename name) ".log")))
 	  (catch '() (unlink filename))
@@ -584,24 +578,25 @@
 	(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))))
+	      (set! pid pid')
-		(t'::report)
+	      (set! retcode (wait-process name pid' #t)))))
-		t')))))
+	(report)
+	(current-environment))
       (define (run-sync-quiet . args)
 	(with-working-directory directory
-	  (set-retcode
+	  (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))
-	   (wait-process
+	  (set! retcode (wait-process name pid #t)))
-	    name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
+	(current-environment))
       (define (run-async . args)
 	(let ((log (open-log-file)))
 	  (with-working-directory directory
-	    (new name directory spawn
+	    (set! pid (spawn args CLOSED_FD log log)))
-		 (spawn args CLOSED_FD log log)
+	  (set! logfd log))
-		 retcode log))))
+	(current-environment))
       (define (status)
 	(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
 	  (if (not t) "FAIL" (cadr t))))
@@ -620,10 +615,10 @@
 	(let ((results (pool::wait)))
 	  (for-each (lambda (t) (t::report)) (reverse results::procs))
 	  (exit (results::report)))
-	(let* ((wd (mkdtemp-autoremove))
+	(let ((wd (mkdtemp-autoremove))
-	       (test (car tests'))
+	      (test (car tests')))
-	       (test' (test::set-directory wd)))
+	  (test:::set! 'directory wd)
-	  (loop (pool::add (test'::run-async))
+	  (loop (pool::add (test::run-async))
 		(cdr tests'))))))
 
 ;; Run the setup target to create an environment, then run all given
@@ -633,10 +628,10 @@
     (if (null? tests')
 	(let ((results (pool::wait)))
 	  (exit (results::report)))
-	(let* ((wd (mkdtemp-autoremove))
+	(let ((wd (mkdtemp-autoremove))
-	       (test (car tests'))
+	      (test (car tests')))
-	       (test' (test::set-directory wd)))
+	  (test:::set! 'directory wd)
-	  (loop (pool::add (test'::run-sync))
+	  (loop (pool::add (test::run-sync))
 		(cdr tests'))))))
 
 ;; Helper to create environment caches from test functions.  SETUP