security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2024-12-22 10:19:57 +01:00
Code Activity

gpgscm: Add 'finally', rework all macros.

Browse Source 
* 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 ; the thrown exception is bound to *error*. Errors can be rethrown
; using (rethrow *error*). ; 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: ; Exceptions are thrown with:
; ;
; (throw "message") ; (throw "message")
@ -622,6 +632,13 @@
(pop-handler) (pop-handler)
,label))))) ,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'. ;; Make the vm use throw'.
(define *error-hook* 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 ;; Bind all variables given in <bindings> and initialize each of them
;; to the given initial value, and close them after evaluting <body>. ;; to the given initial value, and close them after evaluting <body>.
(macro (letfd form) (define-macro (letfd bindings . body)
(let ((result-sym (gensym))) (let bind ((bindings' bindings))
`((lambda (,(caaadr form)) (if (null? bindings')
(let ((,result-sym `(begin ,@body)
,(if (= 1 (length (cadr form))) (let* ((binding (car bindings'))
`(catch (begin (close ,(caaadr form)) (name (car binding))
(rethrow *error*)) (initializer (cadr binding)))
,@(cddr form)) `(let ((,name ,initializer))
`(letfd ,(cdadr form) ,@(cddr form))))) (finally (close ,name)
(close ,(caaadr form)) ,(bind (cdr bindings'))))))))
,result-sym)) ,@(cdaadr form))))
(macro (with-working-directory form) (define-macro (with-working-directory new-directory . expressions)
(let ((result-sym (gensym)) (cwd-sym (gensym))) (let ((new-dir (gensym))
`(let* ((,cwd-sym (getcwd)) (old-dir (gensym)))
(_ (if ,(cadr form) (chdir ,(cadr form)))) `(let* ((,new-dir ,new-directory)
(,result-sym (catch (begin (chdir ,cwd-sym) (,old-dir (getcwd)))
(rethrow *error*)) (dynamic-wind
,@(cddr form)))) (lambda () (if ,new-dir (chdir ,new-dir)))
(chdir ,cwd-sym) (lambda () ,@expressions)
,result-sym))) (lambda () (chdir ,old-dir))))))
;; Make a temporary directory. If arguments are given, they are ;; Make a temporary directory. If arguments are given, they are
;; joined using path-join, and must end in a component ending in ;; joined using path-join, and must end in a component ending in
@ -278,18 +277,12 @@
"-XXXXXX")) "-XXXXXX"))
(apply path-join components)))) (apply path-join components))))
(macro (with-temporary-working-directory form) (define-macro (with-temporary-working-directory . expressions)
(let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) (let ((tmp-sym (gensym)))
`(let* ((,cwd-sym (getcwd)) `(let* ((,tmp-sym (mkdtemp)))
(,tmp-sym (mkdtemp)) (finally (unlink-recursively ,tmp-sym)
(_ (chdir ,tmp-sym)) (with-working-directory ,tmp-sym
(,result-sym (catch (begin (chdir ,cwd-sym) ,@expressions)))))
(unlink-recursively ,tmp-sym)
(rethrow *error*))
,@(cdr form))))
(chdir ,cwd-sym)
(unlink-recursively ,tmp-sym)
,result-sym)))
(define (make-temporary-file . args) (define (make-temporary-file . args)
(canonical-path (path-join (canonical-path (path-join
@ -310,17 +303,15 @@
;; Bind all variables given in <bindings>, initialize each of them to ;; Bind all variables given in <bindings>, initialize each of them to
;; a string representing an unique path in the filesystem, and delete ;; a string representing an unique path in the filesystem, and delete
;; them after evaluting <body>. ;; them after evaluting <body>.
(macro (lettmp form) (define-macro (lettmp bindings . body)
(let ((result-sym (gensym))) (let bind ((bindings' bindings))
`((lambda (,(caadr form)) (if (null? bindings')
(let ((,result-sym `(begin ,@body)
,(if (= 1 (length (cadr form))) (let ((name (car bindings'))
`(catch (begin (remove-temporary-file ,(caadr form)) (rest (cdr bindings')))
(rethrow *error*)) `(let ((,name (make-temporary-file ,(symbol->string name))))
,@(cddr form)) (finally (remove-temporary-file ,name)
`(lettmp ,(cdadr form) ,@(cddr form))))) ,(bind rest)))))))
(remove-temporary-file ,(caadr form))
,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
(define (check-execution source transformer) (define (check-execution source transformer)
(lettmp (sink) (lettmp (sink)