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))
No comments:
Post a Comment