The Exception Type System

The exception type system was designed with four goals in mind.
1- Exceptions can be extended from any other previously defined exceptions
2- Each exception will respond as true to predicates that either detect its type or that of a type it is extended from (or that those types are extended from, ect).
3- Each exception stores a value that can be retrieved.
4- When creating a new exception the operations make-exception-name and exception-name? are pre-defined.

The implementation of this type system is a little more complicated than it needed to be, primarily because I was playing around with ideas that I may use to build my own little object system (hey, every scheme user has to, its like a rite of passage). For example you can try to pass any kind of message to an exception and if that message isn’t supported you get a message-exception thrown.

How it is used:
You define a new exception type with the code:

(extend-exception new-name parent-types+)

For example:

(extend-exception my-new-exception exception)
(extend-exception type3 type2 type1)

You can use make-exception-name followed by the initial value to create a new instance of an exception type.
For example:

(make-exception 'err)
(make-type3 '(val val val))

You can use exception-name? to test if an object is that type of exception.
If err is a type3 exception then:

(type3? err)
(type2? err)
(exception? err)

Are true, but:

(message-exception? err)

is false.
You can get a list of the type of an exception with (exception-type err)
You can get the value stored in an exception with (exception-value err)
You can ser the value stored in an exception with (set-exception-value! err value)

An example of exceptions in use:

(try
    (display "body") (newline)
    (throw (make-message-exception 'message))
    (display "this won't print")
  catch null?
    (display "also will not print")
  catch message-exception?
    (display (exception-value err)) (newline)
)

The implementation of this system:

(define make-exception
  (lambda (val)
    (let ((v val))
      (lambda (message param)
        (cond ((eq? message 'type) (eq? param 'exception))
              ((eq? message 'get-value) v)
              ((eq? message 'get-type) 'exception)
              ((eq? message 'set-value) (set! v param))
              (else (throw (make-message-exception message))))
        ))))

(define exception?
  (lambda (except)
    (except 'type 'exception)))

(define fold-right
  (lambda (func initial lst)
    (if (null? lst)
        initial
        (func (car lst) (fold-right func initial (cdr lst))))))

(define extend-exceptionF
  (lambda (type . parentlist)
    (lambda (val)
      (let ((parent-instances (map (lambda (x) (x val)) parentlist)))
        (lambda (message param)
          (cond ((eq? message 'type)
                 (or (eq? type param)
                     (fold-right (lambda (a b) (or a b)) #f (map (lambda (x) (x 'type param)) parent-instances))))
                ((eq? message 'get-type) (cons type (map (lambda (x) (x 'get-type '())) parent-instances)))
                (else
                 (letrec ((try-each (lambda (pl m p)
                                      (if (null? pl)
                                          (throw (make-message-exception m))
                                          (try
                                            ((car pl) m p)
                                           catch else
                                            (try-each (cdr pl) m p))))))
                   (try-each parent-instances message param))))
          )))))

(define exception-value
  (lambda (except)
    (except 'get-value '())))

(define exception-type
  (lambda (except)
    (except 'get-type '())))

(define set-exception-value!
  (lambda (except val)
    (except 'set-value val)))

(define exception-type?
  (lambda (except type)
    (except 'type type)))

(define-syntax extend-exception
    (lambda (x)
      (letrec (
               (main-transformer
                (lambda (x)
                  `(begin
                     (define ,(string->symbol (string-append "make-" (symbol->string (car x))))
                       (extend-exceptionF (quote ,(car x))
                                          ,@(map (lambda (nm)
                                                   (string->symbol (string-append "make-" (symbol->string nm))))
                                                 (cdr x))))
                     (define ,(string->symbol (string-append (symbol->string (car x)) "?"))
                       (lambda (ex)
                         (exception-type? ex (quote ,(car x)))))
                     ))))
       (datum->syntax-object x (main-transformer (cdr (syntax-object->datum x)))))))

(extend-exception message-exception exception)