324 lines
11 KiB
Scheme
324 lines
11 KiB
Scheme
; Module header is generated automatically
|
|
#cs(module srfi-12 mzscheme
|
|
(require mzlib/defmacro)
|
|
(require "myenv.ss")
|
|
|
|
;************************************************************************
|
|
; srfi-12.scm
|
|
; This file is the part of SSAX package (http://ssax.sourceforge.net),
|
|
; which is in public domain.
|
|
|
|
|
|
|
|
;************************************************************************
|
|
; Implementation of SRFI-12
|
|
;
|
|
; Most of the generic code and the comments are taken from
|
|
;
|
|
; SRFI-12: Exception Handling
|
|
; By William Clinger, R. Kent Dybvig, Matthew Flatt, and Marc Feeley
|
|
; http://srfi.schemers.org/srfi-12/
|
|
|
|
; The SRFI-12 Reference implementation has been amended where needed with
|
|
; a platform-specific code
|
|
;
|
|
|
|
|
|
;------------------------------------------------------------------------
|
|
; Catching exceptions
|
|
; The platform-specific part
|
|
|
|
; Procedure: with-exception-handler HANDLER THUNK
|
|
; Returns the result(s) of invoking thunk. The handler procedure is
|
|
; installed as the current exception handler in the dynamic context of
|
|
; invoking thunk.
|
|
|
|
; Procedure: abort OBJ
|
|
; Raises a non-continuable exception represented by OBJ.
|
|
; The abort procedure does not ensure that its argument is a
|
|
; condition. If its argument is a condition, abort does not ensure that
|
|
; the condition indicates a non-continuable exception.
|
|
|
|
; Procedure: exc:signal OBJ
|
|
; Raises a continuable exception represented by OBJ.
|
|
; In SRFI-12, this procedure is named 'signal'. However, this name
|
|
; clashes with the name of an internal Bigloo procedure. In a compiled
|
|
; code, this clash leads to a Bus error.
|
|
|
|
; Procedure: current-exception-handler
|
|
; Returns the current exception handler.
|
|
|
|
(cond-expand
|
|
(gambit
|
|
; The Gambit implementation relies on internal Gambit procedures,
|
|
; whose names start with ##
|
|
; Such identifiers cannot be _read_ on many other systems
|
|
; The following macro constructs Gambit-specific ids on the fly
|
|
(define-macro (_gid id)
|
|
(string->symbol (string-append "##" (symbol->string id))))
|
|
|
|
; `with-exception-handler` is built-in
|
|
|
|
; `abort` is built-in
|
|
|
|
(define (exc:signal obj) ; Encapsulate the object into a cell
|
|
(raise (list obj))) ; to let Gambit know it's our object
|
|
|
|
(define gambit-error error) ; Save the native Gambit 'error' function
|
|
|
|
(define (error msg . args)
|
|
(abort (make-property-condition
|
|
'exn
|
|
'message (cons msg args))))
|
|
|
|
; `current-exception-handler` is built-in
|
|
|
|
)
|
|
|
|
(bigloo
|
|
(define (with-exception-handler handler thunk)
|
|
(try (thunk)
|
|
; If we raised the condition explicitly, the proc
|
|
; is a pair, whose car is the
|
|
; argument that was passed to 'abort' or 'exc:signal'.
|
|
; The cdr part of the pair is the
|
|
; continuation (for a continuable exception)
|
|
(lambda (escape proc mes obj)
|
|
;(cerr "exn! " proc mes obj nl)
|
|
(if (pair? proc) ; We've caught the exception thrown
|
|
(let ((cont (cdr proc))) ; by abort or exc:signal
|
|
(if (not (null? cont))
|
|
(cont (handler (car proc))) ; continue after the handler
|
|
(handler (car proc))) ; Let Bigloo handle the return
|
|
) ; from the handler
|
|
; If (pair? proc) is false, we caught the exception
|
|
; raised by Bigloo's runtime system
|
|
; Let Bigloo handle the return from the handler
|
|
(handler
|
|
(make-property-condition
|
|
'exn ; condition kind required by SRFI-12
|
|
'message
|
|
(list proc mes obj)))))))
|
|
|
|
; An "at hock" implementation
|
|
(define-macro (handle-exceptions var handle-expr expr . more-exprs)
|
|
`(try
|
|
,(cons `begin (cons expr more-exprs))
|
|
(lambda (escape proc mes obj)
|
|
(let((,var
|
|
(if (pair? proc) ; by abort or exc:signal
|
|
(car proc)
|
|
(make-property-condition ; required by SRFI-12
|
|
'exn
|
|
'message
|
|
(list proc mes obj)))))
|
|
,handle-expr))))
|
|
|
|
(define (abort obj) ; Encapsulate the object into a cell
|
|
(the_failure (list obj) "" "") ; to let Bigloo know it's our object
|
|
(exit 4)) ; In case the exc:signal handler returns
|
|
|
|
; Encapsulate the object into a cell
|
|
; to let Bigloo know it's our object.
|
|
; In addition, we capture the continuation:
|
|
; 'exc:signal' generates a continuable
|
|
; exception
|
|
(define (exc:signal obj)
|
|
(bind-exit (escape)
|
|
(the_failure (cons obj escape) "" "")))
|
|
|
|
|
|
; When the current-exception-handler is applied, we encapsulate the
|
|
; argument (the exception) into a cell to let the framework know
|
|
; it's our exception
|
|
|
|
; We need to capture the continuation at the point current-exception-handler
|
|
; is invoked, so we can come back to that point and issue 'abort'
|
|
; in the dynamic context where current-exception-handler is invoked.
|
|
; We assume that a call to the current-exception-handler is
|
|
; equivalent to the throwing of a non-continuable exception
|
|
; (SRFI-12 does not preclude such an assumption).
|
|
|
|
; DL: had to comment it out, because Bigloo compiler dislikes
|
|
; CALL-WITH-CURRENT-CONTINUATION. A temporary solution.
|
|
;(define (current-exception-handler)
|
|
; (let ((result
|
|
; (call-with-current-continuation
|
|
; (lambda (k)
|
|
; (lambda (exn) (k (list exn)))))))
|
|
; (if (procedure? result) result
|
|
; (abort (car result))))) ; re-entrance after k was invoked
|
|
|
|
|
|
; A simplified version (which is far more efficient on bigloo)
|
|
; If this function is invoked in the context of an exception handler,
|
|
; the function invokes a _parent_ exception handler.
|
|
(define (parent-exception-handler)
|
|
(lambda (exn) (exc:signal exn)))
|
|
)
|
|
|
|
(chicken ; Chicken supports SRFI-12 natively
|
|
(define exc:signal signal)
|
|
)
|
|
|
|
(plt
|
|
|
|
; DL: supported in PLT natively
|
|
; ; Borrowed from Bigloo's cond-expand branch
|
|
; (define (current-exception-handler)
|
|
; (let ((result
|
|
; (call-with-current-continuation
|
|
; (lambda (k)
|
|
; (lambda (exn) (k (list exn)))))))
|
|
; (if (procedure? result) result
|
|
; (abort (car result)))))
|
|
|
|
|
|
; A helper function which converts an exception (PLT internal exception
|
|
; or SRFI-12 exception) into CONDITION
|
|
(define (exn:exception->condition obj)
|
|
(cond
|
|
((exn? obj) ; PLT internal exception
|
|
(make-property-condition
|
|
'exn ; condition kind required by SRFI-12
|
|
'message
|
|
(exn-message obj)))
|
|
((pair? obj) ; exception generated by ABORT or EXN:SIGNAL
|
|
(car obj))
|
|
(else ; some more conditions should be added, I guess
|
|
obj)))
|
|
|
|
|
|
(define-macro (with-exception-handler handler thunk)
|
|
`(with-handlers
|
|
(((lambda (x) #t)
|
|
(lambda (x)
|
|
(,handler (exn:exception->condition x)))))
|
|
(,thunk)))
|
|
|
|
|
|
; Evaluates the body expressions expr1, expr2, ... in sequence with an
|
|
; exception handler constructed from var and handle-expr. Assuming no
|
|
; exception is raised, the result(s) of the last body expression is(are)
|
|
; the result(s) of the HANDLE-EXCEPTIONS expression.
|
|
; The exception handler created by HANDLE-EXCEPTIONS restores the dynamic
|
|
; context (continuation, exception handler, etc.) of the HANDLE-EXCEPTIONS
|
|
; expression, and then evaluates handle-expr with var bound to the value
|
|
; provided to the handler.
|
|
(define-macro (handle-exceptions var handle-expr expr . more-exprs)
|
|
(cons
|
|
`with-handlers
|
|
(cons
|
|
`(((lambda (x) #t)
|
|
(lambda (x)
|
|
(let ((,var (exn:exception->condition x)))
|
|
,handle-expr))))
|
|
(cons expr more-exprs))))
|
|
|
|
|
|
; This implementation was borrowed from Gambit's cond-expand branch
|
|
(define (abort obj)
|
|
(raise (list obj))
|
|
(exit 4))
|
|
|
|
(define (exc:signal obj)
|
|
(raise (list obj)))
|
|
|
|
(define (signal obj)
|
|
(raise (list obj)))
|
|
|
|
) ; end of PLT branch
|
|
|
|
)
|
|
|
|
|
|
; (define (with-exception-handler handler thunk)
|
|
; (let ((old #f))
|
|
; (dynamic-wind
|
|
; (lambda ()
|
|
; (set! old *current-exn-handler*)
|
|
; (set! *current-exn-handler* handler))
|
|
; thunk
|
|
; (lambda ()
|
|
; (set! *current-exn-handler* old)))))
|
|
|
|
; (define (abort obj)
|
|
; ((CURRENT-EXCEPTION-HANDLER) obj)
|
|
; (ABORT (make-property-condition
|
|
; 'exn
|
|
; 'message
|
|
; "Exception handler returned")))
|
|
|
|
; (define (exc:signal exn)
|
|
; ((CURRENT-EXCEPTION-HANDLER) exn))
|
|
|
|
|
|
;------------------------------------------------------------------------
|
|
; Exception conditions
|
|
; The following is an approximate implementation of conditions that
|
|
; uses lists, instead of a disjoint class of values
|
|
; The code below is basically the reference SRFI-12 implementation,
|
|
; with a few types fixed.
|
|
|
|
; A condition is represented as a pair where the first value of the
|
|
; pair is this function. A program could forge conditions, and they're
|
|
; not disjoint from Scheme pairs.
|
|
; Exception conditions are disjoint from any other Scheme values
|
|
; (or so should appear).
|
|
(define (condition? obj)
|
|
(and (pair? obj)
|
|
(eq? condition? (car obj))))
|
|
|
|
|
|
; Procedure: make-property-condition KIND-KEY PROP-KEY VALUE ...
|
|
; This procedure accepts any even number of arguments after kind-key,
|
|
; which are regarded as a sequence of alternating prop-key and value
|
|
; objects. Each prop-key is regarded as the name of a property, and
|
|
; each value is regarded as the value associated with the key that
|
|
; precedes it. Returns a kind-key condition that associates the given
|
|
; prop-keys with the given values.
|
|
(define (make-property-condition kind-key . prop-vals)
|
|
(cons condition? (list (cons kind-key prop-vals))))
|
|
|
|
|
|
; Procedure: make-composite-condition CONDITION ...
|
|
; Returns a newly-allocated condition whose components correspond to
|
|
; the the given conditions. A predicate created by CONDITION-PREDICATE
|
|
; returns true for the new condition if and only if it returns true
|
|
; for one or more of its component conditions.
|
|
(define (make-composite-condition . conditions)
|
|
(cons condition? (apply append (map cdr conditions))))
|
|
|
|
|
|
; Procedure: condition-predicate KIND-KEY
|
|
; Returns a predicate that can be called with any object as its
|
|
; argument. Given a condition that was created by
|
|
; make-property-condition, the predicate returns #t if and only if
|
|
; kind-key is EQV? to the kind key that was passed to
|
|
; make-property-condition. Given a composite condition created with
|
|
; make-composite-condition, the predicate returns #t if and only if
|
|
; the predicate returns #t for at least one of its components.
|
|
(define (condition-predicate kind-key)
|
|
(lambda (exn)
|
|
(and (condition? exn) (assv kind-key (cdr exn)))))
|
|
|
|
; Procedure: condition-property-accessor KIND-KEY PROP-KEY
|
|
; Returns a procedure that can be called with any condition that satisfies
|
|
; (condition-predicate KIND-KEY). Given a condition that was created by
|
|
; make-property-condition and KIND-KEY, the procedure returns the value
|
|
; that is associated with prop-key. Given a composite condition created with
|
|
; make-composite-condition, the procedure returns the value that is
|
|
; associated with prop-key in one of the components that
|
|
; satisfies (condition-predicate KIND-KEY).
|
|
; Otherwise, the result will be #f
|
|
|
|
(define (condition-property-accessor kind-key prop-key)
|
|
(lambda (exn)
|
|
(let* ((p ((condition-predicate kind-key) exn))
|
|
(prop-lst (and p (pair? p) (memq prop-key (cdr p)))))
|
|
(and prop-lst (pair? (cdr prop-lst)) (cadr prop-lst)))))
|
|
|
|
|
|
|
|
(provide (all-defined)))
|