From 7249dc962a9f31f1c8f3d72a3a55d2112514baff Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Sep 2006 16:56:42 +0000 Subject: Added error conditions in `ast.scm'. * src/guile/skribilo/ast.scm: Use `srfi-3[45]' and `condition' but not `lib'. (&ast-error): New. (&ast-orphan-error): New. (&ast-cycle-error): New. (&markup-unknown-option-error): New. (&markup-already-bound-error): New. (handle-ast-error): New. (markup-option): Use `raise' instead of `skribe-(type-)?error'. (markup-option-set!): Likewise. (markup-option-add!): Likewise. (markup-parent): Likewise. (document-bind-node!): Likewise. (find1-down): Likewise. * src/guile/skribilo/resolve.scm (&resolution-error): Removed. (&resolution-orphan-error): Removed. Moved as `&ast-orphan-error' in `ast.scm'. Updated users. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-58 --- src/guile/skribilo/ast.scm | 116 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 104 insertions(+), 12 deletions(-) (limited to 'src/guile/skribilo/ast.scm') diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm index e17b2dd..542f629 100644 --- a/src/guile/skribilo/ast.scm +++ b/src/guile/skribilo/ast.scm @@ -22,10 +22,14 @@ (define-module (skribilo ast) :use-module (oop goops) + + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + :use-module (skribilo condition) + :use-module (skribilo utils syntax) + :autoload (skribilo location) (location?) - :autoload (skribilo lib) (skribe-type-error skribe-error) :autoload (srfi srfi-1) (fold) - :use-module (skribilo utils syntax) :export ( ast? ast-loc ast-loc-set! ast-parent ast->string ast->file-location ast-resolved? @@ -56,7 +60,19 @@ ast-fold container-search-down search-down find-down find1-down find-up find1-up - ast-document ast-chapter ast-section)) + ast-document ast-chapter ast-section + + ;; error conditions + &ast-error &ast-orphan-error &ast-cycle-error + &markup-unknown-option-error &markup-already-bound-error + ast-orphan-error? ast-orphan-error:ast + ast-cycle-error? ast-cycle-error:object + markup-unknown-option-error? + markup-unknown-option-error:markup + markup-unknown-option-error:option + markup-already-bound-error? + markup-already-bound-error:markup + markup-already-bound-error:ident)) ;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès ;;; @@ -71,6 +87,74 @@ (fluid-set! current-reader %skribilo-module-reader) + +;;; +;;; Error conditions. +;;; + +(define-condition-type &ast-error &skribilo-error + ast-error?) + +(define-condition-type &ast-orphan-error &ast-error + ast-orphan-error? + (ast ast-orphan-error:ast)) + +(define-condition-type &ast-cycle-error &ast-error + ast-cycle-error? + (object ast-cycle-error:object)) + +(define-condition-type &markup-unknown-option-error &ast-error + markup-unknown-option-error? + (markup markup-unknown-option-error:markup) + (option markup-unknown-option-error:option)) + +(define-condition-type &markup-already-bound-error &ast-error + markup-already-bound-error? + (markup markup-already-bound-error:markup) + (ident markup-already-bound-error:ident)) + + +(define (handle-ast-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((ast-orphan-error? c) + (let* ((node (ast-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)) + "")))) + + ((ast-cycle-error? c) + (let ((object (ast-cycle-error:object c))) + (format (current-error-port) + "cycle found in AST: ~a~%" object))) + + ((markup-unknown-option-error? c) + (let ((markup (markup-unknown-option-error:markup c)) + (option (markup-unknown-option-error:option c))) + (format (current-error-port) + "~a: unknown markup option for `~a'~%" + option markup))) + + ((markup-already-bound-error? c) + (let ((markup (markup-already-bound-error:markup c)) + (ident (markup-already-bound-error:ident c))) + (format (current-error-port) + "`~a' (~a): markup identifier already bound~%" + ident + (if (markup? markup) + (markup-markup markup) + markup)))) + + (else + (format (current-error-port) "undefined resolution error: ~a~%" + c)))) + +(register-error-condition-handler! ast-error? handle-ast-error) + ;;; @@ -217,22 +301,29 @@ (let ((c (assq opt (slot-ref m 'options)))) (and (pair? c) (pair? (cdr c)) (cadr c))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option") + (argument m)))))) (define (markup-option-set! m opt val) (if (markup? m) (let ((c (assq opt (slot-ref m 'options)))) (if (and (pair? c) (pair? (cdr c))) (set-cdr! c (list val)) - (skribe-error 'markup-option-set! "unknown option: " - m))) - (skribe-type-error 'markup-option-set! "Illegal markup: " m "markup"))) + (raise (condition (&markup-unknown-option-error + (markup m) + (option opt)))))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-set!") + (argument m)))))) (define (markup-option-add! m opt val) (if (markup? m) (slot-set! m 'options (cons (list opt val) (slot-ref m 'options))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-add!") + (argument m)))))) (define (is-markup? obj markup) @@ -243,7 +334,7 @@ (define (markup-parent m) (let ((p (slot-ref m 'parent))) (if (eq? p 'unspecified) - (skribe-error 'markup-parent "Unresolved parent reference" m) + (raise (condition (&ast-orphan-error (ast m)))) p))) (define (markup-document m) @@ -366,8 +457,9 @@ (let ((handle (hash-get-handle (document-node-table doc) ident))) ;;(format (current-error-port) "binding `~a' in `~a'~%" ident node) (if (and (pair? handle) (not (eq? (cdr handle) node))) - (error "node identifier already bound" - (cdr handle)) ;; FIXME: use `raise' + (raise (condition (&markup-already-bound-error + (ident ident) + (markup node)))) (hash-set! (document-node-table doc) ident node)))))) (define (document-bind-nodes! doc) @@ -458,7 +550,7 @@ (stack '())) (cond ((memq obj stack) - (skribe-error 'find1-down "Illegal cyclic object" obj)) + (raise (condition (&ast-cycle-error (object obj))))) ((pair? obj) (let liip ((obj obj)) (cond -- cgit v1.2.3