| blob | e356c95ad7bd3c6e50c583bc683028fe89e757ff |
1 ;;; srfi-11.scm --- let-values and let*-values
3 ;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
4 ;;
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU General Public License as
7 ;; published by the Free Software Foundation; either version 2, or
8 ;; (at your option) any later version.
9 ;;
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this software; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;; Boston, MA 02111-1307 USA
19 ;;
20 ;; As a special exception, the Free Software Foundation gives permission
21 ;; for additional uses of the text contained in its release of GUILE.
22 ;;
23 ;; The exception is that, if you link the GUILE library with other files
24 ;; to produce an executable, this does not by itself cause the
25 ;; resulting executable to be covered by the GNU General Public License.
26 ;; Your use of that executable is in no way restricted on account of
27 ;; linking the GUILE library code into it.
28 ;;
29 ;; This exception does not however invalidate any other reasons why
30 ;; the executable file might be covered by the GNU General Public License.
31 ;;
32 ;; This exception applies only to the code released by the
33 ;; Free Software Foundation under the name GUILE. If you copy
34 ;; code from other Free Software Foundation releases into a copy of
35 ;; GUILE, as the General Public License permits, the exception does
36 ;; not apply to the code that you add in this way. To avoid misleading
37 ;; anyone as to the status of such modified files, you must delete
38 ;; this exception notice from them.
39 ;;
40 ;; If you write modifications of your own for GUILE, it is your choice
41 ;; whether to permit this exception to apply to your modifications.
42 ;; If you do not wish that, delete this exception notice.
44 ;;; Commentary:
46 ;; This module exports two syntax forms: let-values and let*-values.
47 ;;
48 ;; Sample usage:
49 ;;
50 ;; (let-values (((x y . z) (foo a b))
51 ;; ((p q) (bar c)))
52 ;; (baz x y z p q))
53 ;;
54 ;; This binds `x' and `y' to the first to values returned by `foo',
55 ;; `z' to the rest of the values from `foo', and `p' and `q' to the
56 ;; values returned by `bar'. All of these are available to `baz'.
57 ;;
58 ;; let*-values : let-values :: let* : let
59 ;;
60 ;; This module is fully documented in the Guile Reference Manual.
62 ;;; Code:
64 (define-module (srfi srfi-11)
65 :use-module (ice-9 syncase)
66 :export-syntax (let-values let*-values))
68 (cond-expand-provide (current-module) '(srfi-11))
70 ;;;;;;;;;;;;;;
71 ;; let-values
72 ;;
73 ;; Current approach is to translate
74 ;;
75 ;; (let-values (((x y . z) (foo a b))
76 ;; ((p q) (bar c)))
77 ;; (baz x y z p q))
78 ;;
79 ;; into
80 ;;
81 ;; (call-with-values (lambda () (foo a b))
82 ;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
83 ;; (call-with-values (lambda () (bar c))
84 ;; (lambda (<tmp-p> <tmp-q>)
85 ;; (let ((x <tmp-x>)
86 ;; (y <tmp-y>)
87 ;; (z <tmp-z>)
88 ;; (p <tmp-p>)
89 ;; (q <tmp-q>))
90 ;; (baz x y z p q))))))
92 ;; I originally wrote this as a define-macro, but then I found out
93 ;; that guile's gensym/gentemp was broken, so I tried rewriting it as
94 ;; a syntax-rules statement.
95 ;;
96 ;; Since syntax-rules didn't seem powerful enough to implement
97 ;; let-values in one definition without exposing illegal syntax (or
98 ;; perhaps my brain's just not powerful enough :>). I tried writing
99 ;; it using a private helper, but that didn't work because the
100 ;; let-values expands outside the scope of this module. I wonder why
101 ;; syntax-rules wasn't designed to allow "private" patterns or
102 ;; similar...
103 ;;
104 ;; So in the end, I dumped the syntax-rules implementation, reproduced
105 ;; here for posterity, and went with the define-macro one below --
106 ;; gensym/gentemp's got to be fixed anyhow...
107 ;
108 ; (define-syntax let-values-helper
109 ; (syntax-rules ()
110 ; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
111 ; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
112 ; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
113 ; ;; temps you create so you can use them later...
114 ; ;;
115 ; ;; I really don't fully understand why the (var-1 var-1) trick
116 ; ;; works below, but basically, when all those (x x) bindings show
117 ; ;; up in the final "let", syntax-rules forces a renaming.
119 ; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
120 ; body ...)
121 ; (lambda lambda-tmps
122 ; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
124 ; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
125 ; body ...)
126 ; (let-values-helper "consumer"
127 ; (var-2 ...)
128 ; (lambda-tmp ... var-1)
129 ; ((var-1 var-1) . final-let-bindings)
130 ; lv-bindings
131 ; body ...))
133 ; ((_ "cwv" () final-let-bindings body ...)
134 ; (let final-let-bindings
135 ; body ...))
137 ; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
138 ; body ...)
139 ; (call-with-values (lambda () binding-1)
140 ; (let-values-helper "consumer"
141 ; vars-1
142 ; ()
143 ; final-let-bindings
144 ; (other-bindings ...)
145 ; body ...)))))
146 ;
147 ; (define-syntax let-values
148 ; (syntax-rules ()
149 ; ((let-values () body ...)
150 ; (begin body ...))
151 ; ((let-values (binding ...) body ...)
152 ; (let-values-helper "cwv" (binding ...) () body ...))))
153 ;
154 ;
155 ; (define-syntax let-values
156 ; (letrec-syntax ((build-consumer
157 ; ;; Take the vars from one let binding (i.e. the (x
158 ; ;; y z) from ((x y z) (values 1 2 3)) and turn it
159 ; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
160 ; ;; <tmp-z>) ...) from above.
161 ; (syntax-rules ()
162 ; ((_ () new-tmps tmp-vars () body ...)
163 ; (lambda new-tmps
164 ; body ...))
165 ; ((_ () new-tmps tmp-vars vars body ...)
166 ; (lambda new-tmps
167 ; (lv-builder vars tmp-vars body ...)))
168 ; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
169 ; (build-consumer (var-2 ...)
170 ; (tmp-1 . new-tmps)
171 ; ((var-1 tmp-1) . tmp-vars)
172 ; bindings
173 ; body ...))))
174 ; (lv-builder
175 ; (syntax-rules ()
176 ; ((_ () tmp-vars body ...)
177 ; (let tmp-vars
178 ; body ...))
179 ; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
180 ; tmp-vars
181 ; body ...)
182 ; (call-with-values (lambda () binding-1)
183 ; (build-consumer vars-1
184 ; ()
185 ; tmp-vars
186 ; ((vars-2 binding-2) ...)
187 ; body ...))))))
188 ;
189 ; (syntax-rules ()
190 ; ((_ () body ...)
191 ; (begin body ...))
192 ; ((_ ((vars binding) ...) body ...)
193 ; (lv-builder ((vars binding) ...) () body ...)))))
195 ;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is
196 ;; broken -- right now (as of 1.4.1, it doesn't generate unique
197 ;; symbols)
198 (define-macro (let-values vars . body)
200 (define (map-1-dot proc elts)
201 ;; map over one optionally dotted (a b c . d) list, producing an
202 ;; optionally dotted result.
203 (cond
204 ((null? elts) '())
205 ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
206 (else (proc elts))))
208 (define (undot-list lst)
209 ;; produce a non-dotted list from a possibly dotted list.
210 (cond
211 ((null? lst) '())
212 ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
213 (else (list lst))))
215 (define (let-values-helper vars body prev-let-vars)
216 (let* ((var-binding (car vars))
217 (new-tmps (map-1-dot (lambda (sym) (gentemp))
218 (car var-binding)))
219 (let-vars (map (lambda (sym tmp) (list sym tmp))
220 (undot-list (car var-binding))
221 (undot-list new-tmps))))
223 (if (null? (cdr vars))
224 `(call-with-values (lambda () ,(cadr var-binding))
225 (lambda ,new-tmps
226 (let ,(apply append let-vars prev-let-vars)
227 ,@body)))
228 `(call-with-values (lambda () ,(cadr var-binding))
229 (lambda ,new-tmps
230 ,(let-values-helper (cdr vars) body
231 (cons let-vars prev-let-vars)))))))
233 (if (null? vars)
234 `(begin ,@body)
235 (let-values-helper vars body '())))
237 ;;;;;;;;;;;;;;
238 ;; let*-values
239 ;;
240 ;; Current approach is to translate
241 ;;
242 ;; (let*-values (((x y z) (foo a b))
243 ;; ((p q) (bar c)))
244 ;; (baz x y z p q))
245 ;;
246 ;; into
247 ;;
248 ;; (call-with-values (lambda () (foo a b))
249 ;; (lambda (x y z)
250 ;; (call-with-values (lambda (bar c))
251 ;; (lambda (p q)
252 ;; (baz x y z p q)))))
254 (define-syntax let*-values
255 (syntax-rules ()
256 ((let*-values () body ...)
257 (begin body ...))
258 ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
259 (call-with-values (lambda () binding-1)
260 (lambda vars-1
261 (let*-values ((vars-2 binding-2) ...)
262 body ...))))))
264 ; Alternate define-macro implementation...
265 ;
266 ; (define-macro (let*-values vars . body)
267 ; (define (let-values-helper vars body)
268 ; (let ((var-binding (car vars)))
269 ; (if (null? (cdr vars))
270 ; `(call-with-values (lambda () ,(cadr var-binding))
271 ; (lambda ,(car var-binding)
272 ; ,@body))
273 ; `(call-with-values (lambda () ,(cadr var-binding))
274 ; (lambda ,(car var-binding)
275 ; ,(let-values-helper (cdr vars) body))))))
277 ; (if (null? vars)
278 ; `(begin ,@body)
279 ; (let-values-helper vars body)))
281 ;;; srfi-11.scm ends here