X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/31703ab8c630cb21d37148eaaff45438f086584f..f0893308461d9586d4fd00d78fd7999a660058ff:/libguile/vports.c diff --git a/libguile/vports.c b/libguile/vports.c dissimilarity index 88% index 7e14628fa..75e7df303 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -1,178 +1,236 @@ -/* Copyright (C) 1995,1996,1998,1999 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 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. - * - * 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. */ - - -#include -#include "_scm.h" -#include "eval.h" -#include "chars.h" -#include "fports.h" - -#include "vports.h" - -#ifdef HAVE_STRING_H -#include -#endif - - - -/* {Ports - soft ports} - * - */ - - -static void -sfflush (SCM port) -{ - scm_port *pt = SCM_PTAB_ENTRY (port); - SCM stream = pt->stream; - - if (pt->write_pos > pt->write_buf) - { - /* write the byte. */ - scm_apply (SCM_VELTS (stream)[0], SCM_MAKICHR (*pt->write_buf), - scm_listofnull); - pt->write_pos = pt->write_buf; - - /* flush the output. */ - { - SCM f = SCM_VELTS (stream)[2]; - - if (f != SCM_BOOL_F) - scm_apply (f, SCM_EOL, SCM_EOL); - } - } -} - -static void -sf_write (SCM port, void *data, size_t size) -{ - SCM p = SCM_STREAM (port); - - scm_apply (SCM_VELTS (p)[1], scm_cons (scm_makfrom0str ((char *) data), - SCM_EOL), - SCM_EOL); -} - -/* calling the flush proc (element 2) is in case old code needs it, - but perhaps softports could the use port buffer in the same way as - fports. */ - -/* returns a single character. */ -static int -sf_fill_buffer (SCM port) -{ - SCM p = SCM_STREAM (port); - SCM ans; - - ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); /* get char. */ - if (SCM_FALSEP (ans) || SCM_EOF_OBJECT_P (ans)) - return EOF; - SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "sf_fill_buffer"); - { - scm_port *pt = SCM_PTAB_ENTRY (port); - - *pt->read_buf = SCM_ICHR (ans); - pt->read_pos = pt->read_buf; - pt->read_end = pt->read_buf + 1; - return *pt->read_buf; - } -} - - -static int -sfclose (SCM port) -{ - SCM p = SCM_STREAM (port); - SCM f = SCM_VELTS (p)[4]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; -} - - - -SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port); - -SCM -scm_make_soft_port (pv, modes) - SCM pv; - SCM modes; -{ - scm_port *pt; - SCM z; - SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_make_soft_port); - SCM_COERCE_SUBSTR (modes); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_ROCHARS (modes))); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, pv); - pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf; - pt->write_buf = pt->write_pos = &pt->shortbuf; - pt->read_buf_size = pt->write_buf_size = 1; - pt->write_end = pt->write_buf + pt->write_buf_size; - pt->rw_random = 0; - SCM_ALLOW_INTS; - return z; -} - - -void scm_make_sfptob (void); /* Called from ports.c */ - -void -scm_make_sfptob () -{ - long tc = scm_make_port_type ("soft", sf_fill_buffer, sfflush); - scm_set_port_mark (tc, scm_markstream); - scm_set_port_write (tc, sf_write); - scm_set_port_close (tc, sfclose); -} - -void -scm_init_vports () -{ -#include "vports.x" -} +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010 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 + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * 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. + * + * 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., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include + +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/chars.h" +#include "libguile/fports.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" + +#include "libguile/validate.h" +#include "libguile/vports.h" + +#ifdef HAVE_STRING_H +#include +#endif + + + +/* {Ports - soft ports} + * + */ + + +static scm_t_bits scm_tc16_sfport; + + +static void +sf_flush (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM stream = SCM_PACK (pt->stream); + + SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2); + + if (scm_is_true (f)) + scm_call_0 (f); + +} + +static void +sf_write (SCM port, const void *data, size_t size) +{ + SCM p = SCM_PACK (SCM_STREAM (port)); + + /* DATA is assumed to be a locale-encoded C string, which makes it + hard to reliably pass binary data to a soft port. It can be + achieved by choosing a Latin-1 locale, though, but the recommended + approach is to use an R6RS "custom binary output port" instead. */ + scm_call_1 (SCM_SIMPLE_VECTOR_REF (p, 1), + scm_from_locale_stringn ((char *) data, size)); +} + +/* calling the flush proc (element 2) is in case old code needs it, + but perhaps softports could the use port buffer in the same way as + fports. */ + +/* places a single char in the input buffer. */ +static int +sf_fill_input (SCM port) +{ + SCM p = SCM_PACK (SCM_STREAM (port)); + SCM ans; + scm_t_port *pt; + + ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */ + if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) + return EOF; + SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input"); + pt = SCM_PTAB_ENTRY (port); + + if (pt->encoding == NULL) + { + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + *pt->read_buf = SCM_CHAR (ans); + pt->read_pos = pt->read_buf; + pt->read_end = pt->read_buf + 1; + return *pt->read_buf; + } + else + scm_ungetc (SCM_CHAR (ans), port); + return SCM_CHAR (ans); +} + + +static int +sf_close (SCM port) +{ + SCM p = SCM_PACK (SCM_STREAM (port)); + SCM f = SCM_SIMPLE_VECTOR_REF (p, 4); + if (scm_is_false (f)) + return 0; + f = scm_call_0 (f); + errno = 0; + return scm_is_false (f) ? EOF : 0; +} + + +static int +sf_input_waiting (SCM port) +{ + SCM p = SCM_PACK (SCM_STREAM (port)); + if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6) + { + SCM f = SCM_SIMPLE_VECTOR_REF (p, 5); + if (scm_is_true (f)) + return scm_to_int (scm_call_0 (f)); + } + /* Default is such that char-ready? for soft ports returns #t, as it + did before this extension was implemented. */ + return 1; +} + + + +SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, + (SCM pv, SCM modes), + "Return a port capable of receiving or delivering characters as\n" + "specified by the @var{modes} string (@pxref{File Ports,\n" + "open-file}). @var{pv} must be a vector of length 5 or 6. Its\n" + "components are as follows:\n" + "\n" + "@enumerate 0\n" + "@item\n" + "procedure accepting one character for output\n" + "@item\n" + "procedure accepting a string for output\n" + "@item\n" + "thunk for flushing output\n" + "@item\n" + "thunk for getting one character\n" + "@item\n" + "thunk for closing port (not by garbage collection)\n" + "@item\n" + "(if present and not @code{#f}) thunk for computing the number of\n" + "characters that can be read from the port without blocking.\n" + "@end enumerate\n" + "\n" + "For an output-only port only elements 0, 1, 2, and 4 need be\n" + "procedures. For an input-only port only elements 3 and 4 need\n" + "be procedures. Thunks 2 and 4 can instead be @code{#f} if\n" + "there is no useful operation for them to perform.\n" + "\n" + "If thunk 3 returns @code{#f} or an @code{eof-object}\n" + "(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on\n" + "Scheme}) it indicates that the port has reached end-of-file.\n" + "For example:\n" + "\n" + "@lisp\n" + "(define stdout (current-output-port))\n" + "(define p (make-soft-port\n" + " (vector\n" + " (lambda (c) (write c stdout))\n" + " (lambda (s) (display s stdout))\n" + " (lambda () (display \".\" stdout))\n" + " (lambda () (char-upcase (read-char)))\n" + " (lambda () (display \"@@\" stdout)))\n" + " \"rw\"))\n" + "\n" + "(write p p) @result{} #\n" + "@end lisp") +#define FUNC_NAME s_scm_make_soft_port +{ + int vlen; + scm_t_port *pt; + SCM z; + + SCM_VALIDATE_VECTOR (1, pv); + vlen = SCM_SIMPLE_VECTOR_LENGTH (pv); + SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME); + SCM_VALIDATE_STRING (2, modes); + + scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); + z = scm_new_port_table_entry (scm_tc16_sfport); + pt = SCM_PTAB_ENTRY (z); + scm_port_non_buffer (pt); + SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes)); + + SCM_SETSTREAM (z, SCM_UNPACK (pv)); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return z; +} +#undef FUNC_NAME + + +static scm_t_bits +scm_make_sfptob () +{ + scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write); + + scm_set_port_flush (tc, sf_flush); + scm_set_port_close (tc, sf_close); + scm_set_port_input_waiting (tc, sf_input_waiting); + + return tc; +} + +void +scm_init_vports () +{ + scm_tc16_sfport = scm_make_sfptob (); + +#include "libguile/vports.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/