123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147 |
- (define-module (srfi srfi-11)
- :export-syntax (let-values let*-values))
- (cond-expand-provide (current-module) '(srfi-11))
- (define-syntax let-values
- (lambda (x)
- (syntax-case x ()
- ((_ ((binds exp)) b0 b1 ...)
- (syntax (call-with-values (lambda () exp)
- (lambda binds b0 b1 ...))))
- ((_ (clause ...) b0 b1 ...)
- (let lp ((clauses (syntax (clause ...)))
- (ids '())
- (tmps '()))
- (if (null? clauses)
- (with-syntax (((id ...) ids)
- ((tmp ...) tmps))
- (syntax (let ((id tmp) ...)
- b0 b1 ...)))
- (syntax-case (car clauses) ()
- (((var ...) exp)
- (with-syntax (((new-tmp ...) (generate-temporaries
- (syntax (var ...))))
- ((id ...) ids)
- ((tmp ...) tmps))
- (with-syntax ((inner (lp (cdr clauses)
- (syntax (var ... id ...))
- (syntax (new-tmp ... tmp ...)))))
- (syntax (call-with-values (lambda () exp)
- (lambda (new-tmp ...) inner))))))
- ((vars exp)
- (with-syntax ((((new-tmp . new-var) ...)
- (let lp ((vars (syntax vars)))
- (syntax-case vars ()
- ((id . rest)
- (acons (syntax id)
- (car
- (generate-temporaries (syntax (id))))
- (lp (syntax rest))))
- (id (acons (syntax id)
- (car
- (generate-temporaries (syntax (id))))
- '())))))
- ((id ...) ids)
- ((tmp ...) tmps))
- (with-syntax ((inner (lp (cdr clauses)
- (syntax (new-var ... id ...))
- (syntax (new-tmp ... tmp ...))))
- (args (let lp ((tmps (syntax (new-tmp ...))))
- (syntax-case tmps ()
- ((id) (syntax id))
- ((id . rest) (cons (syntax id)
- (lp (syntax rest))))))))
- (syntax (call-with-values (lambda () exp)
- (lambda args inner)))))))))))))
- (define-syntax let*-values
- (syntax-rules ()
- ((let*-values () body ...)
- (let () body ...))
- ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
- (call-with-values (lambda () binding-1)
- (lambda vars-1
- (let*-values ((vars-2 binding-2) ...)
- body ...))))))
|