[Guile-commits] 01/02: Refactor implementation of current-warning-port

[Andy Wingo]

wingo pushed a commit to branch stable-2.0
in repository guile.

commit da757c6814294281b59c8a307b68d24e9d7a01b5
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 14 16:18:47 2016 +0200

    Refactor implementation of current-warning-port
    
    * module/ice-9/boot-9.scm (current-warning-port):
    * libguile/init.c (scm_init_standard_ports):
    * libguile/ports.c (cur_warnport_fluid, scm_current_warning_port)
      (scm_set_current_warning_port, scm_init_ports): Define the warning
      port in the same way as the error/output/input ports, with a fluid
      that doesn't require calling out to Scheme.
---
 libguile/init.c         |    1 +
 libguile/ports.c        |   37 +++++++++++++++++++------------------
 module/ice-9/boot-9.scm |   18 ++----------------
 3 files changed, 22 insertions(+), 34 deletions(-)

diff --git a/libguile/init.c b/libguile/init.c
index a5630d1..adab2b5 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -223,6 +223,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 ());
 }
 
 
diff --git a/libguile/ports.c b/libguile/ports.c
index 5a756b7..6705e8e 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -409,6 +409,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 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,
@@ -453,23 +454,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 
0, 0, 0,
 }
 #undef FUNC_NAME
 
-static SCM current_warning_port_var;
-static scm_i_pthread_once_t current_warning_port_once = 
SCM_I_PTHREAD_ONCE_INIT;
-
-static void
-init_current_warning_port_var (void)
-{
-  current_warning_port_var
-    = scm_c_private_variable ("guile", "current-warning-port");
-}
-
-SCM
-scm_current_warning_port (void)
+SCM_DEFINE (scm_current_warning_port, "current-warning-port", 0, 0, 0,
+           (),
+           "Return the port to which warnings should be sent.")
+#define FUNC_NAME s_scm_current_warning_port
 {
-  scm_i_pthread_once (&current_warning_port_once,
-                      init_current_warning_port_var);
-  return scm_call_0 (scm_variable_ref (current_warning_port_var));
+  if (scm_is_true (cur_warnport_fluid))
+    return scm_fluid_ref (cur_warnport_fluid);
+  else
+    return scm_current_error_port ();
 }
+#undef FUNC_NAME
 
 SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
            (),
@@ -528,11 +523,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,
-                      init_current_warning_port_var);
-  return scm_call_1 (scm_variable_ref (current_warning_port_var), port);
+  SCM owarnp = scm_fluid_ref (cur_warnport_fluid);
+  port = SCM_COERCE_OUTPORT (port);
+  SCM_VALIDATE_OPOUTPORT (1, port);
+  scm_fluid_set_x (cur_warnport_fluid, port);
+  return owarnp;
 }
+#undef FUNC_NAME
 
 
 void
@@ -2900,6 +2899,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_hash = scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
@@ -2923,6 +2923,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);
 }
 
 /*
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1ed2f9d..0d5a005 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -217,9 +217,6 @@ 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-warning-port)
     (lambda ()
@@ -3311,24 +3308,13 @@ 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.
 ;;;