Generalized the error condition handling framework.

* src/guile/skribilo/condition.scm (&too-few-arguments-error): New.
  (%external-error-condition-alist): New.
  (register-error-condition-handler!): New.
  (lookup-error-condition-handler): New.
  (%call-with-skribilo-error-catch): Handle `too-few-arguments-error?'.
  Use `lookup-error-condition-handler' when unhandled exceptions are
  caught.

git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-86

1 files changed, 47 insertions, 3 deletions

diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm
index 820dcc5..e063b4f 100644
--- a/src/guile/skribilo/condition.scm
+++ b/src/guile/skribilo/condition.scm
@@ -19,16 +19,22 @@
 ;;; USA.
 
 (define-module (skribilo condition)
+  :autoload   (srfi srfi-1)  (find)
   :autoload   (srfi srfi-34) (guard)
   :use-module (srfi srfi-35)
   :use-module (srfi srfi-39)
   :export     (&skribilo-error skribilo-error?
 	       &invalid-argument-error invalid-argument-error?
+	       &too-few-arguments-error too-few-arguments-error?
+
 	       &file-error file-error?
 	       &file-search-error file-search-error?
 	       &file-open-error file-open-error?
 	       &file-write-error file-write-error?
 
+	       register-error-condition-handler!
+	       lookup-error-condition-handler
+
 	       %call-with-skribilo-error-catch
 	       call-with-skribilo-error-catch))
 
@@ -58,6 +64,11 @@
   (proc-name invalid-argument-error:proc-name)
   (argument  invalid-argument-error:argument))
 
+(define-condition-type &too-few-arguments-error &skribilo-error
+  too-few-arguments-error?
+  (proc-name too-few-arguments-error:proc-name)
+  (arguments too-few-arguments-error:arguments))
+
 
 ;;;
 ;;; File errors.
@@ -80,6 +91,28 @@
 
 
 ;;;
+;;; Adding new error conditions from other modules.
+;;;
+
+(define %external-error-condition-alist '())
+
+(define (register-error-condition-handler! pred handler)
+  (set! %external-error-condition-alist
+	(cons (cons pred handler)
+	      %external-error-condition-alist)))
+
+(define (lookup-error-condition-handler c)
+  (let ((pair (find (lambda (pair)
+		      (let ((pred (car pair)))
+			(pred c)))
+		    %external-error-condition-alist)))
+    (if (pair? pair)
+	(cdr pair)
+	#f)))
+
+
+
+;;;
 ;;; Convenience functions.
 ;;;
 
@@ -90,6 +123,11 @@
 		     (invalid-argument-error:argument c))
 	     (exit 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)))
+
 	    ((file-search-error? c)
 	     (format (current-error-port) "~a: not found in path `~S'~%"
 		     (file-error:file-name c)
@@ -111,9 +149,15 @@
 		     (file-error:file-name c))
 	     (exit exit-val))
 
-	    ((skribilo-error? c)
-	     (format (current-error-port) "undefined skribilo error: ~S~%"
-		     c)
+	    (;;(skribilo-error? c)
+	     #t ;; XXX: The SRFI-35 currently in `guile-lib' doesn't work
+ 	        ;; properly with non-direct super-types.
+	     (let ((handler (lookup-error-condition-handler c)))
+	       (if (procedure? handler)
+		   (handler c)
+		   (format (current-error-port)
+			   "undefined skribilo error: ~S~%"
+			   c)))
 	     (exit exit-val)))
 
 	 (thunk)))