diff options
| author | Justus Winter <[email protected]> | 2016-12-22 13:42:50 +0000 |
|---|---|---|
| committer | Justus Winter <[email protected]> | 2017-01-02 10:02:34 +0000 |
| commit | b79274a3b7e58f88e9a8c1dc1fb24dd3e983543c (patch) | |
| tree | c2a73dd4a9288f804d50794e6fd9439514d53d0f | |
| parent | gpgscm: Use boxed values for source locations. (diff) | |
| download | gnupg-b79274a3b7e58f88e9a8c1dc1fb24dd3e983543c.tar.gz gnupg-b79274a3b7e58f88e9a8c1dc1fb24dd3e983543c.zip | |
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 <[email protected]>
| -rw-r--r-- | tests/gpgscm/init.scm | 17 | ||||
| -rw-r--r-- | 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 106afd554..83261b001 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*)) + ,@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 f127a93b2..5954704bf 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 ,@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 () ,@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) |