1(library (yuni util binding-constructs)
2         (export
3           let-optionals*
4           rlet1
5           let1
6           define-values)
7         (import (rnrs))
8
9(define-syntax cdr/nil
10  (syntax-rules ()
11    ((_ x)
12     (if (pair? x) (cdr x) '()))))
13
14(define-syntax leto*1
15  (syntax-rules ()
16    ((_ args (var0 default0) body ...)
17     (let1 var0 (if (pair? args) (car args) default0)
18           body ...))))
19
20(define-syntax leto*
21  (syntax-rules ()
22    ((_ args ((var default) restarg) body ...)
23     (leto*1 args (var default)
24             (let1 restarg (cdr/nil args) body ...)))
25    ((_ args ((var0 default0) (var1 default1) ... restarg) body ...)
26     (leto*1 args (var0 default0)
27             (leto* (cdr/nil args) ((var1 default1) ... restarg) body ...)))))
28
29
30
31(define-syntax let-optionals*
32  (syntax-rules ()
33    ((_ args ((var default) ...) body ...)
34     (let-optionals* args ((var default) ... bogus) body ...))
35    ((_ args ((var default) ... restarg) body ...)
36     (leto* args ((var default) ... restarg) body ...))))
37
38(define-syntax let1
39  (syntax-rules ()
40    ((_ obj tm body ...)
41     (let ((obj tm))
42       body ...))))
43
44(define-syntax rlet1
45  (syntax-rules ()
46    ((_ obj tm body ...)
47     (let1 obj tm body ... obj))))
48
49(define-syntax define-values
50  (lambda (x)
51    (syntax-case x ()
52      ((_ (val ...) body)
53       (with-syntax (((name ...)
54                      (generate-temporaries #'(val ...)))
55                     ((tmp ...)
56                      (generate-temporaries #'(val ...))))
57         #'(begin
58             (define name #f)
59             ...
60             (define bogus
61               (begin
62                 (call-with-values (lambda () body)
63                                   (lambda (tmp ...)
64                                     (set! name tmp)
65                                     ...
66                                     ))))
67             (define val name)
68             ...
69             ))))))
70
71)
72
73