X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3fe6190f46da0ac53fc7f4af860789cb33bd642e..7caa1b0780eda67bc7e50969c3a5436f3710d6d4:/libguile/strports.c?ds=sidebyside diff --git a/libguile/strports.c b/libguile/strports.c index 422feac08..107fedd01 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999 Free Software Foundation, Inc. +/* 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 @@ -38,15 +38,28 @@ * 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 -#include "_scm.h" -#include "unif.h" -#include "eval.h" -#include "read.h" +#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 "strports.h" +#include "libguile/strports.h" #ifdef HAVE_STRING_H #include @@ -63,41 +76,45 @@ 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 0. + when rw_active is SCM_PORT_NEITHER. */ -static int -prinstpt (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_prinport (exp, port, "string"); - return !0; -} +scm_t_bits scm_tc16_strport; + static int stfill_buffer (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->read_pos >= pt->read_end) return EOF; else - return scm_return_first (*(pt->read_pos++), port); + 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_port *pt, off_t new_size) +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; - scm_vector_set_length_x (pt->stream, SCM_MAKINUM (new_size)); + for (i = 0; i != min_size; ++i) + SCM_STRING_CHARS (new_stream) [i] = SCM_STRING_CHARS (old_stream) [i]; - /* reset buffer in case reallocation moved the string. */ + /* reset buffer. */ { - pt->read_buf = pt->write_buf = SCM_CHARS (pt->stream); + 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; @@ -112,7 +129,7 @@ st_resize_port (scm_port *pt, off_t new_size) static void st_flush (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (pt->write_pos == pt->write_end) { @@ -124,69 +141,117 @@ st_flush (SCM port) pt->read_end = (unsigned char *) pt->read_pos; pt->read_buf_size = pt->read_end - pt->read_buf; } - pt->rw_active = 0; + 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_read_flush (SCM port, int offset) +st_end_input (SCM port, int offset) { - scm_port *pt = SCM_PTAB_ENTRY (port); + 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->rw_active = 0; + 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_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); off_t target; - /* we can assume at this point that pt->write_pos == pt->read_pos. */ - switch (whence) + if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) + /* special case to avoid disturbing the unread-char buffer. */ { - 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 (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; + } } - if (target < 0) - scm_misc_error ("st_seek", "negative offset", SCM_EOL); - if (target >= pt->write_buf_size) + else + /* all other cases. */ { - if (!(SCM_CAR (port) & SCM_WRTNG)) + if (pt->rw_active == SCM_PORT_WRITE) + st_flush (port); + + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (port); + + switch (whence) { - if (target > pt->write_buf_size) + 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 { - scm_misc_error ("st_seek", "seek past end of read-only strport", - SCM_EOL); + st_resize_port (pt, target + (target == pt->write_buf_size + ? SCM_WRITE_BLOCK + : 0)); } } - else + pt->read_pos = pt->write_pos = pt->read_buf + target; + if (pt->read_pos > pt->read_end) { - st_resize_port (pt, target + (target == pt->write_buf_size - ? SCM_WRITE_BLOCK - : 0)); + pt->read_end = (unsigned char *) pt->read_pos; + pt->read_buf_size = pt->read_end - pt->read_buf; } } - 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_ftruncate (SCM port, off_t length) +st_truncate (SCM port, off_t length) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (length > pt->write_buf_size) st_resize_port (pt, length); @@ -201,37 +266,31 @@ st_ftruncate (SCM port, off_t length) } SCM -scm_mkstrport (pos, str, modes, caller) - SCM pos; - SCM str; - long modes; - const char * caller; +scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { SCM z; - scm_port *pt; - int str_len; + scm_t_port *pt; + size_t str_len; 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); - str_len = SCM_ROLENGTH (str); + 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_NEWCELL (z); + SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_strport | modes); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, str); - pt->write_buf = pt->read_buf = SCM_ROCHARS (str); + 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; - /* doesn't check (modes & SCM_RDNG), since the read_buf must be - maintained even for output-only ports. */ - pt->rw_random = modes & SCM_WRTNG; + pt->rw_random = 1; SCM_ALLOW_INTS; @@ -244,78 +303,126 @@ scm_mkstrport (pos, str, modes, caller) /* create a new string from a string port's buffer. */ SCM scm_strport_to_string (SCM port) { - scm_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM str; if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); - return scm_makfromstr (SCM_CHARS (SCM_STREAM (port)), - pt->read_buf_size, 0); + + str = scm_mem2string ((char *) pt->read_buf, pt->read_buf_size); + scm_remember_upto_here_1 (port); + return str; } -SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string); +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; -SCM -scm_call_with_output_string (proc) - SCM proc; + 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, - s_call_with_output_string); - scm_apply (proc, p, scm_listofnull); + FUNC_NAME); + scm_call_1 (proc, p); return scm_strport_to_string (p); } - - - -/* Return a Scheme string obtained by printing a given object. - */ - - -SCM -scm_strprint_obj (obj) - SCM obj; +#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 str; - SCM port; - - str = scm_makstr (0, 0); - port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); - scm_prin1 (obj, port, 1); - { - return scm_strport_to_string (port); - } + SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME); + return scm_call_1 (proc, p); } - - - - -SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string); - -SCM -scm_call_with_input_string (str, proc) - SCM str; - SCM proc; +#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, s_call_with_input_string); - return scm_apply (proc, p, scm_listofnull); + 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_read_0str (expr) - char *expr; +scm_c_read_string (const char *expr) { SCM port = scm_mkstrport (SCM_INUM0, scm_makfrom0str (expr), SCM_OPN | SCM_RDNG, - "scm_eval_0str"); + "scm_c_read_string"); SCM form; /* Read expressions from that port; ignore the values. */ @@ -328,27 +435,28 @@ scm_read_0str (expr) /* Given a null-terminated string EXPR containing Scheme program text, evaluate it, and return the result of the last expression evaluated. */ SCM -scm_eval_0str (expr) - char *expr; +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); +} -SCM_PROC (s_eval_string, "eval-string", 1, 0, 0, scm_eval_string); -SCM -scm_eval_string (string) - SCM string; +static SCM +inner_eval_string (void *data) { - SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG, - "scm_eval_0str"); + 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_eval_x (form); + 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. @@ -358,38 +466,57 @@ scm_eval_string (string) return ans; } - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; +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 { - return 0; + 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); +} -scm_ptobfuns scm_stptob = +static scm_t_bits +scm_make_stptob () { - scm_markstream, - noop0, - prinstpt, - 0, - st_flush, - st_read_flush, - 0, - stfill_buffer, - st_seek, - st_ftruncate, - 0, -}; + 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 () { -#include "strports.x" + scm_tc16_strport = scm_make_stptob (); + +#include "libguile/strports.x" } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/