1(library (rnrs control (6))
2  (export when unless do case-lambda)
3  (import (for (core primitives)   expand run)
4          (for (core let)          expand run)
5          (for (core with-syntax)  expand)
6          (for (core syntax-rules) expand)
7          (for (primitives not map length assertion-violation = >= apply)
8            expand run) )
9
10  (define-syntax when
11    (syntax-rules ()
12      ((when test result1 result2 ...)
13       (if test
14           (begin result1 result2 ...)))))
15
16  (define-syntax unless
17    (syntax-rules ()
18      ((unless test result1 result2 ...)
19       (if (not test)
20           (begin result1 result2 ...)))))
21
22  (define-syntax do
23    (lambda (orig-x)
24      (syntax-case orig-x ()
25        ((_ ((var init . step) ...) (e0 e1 ...) c ...)
26         (with-syntax (((step ...)
27                        (map (lambda (v s)
28                               (syntax-case s ()
29                                 (()  v)
30                                 ((e) (syntax e))
31                                 (_   (syntax-violation 'do "Invalid step" orig-x s))))
32                             (syntax (var ...))
33                             (syntax (step ...)))))
34           (syntax-case (syntax (e1 ...)) ()
35             (()          (syntax (let do ((var init) ...)
36                                    (if (not e0)
37                                        (begin c ... (do step ...))))))
38             ((e1 e2 ...) (syntax (let do ((var init) ...)
39                                    (if e0
40                                        (begin e1 e2 ...)
41                                        (begin c ... (do step ...))))))))))))
42  (define-syntax case-lambda
43    (syntax-rules ()
44      ((_ (fmls b1 b2 ...))
45       (lambda fmls b1 b2 ...))
46      ((_ (fmls b1 b2 ...) ...)
47       (lambda args
48         (let ((n (length args)))
49           (case-lambda-help args n
50                             (fmls b1 b2 ...) ...))))))
51
52  (define-syntax case-lambda-help
53    (syntax-rules ()
54      ((_ args n)
55       (assertion-violation #f "unexpected number of arguments"))
56      ((_ args n ((x ...) b1 b2 ...) more ...)
57       (if (= n (length '(x ...)))
58           (apply (lambda (x ...) b1 b2 ...) args)
59           (case-lambda-help args n more ...)))
60      ((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...)
61       (if (>= n (length '(x1 x2 ...)))
62           (apply (lambda (x1 x2 ... . r) b1 b2 ...)
63                  args)
64           (case-lambda-help args n more ...)))
65      ((_ args n (r b1 b2 ...) more ...)
66       (apply (lambda r b1 b2 ...) args))))
67
68  ) ; rnrs control
69