Commit | Line | Data |
---|---|---|
69dab98b RB |
1 | ;;;; srfi-11.scm --- SRFI-11 procedures for Guile |
2 | ||
3 | ;;; Copyright (C) 2000 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 | (define-module (srfi srfi-11) | |
21 | :use-module (ice-9 syncase)) | |
22 | ||
23 | ;;;;;;;;;;;;;; | |
24 | ;; let-values | |
25 | ;; | |
26 | ;; Current approach is to translate | |
27 | ;; | |
28 | ;; (let-values (((x y z) (foo a b)) | |
29 | ;; ((p q) (bar c))) | |
30 | ;; (baz x y z p q)) | |
31 | ;; | |
32 | ;; into | |
33 | ;; | |
34 | ;; (call-with-values (lambda () (foo a b)) | |
35 | ;; (lambda (<tmp-x> <tmp-y> <tmp-z>) | |
36 | ;; (call-with-values (lambda () (bar c)) | |
37 | ;; (lambda (<tmp-p> <tmp-q>) | |
38 | ;; (let ((x <tmp-x>) | |
39 | ;; (y <tmp-y>) | |
40 | ;; (z <tmp-z>) | |
41 | ;; (p <tmp-p>) | |
42 | ;; (q <tmp-q>)) | |
43 | ;; (baz x y z p q)))))) | |
44 | ||
45 | ;; I originally wrote this as a define-macro, but then I found out | |
46 | ;; that guile's gensym/gentemp was broken, so I tried rewriting it as | |
47 | ;; a syntax-rules statement. | |
48 | ;; | |
49 | ;; Since syntax-rules didn't seem powerful enough to implement | |
50 | ;; let-values in one definition without exposing illegal syntax (or | |
51 | ;; perhaps my brain's just not powerful enough :>). I tried writing | |
52 | ;; it using a private helper, but that didn't work because the | |
53 | ;; let-values expands outside the scope of this module. I wonder why | |
54 | ;; syntax-rules wasn't designed to allow "private" patterns or | |
55 | ;; similar... | |
56 | ;; | |
57 | ;; So in the end, I dumped the syntax-rules implementation, reproduced | |
58 | ;; here for posterity, and went with the define-macro one below -- | |
59 | ;; gensym/gentemp's got to be fixed anyhow... | |
60 | ; | |
61 | ; (define-syntax let-values-helper | |
62 | ; (syntax-rules () | |
63 | ; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y | |
64 | ; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda | |
65 | ; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the | |
66 | ; ;; temps you create so you can use them later... | |
67 | ; ;; | |
68 | ; ;; I really don't fully understand why the (var-1 var-1) trick | |
69 | ; ;; works below, but basically, when all those (x x) bindings show | |
70 | ; ;; up in the final "let", syntax-rules forces a renaming. | |
71 | ||
72 | ; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings | |
73 | ; body ...) | |
74 | ; (lambda lambda-tmps | |
75 | ; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) | |
76 | ||
77 | ; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings | |
78 | ; body ...) | |
79 | ; (let-values-helper "consumer" | |
80 | ; (var-2 ...) | |
81 | ; (lambda-tmp ... var-1) | |
82 | ; ((var-1 var-1) . final-let-bindings) | |
83 | ; lv-bindings | |
84 | ; body ...)) | |
85 | ||
86 | ; ((_ "cwv" () final-let-bindings body ...) | |
87 | ; (let final-let-bindings | |
88 | ; body ...)) | |
89 | ||
90 | ; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings | |
91 | ; body ...) | |
92 | ; (call-with-values (lambda () binding-1) | |
93 | ; (let-values-helper "consumer" | |
94 | ; vars-1 | |
95 | ; () | |
96 | ; final-let-bindings | |
97 | ; (other-bindings ...) | |
98 | ; body ...))))) | |
99 | ; | |
100 | ; (define-syntax let-values | |
101 | ; (syntax-rules () | |
102 | ; ((let-values () body ...) | |
103 | ; (begin body ...)) | |
104 | ; ((let-values (binding ...) body ...) | |
105 | ; (let-values-helper "cwv" (binding ...) () body ...)))) | |
106 | ; | |
107 | ; | |
108 | ; (define-syntax let-values | |
109 | ; (letrec-syntax ((build-consumer | |
110 | ; ;; Take the vars from one let binding (i.e. the (x | |
111 | ; ;; y z) from ((x y z) (values 1 2 3)) and turn it | |
112 | ; ;; in to the corresponding (lambda (<tmp-x> <tmp-y> | |
113 | ; ;; <tmp-z>) ...) from above. | |
114 | ; (syntax-rules () | |
115 | ; ((_ () new-tmps tmp-vars () body ...) | |
116 | ; (lambda new-tmps | |
117 | ; body ...)) | |
118 | ; ((_ () new-tmps tmp-vars vars body ...) | |
119 | ; (lambda new-tmps | |
120 | ; (lv-builder vars tmp-vars body ...))) | |
121 | ; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) | |
122 | ; (build-consumer (var-2 ...) | |
123 | ; (tmp-1 . new-tmps) | |
124 | ; ((var-1 tmp-1) . tmp-vars) | |
125 | ; bindings | |
126 | ; body ...)))) | |
127 | ; (lv-builder | |
128 | ; (syntax-rules () | |
129 | ; ((_ () tmp-vars body ...) | |
130 | ; (let tmp-vars | |
131 | ; body ...)) | |
132 | ; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) | |
133 | ; tmp-vars | |
134 | ; body ...) | |
135 | ; (call-with-values (lambda () binding-1) | |
136 | ; (build-consumer vars-1 | |
137 | ; () | |
138 | ; tmp-vars | |
139 | ; ((vars-2 binding-2) ...) | |
140 | ; body ...)))))) | |
141 | ; | |
142 | ; (syntax-rules () | |
143 | ; ((_ () body ...) | |
144 | ; (begin body ...)) | |
145 | ; ((_ ((vars binding) ...) body ...) | |
146 | ; (lv-builder ((vars binding) ...) () body ...))))) | |
147 | ||
148 | ;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is | |
149 | ;; broken -- right now (as of 1.4.1, it doesn't generate unique | |
150 | ;; symbols) | |
151 | (define-macro (let-values vars . body) | |
152 | (define (let-values-helper vars body prev-tmps) | |
153 | (let* ((var-binding (car vars)) | |
154 | (new-tmps (map (lambda (sym) (list sym (gentemp))) | |
155 | (car var-binding))) | |
156 | (tmps (append new-tmps prev-tmps))) | |
157 | (if (null? (cdr vars)) | |
158 | `(call-with-values (lambda () ,(cadr var-binding)) | |
159 | (lambda ,(map cadr new-tmps) | |
160 | (let ,tmps | |
161 | ,@body))) | |
162 | `(call-with-values (lambda () ,(cadr var-binding)) | |
163 | (lambda ,(map cadr new-tmps) | |
164 | ,(let-values-helper (cdr vars) body tmps)))))) | |
165 | ||
166 | (if (null? vars) | |
167 | `(begin ,@body) | |
168 | (let-values-helper vars body '()))) | |
169 | ||
170 | ;;;;;;;;;;;;;; | |
171 | ;; let*-values | |
172 | ;; | |
173 | ;; Current approach is to translate | |
174 | ;; | |
175 | ;; (let*-values (((x y z) (foo a b)) | |
176 | ;; ((p q) (bar c))) | |
177 | ;; (baz x y z p q)) | |
178 | ;; | |
179 | ;; into | |
180 | ;; | |
181 | ;; (call-with-values (lambda () (foo a b)) | |
182 | ;; (lambda (x y z) | |
183 | ;; (call-with-values (lambda (bar c)) | |
184 | ;; (lambda (p q) | |
185 | ;; (baz x y z p q))))) | |
186 | ||
187 | (define-syntax let*-values | |
188 | (syntax-rules () | |
189 | ((let*-values () body ...) | |
190 | (begin body ...)) | |
191 | ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) | |
192 | (call-with-values (lambda () binding-1) | |
193 | (lambda vars-1 | |
194 | (let*-values ((vars-2 binding-2) ...) | |
195 | body ...)))))) | |
196 | ||
197 | ; Alternate define-macro implementation... | |
198 | ; | |
199 | ; (define-macro (let*-values vars . body) | |
200 | ; (define (let-values-helper vars body) | |
201 | ; (let ((var-binding (car vars))) | |
202 | ; (if (null? (cdr vars)) | |
203 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
204 | ; (lambda ,(car var-binding) | |
205 | ; ,@body)) | |
206 | ; `(call-with-values (lambda () ,(cadr var-binding)) | |
207 | ; (lambda ,(car var-binding) | |
208 | ; ,(let-values-helper (cdr vars) body)))))) | |
209 | ||
210 | ; (if (null? vars) | |
211 | ; `(begin ,@body) | |
212 | ; (let-values-helper vars body))) | |
213 | ||
214 | (export-syntax let-values | |
215 | let*-values) |