ice-9/calling.scm

   1 ;;;; calling.scm --- Calling Conventions
   2 ;;;;
   3 ;;;;    Copyright (C) 1995, 1996, 1997, 2000, 2001 Free Software Foundation, Inc.
   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
  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.
  43 ;;;;
  44 \f
  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))
  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 ;;;
  73 (defmacro with-excursion-function (vars proc)
  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 ;;;
 118 (defmacro with-getter-and-setter (vars proc)
 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 ;;;
 126 (defmacro with-getter (vars proc)
 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 ;;;
 143 (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
 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 ;;;
 157 (defmacro with-excursion-getter-and-setter (vars proc)
 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))
 164         (tmp-var-name (gensym "temp"))
 165         (swap-fn-name (gensym "swap"))
 166         (thunk-name (gensym "thunk")))
 167     `(lambda (,thunk-name)
 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)))))
 180
 181
 182 (define (getter-and-setter-syntax vars)
 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"))
 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)
 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"))
 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 ;;;
 283 (defmacro with-configuration-getter-and-setter (vars-etc proc)
 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
 306 (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
 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 ;;;
 348 (defmacro let-with-configuration-getter-and-setter (vars-etc proc)
 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)))