-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
/* Headers. */
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
#include <errno.h>
{
}
+static size_t
+scm_port_free0 (SCM port)
+{
+ return 0;
+}
+
scm_t_bits
scm_make_port_type (char *name,
int (*fill_input) (SCM port),
scm_ptobs[scm_numptob].name = name;
scm_ptobs[scm_numptob].mark = 0;
- scm_ptobs[scm_numptob].free = scm_free0;
+ scm_ptobs[scm_numptob].free = scm_port_free0;
scm_ptobs[scm_numptob].print = scm_port_print;
scm_ptobs[scm_numptob].equalp = 0;
scm_ptobs[scm_numptob].close = 0;
"@code{#t} then the next @code{read-char} operation on\n"
"@var{port} is guaranteed not to hang. If @var{port} is a file\n"
"port at end of file then @code{char-ready?} returns @code{#t}.\n"
- "@footnote{@code{char-ready?} exists to make it possible for a\n"
+ "\n"
+ "@code{char-ready?} exists to make it possible for a\n"
"program to accept characters from interactive ports without\n"
"getting stuck waiting for input. Any input editors associated\n"
"with such ports must make sure that characters whose existence\n"
"has been asserted by @code{char-ready?} cannot be rubbed out.\n"
"If @code{char-ready?} were to return @code{#f} at end of file,\n"
"a port at end of file would be indistinguishable from an\n"
- "interactive port that has no ready characters.}")
+ "interactive port that has no ready characters.")
#define FUNC_NAME s_scm_char_ready_p
{
scm_t_port *pt;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_VALIDATE_OPINPORT (1,port);
+ SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
scm_t_port *pt = SCM_PTAB_ENTRY (port);
long count;
- SCM_VALIDATE_OPINPORT (1,port);
+ SCM_VALIDATE_OPINPORT (1, port);
count = pt->read_end - pt->read_pos;
if (pt->read_buf == pt->putback_buf)
SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
(),
"Return the current output port. This is the default port used\n"
- "by many output procedures. Initially, \n"
+ "by many output procedures. Initially,\n"
"@code{current-output-port} returns the @dfn{standard output} in\n"
"Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
(SCM port),
- "@deffnx primitive set-current-output-port port\n"
- "@deffnx primitive set-current-error-port port\n"
+ "@deffnx {Scheme Procedure} set-current-output-port port\n"
+ "@deffnx {Scheme Procedure} set-current-error-port port\n"
"Change the ports returned by @code{current-input-port},\n"
"@code{current-output-port} and @code{current-error-port}, respectively,\n"
"so that they use the supplied @var{port} for input or output.")
#define FUNC_NAME s_scm_set_current_input_port
{
SCM oinp = scm_cur_inp;
- SCM_VALIDATE_OPINPORT (1,port);
+ SCM_VALIDATE_OPINPORT (1, port);
scm_cur_inp = port;
return oinp;
}
{
SCM ooutp = scm_cur_outp;
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1,port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
scm_cur_outp = port;
return ooutp;
}
{
SCM oerrp = scm_cur_errp;
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1,port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
scm_cur_errp = port;
return oerrp;
}
\f
/* The port table --- an array of pointers to ports. */
-scm_t_port **scm_port_table;
+scm_t_port **scm_i_port_table;
-long scm_port_table_size = 0; /* Number of ports in scm_port_table. */
-long scm_port_table_room = 20; /* Size of the array. */
+long scm_i_port_table_size = 0; /* Number of ports in scm_i_port_table. */
+long scm_i_port_table_room = 20; /* Size of the array. */
-/* Add a port to the table. */
+SCM_GLOBAL_MUTEX (scm_i_port_table_mutex);
-scm_t_port *
-scm_add_to_port_table (SCM port)
-#define FUNC_NAME "scm_add_to_port_table"
-{
- scm_t_port *entry;
+/* This function is not and should not be thread safe. */
- if (scm_port_table_size == scm_port_table_room)
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
+#define FUNC_NAME "scm_new_port_table_entry"
+{
+ /*
+ We initialize the cell to empty, this is in case scm_gc_calloc
+ triggers GC ; we don't want the GC to scan a half-finished Z.
+ */
+
+ SCM z = scm_cons (SCM_EOL, SCM_EOL);
+ scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ if (scm_i_port_table_size == scm_i_port_table_room)
{
- /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc.,
+ /* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc.,
since it can never be freed during gc. */
- void *newt = realloc ((char *) scm_port_table,
- (size_t) (sizeof (scm_t_port *)
- * scm_port_table_room * 2));
- if (newt == NULL)
- scm_memory_error ("scm_add_to_port_table");
- scm_port_table = (scm_t_port **) newt;
- scm_port_table_room *= 2;
+ void *newt = scm_realloc ((char *) scm_i_port_table,
+ (size_t) (sizeof (scm_t_port *)
+ * scm_i_port_table_room * 2));
+ scm_i_port_table = (scm_t_port **) newt;
+ scm_i_port_table_room *= 2;
}
- entry = (scm_t_port *) scm_must_malloc (sizeof (scm_t_port), FUNC_NAME);
- entry->port = port;
- entry->entry = scm_port_table_size;
- entry->revealed = 0;
- entry->stream = 0;
+ entry->entry = scm_i_port_table_size;
+
entry->file_name = SCM_BOOL_F;
- entry->line_number = 0;
- entry->column_number = 0;
- entry->putback_buf = 0;
- entry->putback_buf_size = 0;
entry->rw_active = SCM_PORT_NEITHER;
- entry->rw_random = 0;
- scm_port_table[scm_port_table_size] = entry;
- scm_port_table_size++;
+ scm_i_port_table[scm_i_port_table_size] = entry;
+ scm_i_port_table_size++;
- return entry;
+ entry->port = z;
+ SCM_SET_CELL_TYPE(z, tag);
+ SCM_SETPTAB_ENTRY(z, entry);
+
+ return z;
}
#undef FUNC_NAME
+#if SCM_ENABLE_DEPRECATED==1
+SCM_API scm_t_port *
+scm_add_to_port_table (SCM port)
+{
+ SCM z = scm_new_port_table_entry (scm_tc7_port);
+ scm_t_port * pt = SCM_PTAB_ENTRY(z);
+
+ pt->port = port;
+ SCM_SETCAR(z, SCM_EOL);
+ SCM_SETCDR(z, SCM_EOL);
+ SCM_SETPTAB_ENTRY (port, pt);
+ return pt;
+}
+#endif
+
+
/* Remove a port from the table and destroy it. */
+/* This function is not and should not be thread safe. */
+
void
scm_remove_from_port_table (SCM port)
#define FUNC_NAME "scm_remove_from_port_table"
scm_t_port *p = SCM_PTAB_ENTRY (port);
long i = p->entry;
- if (i >= scm_port_table_size)
+ if (i >= scm_i_port_table_size)
SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port));
if (p->putback_buf)
- scm_must_free (p->putback_buf);
- scm_must_free (p);
+ scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
+ scm_gc_free (p, sizeof (scm_t_port), "port");
/* Since we have just freed slot i we can shrink the table by moving
the last entry to that slot... */
- if (i < scm_port_table_size - 1)
+ if (i < scm_i_port_table_size - 1)
{
- scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
- scm_port_table[i]->entry = i;
+ scm_i_port_table[i] = scm_i_port_table[scm_i_port_table_size - 1];
+ scm_i_port_table[i]->entry = i;
}
SCM_SETPTAB_ENTRY (port, 0);
- scm_port_table_size--;
+ scm_i_port_table_size--;
}
#undef FUNC_NAME
"is only included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_pt_size
{
- return SCM_MAKINUM (scm_port_table_size);
+ return SCM_MAKINUM (scm_i_port_table_size);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_pt_member
{
long i;
- SCM_VALIDATE_INUM_COPY (1,index,i);
- if (i < 0 || i >= scm_port_table_size)
+ SCM_VALIDATE_INUM_COPY (1, index, i);
+ if (i < 0 || i >= scm_i_port_table_size)
return SCM_BOOL_F;
else
- return scm_port_table[i]->port;
+ return scm_i_port_table[i]->port;
}
#undef FUNC_NAME
#endif
#define FUNC_NAME s_scm_port_revealed
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
+ SCM_VALIDATE_OPENPORT (1, port);
return SCM_MAKINUM (scm_revealed_count (port));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_set_port_revealed_x
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
- SCM_VALIDATE_INUM (2,rcount);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_VALIDATE_INUM (2, rcount);
SCM_REVEALED (port) = SCM_INUM (rcount);
return SCM_UNSPECIFIED;
}
modes[0] = '\0';
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1,port);
+ SCM_VALIDATE_OPPORT (1, port);
if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
strcpy (modes, "r+");
rv = (scm_ptobs[i].close) (port);
else
rv = 0;
+ scm_mutex_lock (&scm_i_port_table_mutex);
scm_remove_from_port_table (port);
+ scm_mutex_unlock (&scm_i_port_table_mutex);
SCM_CLR_PORT_OPEN_FLAG (port);
return SCM_BOOL (rv >= 0);
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
- (SCM proc),
- "Apply @var{proc} to each port in the Guile port table\n"
- "in turn. The return value is unspecified. More specifically,\n"
- "@var{proc} is applied exactly once to every port that exists\n"
- "in the system at the time @var{port-for-each} is invoked.\n"
- "Changes to the port table while @var{port-for-each} is running\n"
- "have no effect as far as @var{port-for-each} is concerned.\n")
-#define FUNC_NAME s_scm_port_for_each
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
{
long i;
SCM ports;
- SCM_VALIDATE_PROC (1, proc);
-
- /* when pre-emptive multithreading is supported, access to the port
- table will need to be controlled by a mutex. */
-
/* Even without pre-emptive multithreading, running arbitrary code
while scanning the port table is unsafe because the port table
can change arbitrarily (from a GC, for example). So we build a
list in advance while blocking the GC. -mvo */
- SCM_DEFER_INTS;
+ scm_mutex_lock (&scm_i_port_table_mutex);
scm_block_gc++;
ports = SCM_EOL;
- for (i = 0; i < scm_port_table_size; i++)
- ports = scm_cons (scm_port_table[i]->port, ports);
+ for (i = 0; i < scm_i_port_table_size; i++)
+ ports = scm_cons (scm_i_port_table[i]->port, ports);
scm_block_gc--;
- SCM_ALLOW_INTS;
+ scm_mutex_unlock (&scm_i_port_table_mutex);
while (ports != SCM_EOL)
{
- scm_call_1 (proc, SCM_CAR (ports));
+ proc (data, SCM_CAR (ports));
ports = SCM_CDR (ports);
}
+}
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @var{port-for-each} is invoked.\n"
+ "Changes to the port table while @var{port-for-each} is running\n"
+ "have no effect as far as @var{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_port_for_each ((void (*)(void*,SCM))scm_call_1, proc);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
\f
/* Utter miscellany. Gosh, we should clean this up some time. */
"open.")
#define FUNC_NAME s_scm_port_closed_p
{
- SCM_VALIDATE_PORT (1,port);
+ SCM_VALIDATE_PORT (1, port);
return SCM_BOOL (!SCM_OPPORTP (port));
}
#undef FUNC_NAME
SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
(SCM port),
"Flush the specified output port, or the current output port if @var{port}\n"
- "is omitted. The current output buffer contents are passed to the \n"
+ "is omitted. The current output buffer contents are passed to the\n"
"underlying port implementation (e.g., in the case of fports, the\n"
"data will be written to the file and the output buffer will be cleared.)\n"
"It has no effect on an unbuffered port.\n\n"
else
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1,port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
}
scm_flush (port);
return SCM_UNSPECIFIED;
{
size_t i;
- for (i = 0; i < scm_port_table_size; i++)
+ scm_mutex_lock (&scm_i_port_table_mutex);
+ for (i = 0; i < scm_i_port_table_size; i++)
{
- if (SCM_OPOUTPORTP (scm_port_table[i]->port))
- scm_flush (scm_port_table[i]->port);
+ if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
+ scm_flush (scm_i_port_table[i]->port);
}
+ scm_mutex_unlock (&scm_i_port_table_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
int c;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
- SCM_VALIDATE_OPINPORT (1,port);
+ SCM_VALIDATE_OPINPORT (1, port);
c = scm_getc (port);
if (EOF == c)
return SCM_EOF_VAL;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
- {
- /* may be marginally faster than calling scm_flush. */
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
- }
+ /* may be marginally faster than calling scm_flush. */
+ scm_ptobs[SCM_PTOBNUM (port)].flush (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
c = *(pt->read_pos++);
- if (c == '\n')
- {
- SCM_INCLINE (port);
- }
- else if (c == '\t')
- {
- SCM_TABCOL (port);
- }
- else
+ switch (c)
{
- SCM_INCCOL (port);
+ case '\n':
+ SCM_INCLINE (port);
+ break;
+ case '\t':
+ SCM_TABCOL (port);
+ break;
+ default:
+ SCM_INCCOL (port);
+ break;
}
-
+
return c;
}
{
size_t new_size = pt->read_buf_size * 2;
unsigned char *tmp = (unsigned char *)
- scm_must_realloc (pt->putback_buf, pt->read_buf_size, new_size,
- FUNC_NAME);
+ scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
+ "putback buffer");
pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
pt->read_end = pt->read_buf + pt->read_buf_size;
if (pt->putback_buf == NULL)
{
pt->putback_buf
- = (unsigned char *) scm_must_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
- FUNC_NAME);
+ = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
+ "putback buffer");
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
"Return the next character available from @var{port},\n"
"@emph{without} updating @var{port} to point to the following\n"
"character. If no more characters are available, the\n"
- "end-of-file object is returned.@footnote{The value returned by\n"
+ "end-of-file object is returned.\n"
+ "\n"
+ "The value returned by\n"
"a call to @code{peek-char} is the same as the value that would\n"
"have been returned by a call to @code{read-char} on the same\n"
"port. The only difference is that the very next call to\n"
"return the value returned by the preceding call to\n"
"@code{peek-char}. In particular, a call to @code{peek-char} on\n"
"an interactive port will hang waiting for input whenever a call\n"
- "to @code{read-char} would have hung.}")
+ "to @code{read-char} would have hung.")
#define FUNC_NAME s_scm_peek_char
{
- int c;
+ int c, column;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_VALIDATE_OPINPORT (1,port);
+ SCM_VALIDATE_OPINPORT (1, port);
+ column = SCM_COL(port);
c = scm_getc (port);
if (EOF == c)
return SCM_EOF_VAL;
scm_ungetc (c, port);
+ SCM_COL(port) = column;
return SCM_MAKE_CHAR (c);
}
#undef FUNC_NAME
{
int c;
- SCM_VALIDATE_CHAR (1,cobj);
+ SCM_VALIDATE_CHAR (1, cobj);
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_VALIDATE_OPINPORT (2,port);
+ SCM_VALIDATE_OPINPORT (2, port);
c = SCM_CHAR (cobj);
"@var{port} is not supplied, the current-input-port is used.")
#define FUNC_NAME s_scm_unread_string
{
- SCM_VALIDATE_STRING (1,str);
+ SCM_VALIDATE_STRING (1, str);
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_VALIDATE_OPINPORT (2,port);
+ SCM_VALIDATE_OPINPORT (2, port);
scm_ungets (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
}
else /* file descriptor?. */
{
- SCM_VALIDATE_INUM (1,fd_port);
+ SCM_VALIDATE_INUM (1, fd_port);
rv = lseek (SCM_INUM (fd_port), off, how);
if (rv == -1)
SCM_SYSERROR;
{
/* must supply length if object is a filename. */
if (SCM_STRINGP (object))
- SCM_MISC_ERROR("must supply length if OBJECT is a filename",SCM_EOL);
+ SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
}
- c_length = SCM_NUM2LONG (2,length);
+ c_length = SCM_NUM2LONG (2, length);
if (c_length < 0)
SCM_MISC_ERROR ("negative offset", SCM_EOL);
#define FUNC_NAME s_scm_port_line
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
+ SCM_VALIDATE_OPENPORT (1, port);
return SCM_MAKINUM (SCM_LINUM (port));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_set_port_line_x
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
- SCM_VALIDATE_INUM (2,line);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_VALIDATE_INUM (2, line);
SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
return SCM_UNSPECIFIED;
}
SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
(SCM port),
- "@deffnx primitive port-line port\n"
+ "@deffnx {Scheme Procedure} port-line port\n"
"Return the current column number or line number of @var{port},\n"
"using the current input port if none is specified. If the number is\n"
"unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
#define FUNC_NAME s_scm_port_column
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
+ SCM_VALIDATE_OPENPORT (1, port);
return SCM_MAKINUM (SCM_COL (port));
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
(SCM port, SCM column),
- "@deffnx primitive set-port-line! port line\n"
+ "@deffnx {Scheme Procedure} set-port-line! port line\n"
"Set the current column or line number of @var{port}, using the\n"
"current input port if none is specified.")
#define FUNC_NAME s_scm_set_port_column_x
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
- SCM_VALIDATE_INUM (2,column);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_VALIDATE_INUM (2, column);
SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
return SCM_UNSPECIFIED;
}
#define FUNC_NAME s_scm_port_filename
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
+ SCM_VALIDATE_OPENPORT (1, port);
return SCM_FILENAME (port);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_set_port_filename_x
{
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1,port);
+ SCM_VALIDATE_OPENPORT (1, port);
/* We allow the user to set the filename to whatever he likes. */
SCM_SET_FILENAME (port, filename);
return SCM_UNSPECIFIED;
scm_ports_prehistory ()
{
scm_numptob = 0;
- scm_ptobs = (scm_t_ptob_descriptor *) malloc (sizeof (scm_t_ptob_descriptor));
+ scm_ptobs = (scm_t_ptob_descriptor *) scm_malloc (sizeof (scm_t_ptob_descriptor));
}
\f
SCM
scm_void_port (char *mode_str)
{
- int mode_bits;
- SCM answer;
- scm_t_port * pt;
+ scm_mutex_lock (&scm_i_port_table_mutex);
+ {
+ int mode_bits = scm_mode_bits (mode_str);
+ SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
+ scm_t_port * pt = SCM_PTAB_ENTRY(answer);
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- mode_bits = scm_mode_bits (mode_str);
- pt = scm_add_to_port_table (answer);
- scm_port_non_buffer (pt);
- SCM_SETPTAB_ENTRY (answer, pt);
- SCM_SETSTREAM (answer, 0);
- SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- SCM_ALLOW_INTS;
- return answer;
+ scm_port_non_buffer (pt);
+
+ SCM_SETSTREAM (answer, 0);
+ SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
+ scm_mutex_unlock (&scm_i_port_table_mutex);
+ return answer;
+ }
}
SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
(SCM mode),
"Create and return a new void port. A void port acts like\n"
- "/dev/null. The @var{mode} argument\n"
+ "@file{/dev/null}. The @var{mode} argument\n"
"specifies the input/output modes for this port: see the\n"
"documentation for @code{open-file} in @ref{File Ports}.")
#define FUNC_NAME s_scm_sys_make_void_port
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/ports.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff