From: Andy Wingo Date: Sat, 10 Dec 2011 19:04:27 +0000 (+0100) Subject: current-input-port et al are srfi-39 parameters X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/9670f238d406a38bb43658f74dae325c6516094e 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. --- 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 @@ -2914,6 +2914,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 dissimilarity index 63% index d1c46d028..0d540633d 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -1,138 +1,53 @@ -;;; srfi-39.scm --- Parameter objects - -;; Copyright (C) 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 3 of the License, or (at your option) any later version. -;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Jose Antonio Ortega Ruiz -;;; Date: 2004-05-05 - -;;; Commentary: - -;; This is an implementation of SRFI-39 (Parameter objects). -;; -;; The implementation is based on Guile's fluid objects, and is, therefore, -;; thread-safe (parameters are thread-local). -;; -;; In addition to the forms defined in SRFI-39 (`make-parameter', -;; `parameterize'), a new procedure `with-parameters*' is provided. -;; This procedures is analogous to `with-fluids*' but taking as first -;; argument a list of parameter objects instead of a list of fluids. -;; - -;;; 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 ...))) - -(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 - (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))))) +;;; srfi-39.scm --- Parameter objects + +;; Copyright (C) 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Jose Antonio Ortega Ruiz +;;; Date: 2004-05-05 + +;;; Commentary: + +;; This is an implementation of SRFI-39 (Parameter objects). +;; +;; The implementation is based on Guile's fluid objects, and is, therefore, +;; thread-safe (parameters are thread-local). +;; +;; In addition to the forms defined in SRFI-39 (`make-parameter', +;; `parameterize'), a new procedure `with-parameters*' is provided. +;; This procedures is analogous to `with-fluids*' but taking as first +;; argument a list of parameter objects instead of a list of fluids. +;; + +;;; Code: + +(define-module (srfi srfi-39) + ;; helper procedure not in srfi-39. + #:export (with-parameters*) + #:re-export (make-parameter + parameterize + current-input-port current-output-port current-error-port)) + +(define (with-parameters* params values thunk) + (let more ((params params) + (values values) + (fluids '()) ;; fluids from each of PARAMS + (convs '())) ;; VALUES with conversion proc applied + (if (null? params) + (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))))