src/ports.c

   1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
   2    Copyright (C) 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
   3
   4    Guile-R6RS-Libs is free software; you can redistribute it and/or
   5    modify it under the terms of the GNU Lesser General Public
   6    License as published by the Free Software Foundation; either
   7    version 2.1 of the License, or (at your option) any later version.
   8
   9    Guile-R6RS-Libs is distributed in the hope that it will be useful,
  10    but 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 Guile-R6RS-Libs; if not, write to the Free Software
  16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA  */
  17
  18 #include "config.h"
  19
  20 #include <libguile.h>
  21 #include <stdio.h>
  22
  23 #include "bytevector.h"
  24 #include "utils.h"
  25
  26
  27 \f
  28 /* End-of-file object.  */
  29
  30 SCM_DEFINE (scm_r6rs_eof_object, "eof-object", 0, 0, 0,
  31             (void),
  32             "Return the end-of-file object.")
  33 #define FUNC_NAME s_scm_r6rs_eof_object
  34 {
  35   return (SCM_EOF_VAL);
  36 }
  37 #undef FUNC_NAME
  38
  39 \f
  40 /* Binary input.  */
  41
  42 /* We currently don't support specific binary input ports.  */
  43 #define SCM_VALIDATE_R6RS_BINARY_INPUT_PORT SCM_VALIDATE_INPUT_PORT
  44
  45 SCM_DEFINE (scm_r6rs_get_u8, "get-u8", 1, 0, 0,
  46             (SCM port),
  47             "Read an octet from @var{port}, a binary input port, "
  48             "blocking as necessary.")
  49 #define FUNC_NAME s_scm_r6rs_get_u8
  50 {
  51   SCM result;
  52   int c_result;
  53
  54   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
  55
  56   c_result = scm_getc (port);
  57   if (c_result == EOF)
  58     result = SCM_EOF_VAL;
  59   else
  60     result = SCM_I_MAKINUM ((unsigned char) c_result);
  61
  62   return result;
  63 }
  64 #undef FUNC_NAME
  65
  66 SCM_DEFINE (scm_r6rs_lookahead_u8, "lookahead-u8", 1, 0, 0,
  67             (SCM port),
  68             "Like @code{get-u8} but does not update @var{port} to "
  69             "point past the octet.")
  70 #define FUNC_NAME s_scm_r6rs_lookahead_u8
  71 {
  72   SCM result;
  73
  74   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
  75
  76   result = scm_peek_char (port);
  77   if (SCM_CHARP (result))
  78     result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
  79   else
  80     result = SCM_EOF_VAL;
  81
  82   return result;
  83 }
  84 #undef FUNC_NAME
  85
  86 SCM_DEFINE (scm_r6rs_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
  87             (SCM port, SCM count),
  88             "Read @var{count} octets from @var{port}, blocking as "
  89             "necessary and return a bytevector containing the octets "
  90             "read.  If fewer bytes are available, a bytevector smaller "
  91             "than @var{count} is returned.")
  92 #define FUNC_NAME s_scm_r6rs_get_bytevector_n
  93 {
  94   SCM result;
  95   char *c_bv;
  96   unsigned c_count;
  97   size_t read;
  98
  99   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 100   c_count = scm_to_uint (count);
 101
 102   c_bv = (char *) scm_gc_malloc (c_count, SCM_GC_BYTEVECTOR);
 103
 104   /* XXX: `scm_c_read ()' does not update the port position.  */
 105   read = scm_c_read (port, c_bv, c_count);
 106
 107   if (read == 0)
 108     {
 109       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 110         result = SCM_EOF_VAL;
 111       else
 112         result = scm_r6rs_c_take_bytevector (NULL, 0);
 113     }
 114   else
 115     {
 116       if (read < c_count)
 117         c_bv = (char *) scm_gc_realloc (c_bv, c_count, read,
 118                                         SCM_GC_BYTEVECTOR);
 119
 120       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, read);
 121     }
 122
 123   return result;
 124 }
 125 #undef FUNC_NAME
 126
 127 SCM_DEFINE (scm_r6rs_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
 128             (SCM port, SCM bv, SCM start, SCM count),
 129             "Read @var{count} bytes from @var{port} and store them "
 130             "in @var{bv} starting at index @var{start}.  Return either "
 131             "the number of bytes actually read or the end-of-file "
 132             "object.")
 133 #define FUNC_NAME s_scm_r6rs_get_bytevector_n_x
 134 {
 135   SCM result;
 136   char *c_bv;
 137   unsigned c_start, c_count, c_len;
 138   size_t c_read;
 139
 140   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 141   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 142   c_start = scm_to_uint (start);
 143   c_count = scm_to_uint (count);
 144
 145   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 146   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 147
 148   if (EXPECT_FALSE (c_start + c_count > c_len))
 149     scm_out_of_range (FUNC_NAME, count);
 150
 151   c_read = scm_c_read (port, c_bv + c_start, c_count);
 152   if (c_read == 0)
 153     {
 154       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 155         result = SCM_EOF_VAL;
 156       else
 157         result = SCM_I_MAKINUM (0);
 158     }
 159   else
 160     result = scm_from_size_t (c_read);
 161
 162   return result;
 163 }
 164 #undef FUNC_NAME
 165
 166
 167 SCM_DEFINE (scm_r6rs_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 168             (SCM port),
 169             "Read from @var{port}, blocking as necessary, until data "
 170             "are available or and end-of-file is reached.  Return either "
 171             "a new bytevector containing the data read or the "
 172             "end-of-file object.")
 173 #define FUNC_NAME s_scm_r6rs_get_bytevector_some
 174 {
 175   /* Read at least one byte, unless the end-of-file is already reached, and
 176      read while characters are available (buffered).  */
 177
 178   SCM result;
 179   char *c_bv;
 180   unsigned c_len;
 181   size_t c_total;
 182
 183   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 184
 185   c_len = 4096;
 186   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 187   c_total = 0;
 188
 189   do
 190     {
 191       int c_chr;
 192
 193       if (c_total + 1 > c_len)
 194         {
 195           /* Grow the bytevector.  */
 196           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 197                                           SCM_GC_BYTEVECTOR);
 198           c_len *= 2;
 199         }
 200
 201       /* We can't use `scm_c_read ()' since it blocks.  */
 202       c_chr = scm_getc (port);
 203       if (c_chr != EOF)
 204         {
 205           c_bv[c_total] = (char) c_chr;
 206           c_total++;
 207         }
 208     }
 209   while ((scm_is_true (scm_char_ready_p (port)))
 210          && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
 211
 212   if (c_total == 0)
 213     {
 214       result = SCM_EOF_VAL;
 215       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 216     }
 217   else
 218     {
 219       if (c_len > c_total)
 220         {
 221           /* Shrink the bytevector.  */
 222           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 223                                           SCM_GC_BYTEVECTOR);
 224           c_len = (unsigned) c_total;
 225         }
 226
 227       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 228     }
 229
 230   return result;
 231 }
 232 #undef FUNC_NAME
 233
 234 SCM_DEFINE (scm_r6rs_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 235             (SCM port),
 236             "Read from @var{port}, blocking as necessary, until "
 237             "the end-of-file is reached.  Return either "
 238             "a new bytevector containing the data read or the "
 239             "end-of-file object (if no data were available).")
 240 #define FUNC_NAME s_scm_r6rs_get_bytevector_all
 241 {
 242   SCM result;
 243   char *c_bv;
 244   unsigned c_len, c_count;
 245   size_t c_read, c_total;
 246
 247   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 248
 249   c_len = c_count = 4096;
 250   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 251   c_total = c_read = 0;
 252
 253   do
 254     {
 255       if (c_total + c_read > c_len)
 256         {
 257           /* Grow the bytevector.  */
 258           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 259                                           SCM_GC_BYTEVECTOR);
 260           c_count = c_len;
 261           c_len *= 2;
 262         }
 263
 264       /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
 265          reached.  */
 266       c_read = scm_c_read (port, c_bv + c_total, c_count);
 267       c_total += c_read, c_count -= c_read;
 268     }
 269   while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
 270
 271   if (c_total == 0)
 272     {
 273       result = SCM_EOF_VAL;
 274       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 275     }
 276   else
 277     {
 278       if (c_len > c_total)
 279         {
 280           /* Shrink the bytevector.  */
 281           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 282                                           SCM_GC_BYTEVECTOR);
 283           c_len = (unsigned) c_total;
 284         }
 285
 286       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 287     }
 288
 289   return result;
 290 }
 291 #undef FUNC_NAME
 292
 293
 294 \f
 295 /* Binary output.  */
 296
 297 /* We currently don't support specific binary input ports.  */
 298 #define SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OUTPUT_PORT
 299
 300
 301 SCM_DEFINE (scm_r6rs_put_u8, "put-u8", 2, 0, 0,
 302             (SCM port, SCM octet),
 303             "Write @var{octet} to binary port @var{port}.")
 304 #define FUNC_NAME s_scm_r6rs_put_u8
 305 {
 306   scm_t_uint8 c_octet;
 307
 308   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 309   c_octet = scm_to_uint8 (octet);
 310
 311   scm_putc ((char) c_octet, port);
 312
 313   return SCM_UNSPECIFIED;
 314 }
 315 #undef FUNC_NAME
 316
 317 SCM_DEFINE (scm_r6rs_put_bytevector, "put-bytevector", 2, 2, 0,
 318             (SCM port, SCM bv, SCM start, SCM count),
 319             "Write the contents of @var{bv} to @var{port}, optionally "
 320             "starting at index @var{start} and limiting to @var{count} "
 321             "octets.")
 322 #define FUNC_NAME s_scm_r6rs_put_bytevector
 323 {
 324   char *c_bv;
 325   unsigned c_start, c_count, c_len;
 326
 327   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 328   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 329
 330   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 331   c_bv = SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 332
 333   if (start != SCM_UNDEFINED)
 334     {
 335       c_start = scm_to_uint (start);
 336
 337       if (count != SCM_UNDEFINED)
 338         {
 339           c_count = scm_to_uint (count);
 340           if (EXPECT_FALSE (c_start + c_count > c_len))
 341             scm_out_of_range (FUNC_NAME, count);
 342         }
 343       else
 344         {
 345           if (EXPECT_FALSE (c_start >= c_len))
 346             scm_out_of_range (FUNC_NAME, start);
 347           else
 348             c_count = c_len - c_start;
 349         }
 350     }
 351   else
 352     c_start = 0, c_count = c_len;
 353
 354   scm_c_write (port, c_bv + c_start, c_count);
 355
 356   return SCM_UNSPECIFIED;
 357 }
 358 #undef FUNC_NAME
 359
 360 \f
 361 /* Initialization.  */
 362
 363 void
 364 scm_init_r6rs_ports (void)
 365 {
 366 #include "ports.c.x"
 367 }
 368
 369 /* arch-tag: c041ffd6-8871-40e8-a25a-d0f8768a71dc
 370  */