diff --git a/libguile/ports.c b/libguile/ports.c index 677b2789a..a6311003a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -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); } /* diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d5ba67a6d..03dad9b0d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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 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 )) 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)) + #: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))))) diff --git a/test-suite/tests/parameters.test b/test-suite/tests/parameters.test index 9d0a092ab..78b57c68d 100644 --- a/test-suite/tests/parameters.test +++ b/test-suite/tests/parameters.test @@ -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))))