Racket Exception Implementation

exceptional.rkt

#lang racket

(define *handlers* (list))

(define (push-handler proc)
  (set! *handlers* (cons proc *handlers*)))

(define (pop-handler)
  (let ((h (car *handlers*)))
    (set! *handlers* ( cdr *handlers*))
    h))

(define (throw . x)
  (if (pair? *handlers*)
      (apply (pop-handler) x)
      (apply error x)))

(define-syntax catch
  (syntax-rules ()
    ((_ [handler ...] exp1 ...)
     (call/cc (lambda (exit)
                ; ; install the handler
                (push-handler (lambda (ex)
                  ; ; rewrite the handler with a Pattern Matching Expression that rethrow the exception in the default case
                                (exit (match ex handler ... [_ (throw ex)]))))
                (let ((res ; ; evaluate the body
                       (begin exp1 ...)))
                  ; ok : discard the handler
                  (pop-handler)
                  res ))))))

(struct throwable ())
(struct exception throwable (message))


;; TESTS
;; redefine error to test throw...
(define (error . x) (apply displayln x))

;; Simple Test Case
(throw (exception "CiaoBao")) ;; Displays #<exception>

;; Simple Catch Test Case
(catch ([(exception "bao") (displayln "ciao")])
  (throw (exception "bao"))) ;; Displays "ciao"

;; Not so simple Nested Catch Statement
(catch ([(exception "bao") (displayln "ciao")])
  (catch ([(exception "ciao") (displayln "bao")]
          [(throwable) (displayln "throwable")])
    (throw (exception "bao")))) ;; Displays "throwable"

;; Simple Pattern Matching
(catch ([(exception _) (displayln "bao")])
  (throw (exception "ciao"))) ;; Displays "bao"

;; Intermediate Pattern Matching
(catch ([(exception message) (displayln message)])
  (throw (exception "Not so stupid message"))) ;; Displays "Not so stupid message"