[Pkg-gnupg-commit] [gnupg2] 22/116: gpgscm: Add 'finally', rework all macros.

Daniel Kahn Gillmor dkg at fifthhorseman.net
Tue Jan 24 04:40:50 UTC 2017


This is an automated email from the git hooks/post-receive script.

dkg pushed a commit to branch master
in repository gnupg2.

commit b79274a3b7e58f88e9a8c1dc1fb24dd3e983543c
Author: Justus Winter <justus at g10code.com>
Date:   Thu Dec 22 14:42:50 2016 +0100

    gpgscm: Add 'finally', rework all macros.
    
    * tests/gpgscm/init.scm (finally): New macro.
    * tests/gpgscm/tests.scm (letfd): Rewrite.
    (with-working-directory): Likewise.
    (with-temporary-working-directory): Likewise.
    (lettmp): Likewise.
    --
    
    Rewrite all our macros using 'define-macro'. Use the new control flow
    mechanism 'finally', or 'dynamic-wind' where appropriate.  Make sure
    the macros are hygienic.  Reduce code duplication.
    
    Signed-off-by: Justus Winter <justus at g10code.com>
---
 tests/gpgscm/init.scm  | 17 +++++++++++
 tests/gpgscm/tests.scm | 79 ++++++++++++++++++++++----------------------------
 2 files changed, 52 insertions(+), 44 deletions(-)

diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index 106afd5..83261b0 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -569,6 +569,16 @@
 ;    the thrown exception is bound to *error*.  Errors can be rethrown
 ;    using (rethrow *error*).
 ;
+;    Finalization can be expressed using "finally":
+;
+;         (finally (finalize-something called-purely-for side-effects)
+;              (whether-or-not something goes-wrong)
+;              (with-these calls))
+;
+;    The final expression is executed purely for its side-effects,
+;    both when the function exits successfully, and when an exception
+;    is thrown.
+;
 ;    Exceptions are thrown with:
 ;
 ;         (throw "message")
@@ -622,6 +632,13 @@
                     (pop-handler)
                     ,label)))))
 
+(define-macro (finally final-expression . expressions)
+  (let ((result (gensym)))
+    `(let ((,result (catch (begin ,final-expression (rethrow *error*))
+			   , at expressions)))
+       ,final-expression
+       ,result)))
+
 ;; Make the vm use throw'.
 (define *error-hook* throw')
 
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index f127a93..5954704 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -244,27 +244,26 @@
 ;;
 ;; Bind all variables given in <bindings> and initialize each of them
 ;; to the given initial value, and close them after evaluting <body>.
-(macro (letfd form)
-  (let ((result-sym (gensym)))
-    `((lambda (,(caaadr form))
-	(let ((,result-sym
-	       ,(if (= 1 (length (cadr form)))
-		    `(catch (begin (close ,(caaadr form))
-				   (rethrow *error*))
-			    ,@(cddr form))
-		    `(letfd ,(cdadr form) ,@(cddr form)))))
-	  (close ,(caaadr form))
-	  ,result-sym)) ,@(cdaadr form))))
-
-(macro (with-working-directory form)
-  (let ((result-sym (gensym)) (cwd-sym (gensym)))
-    `(let* ((,cwd-sym (getcwd))
-	    (_ (if ,(cadr form) (chdir ,(cadr form))))
-	    (,result-sym (catch (begin (chdir ,cwd-sym)
-				       (rethrow *error*))
-				,@(cddr form))))
-       (chdir ,cwd-sym)
-       ,result-sym)))
+(define-macro (letfd bindings . body)
+  (let bind ((bindings' bindings))
+    (if (null? bindings')
+	`(begin , at body)
+	(let* ((binding (car bindings'))
+	       (name (car binding))
+	       (initializer (cadr binding)))
+	  `(let ((,name ,initializer))
+	     (finally (close ,name)
+		      ,(bind (cdr bindings'))))))))
+
+(define-macro (with-working-directory new-directory . expressions)
+  (let ((new-dir (gensym))
+	(old-dir (gensym)))
+    `(let* ((,new-dir ,new-directory)
+	    (,old-dir (getcwd)))
+       (dynamic-wind
+	   (lambda () (if ,new-dir (chdir ,new-dir)))
+	   (lambda () , at expressions)
+	   (lambda () (chdir ,old-dir))))))
 
 ;; Make a temporary directory.  If arguments are given, they are
 ;; joined using path-join, and must end in a component ending in
@@ -278,18 +277,12 @@
 					  "-XXXXXX"))
 		(apply path-join components))))
 
-(macro (with-temporary-working-directory form)
-  (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
-    `(let* ((,cwd-sym (getcwd))
-	    (,tmp-sym (mkdtemp))
-	    (_ (chdir ,tmp-sym))
-	    (,result-sym (catch (begin (chdir ,cwd-sym)
-				       (unlink-recursively ,tmp-sym)
-				       (rethrow *error*))
-				,@(cdr form))))
-       (chdir ,cwd-sym)
-       (unlink-recursively ,tmp-sym)
-       ,result-sym)))
+(define-macro (with-temporary-working-directory . expressions)
+  (let ((tmp-sym (gensym)))
+    `(let* ((,tmp-sym (mkdtemp)))
+       (finally (unlink-recursively ,tmp-sym)
+		(with-working-directory ,tmp-sym
+					, at expressions)))))
 
 (define (make-temporary-file . args)
   (canonical-path (path-join
@@ -310,17 +303,15 @@
 ;; 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>.
-(macro (lettmp form)
-  (let ((result-sym (gensym)))
-    `((lambda (,(caadr form))
-	(let ((,result-sym
-	       ,(if (= 1 (length (cadr form)))
-		    `(catch (begin (remove-temporary-file ,(caadr form))
-				   (rethrow *error*))
-			    ,@(cddr form))
-		    `(lettmp ,(cdadr form) ,@(cddr form)))))
-	  (remove-temporary-file ,(caadr form))
-	  ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
+(define-macro (lettmp bindings . body)
+  (let bind ((bindings' bindings))
+    (if (null? bindings')
+	`(begin , at body)
+	(let ((name (car bindings'))
+	      (rest (cdr bindings')))
+	  `(let ((,name (make-temporary-file ,(symbol->string name))))
+	     (finally (remove-temporary-file ,name)
+		      ,(bind rest)))))))
 
 (define (check-execution source transformer)
   (lettmp (sink)

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git



More information about the Pkg-gnupg-commit mailing list