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