srfi-39 parameters current-input-port

srfi-39 parameters current-input-port

[Kevin Ryde]

The srfi-39 spec calls for current-input-port and current-output-port
to be implemented as parameter objects.  That will mean new #:replace
bindings exported I think.

There's no actual fluid underlying current-input-port is there?  Could
that be done, so that with-fluids* can be used like on other parameter
objects?  Or should parameterize and with-parameters* do an explicit
dynamic-wind?

(current-error-port could get the same replacement too, for
consistency.)


_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel

Re: srfi-39 parameters current-input-port

[Kevin Ryde]

[-- Attachment #1: Type: text/plain, Size: 91 bytes --]

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


[-- Attachment #2: srfi-39.scm.ports.diff --]
[-- Type: text/plain, Size: 3083 bytes --]

--- 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)))))

[-- Attachment #3: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel