diff options
author | Andy Wingo <wingo@pobox.com> | 2011-12-10 20:04:27 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-12-10 21:37:19 +0100 |
commit | 9670f238d406a38bb43658f74dae325c6516094e (patch) | |
tree | 418e97384e2951844ed242892d28a64134f2c93e /module/srfi | |
parent | 4eb286127c41e67eb90ef1b69f61f613bcd830b2 (diff) | |
download | guile-9670f238d406a38bb43658f74dae325c6516094e.tar.gz |
current-input-port et al are srfi-39 parameters
* libguile/ports.c (scm_init_ports): Export the port fluids to Scheme,
temporarily.
* module/ice-9/boot-9.scm (fluid->parameter): Turn `current-input-port'
et al into srfi-39 parameters, backed by the exported fluids, then
remove the fluids from the guile module.
(%cond-expand-features): Add srfi-39.
* module/srfi/srfi-39.scm: Re-export features from boot-9.
* test-suite/tests/parameters.test: Add tests.
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-39.scm | 101 |
1 files changed, 8 insertions, 93 deletions
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index d1c46d028..0d540633d 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -35,104 +35,19 @@ ;;; Code: (define-module (srfi srfi-39) - #:use-module (srfi srfi-16) - - #:export (make-parameter) - #:export-syntax (parameterize) - ;; helper procedure not in srfi-39. #:export (with-parameters*) - #:replace (current-input-port current-output-port current-error-port)) - -;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. -;; -(cond-expand-provide (current-module) '(srfi-39)) - -(define make-parameter - (case-lambda - ((val) (make-parameter/helper val (lambda (x) x))) - ((val conv) (make-parameter/helper val conv)))) - -(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value -(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value - -(define (make-parameter/helper val conv) - (let ((fluid (make-fluid (conv val)))) - (case-lambda - (() - (fluid-ref fluid)) - ((new-value) - (cond - ((eq? new-value get-fluid-tag) fluid) - ((eq? new-value get-conv-tag) conv) - (else (fluid-set! fluid (conv new-value)))))))) - -(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...) - (with-parameters* (list ?param ...) - (list ?value ...) - (lambda () ?body ...))) + #:re-export (make-parameter + parameterize + current-input-port current-output-port current-error-port)) -(define current-input-port - (case-lambda - (() - ((@ (guile) current-input-port))) - ((new-value) - (set-current-input-port new-value)))) - -(define current-output-port - (case-lambda - (() - ((@ (guile) current-output-port))) - ((new-value) - (set-current-output-port new-value)))) - -(define current-error-port - (case-lambda - (() - ((@ (guile) current-error-port))) - ((new-value) - (set-current-error-port new-value)))) - -(define port-list - (list current-input-port current-output-port current-error-port)) - -;; There are no fluids behind current-input-port etc, so those parameter -;; objects are picked out of the list and handled separately with a -;; dynamic-wind to swap their values to and from a location (the "value" -;; variable in the swapper procedure "let"). -;; -;; current-input-port etc are already per-dynamic-root, so this arrangement -;; works the same as a fluid. Perhaps they could become fluids for ease of -;; implementation here. -;; -;; Notice the use of a param local variable for the swapper procedure. It -;; ensures any application changes to the PARAMS list won't affect the -;; winding. -;; (define (with-parameters* params values thunk) (let more ((params params) (values values) (fluids '()) ;; fluids from each of PARAMS - (convs '()) ;; VALUES with conversion proc applied - (swapper noop)) ;; wind/unwind procedure for ports handling + (convs '())) ;; VALUES with conversion proc applied (if (null? params) - (if (eq? noop swapper) - (with-fluids* fluids convs thunk) - (dynamic-wind - swapper - (lambda () - (with-fluids* fluids convs thunk)) - swapper)) - (if (memq (car params) port-list) - (more (cdr params) (cdr values) - fluids convs - (let ((param (car params)) - (value (car values)) - (prev-swapper swapper)) - (lambda () - (set! value (param value)) - (prev-swapper)))) - (more (cdr params) (cdr values) - (cons ((car params) get-fluid-tag) fluids) - (cons (((car params) get-conv-tag) (car values)) convs) - swapper))))) + (with-fluids* fluids convs thunk) + (more (cdr params) (cdr values) + (cons (parameter-fluid (car params)) fluids) + (cons ((parameter-converter (car params)) (car values)) convs))))) |