From cf289add3ef2144b1341f6f8afe06931d6007721 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 28 Jun 2011 23:24:43 +0200
Subject: [PATCH 1/2] add current-warning-port

* libguile/ports.h:
* libguile/ports.c (scm_current_warning_port)
  (scm_set_current_warning_port): New functions, wrapping the Scheme
  ones.

* module/ice-9/boot-9.scm (current-warning-port)
  (set-current-warning-port): New functions, defining a port for
  warnings.
  (%current-warning-port): New public fluid.  A good idea or not?  We
  commit, you decide!
---
 libguile/ports.c        |   24 ++++++++++++++++++++++++
 libguile/ports.h        |    2 ++
 module/ice-9/boot-9.scm |   27 +++++++++++++++++++++++++++
 3 files changed, 53 insertions(+), 0 deletions(-)

diff --git a/libguile/ports.c b/libguile/ports.c
index 6bb9610..be91b3e 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -412,6 +412,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_current_warning_port (void)
+{
+  static SCM cwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (cwp_var))
+    cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+  
+  return scm_call_0 (scm_variable_ref (cwp_var));
+}
+
 SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
 	    (),
 	    "Return the current-load-port.\n"
@@ -466,6 +477,19 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+
+SCM
+scm_set_current_warning_port (SCM port)
+{
+  static SCM scwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (scwp_var))
+    scwp_var = scm_c_private_lookup ("guile", "set-current-warning-port");
+  
+  return scm_call_1 (scm_variable_ref (scwp_var), port);
+}
+
+
 void
 scm_dynwind_current_input_port (SCM port)
 #define FUNC_NAME NULL
diff --git a/libguile/ports.h b/libguile/ports.h
index 6a669b6..fcf1424 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -247,10 +247,12 @@ SCM_API SCM scm_drain_input (SCM port);
 SCM_API SCM scm_current_input_port (void);
 SCM_API SCM scm_current_output_port (void);
 SCM_API SCM scm_current_error_port (void);
+SCM_API SCM scm_current_warning_port (void);
 SCM_API SCM scm_current_load_port (void);
 SCM_API SCM scm_set_current_input_port (SCM port);
 SCM_API SCM scm_set_current_output_port (SCM port);
 SCM_API SCM scm_set_current_error_port (SCM port);
+SCM_API SCM scm_set_current_warning_port (SCM port);
 SCM_API void scm_dynwind_current_input_port (SCM port);
 SCM_API void scm_dynwind_current_output_port (SCM port);
 SCM_API void scm_dynwind_current_error_port (SCM port);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70b9f7..f07094c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -227,6 +227,8 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)
 
 (define (warn . stuff)
   (with-output-to-port (current-error-port)
@@ -665,6 +667,31 @@ If there is no handler at all, Guile prints an error and then exits."
 
 
 
+;;;
+;;; Warnings.
+;;;
+
+;; Here it would be better to use mutable parameters or something, to
+;; avoid exposing the fluid as a binding.
+;;
+(define %current-warning-port (make-fluid))
+
+;; Instead of initializing %current-warning-port to
+;; (current-error-port), let's be sloppy and leave current-warning-port
+;; dynamically scoped, defaulting to (current-error-port).  This lets
+;; (with-error-to-port ...) redirect warnings, at least in the default
+;; setup.  Is it bad idea?  Let us know!
+;;
+(define (current-warning-port)
+  (or (fluid-ref %current-warning-port) (current-error-port)))
+
+(define (set-current-warning-port port)
+  (let ((old (current-warning-port)))
+    (fluid-set! %current-warning-port port)
+    old))
+
+
+
 
 ;;;
 ;;; Extensible exception printing.
-- 
1.7.5.4