Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-11.scm --- let-values and let*-values |
69dab98b | 2 | |
6be07c52 TTN |
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. | |
69dab98b | 43 | |
0706ae06 TTN |
44 | ;;; Commentary: |
45 | ||
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 | |
6be07c52 TTN |
59 | ;; |
60 | ;; This module is fully documented in the Guile Reference Manual. | |
0706ae06 TTN |
61 | |
62 | ;;; Code: | |
63 | ||
69dab98b | 64 | (define-module (srfi srfi-11) |
1a179b03 MD |
65 | :use-module (ice-9 syncase) |
66 | :export-syntax (let-values let*-values)) | |
69dab98b | 67 | |
1b2f40b9 MG |
68 | (cond-expand-provide (current-module) '(srfi-11)) |
69 | ||
69dab98b RB |
70 | ;;;;;;;;;;;;;; |
71 | ;; let-values | |
72 | ;; | |
73 | ;; Current approach is to translate | |
74 | ;; | |
109c463f | 75 | ;; (let-values (((x y . z) (foo a b)) |
69dab98b RB |
76 | ;; ((p q) (bar c))) |
77 | ;; (baz x y z p q)) | |
78 | ;; | |
79 | ;; into | |
80 | ;; | |
81 | ;; (call-with-values (lambda () (foo a b)) | |
109c463f | 82 | ;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) |
69dab98b RB |
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)))))) | |
91 | ||
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. | |
118 | ||
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 ...))) | |
0706ae06 | 123 | |
69dab98b RB |
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 ...)) | |
132 | ||
133 | ; ((_ "cwv" () final-let-bindings body ...) | |
134 | ; (let final-let-bindings | |
135 | ; body ...)) | |
136 | ||
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 ...)))))) | |
0706ae06 | 188 | ; |
69dab98b RB |
189 | ; (syntax-rules () |
190 | ; ((_ () body ...) | |
191 | ; (begin body ...)) | |
192 | ; ((_ ((vars binding) ...) body ...) | |
193 | ; (lv-builder ((vars binding) ...) () body ...))))) | |
194 | ||
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) | |
109c463f RB |
199 | |
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)))) | |
0706ae06 | 207 | |
109c463f RB |
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)))) | |
214 | ||
215 | (define (let-values-helper vars body prev-let-vars) | |
69dab98b | 216 | (let* ((var-binding (car vars)) |
7733436f | 217 | (new-tmps (map-1-dot (lambda (sym) (gensym)) |
109c463f RB |
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)))) | |
0706ae06 | 222 | |
69dab98b RB |
223 | (if (null? (cdr vars)) |
224 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
225 | (lambda ,new-tmps |
226 | (let ,(apply append let-vars prev-let-vars) | |
69dab98b RB |
227 | ,@body))) |
228 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
229 | (lambda ,new-tmps |
230 | ,(let-values-helper (cdr vars) body | |
231 | (cons let-vars prev-let-vars))))))) | |
0706ae06 | 232 | |
69dab98b RB |
233 | (if (null? vars) |
234 | `(begin ,@body) | |
235 | (let-values-helper vars body '()))) | |
236 | ||
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))))) | |
253 | ||
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 ...)))))) | |
263 | ||
264 | ; Alternate define-macro implementation... | |
0706ae06 | 265 | ; |
69dab98b RB |
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)))))) | |
0706ae06 | 276 | |
69dab98b RB |
277 | ; (if (null? vars) |
278 | ; `(begin ,@body) | |
279 | ; (let-values-helper vars body))) | |
6be07c52 TTN |
280 | |
281 | ;;; srfi-11.scm ends here |