summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/ChangeLog4
-rw-r--r--srfi/srfi-11.scm40
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)