Commit | Line | Data |
---|---|---|
6a4d3cfd JB |
1 | ;;;; calling.scm --- Calling Conventions |
2 | ;;;; | |
1a179b03 | 3 | ;;;; Copyright (C) 1995, 1996, 1997, 2000, 2001 Free Software Foundation, Inc. |
6a4d3cfd JB |
4 | ;;;; |
5 | ;;;; This program is free software; you can redistribute it and/or modify | |
6 | ;;;; it under the terms of the GNU General Public License as published by | |
7 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;;;; 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 | |
13 | ;;;; GNU 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 | |
a482f2cc 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. | |
6a4d3cfd JB |
43 | ;;;; |
44 | \f | |
1a179b03 MD |
45 | (define-module (ice-9 calling) |
46 | :export-syntax (with-excursion-function | |
47 | with-getter-and-setter | |
48 | with-getter | |
49 | with-delegating-getter-and-setter | |
50 | with-excursion-getter-and-setter | |
51 | with-configuration-getter-and-setter | |
52 | with-delegating-configuration-getter-and-setter | |
53 | let-with-configuration-getter-and-setter)) | |
a6401ee0 JB |
54 | |
55 | ;;;; | |
56 | ;;; | |
57 | ;;; This file contains a number of macros that support | |
58 | ;;; common calling conventions. | |
59 | ||
60 | ;;; | |
61 | ;;; with-excursion-function <vars> proc | |
62 | ;;; <vars> is an unevaluated list of names that are bound in the caller. | |
63 | ;;; proc is a procedure, called: | |
64 | ;;; (proc excursion) | |
65 | ;;; | |
66 | ;;; excursion is a procedure isolates all changes to <vars> | |
67 | ;;; in the dynamic scope of the call to proc. In other words, | |
68 | ;;; the values of <vars> are saved when proc is entered, and when | |
69 | ;;; proc returns, those values are restored. Values are also restored | |
70 | ;;; entering and leaving the call to proc non-locally, such as using | |
71 | ;;; call-with-current-continuation, error, or throw. | |
72 | ;;; | |
1a179b03 | 73 | (defmacro with-excursion-function (vars proc) |
a6401ee0 JB |
74 | `(,proc ,(excursion-function-syntax vars))) |
75 | ||
76 | ||
77 | ||
78 | ;;; with-getter-and-setter <vars> proc | |
79 | ;;; <vars> is an unevaluated list of names that are bound in the caller. | |
80 | ;;; proc is a procedure, called: | |
81 | ;;; (proc getter setter) | |
82 | ;;; | |
83 | ;;; getter and setter are procedures used to access | |
84 | ;;; or modify <vars>. | |
85 | ;;; | |
86 | ;;; setter, called with keywords arguments, modifies the named | |
87 | ;;; values. If "foo" and "bar" are among <vars>, then: | |
88 | ;;; | |
89 | ;;; (setter :foo 1 :bar 2) | |
90 | ;;; == (set! foo 1 bar 2) | |
91 | ;;; | |
92 | ;;; getter, called with just keywords, returns | |
93 | ;;; a list of the corresponding values. For example, | |
94 | ;;; if "foo" and "bar" are among the <vars>, then | |
95 | ;;; | |
96 | ;;; (getter :foo :bar) | |
97 | ;;; => (<value-of-foo> <value-of-bar>) | |
98 | ;;; | |
99 | ;;; getter, called with no arguments, returns a list of all accepted | |
100 | ;;; keywords and the corresponding values. If "foo" and "bar" are | |
101 | ;;; the *only* <vars>, then: | |
102 | ;;; | |
103 | ;;; (getter) | |
104 | ;;; => (:foo <value-of-bar> :bar <value-of-foo>) | |
105 | ;;; | |
106 | ;;; The unusual calling sequence of a getter supports too handy | |
107 | ;;; idioms: | |
108 | ;;; | |
109 | ;;; (apply setter (getter)) ;; save and restore | |
110 | ;;; | |
111 | ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind | |
112 | ;;; (lambda (foo bar) ....)) | |
113 | ;;; | |
114 | ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it | |
115 | ;;; ;; takes its arguments in a different order. | |
116 | ;;; | |
117 | ;;; | |
1a179b03 | 118 | (defmacro with-getter-and-setter (vars proc) |
a6401ee0 JB |
119 | `(,proc ,@ (getter-and-setter-syntax vars))) |
120 | ||
121 | ;;; with-getter vars proc | |
122 | ;;; A short-hand for a call to with-getter-and-setter. | |
123 | ;;; The procedure is called: | |
124 | ;;; (proc getter) | |
125 | ;;; | |
1a179b03 | 126 | (defmacro with-getter (vars proc) |
a6401ee0 JB |
127 | `(,proc ,(car (getter-and-setter-syntax vars)))) |
128 | ||
129 | ||
130 | ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc | |
131 | ;;; Compose getters and setters. | |
132 | ;;; | |
133 | ;;; <vars> is an unevaluated list of names that are bound in the caller. | |
134 | ;;; | |
135 | ;;; get-delegate is called by the new getter to extend the set of | |
136 | ;;; gettable variables beyond just <vars> | |
137 | ;;; set-delegate is called by the new setter to extend the set of | |
138 | ;;; gettable variables beyond just <vars> | |
139 | ;;; | |
140 | ;;; proc is a procedure that is called | |
141 | ;;; (proc getter setter) | |
142 | ;;; | |
1a179b03 | 143 | (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc) |
a6401ee0 JB |
144 | `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate))) |
145 | ||
146 | ||
147 | ;;; with-excursion-getter-and-setter <vars> proc | |
148 | ;;; <vars> is an unevaluated list of names that are bound in the caller. | |
149 | ;;; proc is called: | |
150 | ;;; | |
151 | ;;; (proc excursion getter setter) | |
152 | ;;; | |
153 | ;;; See also: | |
154 | ;;; with-getter-and-setter | |
155 | ;;; with-excursion-function | |
156 | ;;; | |
1a179b03 | 157 | (defmacro with-excursion-getter-and-setter (vars proc) |
a6401ee0 JB |
158 | `(,proc ,(excursion-function-syntax vars) |
159 | ,@ (getter-and-setter-syntax vars))) | |
160 | ||
161 | ||
162 | (define (excursion-function-syntax vars) | |
163 | (let ((saved-value-names (map gensym vars)) | |
b68c1eed MD |
164 | (tmp-var-name (gensym "temp")) |
165 | (swap-fn-name (gensym "swap")) | |
166 | (thunk-name (gensym "thunk"))) | |
a6401ee0 | 167 | `(lambda (,thunk-name) |
63da7567 JB |
168 | (letrec ((,tmp-var-name #f) |
169 | (,swap-fn-name | |
170 | (lambda () ,@ (map (lambda (n sn) | |
171 | `(begin (set! ,tmp-var-name ,n) | |
172 | (set! ,n ,sn) | |
173 | (set! ,sn ,tmp-var-name))) | |
174 | vars saved-value-names))) | |
175 | ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars)) | |
176 | (dynamic-wind | |
177 | ,swap-fn-name | |
178 | ,thunk-name | |
179 | ,swap-fn-name))))) | |
a6401ee0 JB |
180 | |
181 | ||
182 | (define (getter-and-setter-syntax vars) | |
b68c1eed MD |
183 | (let ((args-name (gensym "args")) |
184 | (an-arg-name (gensym "an-arg")) | |
185 | (new-val-name (gensym "new-value")) | |
186 | (loop-name (gensym "loop")) | |
a6401ee0 JB |
187 | (kws (map symbol->keyword vars))) |
188 | (list `(lambda ,args-name | |
189 | (let ,loop-name ((,args-name ,args-name)) | |
190 | (if (null? ,args-name) | |
191 | ,(if (null? kws) | |
192 | ''() | |
193 | `(let ((all-vals (,loop-name ',kws))) | |
194 | (let ,loop-name ((vals all-vals) | |
195 | (kws ',kws)) | |
196 | (if (null? vals) | |
197 | '() | |
198 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) | |
199 | (map (lambda (,an-arg-name) | |
200 | (case ,an-arg-name | |
201 | ,@ (append | |
202 | (map (lambda (kw v) `((,kw) ,v)) kws vars) | |
203 | `((else (throw 'bad-get-option ,an-arg-name)))))) | |
204 | ,args-name)))) | |
205 | ||
206 | `(lambda ,args-name | |
207 | (let ,loop-name ((,args-name ,args-name)) | |
208 | (or (null? ,args-name) | |
209 | (null? (cdr ,args-name)) | |
210 | (let ((,an-arg-name (car ,args-name)) | |
211 | (,new-val-name (cadr ,args-name))) | |
212 | (case ,an-arg-name | |
213 | ,@ (append | |
214 | (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) | |
215 | `((else (throw 'bad-set-option ,an-arg-name))))) | |
216 | (,loop-name (cddr ,args-name))))))))) | |
217 | ||
218 | (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate) | |
b68c1eed MD |
219 | (let ((args-name (gensym "args")) |
220 | (an-arg-name (gensym "an-arg")) | |
221 | (new-val-name (gensym "new-value")) | |
222 | (loop-name (gensym "loop")) | |
a6401ee0 JB |
223 | (kws (map symbol->keyword vars))) |
224 | (list `(lambda ,args-name | |
225 | (let ,loop-name ((,args-name ,args-name)) | |
226 | (if (null? ,args-name) | |
227 | (append! | |
228 | ,(if (null? kws) | |
229 | ''() | |
230 | `(let ((all-vals (,loop-name ',kws))) | |
231 | (let ,loop-name ((vals all-vals) | |
232 | (kws ',kws)) | |
233 | (if (null? vals) | |
234 | '() | |
235 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) | |
236 | (,get-delegate)) | |
237 | (map (lambda (,an-arg-name) | |
238 | (case ,an-arg-name | |
239 | ,@ (append | |
240 | (map (lambda (kw v) `((,kw) ,v)) kws vars) | |
241 | `((else (car (,get-delegate ,an-arg-name))))))) | |
242 | ,args-name)))) | |
243 | ||
244 | `(lambda ,args-name | |
245 | (let ,loop-name ((,args-name ,args-name)) | |
246 | (or (null? ,args-name) | |
247 | (null? (cdr ,args-name)) | |
248 | (let ((,an-arg-name (car ,args-name)) | |
249 | (,new-val-name (cadr ,args-name))) | |
250 | (case ,an-arg-name | |
251 | ,@ (append | |
252 | (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) | |
253 | `((else (,set-delegate ,an-arg-name ,new-val-name))))) | |
254 | (,loop-name (cddr ,args-name))))))))) | |
255 | ||
256 | ||
257 | ||
258 | ||
259 | ;;; with-configuration-getter-and-setter <vars-etc> proc | |
260 | ;;; | |
261 | ;;; Create a getter and setter that can trigger arbitrary computation. | |
262 | ;;; | |
263 | ;;; <vars-etc> is a list of variable specifiers, explained below. | |
264 | ;;; proc is called: | |
265 | ;;; | |
266 | ;;; (proc getter setter) | |
267 | ;;; | |
268 | ;;; Each element of the <vars-etc> list is of the form: | |
269 | ;;; | |
270 | ;;; (<var> getter-hook setter-hook) | |
271 | ;;; | |
272 | ;;; Both hook elements are evaluated; the variable name is not. | |
273 | ;;; Either hook may be #f or procedure. | |
274 | ;;; | |
275 | ;;; A getter hook is a thunk that returns a value for the corresponding | |
276 | ;;; variable. If omitted (#f is passed), the binding of <var> is | |
277 | ;;; returned. | |
278 | ;;; | |
279 | ;;; A setter hook is a procedure of one argument that accepts a new value | |
280 | ;;; for the corresponding variable. If omitted, the binding of <var> | |
281 | ;;; is simply set using set!. | |
282 | ;;; | |
1a179b03 | 283 | (defmacro with-configuration-getter-and-setter (vars-etc proc) |
a6401ee0 JB |
284 | `((lambda (simpler-get simpler-set body-proc) |
285 | (with-delegating-getter-and-setter () | |
286 | simpler-get simpler-set body-proc)) | |
287 | ||
288 | (lambda (kw) | |
289 | (case kw | |
290 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) | |
291 | ,(cond | |
292 | ((cadr v) => list) | |
293 | (else `(list ,(car v)))))) | |
294 | vars-etc))) | |
295 | ||
296 | (lambda (kw new-val) | |
297 | (case kw | |
298 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) | |
299 | ,(cond | |
300 | ((caddr v) => (lambda (proc) `(,proc new-val))) | |
301 | (else `(set! ,(car v) new-val))))) | |
302 | vars-etc))) | |
303 | ||
304 | ,proc)) | |
305 | ||
1a179b03 | 306 | (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc) |
a6401ee0 JB |
307 | `((lambda (simpler-get simpler-set body-proc) |
308 | (with-delegating-getter-and-setter () | |
309 | simpler-get simpler-set body-proc)) | |
310 | ||
311 | (lambda (kw) | |
312 | (case kw | |
313 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) | |
314 | ,(cond | |
315 | ((cadr v) => list) | |
316 | (else `(list ,(car v)))))) | |
317 | vars-etc) | |
318 | `((else (,delegate-get kw)))))) | |
319 | ||
320 | (lambda (kw new-val) | |
321 | (case kw | |
322 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) | |
323 | ,(cond | |
324 | ((caddr v) => (lambda (proc) `(,proc new-val))) | |
325 | (else `(set! ,(car v) new-val))))) | |
326 | vars-etc) | |
327 | `((else (,delegate-set kw new-val)))))) | |
328 | ||
329 | ,proc)) | |
330 | ||
331 | ||
332 | ;;; let-configuration-getter-and-setter <vars-etc> proc | |
333 | ;;; | |
334 | ;;; This procedure is like with-configuration-getter-and-setter (q.v.) | |
335 | ;;; except that each element of <vars-etc> is: | |
336 | ;;; | |
337 | ;;; (<var> initial-value getter-hook setter-hook) | |
338 | ;;; | |
339 | ;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter | |
340 | ;;; introduces bindings for the variables named in <vars-etc>. | |
341 | ;;; It is short-hand for: | |
342 | ;;; | |
343 | ;;; (let ((<var1> initial-value-1) | |
344 | ;;; (<var2> initial-value-2) | |
345 | ;;; ...) | |
346 | ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc)) | |
347 | ;;; | |
1a179b03 | 348 | (defmacro let-with-configuration-getter-and-setter (vars-etc proc) |
a6401ee0 JB |
349 | `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc) |
350 | (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc) | |
351 | ,proc))) |