Commit | Line | Data |
---|---|---|
3514320f MV |
1 | ;;; srfi-39.scm --- Parameter objects |
2 | ||
d3cf93bc | 3 | ;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc. |
3514320f | 4 | ;; |
d3cf93bc NJ |
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 2.1 of the License, or (at your option) any later version. | |
3514320f | 9 | ;; |
d3cf93bc | 10 | ;; This library is distributed in the hope that it will be useful, |
3514320f MV |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
d3cf93bc | 13 | ;; Lesser General Public License for more details. |
3514320f | 14 | ;; |
d3cf93bc NJ |
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 | |
3514320f MV |
18 | |
19 | ;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> | |
20 | ;;; Date: 2004-05-05 | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;; This is an implementation of SRFI-39 (Parameter objects). | |
25 | ;; | |
26 | ;; The implementation is based on Guile's fluid objects, and is, therefore, | |
27 | ;; thread-safe (parameters are thread-local). | |
28 | ;; | |
29 | ;; In addition to the forms defined in SRFI-39 (`make-parameter', | |
30 | ;; `parameterize'), a new procedure `with-parameters*' is provided. | |
31 | ;; This procedures is analogous to `with-fluids*' but taking as first | |
32 | ;; argument a list of parameter objects instead of a list of fluids. | |
33 | ;; | |
34 | ||
35 | ;;; Code: | |
36 | ||
37 | (define-module (srfi srfi-39) | |
3514320f MV |
38 | #:use-module (srfi srfi-16) |
39 | ||
40 | #:export (make-parameter) | |
41 | #:export-syntax (parameterize) | |
42 | ||
43 | ;; helper procedure not in srfi-39. | |
b9f69396 KR |
44 | #:export (with-parameters*) |
45 | #:replace (current-input-port current-output-port current-error-port)) | |
3514320f MV |
46 | |
47 | ;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. | |
48 | ;; | |
49 | (cond-expand-provide (current-module) '(srfi-39)) | |
50 | ||
51 | (define make-parameter | |
52 | (case-lambda | |
53 | ((val) (make-parameter/helper val (lambda (x) x))) | |
54 | ((val conv) (make-parameter/helper val conv)))) | |
55 | ||
56 | (define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value | |
57 | (define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value | |
58 | ||
59 | (define (make-parameter/helper val conv) | |
60 | (let ((value (make-fluid)) | |
61 | (conv conv)) | |
62 | (begin | |
63 | (fluid-set! value (conv val)) | |
64 | (lambda new-value | |
65 | (cond | |
66 | ((null? new-value) (fluid-ref value)) | |
67 | ((eq? (car new-value) get-fluid-tag) value) | |
68 | ((eq? (car new-value) get-conv-tag) conv) | |
69 | ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) | |
70 | (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) | |
71 | ||
72 | (define-syntax parameterize | |
73 | (syntax-rules () | |
74 | ((_ ((?param ?value) ...) ?body ...) | |
75 | (with-parameters* (list ?param ...) | |
76 | (list ?value ...) | |
77 | (lambda () ?body ...))))) | |
78 | ||
b9f69396 KR |
79 | (define (current-input-port . new-value) |
80 | (if (null? new-value) | |
81 | ((@ (guile) current-input-port)) | |
82 | (apply set-current-input-port new-value))) | |
83 | ||
84 | (define (current-output-port . new-value) | |
85 | (if (null? new-value) | |
86 | ((@ (guile) current-output-port)) | |
87 | (apply set-current-output-port new-value))) | |
88 | ||
89 | (define (current-error-port . new-value) | |
90 | (if (null? new-value) | |
91 | ((@ (guile) current-error-port)) | |
92 | (apply set-current-error-port new-value))) | |
93 | ||
94 | (define port-list | |
95 | (list current-input-port current-output-port current-error-port)) | |
96 | ||
97 | ;; There are no fluids behind current-input-port etc, so those parameter | |
98 | ;; objects are picked out of the list and handled separately with a | |
99 | ;; dynamic-wind to swap their values to and from a location (the "value" | |
100 | ;; variable in the swapper procedure "let"). | |
101 | ;; | |
102 | ;; current-input-port etc are already per-dynamic-root, so this arrangement | |
103 | ;; works the same as a fluid. Perhaps they could become fluids for ease of | |
104 | ;; implementation here. | |
105 | ;; | |
106 | ;; Notice the use of a param local variable for the swapper procedure. It | |
107 | ;; ensures any application changes to the PARAMS list won't affect the | |
108 | ;; winding. | |
109 | ;; | |
3514320f | 110 | (define (with-parameters* params values thunk) |
b9f69396 KR |
111 | (let more ((params params) |
112 | (values values) | |
113 | (fluids '()) ;; fluids from each of PARAMS | |
114 | (convs '()) ;; VALUES with conversion proc applied | |
115 | (swapper noop)) ;; wind/unwind procedure for ports handling | |
116 | (if (null? params) | |
117 | (if (eq? noop swapper) | |
118 | (with-fluids* fluids convs thunk) | |
119 | (dynamic-wind | |
120 | swapper | |
121 | (lambda () | |
122 | (with-fluids* fluids convs thunk)) | |
123 | swapper)) | |
124 | (if (memq (car params) port-list) | |
125 | (more (cdr params) (cdr values) | |
126 | fluids convs | |
127 | (let ((param (car params)) | |
128 | (value (car values)) | |
129 | (prev-swapper swapper)) | |
130 | (lambda () | |
131 | (set! value (param value)) | |
132 | (prev-swapper)))) | |
133 | (more (cdr params) (cdr values) | |
134 | (cons ((car params) get-fluid-tag) fluids) | |
135 | (cons (((car params) get-conv-tag) (car values)) convs) | |
136 | swapper))))) |