Re: srfi-39 parameters current-input-port

[Kevin Ryde]

I made the change below.  It's not pretty, but it implements what the
spec says, I think.

--- srfi-39.scm.~1.1.~  2004-12-31 20:15:50.000000000 +1100
+++ srfi-39.scm 2005-01-12 10:45:11.000000000 +1100
@@ -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)))))