security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Releases Activity

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@g10code.com>
This commit is contained in:
Justus Winter 2016-12-22 14:42:50 +01:00
parent e8b843508d
commit b79274a3b7
2 changed files with 51 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
tests/gpgscm/init.scm
View File

@ -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*))
,@expressions)))
,final-expression
,result)))
;; Make the vm use throw'.
(define *error-hook* throw')

77
tests/gpgscm/tests.scm
View File

@ -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))))
(define-macro (letfd bindings . body)
(let bind ((bindings' bindings))
(if (null? bindings')
`(begin ,@body)
(let* ((binding (car bindings'))
(name (car binding))
(initializer (cadr binding)))
`(let ((,name ,initializer))
(finally (close ,name)
,(bind (cdr bindings'))))))))
(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 (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 () ,@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
,@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 ,@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)