mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

* srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin.

Browse source
This commit is contained in:
Rob Browning 2001-05-02 21:15:57 +00:00
parent 0892b63b25
commit 109c463fdd
2 changed files with 34 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

4
srfi/ChangeLog
View file

@ -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.

40
srfi/srfi-11.scm
View file

@ -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)