1;R6RS version of SRFI-34 reference impl.
2;by Larceny
3(library (rnrs exceptions (6))
4
5  (export with-exception-handler raise raise-continuable guard)
6
7  (import
8   (rnrs base)
9   (primitives
10    with-exception-handler raise raise-continuable))
11
12  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13  ;
14  ; The definitions of guard and guard-aux come from the
15  ; reference implementation for SRFI 34, whose copyright
16  ; notice is reproduced below.  See
17  ; http://srfi.schemers.org/srfi-34/srfi-34.html
18  ;
19  ; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved.
20  ;
21  ; Permission is hereby granted, free of charge, to any
22  ; person obtaining a copy of this software and associated
23  ; documentation files (the "Software"), to deal in the
24  ; Software without restriction, including without
25  ; limitation the rights to use, copy, modify, merge,
26  ; publish, distribute, sublicense, and/or sell copies of
27  ; the Software, and to permit persons to whom the Software
28  ; is furnished to do so, subject to the following conditions:
29  ;
30  ; The above copyright notice and this permission notice
31  ; shall be included in all copies or substantial portions
32  ; of the Software.
33
34  ; The original call to raise has been changed to a call to
35  ; raise-continuable.  See
36  ; http://www.r6rs.org/r6rs-errata.html
37
38  (define-syntax guard
39    (syntax-rules ()
40      ((guard (var clause ...) e1 e2 ...)
41       ((call-with-current-continuation
42         (lambda (guard-k)
43           (with-exception-handler
44            (lambda (condition)
45              ((call-with-current-continuation
46                 (lambda (handler-k)
47                   (guard-k
48                    (lambda ()
49                      (let ((var condition))      ; clauses may SET! var
50                        (guard-aux (handler-k (lambda ()
51                                                (raise-continuable condition)))
52                                   clause ...))))))))
53            (lambda ()
54              (call-with-values
55               (lambda () e1 e2 ...)
56               (lambda args
57                 (guard-k (lambda ()
58                            (apply values args)))))))))))))
59
60  (define-syntax guard-aux
61    (syntax-rules (else =>)
62      ((guard-aux reraise (else result1 result2 ...))
63       (begin result1 result2 ...))
64      ((guard-aux reraise (test => result))
65       (let ((temp test))
66         (if temp
67             (result temp)
68             reraise)))
69      ((guard-aux reraise (test => result) clause1 clause2 ...)
70       (let ((temp test))
71         (if temp
72             (result temp)
73             (guard-aux reraise clause1 clause2 ...))))
74      ((guard-aux reraise (test))
75       test)
76      ((guard-aux reraise (test) clause1 clause2 ...)
77       (let ((temp test))
78         (if temp
79             temp
80             (guard-aux reraise clause1 clause2 ...))))
81      ((guard-aux reraise (test result1 result2 ...))
82       (if test
83           (begin result1 result2 ...)
84           reraise))
85      ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
86       (if test
87           (begin result1 result2 ...)
88           (guard-aux reraise clause1 clause2 ...)))))
89
90  ; End of copyrighted extract from the reference implementation
91  ; for SRFI 34.
92  ;
93  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94
95  )
96