diff options
-rw-r--r-- | srfi/ChangeLog | 4 | ||||
-rw-r--r-- | srfi/srfi-11.scm | 40 |
2 files changed, 34 insertions, 10 deletions
diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 40afe47b5..0692786ca 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2001-05-02 Rob Browning <rlb@cs.utexas.edu> + + * srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin. + 2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> * Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm. diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm index e4910ac87..0caebab05 100644 --- a/srfi/srfi-11.scm +++ b/srfi/srfi-11.scm @@ -25,14 +25,14 @@ ;; ;; Current approach is to translate ;; -;; (let-values (((x y z) (foo a b)) +;; (let-values (((x y . z) (foo a b)) ;; ((p q) (bar c))) ;; (baz x y z p q)) ;; ;; into ;; ;; (call-with-values (lambda () (foo a b)) -;; (lambda (<tmp-x> <tmp-y> <tmp-z>) +;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) ;; (call-with-values (lambda () (bar c)) ;; (lambda (<tmp-p> <tmp-q>) ;; (let ((x <tmp-x>) @@ -149,19 +149,39 @@ ;; broken -- right now (as of 1.4.1, it doesn't generate unique ;; symbols) (define-macro (let-values vars . body) - (define (let-values-helper vars body prev-tmps) + + (define (map-1-dot proc elts) + ;; map over one optionally dotted (a b c . d) list, producing an + ;; optionally dotted result. + (cond + ((null? elts) '()) + ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) + (else (proc elts)))) + + (define (undot-list lst) + ;; produce a non-dotted list from a possibly dotted list. + (cond + ((null? lst) '()) + ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) + (else (list lst)))) + + (define (let-values-helper vars body prev-let-vars) (let* ((var-binding (car vars)) - (new-tmps (map (lambda (sym) (list sym (gentemp))) - (car var-binding))) - (tmps (append new-tmps prev-tmps))) + (new-tmps (map-1-dot (lambda (sym) (gentemp)) + (car var-binding))) + (let-vars (map (lambda (sym tmp) (list sym tmp)) + (undot-list (car var-binding)) + (undot-list new-tmps)))) + (if (null? (cdr vars)) `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,(map cadr new-tmps) - (let ,tmps + (lambda ,new-tmps + (let ,(apply append let-vars prev-let-vars) ,@body))) `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,(map cadr new-tmps) - ,(let-values-helper (cdr vars) body tmps)))))) + (lambda ,new-tmps + ,(let-values-helper (cdr vars) body + (cons let-vars prev-let-vars))))))) (if (null? vars) `(begin ,@body) |