X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0f2d19dd46f83f41177f61d585732b32a866d613..7caa1b0780eda67bc7e50969c3a5436f3710d6d4:/libguile/strports.c diff --git a/libguile/strports.c b/libguile/strports.c dissimilarity index 66% index 1ba808a51..107fedd01 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,285 +1,522 @@ -/* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, 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" - - - -/* {Ports - string ports} - * - */ - -#ifdef __STDC__ -static int -prinstpt (SCM exp, SCM port, int writing) -#else -static int -prinstpt (exp, port, writing) - SCM exp; - SCM port; - int writing; -#endif -{ - scm_prinport (exp, port, "string"); - return !0; -} - -#ifdef __STDC__ -static int -stputc (int c, SCM p) -#else -static int -stputc (c, p) - int c; - SCM p; -#endif -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - SCM_DEFER_INTS; - if (ind >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1))); - SCM_ALLOW_INTS; - SCM_CHARS (SCM_CDR (p))[ind] = c; - SCM_CAR (p) = SCM_MAKINUM (ind + 1); - return c; -} - -#ifdef __STDC__ -static scm_sizet -stwrite (char *str, scm_sizet siz, scm_sizet num, SCM p) -#else -static scm_sizet -stwrite (str, siz, num, p) - char *str; - scm_sizet siz; - scm_sizet num; - SCM p; -#endif -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - scm_sizet len = siz * num; - char *dst; - SCM_DEFER_INTS; - if (ind + len >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1))); - SCM_ALLOW_INTS; - dst = &(SCM_CHARS (SCM_CDR (p))[ind]); - while (len--) - dst[len] = str[len]; - SCM_CAR (p) = SCM_MAKINUM (ind + siz * num); - return num; -} - -#ifdef __STDC__ -static int -stputs (char *s, SCM p) -#else -static int -stputs (s, p) - char *s; - SCM p; -#endif -{ - stwrite (s, 1, strlen (s), p); - return 0; -} - -#ifdef __STDC__ -static int -stgetc (SCM p) -#else -static int -stgetc (p) - SCM p; -#endif -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - if (ind >= SCM_ROLENGTH (SCM_CDR (p))) - return EOF; - SCM_CAR (p) = SCM_MAKINUM (ind + 1); - return SCM_ROUCHARS (SCM_CDR (p))[ind]; -} - -#ifdef __STDC__ -SCM -scm_mkstrport (SCM pos, SCM str, long modes, char * caller) -#else -SCM -scm_mkstrport (pos, str, modes, caller) - SCM pos; - SCM str; - long modes; - char * caller; -#endif -{ - SCM z; - SCM stream; - struct scm_port_table * pt; - - SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); - SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller); - stream = scm_cons(pos, str); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_CAR (z) = scm_tc16_strport | modes; - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, stream); - SCM_ALLOW_INTS; - return z; -} - -SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string); -#ifdef __STDC__ -SCM -scm_call_with_output_string (SCM proc) -#else -SCM -scm_call_with_output_string (proc) - SCM proc; -#endif -{ - SCM p; - p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s_call_with_output_string); - scm_apply (proc, p, scm_listofnull); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))), - SCM_INUM (SCM_CAR (SCM_STREAM (p))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - -/* Return a Scheme string obtained by printing a given object. - */ - -#ifdef __STDC__ -SCM -scm_strprint_obj (SCM obj) -#else -SCM -scm_strprint_obj (obj) - SCM obj; -#endif -{ - SCM str; - SCM port; - - str = scm_makstr (64, 0); - port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); - scm_iprin1 (obj, port, 1); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))), - SCM_INUM (SCM_CAR (SCM_STREAM (port))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - - -SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string); -#ifdef __STDC__ -SCM -scm_call_with_input_string (SCM str, SCM proc) -#else -SCM -scm_call_with_input_string (str, proc) - SCM str; - SCM proc; -#endif -{ - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string); - return scm_apply (proc, p, scm_listofnull); -} - -#ifdef __STDC__ -static int -noop0 (FILE *stream) -#else -static int -noop0 (stream) - FILE *stream; -#endif -{ - return 0; -} - - -scm_ptobfuns scm_stptob = -{ - scm_markstream, - noop0, - prinstpt, - 0, - stputc, - stputs, - stwrite, - noop0, - stgetc, - 0 -}; - - -#ifdef __STDC__ -void -scm_init_strports (void) -#else -void -scm_init_strports () -#endif -{ -#include "strports.x" -} - +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002 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 "libguile/_scm.h" + +#include +#ifdef HAVE_UNISTD_H +#include +#endif + +#include "libguile/unif.h" +#include "libguile/eval.h" +#include "libguile/ports.h" +#include "libguile/read.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/modules.h" +#include "libguile/validate.h" +#include "libguile/deprecation.h" + +#include "libguile/strports.h" + +#ifdef HAVE_STRING_H +#include +#endif + + + +/* {Ports - string ports} + * + */ + +/* NOTES: + write_buf/write_end point to the ends of the allocated string. + read_buf/read_end in principle point to the part of the string which + has been written to, but this is only updated after a flush. + read_pos and write_pos in principle should be equal, but this is only true + when rw_active is SCM_PORT_NEITHER. +*/ + +scm_t_bits scm_tc16_strport; + + +static int +stfill_buffer (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + if (pt->read_pos >= pt->read_end) + return EOF; + else + return scm_return_first_int (*pt->read_pos, port); +} + +/* change the size of a port's string to new_size. this doesn't + change read_buf_size. */ +static void +st_resize_port (scm_t_port *pt, off_t new_size) +{ + SCM old_stream = SCM_PACK (pt->stream); + SCM new_stream = scm_allocate_string (new_size); + unsigned long int old_size = SCM_STRING_LENGTH (old_stream); + unsigned long int min_size = min (old_size, new_size); + unsigned long int i; + + off_t index = pt->write_pos - pt->write_buf; + + pt->write_buf_size = new_size; + + for (i = 0; i != min_size; ++i) + SCM_STRING_CHARS (new_stream) [i] = SCM_STRING_CHARS (old_stream) [i]; + + /* reset buffer. */ + { + pt->stream = SCM_UNPACK (new_stream); + pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (new_stream); + pt->read_pos = pt->write_pos = pt->write_buf + index; + pt->write_end = pt->write_buf + pt->write_buf_size; + pt->read_end = pt->read_buf + pt->read_buf_size; + } +} + +/* amount by which write_buf is expanded. */ +#define SCM_WRITE_BLOCK 80 + +/* ensure that write_pos < write_end by enlarging the buffer when + necessary. update read_buf to account for written chars. */ +static void +st_flush (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + if (pt->write_pos == pt->write_end) + { + st_resize_port (pt, pt->write_buf_size + SCM_WRITE_BLOCK); + } + pt->read_pos = pt->write_pos; + if (pt->read_pos > pt->read_end) + { + pt->read_end = (unsigned char *) pt->read_pos; + pt->read_buf_size = pt->read_end - pt->read_buf; + } + pt->rw_active = SCM_PORT_NEITHER; +} + +static void +st_write (SCM port, const void *data, size_t size) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + const char *input = (char *) data; + + while (size > 0) + { + int space = pt->write_end - pt->write_pos; + int write_len = (size > space) ? space : size; + + memcpy ((char *) pt->write_pos, input, write_len); + pt->write_pos += write_len; + size -= write_len; + input += write_len; + if (write_len == space) + st_flush (port); + } +} + +static void +st_end_input (SCM port, int offset) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + if (pt->read_pos - pt->read_buf < offset) + scm_misc_error ("st_end_input", "negative position", SCM_EOL); + + pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset); + pt->rw_active = SCM_PORT_NEITHER; +} + +static off_t +st_seek (SCM port, off_t offset, int whence) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + off_t target; + + if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) + /* special case to avoid disturbing the unread-char buffer. */ + { + if (pt->read_buf == pt->putback_buf) + { + target = pt->saved_read_pos - pt->saved_read_buf + - (pt->read_end - pt->read_pos); + } + else + { + target = pt->read_pos - pt->read_buf; + } + } + else + /* all other cases. */ + { + if (pt->rw_active == SCM_PORT_WRITE) + st_flush (port); + + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (port); + + switch (whence) + { + case SEEK_CUR: + target = pt->read_pos - pt->read_buf + offset; + break; + case SEEK_END: + target = pt->read_end - pt->read_buf + offset; + break; + default: /* SEEK_SET */ + target = offset; + break; + } + + if (target < 0) + scm_misc_error ("st_seek", "negative offset", SCM_EOL); + + if (target >= pt->write_buf_size) + { + if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG)) + { + if (target > pt->write_buf_size) + { + scm_misc_error ("st_seek", + "seek past end of read-only strport", + SCM_EOL); + } + } + else + { + st_resize_port (pt, target + (target == pt->write_buf_size + ? SCM_WRITE_BLOCK + : 0)); + } + } + pt->read_pos = pt->write_pos = pt->read_buf + target; + if (pt->read_pos > pt->read_end) + { + pt->read_end = (unsigned char *) pt->read_pos; + pt->read_buf_size = pt->read_end - pt->read_buf; + } + } + return target; +} + +static void +st_truncate (SCM port, off_t length) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + if (length > pt->write_buf_size) + st_resize_port (pt, length); + + pt->read_buf_size = length; + pt->read_end = pt->read_buf + length; + if (pt->read_pos > pt->read_end) + pt->read_pos = pt->read_end; + + if (pt->write_pos > pt->read_end) + pt->write_pos = pt->read_end; +} + +SCM +scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) +{ + SCM z; + scm_t_port *pt; + size_t str_len; + + SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); + SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller); + str_len = SCM_STRING_LENGTH (str); + if (SCM_INUM (pos) > str_len) + scm_out_of_range (caller, pos); + if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) + scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); + + SCM_DEFER_INTS; + z = scm_new_port_table_entry (scm_tc16_strport); + pt = SCM_PTAB_ENTRY(z); + SCM_SETSTREAM (z, SCM_UNPACK (str)); + SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes); + pt->write_buf = pt->read_buf = SCM_STRING_UCHARS (str); + pt->read_pos = pt->write_pos = pt->read_buf + SCM_INUM (pos); + pt->write_buf_size = pt->read_buf_size = str_len; + pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; + + pt->rw_random = 1; + + SCM_ALLOW_INTS; + + /* ensure write_pos is writable. */ + if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end) + st_flush (z); + return z; +} + +/* create a new string from a string port's buffer. */ +SCM scm_strport_to_string (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM str; + + if (pt->rw_active == SCM_PORT_WRITE) + st_flush (port); + + str = scm_mem2string ((char *) pt->read_buf, pt->read_buf_size); + scm_remember_upto_here_1 (port); + return str; +} + +SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, + (SCM obj, SCM printer), + "Return a Scheme string obtained by printing @var{obj}.\n" + "Printing function can be specified by the optional second\n" + "argument @var{printer} (default: @code{write}).") +#define FUNC_NAME s_scm_object_to_string +{ + SCM str, port; + + if (!SCM_UNBNDP (printer)) + SCM_VALIDATE_PROC (2, printer); + + str = scm_allocate_string (0); + port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); + + if (SCM_UNBNDP (printer)) + scm_write (obj, port); + else + scm_call_2 (printer, obj, port); + + return scm_strport_to_string (port); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, + (SCM proc), + "Calls the one-argument procedure @var{proc} with a newly created output\n" + "port. When the function returns, the string composed of the characters\n" + "written into the port is returned.") +#define FUNC_NAME s_scm_call_with_output_string +{ + SCM p; + + p = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + scm_call_1 (proc, p); + + return scm_strport_to_string (p); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0, + (SCM string, SCM proc), + "Calls the one-argument procedure @var{proc} with a newly\n" + "created input port from which @var{string}'s contents may be\n" + "read. The value yielded by the @var{proc} is returned.") +#define FUNC_NAME s_scm_call_with_input_string +{ + SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME); + return scm_call_1 (proc, p); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, + (SCM str), + "Take a string and return an input port that delivers characters\n" + "from the string. The port can be closed by\n" + "@code{close-input-port}, though its storage will be reclaimed\n" + "by the garbage collector if it becomes inaccessible.") +#define FUNC_NAME s_scm_open_input_string +{ + SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); + return p; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, + (void), + "Return an output port that will accumulate characters for\n" + "retrieval by @code{get-output-string}. The port can be closed\n" + "by the procedure @code{close-output-port}, though its storage\n" + "will be reclaimed by the garbage collector if it becomes\n" + "inaccessible.") +#define FUNC_NAME s_scm_open_output_string +{ + SCM p; + + p = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + return p; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, + (SCM port), + "Given an output port created by @code{open-output-string},\n" + "return a string consisting of the characters that have been\n" + "output to the port so far.") +#define FUNC_NAME s_scm_get_output_string +{ + SCM_VALIDATE_OPOUTSTRPORT (1, port); + return scm_strport_to_string (port); +} +#undef FUNC_NAME + + +/* Given a null-terminated string EXPR containing a Scheme expression + read it, and return it as an SCM value. */ +SCM +scm_c_read_string (const char *expr) +{ + SCM port = scm_mkstrport (SCM_INUM0, + scm_makfrom0str (expr), + SCM_OPN | SCM_RDNG, + "scm_c_read_string"); + SCM form; + + /* Read expressions from that port; ignore the values. */ + form = scm_read (port); + + scm_close_port (port); + return form; +} + +/* Given a null-terminated string EXPR containing Scheme program text, + evaluate it, and return the result of the last expression evaluated. */ +SCM +scm_c_eval_string (const char *expr) +{ + return scm_eval_string (scm_makfrom0str (expr)); +} + +SCM +scm_c_eval_string_in_module (const char *expr, SCM module) +{ + return scm_eval_string_in_module (scm_makfrom0str (expr), module); +} + + +static SCM +inner_eval_string (void *data) +{ + SCM port = (SCM)data; + SCM form; + SCM ans = SCM_UNSPECIFIED; + + /* Read expressions from that port; ignore the values. */ + while (!SCM_EOF_OBJECT_P (form = scm_read (port))) + ans = scm_primitive_eval_x (form); + + /* Don't close the port here; if we re-enter this function via a + continuation, then the next time we enter it, we'll get an error. + It's a string port anyway, so there's no advantage to closing it + early. */ + + return ans; +} + +SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, + (SCM string, SCM module), + "Evaluate @var{string} as the text representation of a Scheme\n" + "form or forms, and return whatever value they produce.\n" + "Evaluation takes place in the given module, or the current\n" + "module when no module is given.\n" + "While the code is evaluated, the given module is made the\n" + "current one. The current module is restored when this\n" + "procedure returns.") +#define FUNC_NAME s_scm_eval_string_in_module +{ + SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, + FUNC_NAME); + if (SCM_UNBNDP (module)) + module = scm_current_module (); + return scm_c_call_with_current_module (module, + inner_eval_string, (void *)port); +} +#undef FUNC_NAME + +SCM +scm_eval_string (SCM string) +{ + return scm_eval_string_in_module (string, SCM_UNDEFINED); +} + +static scm_t_bits +scm_make_stptob () +{ + scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write); + + scm_set_port_mark (tc, scm_markstream); + scm_set_port_end_input (tc, st_end_input); + scm_set_port_flush (tc, st_flush); + scm_set_port_seek (tc, st_seek); + scm_set_port_truncate (tc, st_truncate); + + return tc; +} + +void +scm_init_strports () +{ + scm_tc16_strport = scm_make_stptob (); + +#include "libguile/strports.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/