libguile/r6rs-ports.c

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