Commit | Line | Data |
---|---|---|
3514320f MV |
1 | ;;; srfi-39.scm --- Parameter objects |
2 | ||
1b09b607 | 3 | ;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. |
3514320f MV |
4 | ;; |
5 | ;; This program is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU General Public License as | |
7 | ;; published by the Free Software Foundation; either version 2, or | |
8 | ;; (at your option) 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 GNU | |
13 | ;; 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 | |
92205699 MV |
17 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
18 | ;; Boston, MA 02110-1301 USA | |
3514320f MV |
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 | ;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> | |
45 | ;;; Date: 2004-05-05 | |
46 | ||
47 | ;;; Commentary: | |
48 | ||
49 | ;; This is an implementation of SRFI-39 (Parameter objects). | |
50 | ;; | |
51 | ;; The implementation is based on Guile's fluid objects, and is, therefore, | |
52 | ;; thread-safe (parameters are thread-local). | |
53 | ;; | |
54 | ;; In addition to the forms defined in SRFI-39 (`make-parameter', | |
55 | ;; `parameterize'), a new procedure `with-parameters*' is provided. | |
56 | ;; This procedures is analogous to `with-fluids*' but taking as first | |
57 | ;; argument a list of parameter objects instead of a list of fluids. | |
58 | ;; | |
59 | ||
60 | ;;; Code: | |
61 | ||
62 | (define-module (srfi srfi-39) | |
63 | #:use-module (ice-9 syncase) | |
64 | #:use-module (srfi srfi-16) | |
65 | ||
66 | #:export (make-parameter) | |
67 | #:export-syntax (parameterize) | |
68 | ||
69 | ;; helper procedure not in srfi-39. | |
b9f69396 KR |
70 | #:export (with-parameters*) |
71 | #:replace (current-input-port current-output-port current-error-port)) | |
3514320f MV |
72 | |
73 | ;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. | |
74 | ;; | |
75 | (cond-expand-provide (current-module) '(srfi-39)) | |
76 | ||
77 | (define make-parameter | |
78 | (case-lambda | |
79 | ((val) (make-parameter/helper val (lambda (x) x))) | |
80 | ((val conv) (make-parameter/helper val conv)))) | |
81 | ||
82 | (define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value | |
83 | (define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value | |
84 | ||
85 | (define (make-parameter/helper val conv) | |
86 | (let ((value (make-fluid)) | |
87 | (conv conv)) | |
88 | (begin | |
89 | (fluid-set! value (conv val)) | |
90 | (lambda new-value | |
91 | (cond | |
92 | ((null? new-value) (fluid-ref value)) | |
93 | ((eq? (car new-value) get-fluid-tag) value) | |
94 | ((eq? (car new-value) get-conv-tag) conv) | |
95 | ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) | |
96 | (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) | |
97 | ||
98 | (define-syntax parameterize | |
99 | (syntax-rules () | |
100 | ((_ ((?param ?value) ...) ?body ...) | |
101 | (with-parameters* (list ?param ...) | |
102 | (list ?value ...) | |
103 | (lambda () ?body ...))))) | |
104 | ||
b9f69396 KR |
105 | (define (current-input-port . new-value) |
106 | (if (null? new-value) | |
107 | ((@ (guile) current-input-port)) | |
108 | (apply set-current-input-port new-value))) | |
109 | ||
110 | (define (current-output-port . new-value) | |
111 | (if (null? new-value) | |
112 | ((@ (guile) current-output-port)) | |
113 | (apply set-current-output-port new-value))) | |
114 | ||
115 | (define (current-error-port . new-value) | |
116 | (if (null? new-value) | |
117 | ((@ (guile) current-error-port)) | |
118 | (apply set-current-error-port new-value))) | |
119 | ||
120 | (define port-list | |
121 | (list current-input-port current-output-port current-error-port)) | |
122 | ||
123 | ;; There are no fluids behind current-input-port etc, so those parameter | |
124 | ;; objects are picked out of the list and handled separately with a | |
125 | ;; dynamic-wind to swap their values to and from a location (the "value" | |
126 | ;; variable in the swapper procedure "let"). | |
127 | ;; | |
128 | ;; current-input-port etc are already per-dynamic-root, so this arrangement | |
129 | ;; works the same as a fluid. Perhaps they could become fluids for ease of | |
130 | ;; implementation here. | |
131 | ;; | |
132 | ;; Notice the use of a param local variable for the swapper procedure. It | |
133 | ;; ensures any application changes to the PARAMS list won't affect the | |
134 | ;; winding. | |
135 | ;; | |
3514320f | 136 | (define (with-parameters* params values thunk) |
b9f69396 KR |
137 | (let more ((params params) |
138 | (values values) | |
139 | (fluids '()) ;; fluids from each of PARAMS | |
140 | (convs '()) ;; VALUES with conversion proc applied | |
141 | (swapper noop)) ;; wind/unwind procedure for ports handling | |
142 | (if (null? params) | |
143 | (if (eq? noop swapper) | |
144 | (with-fluids* fluids convs thunk) | |
145 | (dynamic-wind | |
146 | swapper | |
147 | (lambda () | |
148 | (with-fluids* fluids convs thunk)) | |
149 | swapper)) | |
150 | (if (memq (car params) port-list) | |
151 | (more (cdr params) (cdr values) | |
152 | fluids convs | |
153 | (let ((param (car params)) | |
154 | (value (car values)) | |
155 | (prev-swapper swapper)) | |
156 | (lambda () | |
157 | (set! value (param value)) | |
158 | (prev-swapper)))) | |
159 | (more (cdr params) (cdr values) | |
160 | (cons ((car params) get-fluid-tag) fluids) | |
161 | (cons (((car params) get-conv-tag) (car values)) convs) | |
162 | swapper))))) |