mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Refactor implementation of current-warning-port

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-07-14 16:18:47 +02:00
parent 1c98b78848
commit da757c6814
3 changed files with 22 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/init.c
View file

@ -223,6 +223,7 @@ scm_init_standard_ports ()
(scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w")); (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
scm_set_current_error_port scm_set_current_error_port
(scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w")); (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
scm_set_current_warning_port (scm_current_error_port ());
} }

37
libguile/ports.c
View file

@ -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_inport_fluid = SCM_BOOL_F;
static SCM cur_outport_fluid = SCM_BOOL_F; static SCM cur_outport_fluid = SCM_BOOL_F;
static SCM cur_errport_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; static SCM cur_loadport_fluid = SCM_BOOL_F;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, 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 #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; (),
"Return the port to which 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_current_error_port ();
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, 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
scm_set_current_warning_port (SCM port) 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 void
@ -2900,6 +2899,7 @@ scm_init_ports ()
cur_inport_fluid = scm_make_fluid (); cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid (); cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid (); cur_errport_fluid = scm_make_fluid ();
cur_warnport_fluid = scm_make_fluid ();
cur_loadport_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)); 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-input-port-fluid", cur_inport_fluid);
scm_c_define ("%current-output-port-fluid", cur_outport_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-error-port-fluid", cur_errport_fluid);
scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid);
} }
/* /*

18
module/ice-9/boot-9.scm
View file

@ -217,9 +217,6 @@ If there is no handler at all, Guile prints an error and then exits."
(define pk peek) (define pk peek)
;; Temporary definition; replaced later.
(define current-warning-port current-error-port)
(define (warn . stuff) (define (warn . stuff)
(with-output-to-port (current-warning-port) (with-output-to-port (current-warning-port)
(lambda () (lambda ()
@ -3311,22 +3308,11 @@ CONV is not applied to the initial value."
(port-parameterize! current-output-port %current-output-port-fluid (port-parameterize! current-output-port %current-output-port-fluid
output-port? "expected an output port") output-port? "expected an output port")
(port-parameterize! current-error-port %current-error-port-fluid (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")) 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. ;;; Languages.