src/ports.c

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