mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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> 2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
* Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm. * 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 ;; 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))) ;; ((p q) (bar c)))
;; (baz x y z p q)) ;; (baz x y z p q))
;; ;;
;; into ;; into
;; ;;
;; (call-with-values (lambda () (foo a b)) ;; (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)) ;; (call-with-values (lambda () (bar c))
;; (lambda (<tmp-p> <tmp-q>) ;; (lambda (<tmp-p> <tmp-q>)
;; (let ((x <tmp-x>) ;; (let ((x <tmp-x>)
@ -149,19 +149,39 @@
;; broken -- right now (as of 1.4.1, it doesn't generate unique ;; broken -- right now (as of 1.4.1, it doesn't generate unique
;; symbols) ;; symbols)
(define-macro (let-values vars . body) (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)) (let* ((var-binding (car vars))
(new-tmps (map (lambda (sym) (list sym (gentemp))) (new-tmps (map-1-dot (lambda (sym) (gentemp))
(car var-binding))) (car var-binding)))
(tmps (append new-tmps prev-tmps))) (let-vars (map (lambda (sym tmp) (list sym tmp))
(undot-list (car var-binding))
(undot-list new-tmps))))
(if (null? (cdr vars)) (if (null? (cdr vars))
`(call-with-values (lambda () ,(cadr var-binding)) `(call-with-values (lambda () ,(cadr var-binding))
(lambda ,(map cadr new-tmps) (lambda ,new-tmps
(let ,tmps (let ,(apply append let-vars prev-let-vars)
,@body))) ,@body)))
`(call-with-values (lambda () ,(cadr var-binding)) `(call-with-values (lambda () ,(cadr var-binding))
(lambda ,(map cadr new-tmps) (lambda ,new-tmps
,(let-values-helper (cdr vars) body tmps)))))) ,(let-values-helper (cdr vars) body
(cons let-vars prev-let-vars)))))))
(if (null? vars) (if (null? vars)
`(begin ,@body) `(begin ,@body)