libguile/r6rs-ports.c

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