module/ice-9/calling.scm

   1 ;;;; calling.scm --- Calling Conventions
   2 ;;;;
   3 ;;;;    Copyright (C) 1995, 1996, 1997, 2000, 2001, 2006 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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)))