libguile/r6rs-ports.c

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