src/ports.c

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