src/ports.c

   1 /* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
   2    Copyright (C) 2007, 2008  Ludovic Courtès <ludo@gnu.org>
   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 #include "compat.h"
  20
  21 #include <libguile.h>
  22 #include <string.h>
  23 #include <stdio.h>
  24
  25 #include "ports.h"
  26 #include "bytevector.h"
  27 #include "utils.h"
  28
  29 \f
  30 /* Unimplemented features.  */
  31
  32
  33 /* Transoders are currently not implemented since Guile 1.8 is not
  34    Unicode-capable.  Thus, most of the code here assumes the use of the
  35    binary transcoder.  */
  36 static inline void
  37 transcoders_not_implemented (void)
  38 {
  39   fprintf (stderr, "%s: warning: transcoders not implemented\n",
  40            PACKAGE_NAME);
  41 }
  42
  43 \f
  44 /* End-of-file object.  */
  45
  46 SCM_DEFINE (scm_r6rs_eof_object, "eof-object", 0, 0, 0,
  47             (void),
  48             "Return the end-of-file object.")
  49 #define FUNC_NAME s_scm_r6rs_eof_object
  50 {
  51   return (SCM_EOF_VAL);
  52 }
  53 #undef FUNC_NAME
  54
  55 \f
  56 /* Input ports.  */
  57
  58 #ifndef MIN
  59 # define MIN(a,b) ((a) < (b) ? (a) : (b))
  60 #endif
  61
  62 /* Bytevector input ports or "bip" for short.  */
  63 static scm_t_bits bytevector_input_port_type = 0;
  64
  65 static inline SCM
  66 make_bip (SCM bv)
  67 {
  68   SCM port;
  69   char *c_bv;
  70   unsigned c_len;
  71   scm_t_port *c_port;
  72   const unsigned long mode_bits = SCM_OPN | SCM_RDNG | SCM_BUF0;
  73
  74   port = scm_new_port_table_entry (bytevector_input_port_type);
  75
  76   /* Prevent BV from being GC'd.  */
  77   SCM_SETSTREAM (port, SCM_UNPACK (bv));
  78
  79   /* Have the port directly access the bytevector.  */
  80   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
  81   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
  82
  83   c_port = SCM_PTAB_ENTRY (port);
  84   c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
  85   c_port->read_end = (unsigned char *) c_bv + c_len;
  86
  87   /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
  88   SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
  89
  90   return port;
  91 }
  92
  93 static SCM
  94 bip_mark (SCM port)
  95 {
  96   /* Mark the underlying bytevector.  */
  97   return (SCM_PACK (SCM_STREAM (port)));
  98 }
  99
 100 #ifndef HAVE_SCM_SET_PORT_READ
 101
 102 static int
 103 bip_fill_input (SCM port)
 104 {
 105   int result;
 106   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 107
 108   if (c_port->read_pos >= c_port->read_end)
 109     result = EOF;
 110   else
 111     result = (int) *c_port->read_pos;
 112
 113   return result;
 114 }
 115
 116 #else /* HAVE_SCM_SET_PORT_READ */
 117
 118 static size_t
 119 bip_read (SCM port, void *buffer, size_t size)
 120 {
 121   size_t remaining, count;
 122   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 123
 124   remaining = c_port->read_end - c_port->read_pos;
 125   count = MIN (remaining, size);
 126
 127   memcpy (buffer, c_port->read_pos, count);
 128   c_port->read_pos += count;
 129
 130   return count;
 131 }
 132
 133 #endif /* HAVE_SCM_SET_PORT_READ */
 134
 135 static off_t
 136 bip_seek (SCM port, off_t offset, int whence)
 137 #define FUNC_NAME "bip_seek"
 138 {
 139   off_t c_result = 0;
 140   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 141
 142   switch (whence)
 143     {
 144     case SEEK_CUR:
 145       offset += c_port->read_pos - c_port->read_buf;
 146       /* Fall through.  */
 147
 148     case SEEK_SET:
 149       if (c_port->read_buf + offset < c_port->read_end)
 150         {
 151           c_port->read_pos = c_port->read_buf + offset;
 152           c_result = offset;
 153         }
 154       else
 155         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 156       break;
 157
 158     case SEEK_END:
 159       if (c_port->read_end - offset >= c_port->read_buf)
 160         {
 161           c_port->read_pos = c_port->read_end - offset;
 162           c_result = c_port->read_pos - c_port->read_buf;
 163         }
 164       else
 165         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 166       break;
 167
 168     default:
 169       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 170                               "invalid `seek' parameter");
 171     }
 172
 173   return c_result;
 174 }
 175 #undef FUNC_NAME
 176
 177
 178 /* Instantiate the bytevector input port type.  */
 179 static inline void
 180 initialize_bytevector_input_ports (void)
 181 {
 182   bytevector_input_port_type =
 183     scm_make_port_type ("r6rs-bytevector-input-port",
 184                         PORT_FILL_INPUT_METHOD (bip_fill_input),
 185                         NULL);
 186
 187   scm_set_port_read (bytevector_input_port_type, bip_read);
 188   scm_set_port_mark (bytevector_input_port_type, bip_mark);
 189   scm_set_port_seek (bytevector_input_port_type, bip_seek);
 190 }
 191
 192
 193 SCM_DEFINE (scm_r6rs_open_bytevector_input_port,
 194             "open-bytevector-input-port", 1, 1, 0,
 195             (SCM bv, SCM transcoder),
 196             "Return an input port whose contents are drawn from "
 197             "bytevector @var{bv}.")
 198 #define FUNC_NAME s_scm_r6rs_open_bytevector_input_port
 199 {
 200   SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv);
 201   if (transcoder != SCM_UNDEFINED)
 202     transcoders_not_implemented ();
 203
 204   return (make_bip (bv));
 205 }
 206 #undef FUNC_NAME
 207
 208
 209 \f
 210 /* Custom binary input port ("cbip" for short).  */
 211
 212 static scm_t_bits custom_binary_input_port_type = 0;
 213
 214 /* Size of the buffer embedded in custom binary input ports.  */
 215 #define CBIP_BUFFER_SIZE  4096
 216
 217 /* Return the bytevector associated to PORT.  */
 218 #define SCM_R6RS_CBIP_BYTEVECTOR(_port)                         \
 219   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
 220
 221 /* Return the various procedures of PORT.  */
 222 #define SCM_R6RS_CBIP_READ_PROC(_port)                          \
 223   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
 224 #define SCM_R6RS_CBIP_GET_POSITION_PROC(_port)                  \
 225   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
 226 #define SCM_R6RS_CBIP_SET_POSITION_PROC(_port)                  \
 227   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
 228 #define SCM_R6RS_CBIP_CLOSE_PROC(_port)                         \
 229   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
 230
 231
 232 static inline SCM
 233 make_cbip (SCM read_proc, SCM get_position_proc,
 234            SCM set_position_proc, SCM close_proc)
 235 {
 236   SCM port, bv, method_vector;
 237   char *c_bv;
 238   unsigned c_len;
 239   scm_t_port *c_port;
 240   const unsigned long mode_bits = SCM_OPN | SCM_RDNG | SCM_BUF0;
 241
 242   /* Use a bytevector as the underlying buffer.  */
 243   c_len = CBIP_BUFFER_SIZE;
 244   bv = scm_r6rs_c_make_bytevector (c_len);
 245   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 246
 247   /* Store the various methods and bytevector in a vector.  */
 248   method_vector = scm_c_make_vector (5, SCM_BOOL_F);
 249   SCM_SIMPLE_VECTOR_SET (method_vector, 0, bv);
 250   SCM_SIMPLE_VECTOR_SET (method_vector, 1, read_proc);
 251   SCM_SIMPLE_VECTOR_SET (method_vector, 2, get_position_proc);
 252   SCM_SIMPLE_VECTOR_SET (method_vector, 3, set_position_proc);
 253   SCM_SIMPLE_VECTOR_SET (method_vector, 4, close_proc);
 254
 255   port = scm_new_port_table_entry (custom_binary_input_port_type);
 256
 257   /* Attach it the method vector.  */
 258   SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
 259
 260   /* Have the port directly access the buffer (bytevector).  */
 261   c_port = SCM_PTAB_ENTRY (port);
 262   c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
 263   c_port->read_end = (unsigned char *) c_bv;
 264
 265   /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
 266   SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
 267
 268   return port;
 269 }
 270
 271 static SCM
 272 cbip_mark (SCM port)
 273 {
 274   /* Mark the underlying bytevector and methods.  */
 275   return (SCM_PACK (SCM_STREAM (port)));
 276 }
 277
 278 static int
 279 cbip_fill_input (SCM port)
 280 #define FUNC_NAME "cbip_fill_input"
 281 {
 282   int result;
 283   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 284
 285  again:
 286   if (c_port->read_pos >= c_port->read_end)
 287     {
 288       /* Invoke the user's `read!' procedure.  */
 289       unsigned c_octets;
 290       SCM bv, read_proc, octets;
 291
 292       bv = SCM_R6RS_CBIP_BYTEVECTOR (port);
 293       read_proc = SCM_R6RS_CBIP_READ_PROC (port);
 294
 295       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
 296                            SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
 297       c_octets = scm_to_uint (octets);
 298
 299       c_port->read_pos = (unsigned char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 300       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
 301
 302       if (c_octets > 0)
 303         goto again;
 304       else
 305         result = EOF;
 306     }
 307   else
 308     result = (int) *c_port->read_pos;
 309
 310   return result;
 311 }
 312 #undef FUNC_NAME
 313
 314 static off_t
 315 cbip_seek (SCM port, off_t offset, int whence)
 316 #define FUNC_NAME "cbip_seek"
 317 {
 318   SCM result;
 319   off_t c_result = 0;
 320
 321   switch (whence)
 322     {
 323     case SEEK_CUR:
 324       {
 325         SCM get_position_proc;
 326
 327         get_position_proc = SCM_R6RS_CBIP_GET_POSITION_PROC (port);
 328         if (EXPECT_TRUE (scm_is_true (get_position_proc)))
 329           result = scm_call_0 (get_position_proc);
 330         else
 331           scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 332                                   "R6RS custom binary input port does not "
 333                                   "support `port-position'");
 334
 335         offset += scm_to_int (result);
 336         /* Fall through.  */
 337       }
 338
 339     case SEEK_SET:
 340       {
 341         SCM set_position_proc;
 342
 343         set_position_proc = SCM_R6RS_CBIP_SET_POSITION_PROC (port);
 344         if (EXPECT_TRUE (scm_is_true (set_position_proc)))
 345           result = scm_call_1 (set_position_proc, scm_from_int (offset));
 346         else
 347           scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 348                                   "R6RS custom binary input port does not "
 349                                   "support `set-port-position!'");
 350
 351         /* Assuming setting the position succeeded.  */
 352         c_result = offset;
 353         break;
 354       }
 355
 356     default:
 357       /* `SEEK_END' cannot be supported.  */
 358       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 359                               "R6RS custom binary input ports do not "
 360                               "support `SEEK_END'");
 361     }
 362
 363   return c_result;
 364 }
 365 #undef FUNC_NAME
 366
 367 static int
 368 cbip_close (SCM port)
 369 {
 370   SCM close_proc;
 371
 372   close_proc = SCM_R6RS_CBIP_CLOSE_PROC (port);
 373   if (scm_is_true (close_proc))
 374     /* Invoke the `close' thunk.  */
 375     scm_call_0 (close_proc);
 376
 377   return 1;
 378 }
 379
 380
 381 SCM_DEFINE (scm_r6rs_make_custom_binary_input_port,
 382             "make-custom-binary-input-port", 2, 3, 0,
 383             (SCM id, SCM read_proc, SCM get_position_proc,
 384              SCM set_position_proc, SCM close_proc),
 385             "Return a new custom binary input port whose input is drained "
 386             "by invoking @var{read_proc} and passing it a bytevector, an "
 387             "index where octets should be written, and an octet count.")
 388 #define FUNC_NAME s_scm_r6rs_make_custom_binary_input_port
 389 {
 390   SCM_VALIDATE_STRING (1, id);
 391   SCM_VALIDATE_PROC (2, read_proc);
 392
 393   if (get_position_proc == SCM_UNDEFINED)
 394     get_position_proc = SCM_BOOL_F;
 395   else
 396     SCM_VALIDATE_PROC (3, get_position_proc);
 397
 398   if (set_position_proc == SCM_UNDEFINED)
 399     set_position_proc = SCM_BOOL_F;
 400   else
 401     SCM_VALIDATE_PROC (4, set_position_proc);
 402
 403   if (close_proc == SCM_UNDEFINED)
 404     close_proc = SCM_BOOL_F;
 405   else
 406     SCM_VALIDATE_PROC (5, close_proc);
 407
 408   return (make_cbip (read_proc, get_position_proc, set_position_proc,
 409                      close_proc));
 410 }
 411 #undef FUNC_NAME
 412
 413
 414 /* Instantiate the custom binary input port type.  */
 415 static inline void
 416 initialize_custom_binary_input_ports (void)
 417 {
 418   custom_binary_input_port_type =
 419     scm_make_port_type ("r6rs-custom-binary-input-port",
 420                         cbip_fill_input, NULL);
 421
 422   scm_set_port_mark (custom_binary_input_port_type, cbip_mark);
 423   scm_set_port_seek (custom_binary_input_port_type, cbip_seek);
 424   scm_set_port_close (custom_binary_input_port_type, cbip_close);
 425 }
 426
 427
 428 \f
 429 /* Binary input.  */
 430
 431 /* We currently don't support specific binary input ports.  */
 432 #define SCM_VALIDATE_R6RS_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
 433
 434 SCM_DEFINE (scm_r6rs_get_u8, "get-u8", 1, 0, 0,
 435             (SCM port),
 436             "Read an octet from @var{port}, a binary input port, "
 437             "blocking as necessary.")
 438 #define FUNC_NAME s_scm_r6rs_get_u8
 439 {
 440   SCM result;
 441   int c_result;
 442
 443   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 444
 445   c_result = scm_getc (port);
 446   if (c_result == EOF)
 447     result = SCM_EOF_VAL;
 448   else
 449     result = SCM_I_MAKINUM ((unsigned char) c_result);
 450
 451   return result;
 452 }
 453 #undef FUNC_NAME
 454
 455 SCM_DEFINE (scm_r6rs_lookahead_u8, "lookahead-u8", 1, 0, 0,
 456             (SCM port),
 457             "Like @code{get-u8} but does not update @var{port} to "
 458             "point past the octet.")
 459 #define FUNC_NAME s_scm_r6rs_lookahead_u8
 460 {
 461   SCM result;
 462
 463   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 464
 465   result = scm_peek_char (port);
 466   if (SCM_CHARP (result))
 467     result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
 468   else
 469     result = SCM_EOF_VAL;
 470
 471   return result;
 472 }
 473 #undef FUNC_NAME
 474
 475 SCM_DEFINE (scm_r6rs_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
 476             (SCM port, SCM count),
 477             "Read @var{count} octets from @var{port}, blocking as "
 478             "necessary and return a bytevector containing the octets "
 479             "read.  If fewer bytes are available, a bytevector smaller "
 480             "than @var{count} is returned.")
 481 #define FUNC_NAME s_scm_r6rs_get_bytevector_n
 482 {
 483   SCM result;
 484   char *c_bv;
 485   unsigned c_count;
 486   size_t c_read;
 487
 488   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 489   c_count = scm_to_uint (count);
 490
 491   result = scm_r6rs_c_make_bytevector (c_count);
 492   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (result);
 493
 494   if (EXPECT_TRUE (c_count > 0))
 495     /* XXX: `scm_c_read ()' does not update the port position.  */
 496     c_read = scm_c_read (port, c_bv, c_count);
 497   else
 498     /* Don't invoke `scm_c_read ()' since it may block.  */
 499     c_read = 0;
 500
 501   if ((c_read == 0) && (c_count > 0))
 502     {
 503       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 504         result = SCM_EOF_VAL;
 505       else
 506         result = scm_r6rs_null_bytevector;
 507     }
 508   else
 509     {
 510       if (c_read < c_count)
 511         result = scm_r6rs_c_shrink_bytevector (result, c_read);
 512     }
 513
 514   return result;
 515 }
 516 #undef FUNC_NAME
 517
 518 SCM_DEFINE (scm_r6rs_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
 519             (SCM port, SCM bv, SCM start, SCM count),
 520             "Read @var{count} bytes from @var{port} and store them "
 521             "in @var{bv} starting at index @var{start}.  Return either "
 522             "the number of bytes actually read or the end-of-file "
 523             "object.")
 524 #define FUNC_NAME s_scm_r6rs_get_bytevector_n_x
 525 {
 526   SCM result;
 527   char *c_bv;
 528   unsigned c_start, c_count, c_len;
 529   size_t c_read;
 530
 531   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 532   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 533   c_start = scm_to_uint (start);
 534   c_count = scm_to_uint (count);
 535
 536   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 537   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 538
 539   if (EXPECT_FALSE (c_start + c_count > c_len))
 540     scm_out_of_range (FUNC_NAME, count);
 541
 542   if (EXPECT_TRUE (c_count > 0))
 543     c_read = scm_c_read (port, c_bv + c_start, c_count);
 544   else
 545     /* Don't invoke `scm_c_read ()' since it may block.  */
 546     c_read = 0;
 547
 548   if ((c_read == 0) && (c_count > 0))
 549     {
 550       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 551         result = SCM_EOF_VAL;
 552       else
 553         result = SCM_I_MAKINUM (0);
 554     }
 555   else
 556     result = scm_from_size_t (c_read);
 557
 558   return result;
 559 }
 560 #undef FUNC_NAME
 561
 562
 563 SCM_DEFINE (scm_r6rs_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 564             (SCM port),
 565             "Read from @var{port}, blocking as necessary, until data "
 566             "are available or and end-of-file is reached.  Return either "
 567             "a new bytevector containing the data read or the "
 568             "end-of-file object.")
 569 #define FUNC_NAME s_scm_r6rs_get_bytevector_some
 570 {
 571   /* Read at least one byte, unless the end-of-file is already reached, and
 572      read while characters are available (buffered).  */
 573
 574   SCM result;
 575   char *c_bv;
 576   unsigned c_len;
 577   size_t c_total;
 578
 579   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 580
 581   c_len = 4096;
 582   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 583   c_total = 0;
 584
 585   do
 586     {
 587       int c_chr;
 588
 589       if (c_total + 1 > c_len)
 590         {
 591           /* Grow the bytevector.  */
 592           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 593                                           SCM_GC_BYTEVECTOR);
 594           c_len *= 2;
 595         }
 596
 597       /* We can't use `scm_c_read ()' since it blocks.  */
 598       c_chr = scm_getc (port);
 599       if (c_chr != EOF)
 600         {
 601           c_bv[c_total] = (char) c_chr;
 602           c_total++;
 603         }
 604     }
 605   while ((scm_is_true (scm_char_ready_p (port)))
 606          && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
 607
 608   if (c_total == 0)
 609     {
 610       result = SCM_EOF_VAL;
 611       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 612     }
 613   else
 614     {
 615       if (c_len > c_total)
 616         {
 617           /* Shrink the bytevector.  */
 618           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 619                                           SCM_GC_BYTEVECTOR);
 620           c_len = (unsigned) c_total;
 621         }
 622
 623       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 624     }
 625
 626   return result;
 627 }
 628 #undef FUNC_NAME
 629
 630 SCM_DEFINE (scm_r6rs_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 631             (SCM port),
 632             "Read from @var{port}, blocking as necessary, until "
 633             "the end-of-file is reached.  Return either "
 634             "a new bytevector containing the data read or the "
 635             "end-of-file object (if no data were available).")
 636 #define FUNC_NAME s_scm_r6rs_get_bytevector_all
 637 {
 638   SCM result;
 639   char *c_bv;
 640   unsigned c_len, c_count;
 641   size_t c_read, c_total;
 642
 643   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 644
 645   c_len = c_count = 4096;
 646   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 647   c_total = c_read = 0;
 648
 649   do
 650     {
 651       if (c_total + c_read > c_len)
 652         {
 653           /* Grow the bytevector.  */
 654           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 655                                           SCM_GC_BYTEVECTOR);
 656           c_count = c_len;
 657           c_len *= 2;
 658         }
 659
 660       /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
 661          reached.  */
 662       c_read = scm_c_read (port, c_bv + c_total, c_count);
 663       c_total += c_read, c_count -= c_read;
 664     }
 665   while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
 666
 667   if (c_total == 0)
 668     {
 669       result = SCM_EOF_VAL;
 670       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 671     }
 672   else
 673     {
 674       if (c_len > c_total)
 675         {
 676           /* Shrink the bytevector.  */
 677           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 678                                           SCM_GC_BYTEVECTOR);
 679           c_len = (unsigned) c_total;
 680         }
 681
 682       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 683     }
 684
 685   return result;
 686 }
 687 #undef FUNC_NAME
 688
 689
 690 \f
 691 /* Binary output.  */
 692
 693 /* We currently don't support specific binary input ports.  */
 694 #define SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
 695
 696
 697 SCM_DEFINE (scm_r6rs_put_u8, "put-u8", 2, 0, 0,
 698             (SCM port, SCM octet),
 699             "Write @var{octet} to binary port @var{port}.")
 700 #define FUNC_NAME s_scm_r6rs_put_u8
 701 {
 702   scm_t_uint8 c_octet;
 703
 704   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 705   c_octet = scm_to_uint8 (octet);
 706
 707   scm_putc ((char) c_octet, port);
 708
 709   return SCM_UNSPECIFIED;
 710 }
 711 #undef FUNC_NAME
 712
 713 SCM_DEFINE (scm_r6rs_put_bytevector, "put-bytevector", 2, 2, 0,
 714             (SCM port, SCM bv, SCM start, SCM count),
 715             "Write the contents of @var{bv} to @var{port}, optionally "
 716             "starting at index @var{start} and limiting to @var{count} "
 717             "octets.")
 718 #define FUNC_NAME s_scm_r6rs_put_bytevector
 719 {
 720   char *c_bv;
 721   unsigned c_start, c_count, c_len;
 722
 723   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 724   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 725
 726   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 727   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 728
 729   if (start != SCM_UNDEFINED)
 730     {
 731       c_start = scm_to_uint (start);
 732
 733       if (count != SCM_UNDEFINED)
 734         {
 735           c_count = scm_to_uint (count);
 736           if (EXPECT_FALSE (c_start + c_count > c_len))
 737             scm_out_of_range (FUNC_NAME, count);
 738         }
 739       else
 740         {
 741           if (EXPECT_FALSE (c_start >= c_len))
 742             scm_out_of_range (FUNC_NAME, start);
 743           else
 744             c_count = c_len - c_start;
 745         }
 746     }
 747   else
 748     c_start = 0, c_count = c_len;
 749
 750   scm_c_write (port, c_bv + c_start, c_count);
 751
 752   return SCM_UNSPECIFIED;
 753 }
 754 #undef FUNC_NAME
 755
 756
 757 \f
 758 /* Bytevector output port ("bop" for short).  */
 759
 760 /* Implementation of "bops".
 761
 762    Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
 763    it.  The procedure returned along with the output port is actually an
 764    applicable SMOB.  The SMOB holds a reference to the port.  When applied,
 765    the SMOB swallows the port's internal buffer, turning it into a
 766    bytevector, and resets it.
 767
 768    XXX: Access to a bop's internal buffer is not thread-safe.  */
 769
 770 static scm_t_bits bytevector_output_port_type = 0;
 771
 772 SCM_SMOB (bytevector_output_port_procedure,
 773           "r6rs-bytevector-output-port-procedure",
 774           0);
 775
 776 #define SCM_GC_BOP "r6rs-bytevector-output-port"
 777 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
 778
 779 /* Representation of a bop's internal buffer.  */
 780 typedef struct
 781 {
 782   size_t total_len;
 783   size_t len;
 784   size_t pos;
 785   char  *buffer;
 786 } scm_t_bop_buffer;
 787
 788
 789 /* Accessing a bop's buffer.  */
 790 #define SCM_R6RS_BOP_BUFFER(_port)              \
 791   ((scm_t_bop_buffer *) SCM_STREAM (_port))
 792 #define SCM_R6RS_SET_BOP_BUFFER(_port, _buf)            \
 793   (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
 794
 795
 796 static inline void
 797 bop_buffer_init (scm_t_bop_buffer *buf)
 798 {
 799   buf->total_len = buf->len = buf->pos = 0;
 800   buf->buffer = NULL;
 801 }
 802
 803 static inline void
 804 bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
 805 {
 806   char *new_buf;
 807   size_t new_size;
 808
 809   for (new_size = buf->total_len
 810          ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
 811        new_size < min_size;
 812        new_size *= 2);
 813
 814   if (buf->buffer)
 815     new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
 816                               new_size, SCM_GC_BOP);
 817   else
 818     new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
 819
 820   buf->buffer = new_buf;
 821   buf->total_len = new_size;
 822 }
 823
 824 static inline SCM
 825 make_bop (void)
 826 {
 827   SCM port, bop_proc;
 828   scm_t_port *c_port;
 829   scm_t_bop_buffer *buf;
 830   const unsigned long mode_bits = SCM_OPN | SCM_WRTNG | SCM_BUF0;
 831
 832   port = scm_new_port_table_entry (bytevector_output_port_type);
 833
 834   buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
 835   bop_buffer_init (buf);
 836
 837   c_port = SCM_PTAB_ENTRY (port);
 838   c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
 839
 840   SCM_R6RS_SET_BOP_BUFFER (port, buf);
 841
 842   /* Mark PORT as open and writable.  */
 843   SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
 844
 845   /* Make the bop procedure.  */
 846   SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
 847                SCM_PACK (port));
 848
 849   return (scm_values (scm_list_2 (port, bop_proc)));
 850 }
 851
 852 static size_t
 853 bop_free (SCM port)
 854 {
 855   /* The port itself is necessarily freed _after_ the bop proc, since the bop
 856      proc holds a reference to it.  Thus we can safely free the internal
 857      buffer when the bop becomes unreferenced.  */
 858   scm_t_bop_buffer *buf;
 859
 860   buf = SCM_R6RS_BOP_BUFFER (port);
 861   if (buf->buffer)
 862     scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
 863
 864   scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
 865
 866   return 0;
 867 }
 868
 869 /* Write SIZE octets from DATA to PORT.  */
 870 static void
 871 bop_write (SCM port, const void *data, size_t size)
 872 {
 873   scm_t_bop_buffer *buf;
 874
 875   buf = SCM_R6RS_BOP_BUFFER (port);
 876
 877   if (buf->pos + size > buf->total_len)
 878     bop_buffer_grow (buf, buf->pos + size);
 879
 880   memcpy (buf->buffer + buf->pos, data, size);
 881   buf->pos += size;
 882   buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
 883 }
 884
 885 static off_t
 886 bop_seek (SCM port, off_t offset, int whence)
 887 #define FUNC_NAME "bop_seek"
 888 {
 889   scm_t_bop_buffer *buf;
 890
 891   buf = SCM_R6RS_BOP_BUFFER (port);
 892   switch (whence)
 893     {
 894     case SEEK_CUR:
 895       offset += (off_t) buf->pos;
 896       /* Fall through.  */
 897
 898     case SEEK_SET:
 899       if (offset > buf->len)
 900         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 901       else
 902         buf->pos = offset;
 903       break;
 904
 905     case SEEK_END:
 906       if (offset >= buf->len)
 907         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 908       else
 909         buf->pos = buf->len - offset;
 910       break;
 911
 912     default:
 913       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 914                               "invalid `seek' parameter");
 915     }
 916
 917   return buf->pos;
 918 }
 919 #undef FUNC_NAME
 920
 921 /* Fetch data from a bop.  */
 922 SCM_SMOB_APPLY (bytevector_output_port_procedure,
 923                 bop_proc_apply, 0, 0, 0, (SCM bop_proc))
 924 {
 925   SCM port, bv;
 926   scm_t_bop_buffer *buf, result_buf;
 927
 928   port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
 929   buf = SCM_R6RS_BOP_BUFFER (port);
 930
 931   result_buf = *buf;
 932   bop_buffer_init (buf);
 933
 934   if (result_buf.len == 0)
 935     bv = scm_r6rs_c_take_bytevector (NULL, 0);
 936   else
 937     {
 938       if (result_buf.total_len > result_buf.len)
 939         /* Shrink the buffer.  */
 940         result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
 941                                             result_buf.total_len,
 942                                             result_buf.len,
 943                                             SCM_GC_BOP);
 944
 945       bv = scm_r6rs_c_take_bytevector ((signed char *) result_buf.buffer,
 946                                        result_buf.len);
 947     }
 948
 949   return bv;
 950 }
 951
 952 SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
 953                bop_proc)
 954 {
 955   /* Mark the port associated to BOP_PROC.  */
 956   return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
 957 }
 958
 959
 960 SCM_DEFINE (scm_r6rs_open_bytevector_output_port,
 961             "open-bytevector-output-port", 0, 1, 0,
 962             (SCM transcoder),
 963             "Return two values: an output port and a procedure.  The latter "
 964             "should be called with zero arguments to obtain a bytevector "
 965             "containing the data accumulated by the port.")
 966 #define FUNC_NAME scm_r6rs_open_bytevector_output_port
 967 {
 968   if (transcoder != SCM_UNDEFINED)
 969     transcoders_not_implemented ();
 970
 971   return (make_bop ());
 972 }
 973 #undef FUNC_NAME
 974
 975 static inline void
 976 initialize_bytevector_output_ports (void)
 977 {
 978   bytevector_output_port_type =
 979     scm_make_port_type ("r6rs-bytevector-output-port",
 980                         NULL, bop_write);
 981
 982   scm_set_port_seek (bytevector_output_port_type, bop_seek);
 983   scm_set_port_free (bytevector_output_port_type, bop_free);
 984 }
 985
 986
 987 \f
 988 /* Initialization.  */
 989
 990 void
 991 scm_init_r6rs_ports (void)
 992 {
 993 #include "ports.x"
 994
 995   initialize_bytevector_input_ports ();
 996   initialize_custom_binary_input_ports ();
 997   initialize_bytevector_output_ports ();
 998 }
 999
1000 /* arch-tag: c041ffd6-8871-40e8-a25a-d0f8768a71dc
1001  */