From a8ace86ebdff03c9d374c54ffd3d1298ca531dda Mon Sep 17 00:00:00 2001
From: Ludovic Courtès
Date: Mon, 24 Nov 2008 23:41:14 +0100
Subject: 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.
---
 src/guile/skribilo/condition.scm | 56 ++++++++++++++++++++++++++++------------
 1 file changed, 39 insertions(+), 17 deletions(-)

(limited to 'src/guile')

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
-- 
cgit v1.2.3