diff options
-rw-r--r-- | libguile/init.c | 3 | ||||
-rw-r--r-- | libguile/ports.c | 43 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 18 |
3 files changed, 26 insertions, 38 deletions
diff --git a/libguile/init.c b/libguile/init.c index 54f73a92d..81cf99707 100644 --- a/libguile/init.c +++ b/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 ()); } diff --git a/libguile/ports.c b/libguile/ports.c index e256d65b8..060c4fb31 100644 --- a/libguile/ports.c +++ b/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; -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, + (void), + "Return the port to which diagnostic warnings should be sent.") +#define FUNC_NAME s_scm_current_warning_port { - scm_i_pthread_once (¤t_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_BOOL_F; } +#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 (¤t_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 @@ -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); } /* diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 9c1bdc4e1..37918cdfb 100644 --- a/module/ice-9/boot-9.scm +++ b/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} ;;; |