1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
#| Copyright (C) 2004 Taylor Campbell. All rights reserved.
|
| Permission is hereby granted, free of charge, to any person
| obtaining a copy of this software and associated documentation
| files (the "Software"), to deal in the Software without
| restriction, including without limitation the rights to use, copy,
| modify, merge, publish, distribute, sublicense, and/or sell copies
| of the Software, and to permit persons to whom the Software is
| furnished to do so, subject to the following conditions:
|
| The above copyright notice and this permission notice shall be
| included in all copies or substantial portions of the Software.
|
| THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
| EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
| MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
| NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
| BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
| ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
| CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
| SOFTWARE.
|#
(define-library (mcgoron srfi 61)
(import (scheme base))
(export cond first-arg)
(begin
(define (first-arg x . rest) x))
(begin
(define-syntax cond/maybe-more
(syntax-rules ()
((cond/maybe-more test consequent)
(if test
consequent))
((cond/maybe-more test consequent clause ...)
(if test
consequent
(cond clause ...)))))
(define-syntax cond
(syntax-rules (=> else)
((cond (else else1 else2 ...))
;; The (IF #T (BEGIN ...)) wrapper ensures that there may be no
;; internal definitions in the body of the clause. R5RS mandates
;; this in text (by referring to each subform of the clauses as
;; <expression>) but not in its reference implementation of COND,
;; which just expands to (BEGIN ...) with no (IF #T ...) wrapper.
(if #t (begin else1 else2 ...)))
((cond (test => receiver) more-clause ...)
(let ((T test))
(cond/maybe-more T
(receiver T)
more-clause ...)))
((cond (generator guard => receiver) more-clause ...)
(call-with-values (lambda () generator)
(lambda T
(cond/maybe-more (apply guard T)
(apply receiver T)
more-clause ...))))
((cond (test) more-clause ...)
(let ((T test))
(cond/maybe-more T T more-clause ...)))
((cond (test body1 body2 ...) more-clause ...)
(cond/maybe-more test
(begin body1 body2 ...)
more-clause ...))))))
|
