libguile/r6rs-ports.c

   1 /* Copyright (C) 2009, 2010, 2011, 2013 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   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
  88
  89   port = scm_new_port_table_entry (bytevector_input_port_type);
  90   c_port = SCM_PTAB_ENTRY (port);
  91
  92   /* Match the expectation of `binary-port?'.  */
  93   c_port->encoding = NULL;
  94
  95   /* Prevent BV from being GC'd.  */
  96   SCM_SETSTREAM (port, SCM_UNPACK (bv));
  97
  98   /* Have the port directly access the bytevector.  */
  99   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
 100   c_len = SCM_BYTEVECTOR_LENGTH (bv);
 101
 102   c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
 103   c_port->read_end = (unsigned char *) c_bv + c_len;
 104   c_port->read_buf_size = c_len;
 105
 106   /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
 107   SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
 108
 109   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 110
 111   return 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_seek (bytevector_input_port_type, bip_seek);
 180 }
 181
 182
 183 SCM_DEFINE (scm_open_bytevector_input_port,
 184             "open-bytevector-input-port", 1, 1, 0,
 185             (SCM bv, SCM transcoder),
 186             "Return an input port whose contents are drawn from "
 187             "bytevector @var{bv}.")
 188 #define FUNC_NAME s_scm_open_bytevector_input_port
 189 {
 190   SCM_VALIDATE_BYTEVECTOR (1, bv);
 191   if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
 192     transcoders_not_implemented ();
 193
 194   return (make_bip (bv));
 195 }
 196 #undef FUNC_NAME
 197
 198 \f
 199 /* Custom binary ports.  The following routines are shared by input and
 200    output custom binary ports.  */
 201
 202 #define SCM_CBP_GET_POSITION_PROC(_port)                        \
 203   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
 204 #define SCM_CBP_SET_POSITION_PROC(_port)                        \
 205   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
 206 #define SCM_CBP_CLOSE_PROC(_port)                               \
 207   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
 208
 209 static scm_t_off
 210 cbp_seek (SCM port, scm_t_off offset, int whence)
 211 #define FUNC_NAME "cbp_seek"
 212 {
 213   SCM result;
 214   scm_t_off c_result = 0;
 215
 216   switch (whence)
 217     {
 218     case SEEK_CUR:
 219       {
 220         SCM get_position_proc;
 221
 222         get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
 223         if (SCM_LIKELY (scm_is_true (get_position_proc)))
 224           result = scm_call_0 (get_position_proc);
 225         else
 226           scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 227                                   "R6RS custom binary port does not "
 228                                   "support `port-position'");
 229
 230         offset += scm_to_int (result);
 231         /* Fall through.  */
 232       }
 233
 234     case SEEK_SET:
 235       {
 236         SCM set_position_proc;
 237
 238         set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
 239         if (SCM_LIKELY (scm_is_true (set_position_proc)))
 240           result = scm_call_1 (set_position_proc, scm_from_int (offset));
 241         else
 242           scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 243                                   "R6RS custom binary port does not "
 244                                   "support `set-port-position!'");
 245
 246         /* Assuming setting the position succeeded.  */
 247         c_result = offset;
 248         break;
 249       }
 250
 251     default:
 252       /* `SEEK_END' cannot be supported.  */
 253       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 254                               "R6RS custom binary ports do not "
 255                               "support `SEEK_END'");
 256     }
 257
 258   return c_result;
 259 }
 260 #undef FUNC_NAME
 261
 262 static int
 263 cbp_close (SCM port)
 264 {
 265   SCM close_proc;
 266
 267   close_proc = SCM_CBP_CLOSE_PROC (port);
 268   if (scm_is_true (close_proc))
 269     /* Invoke the `close' thunk.  */
 270     scm_call_0 (close_proc);
 271
 272   return 1;
 273 }
 274
 275 \f
 276 /* Custom binary input port ("cbip" for short).  */
 277
 278 static scm_t_bits custom_binary_input_port_type = 0;
 279
 280 /* Size of the buffer embedded in custom binary input ports.  */
 281 #define CBIP_BUFFER_SIZE  4096
 282
 283 /* Return the bytevector associated with PORT.  */
 284 #define SCM_CBIP_BYTEVECTOR(_port)                              \
 285   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
 286
 287 /* Return the various procedures of PORT.  */
 288 #define SCM_CBIP_READ_PROC(_port)                               \
 289   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
 290
 291
 292 static inline SCM
 293 make_cbip (SCM read_proc, SCM get_position_proc,
 294            SCM set_position_proc, SCM close_proc)
 295 {
 296   SCM port, bv, method_vector;
 297   char *c_bv;
 298   unsigned c_len;
 299   scm_t_port *c_port;
 300   const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
 301
 302   /* Use a bytevector as the underlying buffer.  */
 303   c_len = CBIP_BUFFER_SIZE;
 304   bv = scm_c_make_bytevector (c_len);
 305   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
 306
 307   /* Store the various methods and bytevector in a vector.  */
 308   method_vector = scm_c_make_vector (5, SCM_BOOL_F);
 309   SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
 310   SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
 311   SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
 312   SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
 313   SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
 314
 315   scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
 316
 317   port = scm_new_port_table_entry (custom_binary_input_port_type);
 318   c_port = SCM_PTAB_ENTRY (port);
 319
 320   /* Match the expectation of `binary-port?'.  */
 321   c_port->encoding = NULL;
 322
 323   /* Attach it the method vector.  */
 324   SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
 325
 326   /* Have the port directly access the buffer (bytevector).  */
 327   c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
 328   c_port->read_end = (unsigned char *) c_bv;
 329   c_port->read_buf_size = c_len;
 330
 331   /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
 332   SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
 333
 334   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 335
 336   return port;
 337 }
 338
 339 static int
 340 cbip_fill_input (SCM port)
 341 #define FUNC_NAME "cbip_fill_input"
 342 {
 343   int result;
 344   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 345
 346  again:
 347   if (c_port->read_pos >= c_port->read_end)
 348     {
 349       /* Invoke the user's `read!' procedure.  */
 350       unsigned c_octets;
 351       SCM bv, read_proc, octets;
 352
 353       /* Use the bytevector associated with PORT as the buffer passed to the
 354          `read!' procedure, thereby avoiding additional allocations.  */
 355       bv = SCM_CBIP_BYTEVECTOR (port);
 356       read_proc = SCM_CBIP_READ_PROC (port);
 357
 358       /* The assumption here is that C_PORT's internal buffer wasn't changed
 359          behind our back.  */
 360       assert (c_port->read_buf ==
 361               (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
 362       assert ((unsigned) c_port->read_buf_size
 363               == SCM_BYTEVECTOR_LENGTH (bv));
 364
 365       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
 366                            SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
 367       c_octets = scm_to_uint (octets);
 368
 369       c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
 370       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
 371
 372       if (c_octets > 0)
 373         goto again;
 374       else
 375         result = EOF;
 376     }
 377   else
 378     result = (int) *c_port->read_pos;
 379
 380   return result;
 381 }
 382 #undef FUNC_NAME
 383
 384
 385 SCM_DEFINE (scm_make_custom_binary_input_port,
 386             "make-custom-binary-input-port", 5, 0, 0,
 387             (SCM id, SCM read_proc, SCM get_position_proc,
 388              SCM set_position_proc, SCM close_proc),
 389             "Return a new custom binary input port whose input is drained "
 390             "by invoking @var{read_proc} and passing it a bytevector, an "
 391             "index where octets should be written, and an octet count.")
 392 #define FUNC_NAME s_scm_make_custom_binary_input_port
 393 {
 394   SCM_VALIDATE_STRING (1, id);
 395   SCM_VALIDATE_PROC (2, read_proc);
 396
 397   if (!scm_is_false (get_position_proc))
 398     SCM_VALIDATE_PROC (3, get_position_proc);
 399
 400   if (!scm_is_false (set_position_proc))
 401     SCM_VALIDATE_PROC (4, set_position_proc);
 402
 403   if (!scm_is_false (close_proc))
 404     SCM_VALIDATE_PROC (5, close_proc);
 405
 406   return (make_cbip (read_proc, get_position_proc, set_position_proc,
 407                      close_proc));
 408 }
 409 #undef FUNC_NAME
 410
 411
 412 /* Instantiate the custom binary input port type.  */
 413 static inline void
 414 initialize_custom_binary_input_ports (void)
 415 {
 416   custom_binary_input_port_type =
 417     scm_make_port_type ("r6rs-custom-binary-input-port",
 418                         cbip_fill_input, NULL);
 419
 420   scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
 421   scm_set_port_close (custom_binary_input_port_type, cbp_close);
 422 }
 423
 424
 425 \f
 426 /* Binary input.  */
 427
 428 /* We currently don't support specific binary input ports.  */
 429 #define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
 430
 431 SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
 432             (SCM port),
 433             "Read an octet from @var{port}, a binary input port, "
 434             "blocking as necessary.")
 435 #define FUNC_NAME s_scm_get_u8
 436 {
 437   SCM result;
 438   int c_result;
 439
 440   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 441
 442   c_result = scm_get_byte_or_eof (port);
 443   if (c_result == EOF)
 444     result = SCM_EOF_VAL;
 445   else
 446     result = SCM_I_MAKINUM ((unsigned char) c_result);
 447
 448   return result;
 449 }
 450 #undef FUNC_NAME
 451
 452 SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
 453             (SCM port),
 454             "Like @code{get-u8} but does not update @var{port} to "
 455             "point past the octet.")
 456 #define FUNC_NAME s_scm_lookahead_u8
 457 {
 458   int u8;
 459   SCM result;
 460
 461   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 462
 463   u8 = scm_peek_byte_or_eof (port);
 464   if (u8 == EOF)
 465     result = SCM_EOF_VAL;
 466   else
 467     result = SCM_I_MAKINUM ((scm_t_uint8) u8);
 468
 469   return result;
 470 }
 471 #undef FUNC_NAME
 472
 473 SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
 474             (SCM port, SCM count),
 475             "Read @var{count} octets from @var{port}, blocking as "
 476             "necessary and return a bytevector containing the octets "
 477             "read.  If fewer bytes are available, a bytevector smaller "
 478             "than @var{count} is returned.")
 479 #define FUNC_NAME s_scm_get_bytevector_n
 480 {
 481   SCM result;
 482   char *c_bv;
 483   unsigned c_count;
 484   size_t c_read;
 485
 486   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 487   c_count = scm_to_uint (count);
 488
 489   result = scm_c_make_bytevector (c_count);
 490   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
 491
 492   if (SCM_LIKELY (c_count > 0))
 493     /* XXX: `scm_c_read ()' does not update the port position.  */
 494     c_read = scm_c_read (port, c_bv, c_count);
 495   else
 496     /* Don't invoke `scm_c_read ()' since it may block.  */
 497     c_read = 0;
 498
 499   if (c_read < c_count)
 500     {
 501       if (c_read == 0)
 502         result = SCM_EOF_VAL;
 503       else
 504         result = scm_c_shrink_bytevector (result, c_read);
 505     }
 506
 507   return result;
 508 }
 509 #undef FUNC_NAME
 510
 511 SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
 512             (SCM port, SCM bv, SCM start, SCM count),
 513             "Read @var{count} bytes from @var{port} and store them "
 514             "in @var{bv} starting at index @var{start}.  Return either "
 515             "the number of bytes actually read or the end-of-file "
 516             "object.")
 517 #define FUNC_NAME s_scm_get_bytevector_n_x
 518 {
 519   SCM result;
 520   char *c_bv;
 521   unsigned c_start, c_count, c_len;
 522   size_t c_read;
 523
 524   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 525   SCM_VALIDATE_BYTEVECTOR (2, bv);
 526   c_start = scm_to_uint (start);
 527   c_count = scm_to_uint (count);
 528
 529   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
 530   c_len = SCM_BYTEVECTOR_LENGTH (bv);
 531
 532   if (SCM_UNLIKELY (c_start + c_count > c_len))
 533     scm_out_of_range (FUNC_NAME, count);
 534
 535   if (SCM_LIKELY (c_count > 0))
 536     c_read = scm_c_read (port, c_bv + c_start, c_count);
 537   else
 538     /* Don't invoke `scm_c_read ()' since it may block.  */
 539     c_read = 0;
 540
 541   if (c_read == 0 && c_count > 0)
 542     result = SCM_EOF_VAL;
 543   else
 544     result = scm_from_size_t (c_read);
 545
 546   return result;
 547 }
 548 #undef FUNC_NAME
 549
 550
 551 SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 552             (SCM port),
 553             "Read from @var{port}, blocking as necessary, until data "
 554             "are available or and end-of-file is reached.  Return either "
 555             "a new bytevector containing the data read or the "
 556             "end-of-file object.")
 557 #define FUNC_NAME s_scm_get_bytevector_some
 558 {
 559   /* Read at least one byte, unless the end-of-file is already reached, and
 560      read while characters are available (buffered).  */
 561
 562   SCM result;
 563   char *c_bv;
 564   unsigned c_len;
 565   size_t c_total;
 566
 567   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 568
 569   c_len = 4096;
 570   c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
 571   c_total = 0;
 572
 573   do
 574     {
 575       int c_chr;
 576
 577       if (c_total + 1 > c_len)
 578         {
 579           /* Grow the bytevector.  */
 580           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 581                                           SCM_GC_BYTEVECTOR);
 582           c_len *= 2;
 583         }
 584
 585       /* We can't use `scm_c_read ()' since it blocks.  */
 586       c_chr = scm_get_byte_or_eof (port);
 587       if (c_chr != EOF)
 588         {
 589           c_bv[c_total] = (char) c_chr;
 590           c_total++;
 591         }
 592       else
 593         break;
 594     }
 595   /* XXX: We want to check for the availability of a byte, but that's
 596      what `scm_char_ready_p' actually does.  */
 597   while (scm_is_true (scm_char_ready_p (port)));
 598
 599   if (c_total == 0)
 600     {
 601       result = SCM_EOF_VAL;
 602       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 603     }
 604   else
 605     {
 606       if (c_len > c_total)
 607         {
 608           /* Shrink the bytevector.  */
 609           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 610                                           SCM_GC_BYTEVECTOR);
 611           c_len = (unsigned) c_total;
 612         }
 613
 614       result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
 615     }
 616
 617   return result;
 618 }
 619 #undef FUNC_NAME
 620
 621 SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 622             (SCM port),
 623             "Read from @var{port}, blocking as necessary, until "
 624             "the end-of-file is reached.  Return either "
 625             "a new bytevector containing the data read or the "
 626             "end-of-file object (if no data were available).")
 627 #define FUNC_NAME s_scm_get_bytevector_all
 628 {
 629   SCM result;
 630   char *c_bv;
 631   unsigned c_len, c_count;
 632   size_t c_read, c_total;
 633
 634   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
 635
 636   c_len = c_count = 4096;
 637   c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
 638   c_total = c_read = 0;
 639
 640   do
 641     {
 642       if (c_total + c_read > c_len)
 643         {
 644           /* Grow the bytevector.  */
 645           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 646                                           SCM_GC_BYTEVECTOR);
 647           c_count = c_len;
 648           c_len *= 2;
 649         }
 650
 651       /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
 652          reached.  */
 653       c_read = scm_c_read (port, c_bv + c_total, c_count);
 654       c_total += c_read, c_count -= c_read;
 655     }
 656   while (c_count == 0);
 657
 658   if (c_total == 0)
 659     {
 660       result = SCM_EOF_VAL;
 661       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 662     }
 663   else
 664     {
 665       if (c_len > c_total)
 666         {
 667           /* Shrink the bytevector.  */
 668           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 669                                           SCM_GC_BYTEVECTOR);
 670           c_len = (unsigned) c_total;
 671         }
 672
 673       result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
 674     }
 675
 676   return result;
 677 }
 678 #undef FUNC_NAME
 679
 680
 681 \f
 682 /* Binary output.  */
 683
 684 /* We currently don't support specific binary input ports.  */
 685 #define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
 686
 687
 688 SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
 689             (SCM port, SCM octet),
 690             "Write @var{octet} to binary port @var{port}.")
 691 #define FUNC_NAME s_scm_put_u8
 692 {
 693   scm_t_uint8 c_octet;
 694
 695   SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
 696   c_octet = scm_to_uint8 (octet);
 697
 698   scm_putc ((char) c_octet, port);
 699
 700   return SCM_UNSPECIFIED;
 701 }
 702 #undef FUNC_NAME
 703
 704 SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
 705             (SCM port, SCM bv, SCM start, SCM count),
 706             "Write the contents of @var{bv} to @var{port}, optionally "
 707             "starting at index @var{start} and limiting to @var{count} "
 708             "octets.")
 709 #define FUNC_NAME s_scm_put_bytevector
 710 {
 711   char *c_bv;
 712   unsigned c_start, c_count, c_len;
 713
 714   SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
 715   SCM_VALIDATE_BYTEVECTOR (2, bv);
 716
 717   c_len = SCM_BYTEVECTOR_LENGTH (bv);
 718   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
 719
 720   if (!scm_is_eq (start, SCM_UNDEFINED))
 721     {
 722       c_start = scm_to_uint (start);
 723
 724       if (!scm_is_eq (count, SCM_UNDEFINED))
 725         {
 726           c_count = scm_to_uint (count);
 727           if (SCM_UNLIKELY (c_start + c_count > c_len))
 728             scm_out_of_range (FUNC_NAME, count);
 729         }
 730       else
 731         {
 732           if (SCM_UNLIKELY (c_start >= c_len))
 733             scm_out_of_range (FUNC_NAME, start);
 734           else
 735             c_count = c_len - c_start;
 736         }
 737     }
 738   else
 739     c_start = 0, c_count = c_len;
 740
 741   scm_c_write (port, c_bv + c_start, c_count);
 742
 743   return SCM_UNSPECIFIED;
 744 }
 745 #undef FUNC_NAME
 746
 747
 748 \f
 749 /* Bytevector output port ("bop" for short).  */
 750
 751 /* Implementation of "bops".
 752
 753    Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
 754    it.  The procedure returned along with the output port is actually an
 755    applicable SMOB.  The SMOB holds a reference to the port.  When applied,
 756    the SMOB swallows the port's internal buffer, turning it into a
 757    bytevector, and resets it.
 758
 759    XXX: Access to a bop's internal buffer is not thread-safe.  */
 760
 761 static scm_t_bits bytevector_output_port_type = 0;
 762
 763 SCM_SMOB (bytevector_output_port_procedure,
 764           "r6rs-bytevector-output-port-procedure",
 765           0);
 766
 767 #define SCM_GC_BOP "r6rs-bytevector-output-port"
 768 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
 769
 770 /* Representation of a bop's internal buffer.  */
 771 typedef struct
 772 {
 773   size_t total_len;
 774   size_t len;
 775   size_t pos;
 776   char  *buffer;
 777 } scm_t_bop_buffer;
 778
 779
 780 /* Accessing a bop's buffer.  */
 781 #define SCM_BOP_BUFFER(_port)           \
 782   ((scm_t_bop_buffer *) SCM_STREAM (_port))
 783 #define SCM_SET_BOP_BUFFER(_port, _buf)         \
 784   (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
 785
 786
 787 static inline void
 788 bop_buffer_init (scm_t_bop_buffer *buf)
 789 {
 790   buf->total_len = buf->len = buf->pos = 0;
 791   buf->buffer = NULL;
 792 }
 793
 794 static inline void
 795 bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
 796 {
 797   char *new_buf;
 798   size_t new_size;
 799
 800   for (new_size = buf->total_len
 801          ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
 802        new_size < min_size;
 803        new_size *= 2);
 804
 805   if (buf->buffer)
 806     new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
 807                               new_size, SCM_GC_BOP);
 808   else
 809     new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP);
 810
 811   buf->buffer = new_buf;
 812   buf->total_len = new_size;
 813 }
 814
 815 static inline SCM
 816 make_bop (void)
 817 {
 818   SCM port, bop_proc;
 819   scm_t_port *c_port;
 820   scm_t_bop_buffer *buf;
 821   const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
 822
 823   scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
 824
 825   port = scm_new_port_table_entry (bytevector_output_port_type);
 826   c_port = SCM_PTAB_ENTRY (port);
 827
 828   /* Match the expectation of `binary-port?'.  */
 829   c_port->encoding = NULL;
 830
 831   buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
 832   bop_buffer_init (buf);
 833
 834   c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
 835   c_port->write_buf_size = 0;
 836
 837   SCM_SET_BOP_BUFFER (port, buf);
 838
 839   /* Mark PORT as open and writable.  */
 840   SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
 841
 842   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 843
 844   /* Make the bop procedure.  */
 845   SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
 846
 847   return (scm_values (scm_list_2 (port, bop_proc)));
 848 }
 849
 850 /* Write SIZE octets from DATA to PORT.  */
 851 static void
 852 bop_write (SCM port, const void *data, size_t size)
 853 {
 854   scm_t_bop_buffer *buf;
 855
 856   buf = SCM_BOP_BUFFER (port);
 857
 858   if (buf->pos + size > buf->total_len)
 859     bop_buffer_grow (buf, buf->pos + size);
 860
 861   memcpy (buf->buffer + buf->pos, data, size);
 862   buf->pos += size;
 863   buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
 864 }
 865
 866 static scm_t_off
 867 bop_seek (SCM port, scm_t_off offset, int whence)
 868 #define FUNC_NAME "bop_seek"
 869 {
 870   scm_t_bop_buffer *buf;
 871
 872   buf = SCM_BOP_BUFFER (port);
 873   switch (whence)
 874     {
 875     case SEEK_CUR:
 876       offset += (scm_t_off) buf->pos;
 877       /* Fall through.  */
 878
 879     case SEEK_SET:
 880       if (offset < 0 || (unsigned) offset > buf->len)
 881         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 882       else
 883         buf->pos = offset;
 884       break;
 885
 886     case SEEK_END:
 887       if (offset < 0 || (unsigned) offset >= buf->len)
 888         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 889       else
 890         buf->pos = buf->len - (offset + 1);
 891       break;
 892
 893     default:
 894       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 895                               "invalid `seek' parameter");
 896     }
 897
 898   return buf->pos;
 899 }
 900 #undef FUNC_NAME
 901
 902 /* Fetch data from a bop.  */
 903 SCM_SMOB_APPLY (bytevector_output_port_procedure,
 904                 bop_proc_apply, 0, 0, 0, (SCM bop_proc))
 905 {
 906   SCM bv;
 907   scm_t_bop_buffer *buf, result_buf;
 908
 909   buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
 910
 911   result_buf = *buf;
 912   bop_buffer_init (buf);
 913
 914   if (result_buf.len == 0)
 915     bv = scm_c_take_gc_bytevector (NULL, 0);
 916   else
 917     {
 918       if (result_buf.total_len > result_buf.len)
 919         /* Shrink the buffer.  */
 920         result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
 921                                             result_buf.total_len,
 922                                             result_buf.len,
 923                                             SCM_GC_BOP);
 924
 925       bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
 926                                      result_buf.len);
 927     }
 928
 929   return bv;
 930 }
 931
 932 SCM_DEFINE (scm_open_bytevector_output_port,
 933             "open-bytevector-output-port", 0, 1, 0,
 934             (SCM transcoder),
 935             "Return two values: an output port and a procedure.  The latter "
 936             "should be called with zero arguments to obtain a bytevector "
 937             "containing the data accumulated by the port.")
 938 #define FUNC_NAME s_scm_open_bytevector_output_port
 939 {
 940   if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
 941     transcoders_not_implemented ();
 942
 943   return (make_bop ());
 944 }
 945 #undef FUNC_NAME
 946
 947 static inline void
 948 initialize_bytevector_output_ports (void)
 949 {
 950   bytevector_output_port_type =
 951     scm_make_port_type ("r6rs-bytevector-output-port",
 952                         NULL, bop_write);
 953
 954   scm_set_port_seek (bytevector_output_port_type, bop_seek);
 955 }
 956
 957 \f
 958 /* Custom binary output port ("cbop" for short).  */
 959
 960 static scm_t_bits custom_binary_output_port_type;
 961
 962 /* Return the various procedures of PORT.  */
 963 #define SCM_CBOP_WRITE_PROC(_port)                              \
 964   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
 965
 966
 967 static inline SCM
 968 make_cbop (SCM write_proc, SCM get_position_proc,
 969            SCM set_position_proc, SCM close_proc)
 970 {
 971   SCM port, method_vector;
 972   scm_t_port *c_port;
 973   const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
 974
 975   /* Store the various methods and bytevector in a vector.  */
 976   method_vector = scm_c_make_vector (4, SCM_BOOL_F);
 977   SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
 978   SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
 979   SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
 980   SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
 981
 982   scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
 983
 984   port = scm_new_port_table_entry (custom_binary_output_port_type);
 985   c_port = SCM_PTAB_ENTRY (port);
 986
 987   /* Match the expectation of `binary-port?'.  */
 988   c_port->encoding = NULL;
 989
 990   /* Attach it the method vector.  */
 991   SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
 992
 993   /* Have the port directly access the buffer (bytevector).  */
 994   c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
 995   c_port->write_buf_size = c_port->read_buf_size = 0;
 996
 997   /* Mark PORT as open, writable and unbuffered.  */
 998   SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
 999
1000   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
1001
1002   return port;
1003 }
1004
1005 /* Write SIZE octets from DATA to PORT.  */
1006 static void
1007 cbop_write (SCM port, const void *data, size_t size)
1008 #define FUNC_NAME "cbop_write"
1009 {
1010   long int c_result;
1011   size_t c_written;
1012   SCM bv, write_proc, result;
1013
1014   /* XXX: Allocating a new bytevector at each `write' call is inefficient,
1015      but necessary since (1) we don't control the lifetime of the buffer
1016      pointed to by DATA, and (2) the `write!' procedure could capture the
1017      bytevector it is passed.  */
1018   bv = scm_c_make_bytevector (size);
1019   memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
1020
1021   write_proc = SCM_CBOP_WRITE_PROC (port);
1022
1023   /* Since the `write' procedure of Guile's ports has type `void', it must
1024      try hard to write exactly SIZE bytes, regardless of how many bytes the
1025      sink can handle.  */
1026   for (c_written = 0;
1027        c_written < size;
1028        c_written += c_result)
1029     {
1030       result = scm_call_3 (write_proc, bv,
1031                            scm_from_size_t (c_written),
1032                            scm_from_size_t (size - c_written));
1033
1034       c_result = scm_to_long (result);
1035       if (SCM_UNLIKELY (c_result < 0
1036                         || (size_t) c_result > (size - c_written)))
1037         scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
1038                                 "R6RS custom binary output port `write!' "
1039                                 "returned a incorrect integer");
1040     }
1041 }
1042 #undef FUNC_NAME
1043
1044
1045 SCM_DEFINE (scm_make_custom_binary_output_port,
1046             "make-custom-binary-output-port", 5, 0, 0,
1047             (SCM id, SCM write_proc, SCM get_position_proc,
1048              SCM set_position_proc, SCM close_proc),
1049             "Return a new custom binary output port whose output is drained "
1050             "by invoking @var{write_proc} and passing it a bytevector, an "
1051             "index where octets should be written, and an octet count.")
1052 #define FUNC_NAME s_scm_make_custom_binary_output_port
1053 {
1054   SCM_VALIDATE_STRING (1, id);
1055   SCM_VALIDATE_PROC (2, write_proc);
1056
1057   if (!scm_is_false (get_position_proc))
1058     SCM_VALIDATE_PROC (3, get_position_proc);
1059
1060   if (!scm_is_false (set_position_proc))
1061     SCM_VALIDATE_PROC (4, set_position_proc);
1062
1063   if (!scm_is_false (close_proc))
1064     SCM_VALIDATE_PROC (5, close_proc);
1065
1066   return (make_cbop (write_proc, get_position_proc, set_position_proc,
1067                      close_proc));
1068 }
1069 #undef FUNC_NAME
1070
1071
1072 /* Instantiate the custom binary output port type.  */
1073 static inline void
1074 initialize_custom_binary_output_ports (void)
1075 {
1076   custom_binary_output_port_type =
1077     scm_make_port_type ("r6rs-custom-binary-output-port",
1078                         NULL, cbop_write);
1079
1080   scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
1081   scm_set_port_close (custom_binary_output_port_type, cbp_close);
1082 }
1083
1084 \f
1085 /* Transcoded ports ("tp" for short).  */
1086 static scm_t_bits transcoded_port_type = 0;
1087
1088 #define TP_INPUT_BUFFER_SIZE 4096
1089
1090 #define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port))
1091
1092 static inline SCM
1093 make_tp (SCM binary_port, unsigned long mode)
1094 {
1095   SCM port;
1096   scm_t_port *c_port;
1097   const unsigned long mode_bits = SCM_OPN | mode;
1098
1099   scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
1100
1101   port = scm_new_port_table_entry (transcoded_port_type);
1102
1103   SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
1104
1105   SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
1106
1107   if (SCM_INPUT_PORT_P (port))
1108     {
1109       c_port = SCM_PTAB_ENTRY (port);
1110       c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE,
1111                                                     "port buffer");
1112       c_port->read_pos = c_port->read_end = c_port->read_buf;
1113       c_port->read_buf_size = TP_INPUT_BUFFER_SIZE;
1114
1115       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
1116     }
1117
1118   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
1119
1120   return port;
1121 }
1122
1123 static void
1124 tp_write (SCM port, const void *data, size_t size)
1125 {
1126   scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
1127 }
1128
1129 static int
1130 tp_fill_input (SCM port)
1131 {
1132   size_t count;
1133   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
1134   SCM bport = SCM_TP_BINARY_PORT (port);
1135   scm_t_port *c_bport = SCM_PTAB_ENTRY (bport);
1136
1137   /* We can't use `scm_c_read' here, since it blocks until the whole
1138      block has been read or EOF. */
1139
1140   if (c_bport->rw_active == SCM_PORT_WRITE)
1141     scm_force_output (bport);
1142
1143   if (c_bport->read_pos >= c_bport->read_end)
1144     scm_fill_input (bport);
1145
1146   count = c_bport->read_end - c_bport->read_pos;
1147   if (count > c_port->read_buf_size)
1148     count = c_port->read_buf_size;
1149
1150   memcpy (c_port->read_buf, c_bport->read_pos, count);
1151   c_bport->read_pos += count;
1152
1153   if (c_bport->rw_random)
1154     c_bport->rw_active = SCM_PORT_READ;
1155
1156   if (count == 0)
1157     return EOF;
1158   else
1159     {
1160       c_port->read_pos = c_port->read_buf;
1161       c_port->read_end = c_port->read_buf + count;
1162       return *c_port->read_buf;
1163     }
1164 }
1165
1166 static void
1167 tp_flush (SCM port)
1168 {
1169   SCM binary_port = SCM_TP_BINARY_PORT (port);
1170   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
1171   size_t count = c_port->write_pos - c_port->write_buf;
1172
1173   /* As the runtime will try to flush all ports upon exit, we test for
1174      the underlying port still being open here. Otherwise, when you
1175      would explicitly close the underlying port and the transcoded port
1176      still had data outstanding, you'd get an exception on Guile exit.
1177
1178      We just throw away the data when the underlying port is closed.  */
1179
1180   if (SCM_OPOUTPORTP (binary_port))
1181       scm_c_write (binary_port, c_port->write_buf, count);
1182
1183   c_port->write_pos = c_port->write_buf;
1184   c_port->rw_active = SCM_PORT_NEITHER;
1185
1186   if (SCM_OPOUTPORTP (binary_port))
1187     scm_force_output (binary_port);
1188 }
1189
1190 static int
1191 tp_close (SCM port)
1192 {
1193   if (SCM_OUTPUT_PORT_P (port))
1194     tp_flush (port);
1195   return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1;
1196 }
1197
1198 static inline void
1199 initialize_transcoded_ports (void)
1200 {
1201   transcoded_port_type =
1202     scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write);
1203
1204   scm_set_port_flush (transcoded_port_type, tp_flush);
1205   scm_set_port_close (transcoded_port_type, tp_close);
1206 }
1207
1208 SCM_DEFINE (scm_i_make_transcoded_port,
1209             "%make-transcoded-port", 1, 0, 0,
1210             (SCM port),
1211             "Return a new port which reads and writes to @var{port}")
1212 #define FUNC_NAME s_scm_i_make_transcoded_port
1213 {
1214   SCM result;
1215   unsigned long mode = 0;
1216
1217   SCM_VALIDATE_PORT (SCM_ARG1, port);
1218
1219   if (scm_is_true (scm_output_port_p (port)))
1220     mode |= SCM_WRTNG;
1221   else if (scm_is_true (scm_input_port_p (port)))
1222     mode |=  SCM_RDNG;
1223
1224   result = make_tp (port, mode);
1225
1226   /* FIXME: We should actually close `port' "in a special way" here,
1227      according to R6RS.  As there is no way to do that in Guile without
1228      rendering the underlying port unusable for our purposes as well, we
1229      just leave it open. */
1230
1231   return result;
1232 }
1233 #undef FUNC_NAME
1234
1235 \f
1236 /* Textual I/O */
1237
1238 SCM_DEFINE (scm_get_string_n_x,
1239             "get-string-n!", 4, 0, 0,
1240             (SCM port, SCM str, SCM start, SCM count),
1241             "Read up to @var{count} characters from @var{port} into "
1242             "@var{str}, starting at @var{start}.  If no characters "
1243             "can be read before the end of file is encountered, the end "
1244             "of file object is returned.  Otherwise, the number of "
1245             "characters read is returned.")
1246 #define FUNC_NAME s_scm_get_string_n_x
1247 {
1248   size_t c_start, c_count, c_len, c_end, j;
1249   scm_t_wchar c;
1250
1251   SCM_VALIDATE_OPINPORT (1, port);
1252   SCM_VALIDATE_STRING (2, str);
1253   c_len = scm_c_string_length (str);
1254   c_start = scm_to_size_t (start);
1255   c_count = scm_to_size_t (count);
1256   c_end = c_start + c_count;
1257
1258   if (SCM_UNLIKELY (c_end > c_len))
1259     scm_out_of_range (FUNC_NAME, count);
1260
1261   for (j = c_start; j < c_end; j++)
1262     {
1263       c = scm_getc (port);
1264       if (c == EOF)
1265         {
1266           size_t chars_read = j - c_start;
1267           return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
1268         }
1269       scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
1270     }
1271   return count;
1272 }
1273 #undef FUNC_NAME
1274
1275 \f
1276 /* Initialization.  */
1277
1278 void
1279 scm_register_r6rs_ports (void)
1280 {
1281   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1282                             "scm_init_r6rs_ports",
1283                             (scm_t_extension_init_func) scm_init_r6rs_ports,
1284                             NULL);
1285 }
1286
1287 void
1288 scm_init_r6rs_ports (void)
1289 {
1290 #include "libguile/r6rs-ports.x"
1291
1292   initialize_bytevector_input_ports ();
1293   initialize_custom_binary_input_ports ();
1294   initialize_bytevector_output_ports ();
1295   initialize_custom_binary_output_ports ();
1296   initialize_transcoded_ports ();
1297 }