libguile/rdelim.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2006,
   2  *   2011 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20 #ifdef HAVE_CONFIG_H
  21 #  include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25
  26 #include <stdio.h>
  27
  28 #ifdef HAVE_STRING_H
  29 #include <string.h>
  30 #endif
  31
  32 #include "libguile/chars.h"
  33 #include "libguile/modules.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/rdelim.h"
  36 #include "libguile/root.h"
  37 #include "libguile/strings.h"
  38 #include "libguile/strports.h"
  39 #include "libguile/validate.h"
  40
  41 SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
  42             (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end),
  43             "Read characters from @var{port} into @var{str} until one of the\n"
  44             "characters in the @var{delims} string is encountered.  If\n"
  45             "@var{gobble} is true, discard the delimiter character;\n"
  46             "otherwise, leave it in the input stream for the next read.  If\n"
  47             "@var{port} is not specified, use the value of\n"
  48             "@code{(current-input-port)}.  If @var{start} or @var{end} are\n"
  49             "specified, store data only into the substring of @var{str}\n"
  50             "bounded by @var{start} and @var{end} (which default to the\n"
  51             "beginning and end of the string, respectively).\n"
  52             "\n"
  53             " Return a pair consisting of the delimiter that terminated the\n"
  54             "string and the number of characters read.  If reading stopped\n"
  55             "at the end of file, the delimiter returned is the\n"
  56             "@var{eof-object}; if the string was filled without encountering\n"
  57             "a delimiter, this value is @code{#f}.")
  58 #define FUNC_NAME s_scm_read_delimited_x
  59 {
  60   size_t j;
  61   size_t cstart;
  62   size_t cend;
  63   scm_t_wchar c;
  64   size_t num_delims;
  65
  66   SCM_VALIDATE_STRING (1, delims);
  67   num_delims = scm_i_string_length (delims);
  68
  69   SCM_VALIDATE_STRING (2, str);
  70   scm_i_get_substring_spec (scm_i_string_length (str),
  71                             start, &cstart, end, &cend);
  72
  73   if (SCM_UNBNDP (port))
  74     port = scm_current_input_port ();
  75   else
  76     SCM_VALIDATE_OPINPORT (4, port);
  77
  78   for (j = cstart; j < cend; j++)
  79     {
  80       size_t k;
  81
  82       c = scm_getc_unlocked (port);
  83       for (k = 0; k < num_delims; k++)
  84         {
  85           if (scm_i_string_ref (delims, k) == c)
  86             {
  87               if (scm_is_false (gobble))
  88                 scm_ungetc_unlocked (c, port);
  89
  90               return scm_cons (SCM_MAKE_CHAR (c),
  91                                scm_from_size_t (j - cstart));
  92             }
  93         }
  94       if (c == EOF)
  95         return scm_cons (SCM_EOF_VAL,
  96                          scm_from_size_t (j - cstart));
  97
  98       scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
  99     }
 100   return scm_cons (SCM_BOOL_F, scm_from_size_t (j - cstart));
 101 }
 102 #undef FUNC_NAME
 103
 104
 105 /*
 106  * %read-line
 107  * truncates any terminating newline from its input, and returns
 108  * a cons of the string read and its terminating character.  Doing
 109  * so makes it easy to implement the hairy `read-line' options
 110  * efficiently in Scheme.
 111  */
 112
 113 SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
 114             (SCM port),
 115             "Read a newline-terminated line from @var{port}, allocating storage as\n"
 116             "necessary.  The newline terminator (if any) is removed from the string,\n"
 117             "and a pair consisting of the line and its delimiter is returned.  The\n"
 118             "delimiter may be either a newline or the @var{eof-object}; if\n"
 119             "@code{%read-line} is called at the end of file, it returns the pair\n"
 120             "@code{(#<eof> . #<eof>)}.")
 121 #define FUNC_NAME s_scm_read_line
 122 {
 123 /* Threshold under which the only allocation performed is that of the
 124    resulting string and pair.  */
 125 #define LINE_BUFFER_SIZE 256
 126
 127   SCM line, strings, result;
 128   scm_t_wchar buf[LINE_BUFFER_SIZE], delim;
 129   size_t index;
 130
 131   if (SCM_UNBNDP (port))
 132     port = scm_current_input_port ();
 133
 134   SCM_VALIDATE_OPINPORT (1,port);
 135
 136   index = 0;
 137   delim = 0;
 138   strings = SCM_BOOL_F;
 139
 140   do
 141     {
 142       if (SCM_UNLIKELY (index >= LINE_BUFFER_SIZE))
 143         {
 144           /* The line is getting longer than BUF so store its current
 145              contents in STRINGS.  */
 146           strings = scm_cons (scm_from_utf32_stringn (buf, index),
 147                               scm_is_false (strings) ? SCM_EOL : strings);
 148           index = 0;
 149         }
 150       else
 151         {
 152           buf[index] = scm_getc_unlocked (port);
 153           switch (buf[index])
 154             {
 155             case EOF:
 156             case '\n':
 157               delim = buf[index];
 158               break;
 159
 160             default:
 161               index++;
 162             }
 163         }
 164     }
 165   while (delim == 0);
 166
 167   if (SCM_LIKELY (scm_is_false (strings)))
 168     /* The fast path.  */
 169     line = scm_from_utf32_stringn (buf, index);
 170   else
 171     {
 172       /* Aggregate the intermediary results.  */
 173       strings = scm_cons (scm_from_utf32_stringn (buf, index), strings);
 174       line = scm_string_concatenate (scm_reverse (strings));
 175     }
 176
 177   if (delim == EOF && scm_i_string_length (line) == 0)
 178     result = scm_cons (SCM_EOF_VAL, SCM_EOF_VAL);
 179   else
 180     result = scm_cons (line,
 181                        delim == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (delim));
 182
 183   return result;
 184 #undef LINE_BUFFER_SIZE
 185 }
 186 #undef FUNC_NAME
 187
 188 SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
 189             (SCM obj, SCM port),
 190             "Display @var{obj} and a newline character to @var{port}.  If\n"
 191             "@var{port} is not specified, @code{(current-output-port)} is\n"
 192             "used.  This function is equivalent to:\n"
 193             "@lisp\n"
 194             "(display obj [port])\n"
 195             "(newline [port])\n"
 196             "@end lisp")
 197 #define FUNC_NAME s_scm_write_line
 198 {
 199   scm_display (obj, port);
 200   return scm_newline (port);
 201 }
 202 #undef FUNC_NAME
 203
 204 SCM
 205 scm_init_rdelim_builtins (void)
 206 {
 207 #include "libguile/rdelim.x"
 208
 209   return SCM_UNSPECIFIED;
 210 }
 211
 212 void
 213 scm_init_rdelim (void)
 214 {
 215   scm_c_define_gsubr ("%init-rdelim-builtins", 0, 0, 0,
 216                       scm_init_rdelim_builtins);
 217 }
 218
 219 /*
 220   Local Variables:
 221   c-file-style: "gnu"
 222   End:
 223 */