Commit | Line | Data |
---|---|---|
69dab98b RB |
1 | ;;;; srfi-11.scm --- SRFI-11 procedures for Guile |
2 | ||
46a7b46f | 3 | ;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. |
69dab98b RB |
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 | |
f480396b MV |
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 RB |
43 | |
44 | (define-module (srfi srfi-11) | |
1a179b03 MD |
45 | :use-module (ice-9 syncase) |
46 | :export-syntax (let-values let*-values)) | |
69dab98b | 47 | |
1b2f40b9 MG |
48 | (cond-expand-provide (current-module) '(srfi-11)) |
49 | ||
69dab98b RB |
50 | ;;;;;;;;;;;;;; |
51 | ;; let-values | |
52 | ;; | |
53 | ;; Current approach is to translate | |
54 | ;; | |
109c463f | 55 | ;; (let-values (((x y . z) (foo a b)) |
69dab98b RB |
56 | ;; ((p q) (bar c))) |
57 | ;; (baz x y z p q)) | |
58 | ;; | |
59 | ;; into | |
60 | ;; | |
61 | ;; (call-with-values (lambda () (foo a b)) | |
109c463f | 62 | ;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) |
69dab98b RB |
63 | ;; (call-with-values (lambda () (bar c)) |
64 | ;; (lambda (<tmp-p> <tmp-q>) | |
65 | ;; (let ((x <tmp-x>) | |
66 | ;; (y <tmp-y>) | |
67 | ;; (z <tmp-z>) | |
68 | ;; (p <tmp-p>) | |
69 | ;; (q <tmp-q>)) | |
70 | ;; (baz x y z p q)))))) | |
71 | ||
72 | ;; I originally wrote this as a define-macro, but then I found out | |
73 | ;; that guile's gensym/gentemp was broken, so I tried rewriting it as | |
74 | ;; a syntax-rules statement. | |
75 | ;; | |
76 | ;; Since syntax-rules didn't seem powerful enough to implement | |
77 | ;; let-values in one definition without exposing illegal syntax (or | |
78 | ;; perhaps my brain's just not powerful enough :>). I tried writing | |
79 | ;; it using a private helper, but that didn't work because the | |
80 | ;; let-values expands outside the scope of this module. I wonder why | |
81 | ;; syntax-rules wasn't designed to allow "private" patterns or | |
82 | ;; similar... | |
83 | ;; | |
84 | ;; So in the end, I dumped the syntax-rules implementation, reproduced | |
85 | ;; here for posterity, and went with the define-macro one below -- | |
86 | ;; gensym/gentemp's got to be fixed anyhow... | |
87 | ; | |
88 | ; (define-syntax let-values-helper | |
89 | ; (syntax-rules () | |
90 | ; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y | |
91 | ; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda | |
92 | ; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the | |
93 | ; ;; temps you create so you can use them later... | |
94 | ; ;; | |
95 | ; ;; I really don't fully understand why the (var-1 var-1) trick | |
96 | ; ;; works below, but basically, when all those (x x) bindings show | |
97 | ; ;; up in the final "let", syntax-rules forces a renaming. | |
98 | ||
99 | ; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings | |
100 | ; body ...) | |
101 | ; (lambda lambda-tmps | |
102 | ; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) | |
103 | ||
104 | ; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings | |
105 | ; body ...) | |
106 | ; (let-values-helper "consumer" | |
107 | ; (var-2 ...) | |
108 | ; (lambda-tmp ... var-1) | |
109 | ; ((var-1 var-1) . final-let-bindings) | |
110 | ; lv-bindings | |
111 | ; body ...)) | |
112 | ||
113 | ; ((_ "cwv" () final-let-bindings body ...) | |
114 | ; (let final-let-bindings | |
115 | ; body ...)) | |
116 | ||
117 | ; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings | |
118 | ; body ...) | |
119 | ; (call-with-values (lambda () binding-1) | |
120 | ; (let-values-helper "consumer" | |
121 | ; vars-1 | |
122 | ; () | |
123 | ; final-let-bindings | |
124 | ; (other-bindings ...) | |
125 | ; body ...))))) | |
126 | ; | |
127 | ; (define-syntax let-values | |
128 | ; (syntax-rules () | |
129 | ; ((let-values () body ...) | |
130 | ; (begin body ...)) | |
131 | ; ((let-values (binding ...) body ...) | |
132 | ; (let-values-helper "cwv" (binding ...) () body ...)))) | |
133 | ; | |
134 | ; | |
135 | ; (define-syntax let-values | |
136 | ; (letrec-syntax ((build-consumer | |
137 | ; ;; Take the vars from one let binding (i.e. the (x | |
138 | ; ;; y z) from ((x y z) (values 1 2 3)) and turn it | |
139 | ; ;; in to the corresponding (lambda (<tmp-x> <tmp-y> | |
140 | ; ;; <tmp-z>) ...) from above. | |
141 | ; (syntax-rules () | |
142 | ; ((_ () new-tmps tmp-vars () body ...) | |
143 | ; (lambda new-tmps | |
144 | ; body ...)) | |
145 | ; ((_ () new-tmps tmp-vars vars body ...) | |
146 | ; (lambda new-tmps | |
147 | ; (lv-builder vars tmp-vars body ...))) | |
148 | ; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) | |
149 | ; (build-consumer (var-2 ...) | |
150 | ; (tmp-1 . new-tmps) | |
151 | ; ((var-1 tmp-1) . tmp-vars) | |
152 | ; bindings | |
153 | ; body ...)))) | |
154 | ; (lv-builder | |
155 | ; (syntax-rules () | |
156 | ; ((_ () tmp-vars body ...) | |
157 | ; (let tmp-vars | |
158 | ; body ...)) | |
159 | ; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) | |
160 | ; tmp-vars | |
161 | ; body ...) | |
162 | ; (call-with-values (lambda () binding-1) | |
163 | ; (build-consumer vars-1 | |
164 | ; () | |
165 | ; tmp-vars | |
166 | ; ((vars-2 binding-2) ...) | |
167 | ; body ...)))))) | |
168 | ; | |
169 | ; (syntax-rules () | |
170 | ; ((_ () body ...) | |
171 | ; (begin body ...)) | |
172 | ; ((_ ((vars binding) ...) body ...) | |
173 | ; (lv-builder ((vars binding) ...) () body ...))))) | |
174 | ||
175 | ;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is | |
176 | ;; broken -- right now (as of 1.4.1, it doesn't generate unique | |
177 | ;; symbols) | |
178 | (define-macro (let-values vars . body) | |
109c463f RB |
179 | |
180 | (define (map-1-dot proc elts) | |
181 | ;; map over one optionally dotted (a b c . d) list, producing an | |
182 | ;; optionally dotted result. | |
183 | (cond | |
184 | ((null? elts) '()) | |
185 | ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) | |
186 | (else (proc elts)))) | |
187 | ||
188 | (define (undot-list lst) | |
189 | ;; produce a non-dotted list from a possibly dotted list. | |
190 | (cond | |
191 | ((null? lst) '()) | |
192 | ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) | |
193 | (else (list lst)))) | |
194 | ||
195 | (define (let-values-helper vars body prev-let-vars) | |
69dab98b | 196 | (let* ((var-binding (car vars)) |
109c463f RB |
197 | (new-tmps (map-1-dot (lambda (sym) (gentemp)) |
198 | (car var-binding))) | |
199 | (let-vars (map (lambda (sym tmp) (list sym tmp)) | |
200 | (undot-list (car var-binding)) | |
201 | (undot-list new-tmps)))) | |
202 | ||
69dab98b RB |
203 | (if (null? (cdr vars)) |
204 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
205 | (lambda ,new-tmps |
206 | (let ,(apply append let-vars prev-let-vars) | |
69dab98b RB |
207 | ,@body))) |
208 | `(call-with-values (lambda () ,(cadr var-binding)) | |
109c463f RB |
209 | (lambda ,new-tmps |
210 | ,(let-values-helper (cdr vars) body | |
211 | (cons let-vars prev-let-vars))))))) | |
69dab98b RB |
212 | |
213 | (if (null? vars) | |
214 | `(begin ,@body) | |
215 | (let-values-helper vars body '()))) | |
216 | ||
217 | ;;;;;;;;;;;;;; | |
218 | ;; let*-values | |
219 | ;; | |
220 | ;; Current approach is to translate | |
221 | ;; | |
222 | ;; (let*-values (((x y z) (foo a b)) | |
223 | ;; ((p q) (bar c))) | |
224 | ;; (baz x y z p q)) | |
225 | ;; | |
226 | ;; into | |
227 | ;; | |
228 | ;; (call-with-values (lambda () (foo a b)) | |
229 | ;; (lambda (x y z) | |
230 | ;; (call-with-values (lambda (bar c)) | |
231 | ;; (lambda (p q) | |
232 | ;; (baz x y z p q))))) | |
233 | ||
234 | (define-syntax let*-values | |
235 | (syntax-rules () | |
236 | ((let*-values () body ...) | |
237 | (begin body ...)) | |
238 | ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) | |
239 | (call-with-values (lambda () binding-1) | |
240 | (lambda vars-1 | |
241 | (let*-values ((vars-2 binding-2) ...) | |
242 | body ...)))))) | |
243 | ||
244 | ; Alternate define-macro implementation... | |
245 | ; | |
246 | ; (define-macro (let*-values vars . body) | |
247 | ; (define (let-values-helper vars body) | |
248 | ; (let ((var-binding (car vars))) | |
249 | ; (if (null? (cdr vars)) | |
250 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
251 | ; (lambda ,(car var-binding) | |
252 | ; ,@body)) | |
253 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
254 | ; (lambda ,(car var-binding) | |
255 | ; ,(let-values-helper (cdr vars) body)))))) | |
256 | ||
257 | ; (if (null? vars) | |
258 | ; `(begin ,@body) | |
259 | ; (let-values-helper vars body))) |