ice-9/calling.scm

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