From f373fe42794b5b3ab4537b3cef73640c2fb583ef Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Tue, 11 Jul 2006 15:59:41 +0000
Subject: Use SRFI-35 error conditions in `resolve.scm' rather than the `error'
 procedures.

* src/guile/skribilo/resolve.scm: Don't use `(skribilo runtime)'
  (unneeded).  Use `conditions' and SRFI-3[45].
  (&resolution-error): New.
  (&resolution-orphan-error): New.
  (handle-resolution-error): New.  Register it.
  (do-resolve!): Raise an invalid-arg condition instead of invoking
  `error'.
  (resolve-counter): Raise a `&resolution-orphan-error' condition instead
  of invoking `skribe-error'.
  (resolve-ident): Raise an invalid-arg condition rather than invoking
  `skribe-type-error'.

git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-5
---
 src/guile/skribilo/resolve.scm | 65 ++++++++++++++++++++++++++++++++++++------
 1 file changed, 56 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 34d6bde..a2fc1d7 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -21,19 +21,65 @@
 
 (define-module (skribilo resolve)
   :use-module (skribilo debug)
-  :use-module (skribilo runtime)
   :use-module (skribilo ast)
   :use-module (skribilo utils syntax)
 
   :use-module (oop goops)
   :use-module (srfi srfi-39)
 
+  :use-module (skribilo condition)
+  :use-module (srfi srfi-34)
+  :use-module (srfi srfi-35)
+
   :export (resolve! resolve-search-parent resolve-children resolve-children*
-	   find1 resolve-counter resolve-parent resolve-ident))
+	   find1 resolve-counter resolve-parent resolve-ident
+
+           &resolution-error resolution-error?
+           &resolution-orphan-error resolution-orphan-error?
+           resolution-orphan-error:ast))
 
 (fluid-set! current-reader %skribilo-module-reader)
 
 
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &resolution-error &skribilo-error
+  resolution-error?)
+
+(define-condition-type &resolution-orphan-error &resolution-error
+  resolution-orphan-error?
+  (ast resolution-orphan-error:ast))
+
+
+(define (handle-resolution-error c)
+  ;; Issue a user-friendly error message for error condition C.
+  (cond ((resolution-orphan-error? c)
+	 (let* ((node (resolution-orphan-error:ast c))
+		(location (and (ast? node) (ast-loc node))))
+	   (format (current-error-port) "orphan node: ~a~a~%"
+		   node
+		   (if (location? location)
+		       (string-append " "
+				      (location-file location) ":"
+				      (location-line location))
+		       ""))))
+
+	(else
+	 (format (current-error-port) "undefined resolution error: ~a~%"
+		 c))))
+
+(register-error-condition-handler! resolution-error?
+				   handle-resolution-error)
+
+
+
+;;;
+;;; Resolving nodes.
+;;;
+
 (define *unresolved* (make-parameter #f))
 (define-generic do-resolve!)
 
@@ -81,7 +127,9 @@
        (set-car! n* (do-resolve! (car n*) engine env))
        (set-cdr! n* (do-resolve! (cdr n*) engine env)))
       (else
-       (error 'do-resolve "illegal argument" n*)))))
+       (raise (condition (&invalid-argument-error
+			  (proc-name "do-resolve!<pair>")
+			  (argument n*))))))))
 
 
 (define-method (do-resolve! (node <node>) engine env)
@@ -186,7 +234,7 @@
 	      (cadr c)
 	      n)))
        ((eq? (slot-ref n 'parent) 'unspecified)
-	(skribe-error 'resolve-parent "orphan node" n))
+        (raise (condition (&resolution-orphan-error (ast n)))))
        (else
 	(slot-ref n 'parent)))))
 
@@ -219,7 +267,7 @@
   (let ((c (assq (symbol-append cnt '-counter) e)))
     (if (not (pair? c))
 	(if (or (null? opt) (not (car opt)) (null? e))
-	    (skribe-error cnt "orphan node" n)
+            (raise (condition (&resolution-orphan-error (ast n))))
 	    (begin
 	      (set-cdr! (last-pair e)
 			(list (list (symbol-append cnt '-counter) 0)
@@ -252,10 +300,9 @@
      (debug-item "markup=" markup)
      (debug-item "n=" (if (markup? n) (markup-markup n) n))
      (if (not (string? ident))
-	 (skribe-type-error 'resolve-ident
-			    "Illegal ident"
-			    ident
-			    "string")
+         (raise (condition (&invalid-argument-error ;; type error
+                            (proc-name "resolve-ident")
+                            (argument  ident))))
 	 (let ((mks (find-markups ident)))
 	   (and mks
 		(if (not markup)
-- 
cgit v1.2.3