| 1 | ;;;; calling.scm --- Calling Conventions |
| 2 | ;;;; |
| 3 | ;;;; Copyright (C) 1995, 1996, 1997, 2000, 2001 Free Software Foundation, Inc. |
| 4 | ;;;; |
| 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, |
| 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. |
| 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 |
| 17 | ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| 18 | ;;;; |
| 19 | \f |
| 20 | (define-module (ice-9 calling) |
| 21 | :export-syntax (with-excursion-function |
| 22 | with-getter-and-setter |
| 23 | with-getter |
| 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)) |
| 29 | |
| 30 | ;;;; |
| 31 | ;;; |
| 32 | ;;; This file contains a number of macros that support |
| 33 | ;;; common calling conventions. |
| 34 | |
| 35 | ;;; |
| 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: |
| 39 | ;;; (proc excursion) |
| 40 | ;;; |
| 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. |
| 47 | ;;; |
| 48 | (defmacro with-excursion-function (vars proc) |
| 49 | `(,proc ,(excursion-function-syntax vars))) |
| 50 | |
| 51 | |
| 52 | |
| 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) |
| 57 | ;;; |
| 58 | ;;; getter and setter are procedures used to access |
| 59 | ;;; or modify <vars>. |
| 60 | ;;; |
| 61 | ;;; setter, called with keywords arguments, modifies the named |
| 62 | ;;; values. If "foo" and "bar" are among <vars>, then: |
| 63 | ;;; |
| 64 | ;;; (setter :foo 1 :bar 2) |
| 65 | ;;; == (set! foo 1 bar 2) |
| 66 | ;;; |
| 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 |
| 70 | ;;; |
| 71 | ;;; (getter :foo :bar) |
| 72 | ;;; => (<value-of-foo> <value-of-bar>) |
| 73 | ;;; |
| 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: |
| 77 | ;;; |
| 78 | ;;; (getter) |
| 79 | ;;; => (:foo <value-of-bar> :bar <value-of-foo>) |
| 80 | ;;; |
| 81 | ;;; The unusual calling sequence of a getter supports too handy |
| 82 | ;;; idioms: |
| 83 | ;;; |
| 84 | ;;; (apply setter (getter)) ;; save and restore |
| 85 | ;;; |
| 86 | ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind |
| 87 | ;;; (lambda (foo bar) ....)) |
| 88 | ;;; |
| 89 | ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it |
| 90 | ;;; ;; takes its arguments in a different order. |
| 91 | ;;; |
| 92 | ;;; |
| 93 | (defmacro with-getter-and-setter (vars proc) |
| 94 | `(,proc ,@ (getter-and-setter-syntax vars))) |
| 95 | |
| 96 | ;;; with-getter vars proc |
| 97 | ;;; A short-hand for a call to with-getter-and-setter. |
| 98 | ;;; The procedure is called: |
| 99 | ;;; (proc getter) |
| 100 | ;;; |
| 101 | (defmacro with-getter (vars proc) |
| 102 | `(,proc ,(car (getter-and-setter-syntax vars)))) |
| 103 | |
| 104 | |
| 105 | ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc |
| 106 | ;;; Compose getters and setters. |
| 107 | ;;; |
| 108 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 109 | ;;; |
| 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> |
| 114 | ;;; |
| 115 | ;;; proc is a procedure that is called |
| 116 | ;;; (proc getter setter) |
| 117 | ;;; |
| 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))) |
| 120 | |
| 121 | |
| 122 | ;;; with-excursion-getter-and-setter <vars> proc |
| 123 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 124 | ;;; proc is called: |
| 125 | ;;; |
| 126 | ;;; (proc excursion getter setter) |
| 127 | ;;; |
| 128 | ;;; See also: |
| 129 | ;;; with-getter-and-setter |
| 130 | ;;; with-excursion-function |
| 131 | ;;; |
| 132 | (defmacro with-excursion-getter-and-setter (vars proc) |
| 133 | `(,proc ,(excursion-function-syntax vars) |
| 134 | ,@ (getter-and-setter-syntax vars))) |
| 135 | |
| 136 | |
| 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) |
| 144 | (,swap-fn-name |
| 145 | (lambda () ,@ (map (lambda (n sn) |
| 146 | `(begin (set! ,tmp-var-name ,n) |
| 147 | (set! ,n ,sn) |
| 148 | (set! ,sn ,tmp-var-name))) |
| 149 | vars saved-value-names))) |
| 150 | ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars)) |
| 151 | (dynamic-wind |
| 152 | ,swap-fn-name |
| 153 | ,thunk-name |
| 154 | ,swap-fn-name))))) |
| 155 | |
| 156 | |
| 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) |
| 166 | ,(if (null? kws) |
| 167 | ''() |
| 168 | `(let ((all-vals (,loop-name ',kws))) |
| 169 | (let ,loop-name ((vals all-vals) |
| 170 | (kws ',kws)) |
| 171 | (if (null? vals) |
| 172 | '() |
| 173 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) |
| 174 | (map (lambda (,an-arg-name) |
| 175 | (case ,an-arg-name |
| 176 | ,@ (append |
| 177 | (map (lambda (kw v) `((,kw) ,v)) kws vars) |
| 178 | `((else (throw 'bad-get-option ,an-arg-name)))))) |
| 179 | ,args-name)))) |
| 180 | |
| 181 | `(lambda ,args-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))) |
| 187 | (case ,an-arg-name |
| 188 | ,@ (append |
| 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))))))))) |
| 192 | |
| 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) |
| 202 | (append! |
| 203 | ,(if (null? kws) |
| 204 | ''() |
| 205 | `(let ((all-vals (,loop-name ',kws))) |
| 206 | (let ,loop-name ((vals all-vals) |
| 207 | (kws ',kws)) |
| 208 | (if (null? vals) |
| 209 | '() |
| 210 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) |
| 211 | (,get-delegate)) |
| 212 | (map (lambda (,an-arg-name) |
| 213 | (case ,an-arg-name |
| 214 | ,@ (append |
| 215 | (map (lambda (kw v) `((,kw) ,v)) kws vars) |
| 216 | `((else (car (,get-delegate ,an-arg-name))))))) |
| 217 | ,args-name)))) |
| 218 | |
| 219 | `(lambda ,args-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))) |
| 225 | (case ,an-arg-name |
| 226 | ,@ (append |
| 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))))))))) |
| 230 | |
| 231 | |
| 232 | |
| 233 | |
| 234 | ;;; with-configuration-getter-and-setter <vars-etc> proc |
| 235 | ;;; |
| 236 | ;;; Create a getter and setter that can trigger arbitrary computation. |
| 237 | ;;; |
| 238 | ;;; <vars-etc> is a list of variable specifiers, explained below. |
| 239 | ;;; proc is called: |
| 240 | ;;; |
| 241 | ;;; (proc getter setter) |
| 242 | ;;; |
| 243 | ;;; Each element of the <vars-etc> list is of the form: |
| 244 | ;;; |
| 245 | ;;; (<var> getter-hook setter-hook) |
| 246 | ;;; |
| 247 | ;;; Both hook elements are evaluated; the variable name is not. |
| 248 | ;;; Either hook may be #f or procedure. |
| 249 | ;;; |
| 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 |
| 252 | ;;; returned. |
| 253 | ;;; |
| 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!. |
| 257 | ;;; |
| 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)) |
| 262 | |
| 263 | (lambda (kw) |
| 264 | (case kw |
| 265 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) |
| 266 | ,(cond |
| 267 | ((cadr v) => list) |
| 268 | (else `(list ,(car v)))))) |
| 269 | vars-etc))) |
| 270 | |
| 271 | (lambda (kw new-val) |
| 272 | (case kw |
| 273 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) |
| 274 | ,(cond |
| 275 | ((caddr v) => (lambda (proc) `(,proc new-val))) |
| 276 | (else `(set! ,(car v) new-val))))) |
| 277 | vars-etc))) |
| 278 | |
| 279 | ,proc)) |
| 280 | |
| 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)) |
| 285 | |
| 286 | (lambda (kw) |
| 287 | (case kw |
| 288 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) |
| 289 | ,(cond |
| 290 | ((cadr v) => list) |
| 291 | (else `(list ,(car v)))))) |
| 292 | vars-etc) |
| 293 | `((else (,delegate-get kw)))))) |
| 294 | |
| 295 | (lambda (kw new-val) |
| 296 | (case kw |
| 297 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) |
| 298 | ,(cond |
| 299 | ((caddr v) => (lambda (proc) `(,proc new-val))) |
| 300 | (else `(set! ,(car v) new-val))))) |
| 301 | vars-etc) |
| 302 | `((else (,delegate-set kw new-val)))))) |
| 303 | |
| 304 | ,proc)) |
| 305 | |
| 306 | |
| 307 | ;;; let-configuration-getter-and-setter <vars-etc> proc |
| 308 | ;;; |
| 309 | ;;; This procedure is like with-configuration-getter-and-setter (q.v.) |
| 310 | ;;; except that each element of <vars-etc> is: |
| 311 | ;;; |
| 312 | ;;; (<var> initial-value getter-hook setter-hook) |
| 313 | ;;; |
| 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: |
| 317 | ;;; |
| 318 | ;;; (let ((<var1> initial-value-1) |
| 319 | ;;; (<var2> initial-value-2) |
| 320 | ;;; ...) |
| 321 | ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc)) |
| 322 | ;;; |
| 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) |
| 326 | ,proc))) |