exception handling, take two

A bit tricky, but I found a way to implement try/except almost completely with defmacro.  I needed to add some extra typechecking around raise and try to ensure that all exception types are monomorphic.  I achieved this by having the compiler keep a global map of exception-name => tvar.   Seems to work...

While working on this I learned that the Scheme-style call/cc is not really type safe, and I need to use the SML version.  The main difference is the protocol - SML's callcc requires the use of a throw procedure since the continuation needs to carry type information:

(define (callcc p) : (((continuation 'a) -> 'a) -> 'a)
  (p (getcc)))

(define (throw k v)
  (putcc k v))

;; -*- Mode: Irken -*-

(include "lib/core.scm")
(include "lib/random.scm")

;; We use polymorphic variants for exceptions.
;; Since we're a whole-program compiler there's no need to declare
;; them - though I might could be convinced it's still a good idea.
;;
;; Exception data must be monomorphic to preserve type safety.
;;
;; <try> and <raise> are implemented as macros, with one extra hitch:
;;  two special compiler primitives are used to check that exception
;;  types are consistent: %exn-raise and %exn-handle

(define (base-exception-handler exn) : ((rsum 'a) -> 'b)
  (error1 "uncaught exception" exn))

(define *the-exception-handler* base-exception-handler)

(defmacro raise
  (raise exn) -> (*the-exception-handler* (%exn-raise #f exn))
  )

(defmacro try
  ;; done accumulating body parts, finish up.
  (try (begin body0 ...) <except> exn-match ...)
  -> (callcc
      (lambda ($exn-k0)
        (let (($old-hand *the-exception-handler*))
          (set!
           *the-exception-handler*
           (lambda ($exn-val)
             (set! *the-exception-handler* $old-hand)
             (throw $exn-k0
              (%exn-handle #f $exn-val
               (match $exn-val with
                 exn-match ...
                 _ -> (raise $exn-val))))))
          (let (($result (begin body0 ...)))
            (set! *the-exception-handler* $old-hand)
            $result))))
  ;; accumulating body parts...
  (try (begin body0 ...) body1 body2 ...) -> (try (begin body0 ... body1) body2 ...)
  ;; begin to accumulate...
  (try body0 body1 ...)                   -> (try (begin body0) body1 ...)
  )

(define (level0 x)
  (try
   (level1 x)
   except
   (:Level0 x) -> (:pair "level 0" x)
   ))

(define (level1 x)
  (try
   (level2 x)
   except
   (:Level1 x) -> (:pair "level 1" x)
   ))

(define (level2 x)
  (try
   (level3 x)
   except
   (:Level2 x) -> (:pair "level 2" x)
   ))

(define (level3 x)
  (try
   (match x with
     0 -> (raise (:Level0 x))
     1 -> (raise (:Level1 x))
     2 -> (raise (:Level2 x))
     3 -> (raise (:Level3 x))
     4 -> (:pair "no exception!" 99)
     _ -> (raise (:Bottom x))
     )
   except
   (:Level3 x) -> (:pair "level 3" x)
   ))


(printn (level0 0))
(printn (level0 1))
(printn (level0 2))
(printn (level0 3))
(printn (level0 4))
(printn (level0 5))