summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorLudovic Court`es2006-07-11 15:59:41 +0000
committerLudovic Court`es2006-07-11 15:59:41 +0000
commitf373fe42794b5b3ab4537b3cef73640c2fb583ef (patch)
treebfaf508c7962b79f30074581540ed4ef270348bc /src
parent4420b6ce4292ae201a95c8ad22a9cc233aa7437a (diff)
downloadskribilo-f373fe42794b5b3ab4537b3cef73640c2fb583ef.tar.gz
skribilo-f373fe42794b5b3ab4537b3cef73640c2fb583ef.tar.lz
skribilo-f373fe42794b5b3ab4537b3cef73640c2fb583ef.zip
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
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo/resolve.scm65
1 files changed, 56 insertions, 9 deletions
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)