On Scheme

Thoughts on Scheme and teaching Scheme

Archive for March 16th, 2006

The Exception Type System

Posted by Peter on March 16, 2006

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)

Posted in Exploring Scheme | Leave a Comment »