[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