calling.scm 11 KB

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