[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
From: |
Ludovic Courtès |
Date: |
Mon, 19 Mar 2018 19:00:58 -0400 (EDT) |
branch: master
commit 99d88929a62207843aa66cbfb7093391e54ea199
Author: Ludovic Courtès <address@hidden>
Date: Mon Mar 19 22:13:54 2018 +0100
'with-store' and 'with-database' and written in terms of 'unwind-protect'.
* src/cuirass/base.scm (with-store): Rewrite using 'unwind-protect'.
* src/cuirass/database.scm (with-database): Likewise.
---
src/cuirass/base.scm | 25 ++++++++++++-------------
src/cuirass/database.scm | 6 ++----
2 files changed, 14 insertions(+), 17 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index c0091bc..a3fc316 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -67,19 +67,18 @@
;; currently closes in a 'dynamic-wind' handler, which means it would close
;; the store at each context switch. Remove this when the real 'with-store'
;; has been fixed.
- (let* ((store (open-connection))
- (result (begin
- ;; Always set #:keep-going? so we don't stop on the first
- ;; build failure. Set #:print-build-trace explicitly to
- ;; make sure 'process-build-log' sees build events.
- (set-build-options store
- #:use-substitutes? (%use-substitutes?)
- #:fallback? (%fallback?)
- #:keep-going? #t
- #:print-build-trace #t)
- exp ...)))
- (close-connection store)
- result))
+ (let ((store (open-connection)))
+ (unwind-protect
+ ;; Always set #:keep-going? so we don't stop on the first build failure.
+ ;; Set #:print-build-trace explicitly to make sure 'process-build-log'
+ ;; sees build events.
+ (set-build-options store
+ #:use-substitutes? (%use-substitutes?)
+ #:fallback? (%fallback?)
+ #:keep-going? #t
+ #:print-build-trace #t)
+ exp ...
+ (close-connection store))))
(cond-expand
(guile-2.2
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index f47152a..2b1d532 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -253,10 +253,8 @@ INSERT INTO Evaluations (specification, revision) VALUES ("
;; XXX: We don't install an unwind handler to play well with delimited
;; continuations and fibers. But as a consequence, we leak DB when BODY
;; raises an exception.
- (let* ((db (db-open))
- (result (begin body ...)))
- (db-close db)
- result))
+ (let ((db (db-open)))
+ (unwind-protect body ... (db-close db))))
(define* (read-quoted-string #:optional (port (current-input-port)))
"Read all of the characters out of PORT and return them as a SQL quoted