1 ;;;; calling.scm --- Calling Conventions
3 ;;;; Copyright (C) 1995, 1996, 1997, 2000, 2001, 2006 Free Software Foundation, Inc.
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.
10 ;;;; This library 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 ;;;; Lesser General Public License for more details.
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
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (ice-9 calling)
21 :export-syntax (with-excursion-function
22 with-getter-and-setter
24 with-delegating-getter-and-setter
25 with-excursion-getter-and-setter
26 with-configuration-getter-and-setter
27 with-delegating-configuration-getter-and-setter
28 let-with-configuration-getter-and-setter))
32 ;;; This file contains a number of macros that support
33 ;;; common calling conventions.
36 ;;; with-excursion-function <vars> proc
37 ;;; <vars> is an unevaluated list of names that are bound in the caller.
38 ;;; proc is a procedure, called:
41 ;;; excursion is a procedure isolates all changes to <vars>
42 ;;; in the dynamic scope of the call to proc. In other words,
43 ;;; the values of <vars> are saved when proc is entered, and when
44 ;;; proc returns, those values are restored. Values are also restored
45 ;;; entering and leaving the call to proc non-locally, such as using
46 ;;; call-with-current-continuation, error, or throw.
48 (defmacro with-excursion-function (vars proc)
49 `(,proc ,(excursion-function-syntax vars)))
53 ;;; with-getter-and-setter <vars> proc
54 ;;; <vars> is an unevaluated list of names that are bound in the caller.
55 ;;; proc is a procedure, called:
56 ;;; (proc getter setter)
58 ;;; getter and setter are procedures used to access
61 ;;; setter, called with keywords arguments, modifies the named
62 ;;; values. If "foo" and "bar" are among <vars>, then:
64 ;;; (setter :foo 1 :bar 2)
65 ;;; == (set! foo 1 bar 2)
67 ;;; getter, called with just keywords, returns
68 ;;; a list of the corresponding values. For example,
69 ;;; if "foo" and "bar" are among the <vars>, then
71 ;;; (getter :foo :bar)
72 ;;; => (<value-of-foo> <value-of-bar>)
74 ;;; getter, called with no arguments, returns a list of all accepted
75 ;;; keywords and the corresponding values. If "foo" and "bar" are
76 ;;; the *only* <vars>, then:
79 ;;; => (:foo <value-of-bar> :bar <value-of-foo>)
81 ;;; The unusual calling sequence of a getter supports too handy
84 ;;; (apply setter (getter)) ;; save and restore
86 ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
87 ;;; (lambda (foo bar) ....))
89 ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
90 ;;; ;; takes its arguments in a different order.
93 (defmacro with-getter-and-setter (vars proc)
94 `(,proc ,@ (getter-and-setter-syntax vars)))
96 ;;; with-getter vars proc
97 ;;; A short-hand for a call to with-getter-and-setter.
98 ;;; The procedure is called:
101 (defmacro with-getter (vars proc)
102 `(,proc ,(car (getter-and-setter-syntax vars))))
105 ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
106 ;;; Compose getters and setters.
108 ;;; <vars> is an unevaluated list of names that are bound in the caller.
110 ;;; get-delegate is called by the new getter to extend the set of
111 ;;; gettable variables beyond just <vars>
112 ;;; set-delegate is called by the new setter to extend the set of
113 ;;; gettable variables beyond just <vars>
115 ;;; proc is a procedure that is called
116 ;;; (proc getter setter)
118 (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
119 `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
122 ;;; with-excursion-getter-and-setter <vars> proc
123 ;;; <vars> is an unevaluated list of names that are bound in the caller.
126 ;;; (proc excursion getter setter)
129 ;;; with-getter-and-setter
130 ;;; with-excursion-function
132 (defmacro with-excursion-getter-and-setter (vars proc)
133 `(,proc ,(excursion-function-syntax vars)
134 ,@ (getter-and-setter-syntax vars)))
137 (define (excursion-function-syntax vars)
138 (let ((saved-value-names (map gensym vars))
139 (tmp-var-name (gensym "temp"))
140 (swap-fn-name (gensym "swap"))
141 (thunk-name (gensym "thunk")))
142 `(lambda (,thunk-name)
143 (letrec ((,tmp-var-name #f)
145 (lambda () ,@ (map (lambda (n sn)
146 `(begin (set! ,tmp-var-name ,n)
148 (set! ,sn ,tmp-var-name)))
149 vars saved-value-names)))
150 ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
157 (define (getter-and-setter-syntax vars)
158 (let ((args-name (gensym "args"))
159 (an-arg-name (gensym "an-arg"))
160 (new-val-name (gensym "new-value"))
161 (loop-name (gensym "loop"))
162 (kws (map symbol->keyword vars)))
163 (list `(lambda ,args-name
164 (let ,loop-name ((,args-name ,args-name))
165 (if (null? ,args-name)
168 `(let ((all-vals (,loop-name ',kws)))
169 (let ,loop-name ((vals all-vals)
173 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
174 (map (lambda (,an-arg-name)
177 (map (lambda (kw v) `((,kw) ,v)) kws vars)
178 `((else (throw 'bad-get-option ,an-arg-name))))))
182 (let ,loop-name ((,args-name ,args-name))
183 (or (null? ,args-name)
184 (null? (cdr ,args-name))
185 (let ((,an-arg-name (car ,args-name))
186 (,new-val-name (cadr ,args-name)))
189 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
190 `((else (throw 'bad-set-option ,an-arg-name)))))
191 (,loop-name (cddr ,args-name)))))))))
193 (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
194 (let ((args-name (gensym "args"))
195 (an-arg-name (gensym "an-arg"))
196 (new-val-name (gensym "new-value"))
197 (loop-name (gensym "loop"))
198 (kws (map symbol->keyword vars)))
199 (list `(lambda ,args-name
200 (let ,loop-name ((,args-name ,args-name))
201 (if (null? ,args-name)
205 `(let ((all-vals (,loop-name ',kws)))
206 (let ,loop-name ((vals all-vals)
210 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
212 (map (lambda (,an-arg-name)
215 (map (lambda (kw v) `((,kw) ,v)) kws vars)
216 `((else (car (,get-delegate ,an-arg-name)))))))
220 (let ,loop-name ((,args-name ,args-name))
221 (or (null? ,args-name)
222 (null? (cdr ,args-name))
223 (let ((,an-arg-name (car ,args-name))
224 (,new-val-name (cadr ,args-name)))
227 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
228 `((else (,set-delegate ,an-arg-name ,new-val-name)))))
229 (,loop-name (cddr ,args-name)))))))))
234 ;;; with-configuration-getter-and-setter <vars-etc> proc
236 ;;; Create a getter and setter that can trigger arbitrary computation.
238 ;;; <vars-etc> is a list of variable specifiers, explained below.
241 ;;; (proc getter setter)
243 ;;; Each element of the <vars-etc> list is of the form:
245 ;;; (<var> getter-hook setter-hook)
247 ;;; Both hook elements are evaluated; the variable name is not.
248 ;;; Either hook may be #f or procedure.
250 ;;; A getter hook is a thunk that returns a value for the corresponding
251 ;;; variable. If omitted (#f is passed), the binding of <var> is
254 ;;; A setter hook is a procedure of one argument that accepts a new value
255 ;;; for the corresponding variable. If omitted, the binding of <var>
256 ;;; is simply set using set!.
258 (defmacro with-configuration-getter-and-setter (vars-etc proc)
259 `((lambda (simpler-get simpler-set body-proc)
260 (with-delegating-getter-and-setter ()
261 simpler-get simpler-set body-proc))
265 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
268 (else `(list ,(car v))))))
273 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
275 ((caddr v) => (lambda (proc) `(,proc new-val)))
276 (else `(set! ,(car v) new-val)))))
281 (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
282 `((lambda (simpler-get simpler-set body-proc)
283 (with-delegating-getter-and-setter ()
284 simpler-get simpler-set body-proc))
288 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
291 (else `(list ,(car v))))))
293 `((else (,delegate-get kw))))))
297 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
299 ((caddr v) => (lambda (proc) `(,proc new-val)))
300 (else `(set! ,(car v) new-val)))))
302 `((else (,delegate-set kw new-val))))))
307 ;;; let-configuration-getter-and-setter <vars-etc> proc
309 ;;; This procedure is like with-configuration-getter-and-setter (q.v.)
310 ;;; except that each element of <vars-etc> is:
312 ;;; (<var> initial-value getter-hook setter-hook)
314 ;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
315 ;;; introduces bindings for the variables named in <vars-etc>.
316 ;;; It is short-hand for:
318 ;;; (let ((<var1> initial-value-1)
319 ;;; (<var2> initial-value-2)
321 ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
323 (defmacro let-with-configuration-getter-and-setter (vars-etc proc)
324 `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
325 (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)