source: project/release/4/srfi-34/trunk/srfi-34.scm @ 15265

Last change on this file since 15265 was 15265, checked in by sjamaan, 12 years ago

Import chicken 4 port of srfi-34, courtesy of C-Keen

File size: 3.0 KB
Line 
1;;; SRFI-34: Exceptions for scheme
2
3;;; This file contains the macros.  srfi-34-support.scm contains
4;;; some support procedures needed at runtime.
5       
6;;; This is the reference implementation copied (almost) verbatim from
7;;; http://srfi.schemers.org/srfi-34/srfi-34.html with rearranging and
8;;; slight modifications to be a chicken egg.
9
10(module srfi-34
11   (*current-exception-handlers*
12    with-exception-handlers
13    with-exception-handler
14    raise
15    guard)
16(import (except chicken with-exception-handler) scheme)
17
18(define *current-exception-handlers*
19  (list (lambda (condition)
20          (error "unhandled exception" condition))))
21
22(define (with-exception-handlers new-handlers thunk)
23  (let ((previous-handlers *current-exception-handlers*))
24    (dynamic-wind
25      (lambda ()
26        (set! *current-exception-handlers* new-handlers))
27      thunk
28      (lambda ()
29        (set! *current-exception-handlers* previous-handlers)))))
30
31(define (with-exception-handler handler thunk)
32  (with-exception-handlers (cons handler *current-exception-handlers*)
33                           thunk))
34
35(define (raise obj)
36  (let ((handlers *current-exception-handlers*))
37    (with-exception-handlers (cdr handlers)
38      (lambda ()
39        ((car handlers) obj)
40        (error "handler returned"
41               (car handlers)
42               obj))))) 
43
44;(require-extension ports)
45
46(define-syntax guard
47  (syntax-rules ()
48    ((guard (var clause ...) e1 e2 ...)
49     ((call-with-current-continuation
50       (lambda (guard-k)
51         (with-exception-handler
52           (lambda (condition)
53             ((call-with-current-continuation
54               (lambda (handler-k)
55                 (guard-k
56                  (lambda ()
57                    (let ((var condition))      ; clauses may SET! var
58                      (guard-aux (handler-k (lambda ()
59                                              (raise condition)))
60                                 clause ...))))))))
61           (lambda ()
62             (call-with-values
63                 (lambda () e1 e2 ...)
64               (lambda args
65                 (guard-k (lambda ()
66                            (apply values args)))))))))))))
67
68
69(define-syntax guard-aux
70  (syntax-rules (else =>)
71    ((guard-aux reraise (else result1 result2 ...))
72     (begin result1 result2 ...))
73    ((guard-aux reraise (test => result))
74     (let ((temp test))
75       (if temp 
76           (result temp)
77           reraise)))
78    ((guard-aux reraise (test => result) clause1 clause2 ...)
79     (let ((temp test))
80       (if temp
81           (result temp)
82           (guard-aux reraise clause1 clause2 ...))))
83    ((guard-aux reraise (test))
84     test)
85    ((guard-aux reraise (test) clause1 clause2 ...)
86     (let ((temp test))
87       (if temp
88           temp
89           (guard-aux reraise clause1 clause2 ...))))
90    ((guard-aux reraise (test result1 result2 ...))
91     (if test
92         (begin result1 result2 ...)
93         reraise))
94    ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
95     (if test
96         (begin result1 result2 ...)
97         (guard-aux reraise clause1 clause2 ...))))) )
Note: See TracBrowser for help on using the repository browser.