Define a C fluid for current-warning-port

* libguile/ports.c (scm_current_input_port, scm_current_output_port)
  (scm_current_error_port): Fix declarations to C99.
  (scm_current_warning_port, scm_set_current_warning_port): Rework to
  use a C fluid, like scm_current_error_port.
  (scm_init_ports): Initialize and define the warning port fluid.

* libguile/init.c (scm_init_standard_ports): Init the current warning
  port.

* module/ice-9/boot-9.scm: Remove definitions for current-warning-port.
  Instead, steal it from the boot objtable with port-parameterize!.

libguile/init.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- *   2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -222,6 +222,7 @@ scm_init_standard_ports ()
     (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
   scm_set_current_error_port
     (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
+  scm_set_current_warning_port (scm_current_error_port ());
 }
 
 

libguile/ports.c

@@ -391,10 +391,11 @@ SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0,
 static SCM cur_inport_fluid = SCM_BOOL_F;
 static SCM cur_outport_fluid = SCM_BOOL_F;
 static SCM cur_errport_fluid = SCM_BOOL_F;
+static SCM cur_warnport_fluid = SCM_BOOL_F;
 static SCM cur_loadport_fluid = SCM_BOOL_F;
 
 SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
-	    (),
+	    (void),
 	    "Return the current input port.  This is the default port used\n"
 	    "by many input procedures.  Initially, @code{current-input-port}\n"
 	    "returns the @dfn{standard input} in Unix and C terminology.")
@@ -408,7 +409,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
-	    (),
+	    (void),
             "Return the current output port.  This is the default port used\n"
 	    "by many output procedures.  Initially,\n"
 	    "@code{current-output-port} returns the @dfn{standard output} in\n"
@@ -423,7 +424,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
-           (),
+            (void),
 	    "Return the port to which errors and warnings should be sent (the\n"
 	    "@dfn{standard error} in Unix and C terminology).")
 #define FUNC_NAME s_scm_current_error_port
@@ -435,23 +436,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
 }
 #undef FUNC_NAME
 
-static SCM current_warning_port_var;
+SCM_DEFINE (scm_current_warning_port, "current-warning-port", 0, 0, 0,
-static scm_i_pthread_once_t current_warning_port_once = SCM_I_PTHREAD_ONCE_INIT;
+            (void),
-
+	    "Return the port to which diagnostic warnings should be sent.")
-static void
+#define FUNC_NAME s_scm_current_warning_port
-init_current_warning_port_var (void)
 {
-  current_warning_port_var
+  if (scm_is_true (cur_warnport_fluid))
-    = scm_c_private_variable ("guile", "current-warning-port");
+    return scm_fluid_ref (cur_warnport_fluid);
-}
+  else
-
+    return SCM_BOOL_F;
-SCM
-scm_current_warning_port (void)
-{
-  scm_i_pthread_once (&current_warning_port_once,
-                      init_current_warning_port_var);
-  return scm_call_0 (scm_variable_ref (current_warning_port_var));
 }
+#undef FUNC_NAME
 
 SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
 	    (),
@@ -510,11 +505,15 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 
 SCM
 scm_set_current_warning_port (SCM port)
+#define FUNC_NAME "set-current-warning-port"
 {
-  scm_i_pthread_once (&current_warning_port_once,
+  SCM owarnp = scm_fluid_ref (cur_warnport_fluid);
-                      init_current_warning_port_var);
+  port = SCM_COERCE_OUTPORT (port);
-  return scm_call_1 (scm_variable_ref (current_warning_port_var), port);
+  SCM_VALIDATE_OPOUTPORT (1, port);
+  scm_fluid_set_x (cur_warnport_fluid, port);
+  return owarnp;
 }
+#undef FUNC_NAME
 
 
 void
@@ -3197,6 +3196,7 @@ scm_init_ports ()
   cur_inport_fluid = scm_make_fluid ();
   cur_outport_fluid = scm_make_fluid ();
   cur_errport_fluid = scm_make_fluid ();
+  cur_warnport_fluid = scm_make_fluid ();
   cur_loadport_fluid = scm_make_fluid ();
 
   scm_i_port_weak_set = scm_c_make_weak_set (31);
@@ -3217,6 +3217,7 @@ scm_init_ports ()
   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);
+  scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid);
 }
 
 /*

module/ice-9/boot-9.scm

@@ -206,9 +206,6 @@ file with the given name already exists, the effect is unspecified."
 
 (define pk peek)
 
-;; Temporary definition; replaced later.
-(define current-warning-port current-error-port)
-
 (define (warn . stuff)
   (newline (current-warning-port))
   (display ";;; WARNING " (current-warning-port))
@@ -1541,23 +1538,12 @@ CONV is not applied to the initial value."
   (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")
+  (port-parameterize! current-warning-port %current-warning-port-fluid
                       output-port? "expected an output port"))
 
 
 
-;;; {Warnings}
-;;;
-
-(define current-warning-port
-  (make-parameter (current-error-port)
-                  (lambda (x)
-                    (if (output-port? x)
-                        x
-                        (error "expected an output port" x)))))
-
-
-
-
 ;;; {Languages}
 ;;;