Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-11.scm --- let-values and let*-values |
69dab98b | 2 | |
1b09b607 | 3 | ;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. |
6be07c52 | 4 | ;; |
73be1d9e MV |
5 | ;; This library is free software; you can redistribute it and/or |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 2.1 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
6be07c52 TTN |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
73be1d9e MV |
13 | ;; Lesser General Public License for more details. |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
69dab98b | 18 | |
0706ae06 TTN |
19 | ;;; Commentary: |
20 | ||
21 | ;; This module exports two syntax forms: let-values and let*-values. | |
22 | ;; | |
23 | ;; Sample usage: | |
24 | ;; | |
25 | ;; (let-values (((x y . z) (foo a b)) | |
26 | ;; ((p q) (bar c))) | |
27 | ;; (baz x y z p q)) | |
28 | ;; | |
29 | ;; This binds `x' and `y' to the first to values returned by `foo', | |
30 | ;; `z' to the rest of the values from `foo', and `p' and `q' to the | |
31 | ;; values returned by `bar'. All of these are available to `baz'. | |
32 | ;; | |
33 | ;; let*-values : let-values :: let* : let | |
6be07c52 TTN |
34 | ;; |
35 | ;; This module is fully documented in the Guile Reference Manual. | |
0706ae06 TTN |
36 | |
37 | ;;; Code: | |
38 | ||
69dab98b | 39 | (define-module (srfi srfi-11) |
1a179b03 MD |
40 | :use-module (ice-9 syncase) |
41 | :export-syntax (let-values let*-values)) | |
69dab98b | 42 | |
1b2f40b9 MG |
43 | (cond-expand-provide (current-module) '(srfi-11)) |
44 | ||
69dab98b RB |
45 | ;;;;;;;;;;;;;; |
46 | ;; let-values | |
47 | ;; | |
48 | ;; Current approach is to translate | |
49 | ;; | |
109c463f | 50 | ;; (let-values (((x y . z) (foo a b)) |
69dab98b RB |
51 | ;; ((p q) (bar c))) |
52 | ;; (baz x y z p q)) | |
53 | ;; | |
54 | ;; into | |
55 | ;; | |
56 | ;; (call-with-values (lambda () (foo a b)) | |
109c463f | 57 | ;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) |
69dab98b RB |
58 | ;; (call-with-values (lambda () (bar c)) |
59 | ;; (lambda (<tmp-p> <tmp-q>) | |
60 | ;; (let ((x <tmp-x>) | |
61 | ;; (y <tmp-y>) | |
62 | ;; (z <tmp-z>) | |
63 | ;; (p <tmp-p>) | |
64 | ;; (q <tmp-q>)) | |
65 | ;; (baz x y z p q)))))) | |
66 | ||
67 | ;; I originally wrote this as a define-macro, but then I found out | |
68 | ;; that guile's gensym/gentemp was broken, so I tried rewriting it as | |
69 | ;; a syntax-rules statement. | |
7c9da364 | 70 | ;; [make-symbol now fixes gensym/gentemp problems.] |
69dab98b RB |
71 | ;; |
72 | ;; Since syntax-rules didn't seem powerful enough to implement | |
73 | ;; let-values in one definition without exposing illegal syntax (or | |
74 | ;; perhaps my brain's just not powerful enough :>). I tried writing | |
75 | ;; it using a private helper, but that didn't work because the | |
76 | ;; let-values expands outside the scope of this module. I wonder why | |
77 | ;; syntax-rules wasn't designed to allow "private" patterns or | |
78 | ;; similar... | |
79 | ;; | |
80 | ;; So in the end, I dumped the syntax-rules implementation, reproduced | |
81 | ;; here for posterity, and went with the define-macro one below -- | |
82 | ;; gensym/gentemp's got to be fixed anyhow... | |
83 | ; | |
84 | ; (define-syntax let-values-helper | |
85 | ; (syntax-rules () | |
86 | ; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y | |
87 | ; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda | |
88 | ; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the | |
89 | ; ;; temps you create so you can use them later... | |
90 | ; ;; | |
91 | ; ;; I really don't fully understand why the (var-1 var-1) trick | |
92 | ; ;; works below, but basically, when all those (x x) bindings show | |
93 | ; ;; up in the final "let", syntax-rules forces a renaming. | |
94 | ||
95 | ; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings | |
96 | ; body ...) | |
97 | ; (lambda lambda-tmps | |
98 | ; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) | |
0706ae06 | 99 | |
69dab98b RB |
100 | ; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings |
101 | ; body ...) | |
102 | ; (let-values-helper "consumer" | |
103 | ; (var-2 ...) | |
104 | ; (lambda-tmp ... var-1) | |
105 | ; ((var-1 var-1) . final-let-bindings) | |
106 | ; lv-bindings | |
107 | ; body ...)) | |
108 | ||
109 | ; ((_ "cwv" () final-let-bindings body ...) | |
110 | ; (let final-let-bindings | |
111 | ; body ...)) | |
112 | ||
113 | ; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings | |
114 | ; body ...) | |
115 | ; (call-with-values (lambda () binding-1) | |
116 | ; (let-values-helper "consumer" | |
117 | ; vars-1 | |
118 | ; () | |
119 | ; final-let-bindings | |
120 | ; (other-bindings ...) | |
121 | ; body ...))))) | |
122 | ; | |
123 | ; (define-syntax let-values | |
124 | ; (syntax-rules () | |
125 | ; ((let-values () body ...) | |
126 | ; (begin body ...)) | |
127 | ; ((let-values (binding ...) body ...) | |
128 | ; (let-values-helper "cwv" (binding ...) () body ...)))) | |
129 | ; | |
130 | ; | |
131 | ; (define-syntax let-values | |
132 | ; (letrec-syntax ((build-consumer | |
133 | ; ;; Take the vars from one let binding (i.e. the (x | |
134 | ; ;; y z) from ((x y z) (values 1 2 3)) and turn it | |
135 | ; ;; in to the corresponding (lambda (<tmp-x> <tmp-y> | |
136 | ; ;; <tmp-z>) ...) from above. | |
137 | ; (syntax-rules () | |
138 | ; ((_ () new-tmps tmp-vars () body ...) | |
139 | ; (lambda new-tmps | |
140 | ; body ...)) | |
141 | ; ((_ () new-tmps tmp-vars vars body ...) | |
142 | ; (lambda new-tmps | |
143 | ; (lv-builder vars tmp-vars body ...))) | |
144 | ; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) | |
145 | ; (build-consumer (var-2 ...) | |
146 | ; (tmp-1 . new-tmps) | |
147 | ; ((var-1 tmp-1) . tmp-vars) | |
148 | ; bindings | |
149 | ; body ...)))) | |
150 | ; (lv-builder | |
151 | ; (syntax-rules () | |
152 | ; ((_ () tmp-vars body ...) | |
153 | ; (let tmp-vars | |
154 | ; body ...)) | |
155 | ; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) | |
156 | ; tmp-vars | |
157 | ; body ...) | |
158 | ; (call-with-values (lambda () binding-1) | |
159 | ; (build-consumer vars-1 | |
160 | ; () | |
161 | ; tmp-vars | |
162 | ; ((vars-2 binding-2) ...) | |
163 | ; body ...)))))) | |
0706ae06 | 164 | ; |
69dab98b RB |
165 | ; (syntax-rules () |
166 | ; ((_ () body ...) | |
167 | ; (begin body ...)) | |
168 | ; ((_ ((vars binding) ...) body ...) | |
169 | ; (lv-builder ((vars binding) ...) () body ...))))) | |
170 | ||
69dab98b | 171 | (define-macro (let-values vars . body) |
109c463f RB |
172 | |
173 | (define (map-1-dot proc elts) | |
174 | ;; map over one optionally dotted (a b c . d) list, producing an | |
175 | ;; optionally dotted result. | |
176 | (cond | |
177 | ((null? elts) '()) | |
178 | ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) | |
179 | (else (proc elts)))) | |
0706ae06 | 180 | |
109c463f RB |
181 | (define (undot-list lst) |
182 | ;; produce a non-dotted list from a possibly dotted list. | |
183 | (cond | |
184 | ((null? lst) '()) | |
185 | ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) | |
186 | (else (list lst)))) | |
187 | ||
188 | (define (let-values-helper vars body prev-let-vars) | |
69dab98b | 189 | (let* ((var-binding (car vars)) |
7c9da364 | 190 | (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var")) |
109c463f RB |
191 | (car var-binding))) |
192 | (let-vars (map (lambda (sym tmp) (list sym tmp)) | |
193 | (undot-list (car var-binding)) | |
194 | (undot-list new-tmps)))) | |
0706ae06 | 195 | |
69dab98b RB |
196 | (if (null? (cdr vars)) |
197 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
198 | (lambda ,new-tmps |
199 | (let ,(apply append let-vars prev-let-vars) | |
69dab98b RB |
200 | ,@body))) |
201 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
202 | (lambda ,new-tmps |
203 | ,(let-values-helper (cdr vars) body | |
204 | (cons let-vars prev-let-vars))))))) | |
0706ae06 | 205 | |
69dab98b RB |
206 | (if (null? vars) |
207 | `(begin ,@body) | |
208 | (let-values-helper vars body '()))) | |
209 | ||
210 | ;;;;;;;;;;;;;; | |
211 | ;; let*-values | |
212 | ;; | |
213 | ;; Current approach is to translate | |
214 | ;; | |
215 | ;; (let*-values (((x y z) (foo a b)) | |
216 | ;; ((p q) (bar c))) | |
217 | ;; (baz x y z p q)) | |
218 | ;; | |
219 | ;; into | |
220 | ;; | |
221 | ;; (call-with-values (lambda () (foo a b)) | |
222 | ;; (lambda (x y z) | |
223 | ;; (call-with-values (lambda (bar c)) | |
224 | ;; (lambda (p q) | |
225 | ;; (baz x y z p q))))) | |
226 | ||
227 | (define-syntax let*-values | |
228 | (syntax-rules () | |
229 | ((let*-values () body ...) | |
230 | (begin body ...)) | |
231 | ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) | |
232 | (call-with-values (lambda () binding-1) | |
233 | (lambda vars-1 | |
234 | (let*-values ((vars-2 binding-2) ...) | |
235 | body ...)))))) | |
236 | ||
237 | ; Alternate define-macro implementation... | |
0706ae06 | 238 | ; |
69dab98b RB |
239 | ; (define-macro (let*-values vars . body) |
240 | ; (define (let-values-helper vars body) | |
241 | ; (let ((var-binding (car vars))) | |
242 | ; (if (null? (cdr vars)) | |
243 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
244 | ; (lambda ,(car var-binding) | |
245 | ; ,@body)) | |
246 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
247 | ; (lambda ,(car var-binding) | |
248 | ; ,(let-values-helper (cdr vars) body)))))) | |
0706ae06 | 249 | |
69dab98b RB |
250 | ; (if (null? vars) |
251 | ; `(begin ,@body) | |
252 | ; (let-values-helper vars body))) | |
6be07c52 TTN |
253 | |
254 | ;;; srfi-11.scm ends here |