mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

(current-input-port, current-output-port): Parameter

Browse source 
replacements for core functions, per SRFI spec.
(current-error-port): The same, for consistency.
This commit is contained in:
Kevin Ryde 2005-01-11 23:47:44 +00:00
parent 2c1c0b1ffe
commit b9f69396c7
1 changed files with 60 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

65
srfi/srfi-39.scm
View file

@ -1,6 +1,6 @@
;;; srfi-39.scm --- Parameter objects
;; Copyright (C) 2004 Free Software Foundation, Inc.
;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -67,7 +67,8 @@
#:export-syntax (parameterize)
;; helper procedure not in srfi-39.
#:export (with-parameters*))
#:export (with-parameters*)
#:replace (current-input-port current-output-port current-error-port))
;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
;;
@ -101,7 +102,61 @@
(list ?value ...)
(lambda () ?body ...)))))
(define (current-input-port . new-value)
(if (null? new-value)
((@ (guile) current-input-port))
(apply set-current-input-port new-value)))
(define (current-output-port . new-value)
(if (null? new-value)
((@ (guile) current-output-port))
(apply set-current-output-port new-value)))
(define (current-error-port . new-value)
(if (null? new-value)
((@ (guile) current-error-port))
(apply 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)
(with-fluids* (map (lambda (p) (p get-fluid-tag)) params)
(map (lambda (p v) ((p get-conv-tag) v)) 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)))))