-/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2007, 2008, 2009, 2010, 2011, 2012, 2013,
+ * 2014, 2015 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
#include "libguile/weak-set.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
+#include "libguile/alist.h"
#ifdef HAVE_STRING_H
#include <string.h>
#include <io.h>
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#endif
#ifdef HAVE_SYS_IOCTL_H
#include <sys/ioctl.h>
ptobnum = scm_c_port_type_add_x (desc);
/* Make a class object if GOOPS is present. */
- if (SCM_UNPACK (scm_port_class[0]) != 0)
+ if (SCM_UNPACK (scm_i_port_class[0]) != 0)
scm_make_port_classes (ptobnum, name);
return scm_tc7_port + ptobnum * 256;
scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting;
}
+void
+scm_set_port_setvbuf (scm_t_bits tc, void (*setvbuf) (SCM, long, long))
+{
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->setvbuf = setvbuf;
+}
+
static void
scm_i_set_pending_eof (SCM port)
{
SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
}
-SCM
-scm_i_port_alist (SCM port)
+SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0,
+ (SCM port, SCM key),
+ "Return the property of @var{port} associated with @var{key}.")
+#define FUNC_NAME s_scm_i_port_property
{
- return SCM_PORT_GET_INTERNAL (port)->alist;
+ scm_i_pthread_mutex_t *lock;
+ SCM result;
+
+ SCM_VALIDATE_OPPORT (1, port);
+ scm_c_lock_port (port, &lock);
+ result = scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+ return result;
}
+#undef FUNC_NAME
-void
-scm_i_set_port_alist_x (SCM port, SCM alist)
+SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0,
+ (SCM port, SCM key, SCM value),
+ "Set the property of @var{port} associated with @var{key} to @var{value}.")
+#define FUNC_NAME s_scm_i_set_port_property_x
{
- SCM_PORT_GET_INTERNAL (port)->alist = alist;
+ scm_i_pthread_mutex_t *lock;
+ scm_t_port_internal *pti;
+
+ SCM_VALIDATE_OPPORT (1, port);
+ scm_c_lock_port (port, &lock);
+ pti = SCM_PORT_GET_INTERNAL (port);
+ pti->alist = scm_assq_set_x (pti->alist, key, value);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
\f
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.")
#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"
#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
}
#undef FUNC_NAME
-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
{
- static SCM cwp_var = SCM_UNDEFINED;
- static scm_i_pthread_mutex_t cwp_var_mutex
- = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
- scm_i_scm_pthread_mutex_lock (&cwp_var_mutex);
- if (SCM_UNBNDP (cwp_var))
- cwp_var = scm_c_private_variable ("guile", "current-warning-port");
- scm_i_pthread_mutex_unlock (&cwp_var_mutex);
-
- return scm_call_0 (scm_variable_ref (cwp_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,
(),
SCM
scm_set_current_warning_port (SCM port)
+#define FUNC_NAME "set-current-warning-port"
{
- static SCM cwp_var = SCM_BOOL_F;
-
- if (scm_is_false (cwp_var))
- cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
-
- return scm_call_1 (scm_variable_ref (cwp_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
}
#undef FUNC_NAME
-
\f
/* The port table --- a weak set of all ports.
{
scm_t_string_failed_conversion_handler h;
- SCM_VALIDATE_OPPORT (1, port);
-
if (scm_is_false (port))
h = scm_i_default_port_conversion_handler ();
else
if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
{
- if (c < 0xf0)
+ if (c < 0x80)
{
result_buf[0] = (char) c;
result = result_buf;
free (result);
if (c == '\n')
- {
- /* What should col be in this case?
- * We'll leave it at -1.
- */
- SCM_LINUM (port) -= 1;
- }
- else
- SCM_COL(port) -= 1;
+ SCM_LINUM (port) -= 1;
+ SCM_DECCOL (port);
}
#undef FUNC_NAME
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);
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);
}
/*
HCoop / bpt / guile.git / blobdiff