summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès2008-11-24 23:41:14 +0100
committerLudovic Courtès2008-11-24 23:41:14 +0100
commita8ace86ebdff03c9d374c54ffd3d1298ca531dda (patch)
tree5794c27676e11bf98f53ea7511502d6c24963f09
parent80e465ec094b1276596b267c132901b5b3cd0675 (diff)
downloadskribilo-a8ace86ebdff03c9d374c54ffd3d1298ca531dda.tar.gz
skribilo-a8ace86ebdff03c9d374c54ffd3d1298ca531dda.tar.lz
skribilo-a8ace86ebdff03c9d374c54ffd3d1298ca531dda.zip
Delete the destination file upon failure.
* src/guile/skribilo/condition.scm (abort): New. Delete `(*destination-file*)'. (%call-with-skribilo-error-catch): Use `abort' instead of `show-stack-trace' and `exit'. (with-exception-handler): New.
-rw-r--r--src/guile/skribilo/condition.scm56
1 files changed, 39 insertions, 17 deletions
diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm
index 2fc0e33..85ab70e 100644
--- a/src/guile/skribilo/condition.scm
+++ b/src/guile/skribilo/condition.scm
@@ -23,6 +23,7 @@
:autoload (srfi srfi-34) (with-exception-handler)
:use-module (srfi srfi-35)
:use-module (srfi srfi-39)
+ :autoload (skribilo parameters) (*destination-file*)
:autoload (skribilo utils syntax) (_ N_)
:export (&skribilo-error skribilo-error?
&invalid-argument-error invalid-argument-error?
@@ -127,7 +128,18 @@
(display-backtrace stack (current-error-port)))
(begin
(format (current-error-port) (_ "Call stack trace not available.~%"))
- (format (current-error-port) (_ "Use `GUILE=\"guile --debug\" skribilo ...' for a detailed stack trace."))))))
+ (format (current-error-port) (_ "Use `GUILE=\"guile --debug\" skribilo ...' for a detailed stack trace.~%"))))))
+
+(define (abort exit-val)
+ ;; Abort the `skribilo' command-line program, returning EXIT-VAL.
+
+ ;; XXX: Whether this works depends on whether `with-exception-handler' is
+ ;; broken, see below.
+ (and (string? (*destination-file*))
+ (false-if-exception (delete-file (*destination-file*))))
+
+ (show-stack-trace)
+ (exit exit-val))
(define (%call-with-skribilo-error-catch thunk exit exit-val)
(with-exception-handler
@@ -137,45 +149,39 @@
(_ "in `~a': invalid argument: ~S~%")
(invalid-argument-error:proc-name c)
(invalid-argument-error:argument c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((too-few-arguments-error? c)
(format (current-error-port)
(_ "in `~a': too few arguments: ~S~%")
(too-few-arguments-error:proc-name c)
(too-few-arguments-error:arguments c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((file-search-error? c)
(format (current-error-port)
(_ "~a: not found in path `~S'~%")
(file-error:file-name c)
(file-search-error:path c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((file-open-error? c)
(format (current-error-port)
(_ "~a: cannot open file~%")
(file-error:file-name c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((file-write-error? c)
(format (current-error-port)
(_ "~a: cannot write to file~%")
(file-error:file-name c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((file-error? c)
(format (current-error-port)
(_ "file error: ~a~%")
(file-error:file-name c))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((skribilo-error? c)
(let ((handler (lookup-error-condition-handler c)))
@@ -184,13 +190,16 @@
(format (current-error-port)
(_ "undefined skribilo error: ~S~%")
c)))
- (show-stack-trace)
- (exit exit-val))
+ (abort exit-val))
((message-condition? c)
(format (current-error-port) (condition-message c))
- (show-stack-trace)
- (exit exit-val))))
+ (abort exit-val))
+
+ (else
+ (format (current-error-port)
+ (_ "unexpected error condition: ~A~%") c)
+ (abort exit-val))))
thunk))
@@ -201,5 +210,18 @@
(define (call-with-skribilo-error-catch/exit thunk)
(%call-with-skribilo-error-catch thunk primitive-exit 1))
+
+;;;
+;;; SRFI-34 replacement.
+;;;
+
+(define (with-exception-handler handler thunk)
+ ;; Work around a "bug" in `with-exception-handler' in Guile up to 1.8.5.
+ ;; See http://thread.gmane.org/gmane.lisp.guile.user/6969 for details.
+ ;; XXX: This code is useless for 1.8.6 and later.
+ (with-throw-handler 'srfi-34
+ thunk
+ (lambda (key obj)
+ (handler obj))))
;;; conditions.scm ends here