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

Define a C fluid for current-warning-port

Browse source 
* 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!.
This commit is contained in:
Andy Wingo 2014-03-22 15:42:15 +01:00
parent 48c2a5395a
commit 0463a927c4
3 changed files with 26 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

3
libguile/init.c
View file

@ -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 ());
}

43
libguile/ports.c
View file

@ -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)
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
{
current_warning_port_var
= scm_c_private_variable ("guile", "current-warning-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));
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 (&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
@ -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);
}
/*

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

@ -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}
;;;