;;;; condition-case.scm --- class based error handling ;;;; ;;;; Copyright (C) 2001 Neil Jerram (address@hidden) ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2, or (at your option) ;;;; any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;; !!! Before posting this, need to find out more about existing ;;; Guile error handling. ;;; {Class Based Error Handling} ;;; ;;; This module extends Guile's basic catch/throw mechanism, based on ;;; symbols, to support error type inheritance and class based error ;;; handling similar to that found in, for example, Java and Emacs ;;; Lisp. ;;; ;;; It is often useful for an application to handle a certain category ;;; of error in the same way, while at the same time having the ;;; ability to define new, finer error categories that are ;;; specializations of this existing category. For example, given a ;;; `math-error' category, it may be useful to define and use a ;;; `division-by-zero-error' subcategory, but still be able to handle ;;; both `math-error's and `division-by-zero-error's, and any other ;;; subcategories of `math-error', by a form that refers explicitly ;;; only to `math-error'. ;;; ;;; The resulting error category relationships have the same pattern ;;; as the relationships in a single inheritance class hierarchy. In ;;; Guile, therefore, it makes sense to model an error category as a ;;; GOOPS class -- we call this an "error class" -- and to use GOOPS ;;; class inheritance to implement error category inheritance. ;;; ;;; The components that this module provides are: ;;; - a way of mapping between error symbols and error classes ;;; - a way for applications to define new error classes, and to throw ;;; errors using the new classes ;;; - the `condition-case' syntax, inspired by that in Emacs Lisp, ;;; to simplify the use of class based error handling. ;;; ;;; Example: ;;; ;;; 1. Define application specific error classes. ;;; ;;; (define-class ()) ;;; (define-class ()) ;;; ;;; 2. Use `condition-case' to protect code in which an error ;;; may be thrown and should be handled. ;;; ;;; (condition-case ;;; ;; protected code ;;; (lambda () ;;; (translate-document doc)) ;;; ;; handlers ;;; (() ;;; (lambda (key . args) ;;; ;; handle all kinds of translation error, including ;;; ;; ;;; ...)) ;;; (() ;;; (lambda (key . args) ;;; ;; handle all kinds of parsing error ;;; ...)) ;;; ...) ;;; ;;; 3. Where appropriate, throw an error using the new classes. ;;; ;;; (throw context detail) (define-module (ossau condition-case) :use-module (ice-9 syncase) :use-module (oop goops) :export (condition-case catch throw process-condition-case list define-class error-description display-error)) ;;; {Error Classes} ;;; ;;; Infrastructure for defining error classes. ;;; error-symbol->class ;;; ;;; Property mapping error symbols to their corresponding error class. (define error-symbol->class (make-object-property)) ;;; ;;; ;;; Every error class is an instance of the metaclass ;;; . This metaclass has two slots. ;;; ;;; - symbol is the error symbol that is uniquely associated with this ;;; error class. `throw' maps an error class to its associated ;;; symbol; `catch' maps an error symbol back to its class, if there ;;; is one. ;;; ;;; - description is a brief description of the error type for use by ;;; procedures that display error descriptions. (define-class () (symbol #:accessor error-symbol) (description #:accessor error-description)) ;;; initialize (class ) initargs ;;; ;;; Custom initialization method for error classes. Checks that the ;;; new error class inherits from exactly one existing error class, ;;; sets the symbol slot according to the #:symbol option, and ;;; inherits the description and printer slots from the superclass. (define-method (initialize (class ) initargs) (let ((symbol (get-keyword #:symbol initargs #f))) (or symbol (error "An error class must specify an error symbol using the #:symbol option")) (if (get-keyword #:new-root-error initargs #f) ;; Don't apply constraints, or initialize slots, if ;; #:new-root-error option is #t. The caller has to know what ;; they're doing in this case. (next-method) (let ((supers (get-keyword #:dsupers initargs '()))) (or (and (= (length supers) 1) (is-a? (car supers) )) (error "An error class must inherit from exactly one existing error class")) (next-method) (slot-set! class 'symbol symbol) (set! (error-symbol->class symbol) class) (slot-set! class 'description (or (get-keyword #:description initargs #f) (slot-ref (car supers) 'description))))))) ;;; ;;; ;;; The root of all error classes. This class is never thrown itself. (define-class () #:metaclass #:new-root-error #t #:symbol 'root-error #:description "ERROR") ;;; display-error (error ) . args ;;; ;;; Standard error reporter for class based errors. (define-generic display-error) (define-method (display-error (error ) . args) (display (error-description error)) (display ":") (let loop ((args args)) (or (null? args) (begin (simple-format #t " ~S" (car args)) (loop (cdr args))))) (newline)) ;;; display-error (error ) . args ;;; ;;; Standard error reported for symbol based errors. (define-method (display-error (error ) . args) (let ((class (error-symbol->class error))) (if class (apply display-error class args) (apply display-error error args)))) ;;; {Standard Error Classes} ;;; ;;; Error classes corresponding to standard Guile error symbols. ;;; ;;; ;;; Error class corresponding with Guile `misc-error's. (define-class () #:symbol 'misc-error #:description "ERROR: misc-error") ;;; {Throwing and Handling Errors} ;;; throw (error ) . args ;;; ;;; An extended throw that accepts an error class as the key. (define-generic throw) (define-method (throw (error ) . args) (apply throw (error-symbol error) args)) ;;; condition-case protected handler... ;;; ;;; Call the thunk PROTECTED. If an error is thrown from within this ;;; thunk, try to handle it using one of the HANDLERs. ;;; ;;; Each HANDLER has the form ((CONDITION...) PROC), where each ;;; CONDITION is either an error symbol or an error class. If the key ;;; of the thrown error matches one of a handler's CONDITIONs, that ;;; handler's PROC is invoked, with the key and the throw args, to ;;; handle the error. (define-syntax condition-case (syntax-rules () ((_ protected ((conditions ...) handler) ...) (process-condition-case protected (list handler conditions ...) ...)))) (define (process-condition-case protected . handlers) (catch #t protected (lambda (key . args) (let* ((class (error-symbol->class key)) (result (or-map (lambda (handler) (or-map (lambda (condition) (cond ((or (eq? condition key) (eq? condition #t)) (list (apply (car handler) key args))) ((and (is-a? condition ) (is-a? class ) (memq condition (class-precedence-list class))) (list (apply (car handler) class args))) (else #f))) (cdr handler))) handlers))) (if result (car result) (apply throw key args)))))) ;;; catch (error ) protected handler ;;; ;;; An extended catch that accepts an error class as the key. (define-generic catch) (define-method (catch (error ) protected handler) (condition-case protected ((error) handler)))