mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
4eb286127c
commit
9670f238d4
4 changed files with 106 additions and 94 deletions
|
|
@ -2582,6 +2582,11 @@ scm_init_ports ()
|
|||
(scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)));
|
||||
scm_conversion_strategy_init = 1;
|
||||
|
||||
/* These bindings are used when boot-9 turns `current-input-port' et
|
||||
al into parameters. They are then removed from the guile module. */
|
||||
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
|
||||
scm_c_define ("%current-output-port-fluid", cur_outport_fluid);
|
||||
scm_c_define ("%current-error-port-fluid", cur_errport_fluid);
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -2913,6 +2913,36 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
...)
|
||||
body body* ...)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Current ports as parameters.
|
||||
;;;
|
||||
|
||||
(let ((fluid->parameter
|
||||
(lambda (fluid conv)
|
||||
(make-struct <parameter> 0
|
||||
(case-lambda
|
||||
(() (fluid-ref fluid))
|
||||
((x) (let ((prev (fluid-ref fluid)))
|
||||
(fluid-set! fluid (conv x))
|
||||
prev)))
|
||||
fluid conv))))
|
||||
(define-syntax-rule (port-parameterize! binding fluid predicate msg)
|
||||
(begin
|
||||
(set! binding (fluid->parameter (module-ref (current-module) 'fluid)
|
||||
(lambda (x)
|
||||
(if (predicate x) x
|
||||
(error msg x)))))
|
||||
(module-remove! (current-module) 'fluid)))
|
||||
|
||||
(port-parameterize! current-input-port %current-input-port-fluid
|
||||
input-port? "expected an input port")
|
||||
(port-parameterize! current-output-port %current-output-port-fluid
|
||||
output-port? "expected an output port")
|
||||
(port-parameterize! current-error-port %current-error-port-fluid
|
||||
output-port? "expected an output port"))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Warnings.
|
||||
|
|
@ -3657,8 +3687,9 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
srfi-4 ;; homogenous numeric vectors
|
||||
srfi-6 ;; open-input-string etc, in the guile core
|
||||
srfi-13 ;; string library
|
||||
srfi-23 ;; `error` procedure
|
||||
srfi-14 ;; character sets
|
||||
srfi-23 ;; `error` procedure
|
||||
srfi-39 ;; parameterize
|
||||
srfi-55 ;; require-extension
|
||||
srfi-61 ;; general cond clause
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
#:re-export (make-parameter
|
||||
parameterize
|
||||
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 ...)))
|
||||
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -67,3 +67,64 @@
|
|||
(lambda ()
|
||||
(parameterize ((inside? #t))
|
||||
(raise 'some-exception)))))))))
|
||||
|
||||
(let ()
|
||||
(define (test-ports param new-port new-port-2)
|
||||
(let ((old-port (param)))
|
||||
|
||||
(pass-if "new value"
|
||||
(parameterize ((param new-port))
|
||||
(eq? (param) new-port)))
|
||||
|
||||
(pass-if "set value"
|
||||
(parameterize ((param old-port))
|
||||
(param new-port)
|
||||
(eq? (param) new-port)))
|
||||
|
||||
(pass-if "old restored"
|
||||
(parameterize ((param new-port))
|
||||
#f)
|
||||
(eq? (param) old-port))
|
||||
|
||||
(pass-if "throw exit"
|
||||
(catch 'bail
|
||||
(lambda ()
|
||||
(parameterize ((param new-port))
|
||||
(throw 'bail)))
|
||||
(lambda args #f))
|
||||
(eq? (param) old-port))
|
||||
|
||||
(pass-if "call/cc re-enter"
|
||||
(let ((cont #f)
|
||||
(count 0)
|
||||
(port #f)
|
||||
(good #t))
|
||||
(parameterize ((param new-port))
|
||||
(call/cc (lambda (k) (set! cont k)))
|
||||
(set! count (1+ count))
|
||||
(set! port (param))
|
||||
(if (= 1 count) (param new-port-2)))
|
||||
(set! good (and good (eq? (param) old-port)))
|
||||
(case count
|
||||
((1)
|
||||
(set! good (and good (eq? port new-port)))
|
||||
;; re-entering should give new-port-2 left there last time
|
||||
(cont))
|
||||
((2)
|
||||
(set! good (and good (eq? port new-port-2)))))
|
||||
good))
|
||||
|
||||
(pass-if "original unchanged"
|
||||
(eq? (param) old-port))))
|
||||
|
||||
(with-test-prefix "current-input-port"
|
||||
(test-ports current-input-port
|
||||
(open-input-string "xyz") (open-input-string "xyz")))
|
||||
|
||||
(with-test-prefix "current-output-port"
|
||||
(test-ports current-output-port
|
||||
(open-output-string) (open-output-string)))
|
||||
|
||||
(with-test-prefix "current-error-port"
|
||||
(test-ports current-error-port
|
||||
(open-output-string) (open-output-string))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue