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_INPUT_PORT
 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 read;
 459
 460   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 461   c_count = scm_to_uint (count);
 462
 463   c_bv = (char *) scm_gc_malloc (c_count, SCM_GC_BYTEVECTOR);
 464
 465   /* XXX: `scm_c_read ()' does not update the port position.  */
 466   read = scm_c_read (port, c_bv, c_count);
 467
 468   if (read == 0)
 469     {
 470       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 471         result = SCM_EOF_VAL;
 472       else
 473         result = scm_r6rs_c_take_bytevector (NULL, 0);
 474     }
 475   else
 476     {
 477       if (read < c_count)
 478         c_bv = (char *) scm_gc_realloc (c_bv, c_count, read,
 479                                         SCM_GC_BYTEVECTOR);
 480
 481       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, read);
 482     }
 483
 484   return result;
 485 }
 486 #undef FUNC_NAME
 487
 488 SCM_DEFINE (scm_r6rs_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
 489             (SCM port, SCM bv, SCM start, SCM count),
 490             "Read @var{count} bytes from @var{port} and store them "
 491             "in @var{bv} starting at index @var{start}.  Return either "
 492             "the number of bytes actually read or the end-of-file "
 493             "object.")
 494 #define FUNC_NAME s_scm_r6rs_get_bytevector_n_x
 495 {
 496   SCM result;
 497   char *c_bv;
 498   unsigned c_start, c_count, c_len;
 499   size_t c_read;
 500
 501   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 502   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 503   c_start = scm_to_uint (start);
 504   c_count = scm_to_uint (count);
 505
 506   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 507   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 508
 509   if (EXPECT_FALSE (c_start + c_count > c_len))
 510     scm_out_of_range (FUNC_NAME, count);
 511
 512   c_read = scm_c_read (port, c_bv + c_start, c_count);
 513   if (c_read == 0)
 514     {
 515       if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
 516         result = SCM_EOF_VAL;
 517       else
 518         result = SCM_I_MAKINUM (0);
 519     }
 520   else
 521     result = scm_from_size_t (c_read);
 522
 523   return result;
 524 }
 525 #undef FUNC_NAME
 526
 527
 528 SCM_DEFINE (scm_r6rs_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 529             (SCM port),
 530             "Read from @var{port}, blocking as necessary, until data "
 531             "are available or and end-of-file is reached.  Return either "
 532             "a new bytevector containing the data read or the "
 533             "end-of-file object.")
 534 #define FUNC_NAME s_scm_r6rs_get_bytevector_some
 535 {
 536   /* Read at least one byte, unless the end-of-file is already reached, and
 537      read while characters are available (buffered).  */
 538
 539   SCM result;
 540   char *c_bv;
 541   unsigned c_len;
 542   size_t c_total;
 543
 544   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 545
 546   c_len = 4096;
 547   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 548   c_total = 0;
 549
 550   do
 551     {
 552       int c_chr;
 553
 554       if (c_total + 1 > c_len)
 555         {
 556           /* Grow the bytevector.  */
 557           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 558                                           SCM_GC_BYTEVECTOR);
 559           c_len *= 2;
 560         }
 561
 562       /* We can't use `scm_c_read ()' since it blocks.  */
 563       c_chr = scm_getc (port);
 564       if (c_chr != EOF)
 565         {
 566           c_bv[c_total] = (char) c_chr;
 567           c_total++;
 568         }
 569     }
 570   while ((scm_is_true (scm_char_ready_p (port)))
 571          && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
 572
 573   if (c_total == 0)
 574     {
 575       result = SCM_EOF_VAL;
 576       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 577     }
 578   else
 579     {
 580       if (c_len > c_total)
 581         {
 582           /* Shrink the bytevector.  */
 583           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 584                                           SCM_GC_BYTEVECTOR);
 585           c_len = (unsigned) c_total;
 586         }
 587
 588       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 589     }
 590
 591   return result;
 592 }
 593 #undef FUNC_NAME
 594
 595 SCM_DEFINE (scm_r6rs_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 596             (SCM port),
 597             "Read from @var{port}, blocking as necessary, until "
 598             "the end-of-file is reached.  Return either "
 599             "a new bytevector containing the data read or the "
 600             "end-of-file object (if no data were available).")
 601 #define FUNC_NAME s_scm_r6rs_get_bytevector_all
 602 {
 603   SCM result;
 604   char *c_bv;
 605   unsigned c_len, c_count;
 606   size_t c_read, c_total;
 607
 608   SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
 609
 610   c_len = c_count = 4096;
 611   c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
 612   c_total = c_read = 0;
 613
 614   do
 615     {
 616       if (c_total + c_read > c_len)
 617         {
 618           /* Grow the bytevector.  */
 619           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
 620                                           SCM_GC_BYTEVECTOR);
 621           c_count = c_len;
 622           c_len *= 2;
 623         }
 624
 625       /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
 626          reached.  */
 627       c_read = scm_c_read (port, c_bv + c_total, c_count);
 628       c_total += c_read, c_count -= c_read;
 629     }
 630   while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
 631
 632   if (c_total == 0)
 633     {
 634       result = SCM_EOF_VAL;
 635       scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
 636     }
 637   else
 638     {
 639       if (c_len > c_total)
 640         {
 641           /* Shrink the bytevector.  */
 642           c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
 643                                           SCM_GC_BYTEVECTOR);
 644           c_len = (unsigned) c_total;
 645         }
 646
 647       result = scm_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
 648     }
 649
 650   return result;
 651 }
 652 #undef FUNC_NAME
 653
 654
 655 \f
 656 /* Binary output.  */
 657
 658 /* We currently don't support specific binary input ports.  */
 659 #define SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OUTPUT_PORT
 660
 661
 662 SCM_DEFINE (scm_r6rs_put_u8, "put-u8", 2, 0, 0,
 663             (SCM port, SCM octet),
 664             "Write @var{octet} to binary port @var{port}.")
 665 #define FUNC_NAME s_scm_r6rs_put_u8
 666 {
 667   scm_t_uint8 c_octet;
 668
 669   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 670   c_octet = scm_to_uint8 (octet);
 671
 672   scm_putc ((char) c_octet, port);
 673
 674   return SCM_UNSPECIFIED;
 675 }
 676 #undef FUNC_NAME
 677
 678 SCM_DEFINE (scm_r6rs_put_bytevector, "put-bytevector", 2, 2, 0,
 679             (SCM port, SCM bv, SCM start, SCM count),
 680             "Write the contents of @var{bv} to @var{port}, optionally "
 681             "starting at index @var{start} and limiting to @var{count} "
 682             "octets.")
 683 #define FUNC_NAME s_scm_r6rs_put_bytevector
 684 {
 685   char *c_bv;
 686   unsigned c_start, c_count, c_len;
 687
 688   SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
 689   SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
 690
 691   c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
 692   c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
 693
 694   if (start != SCM_UNDEFINED)
 695     {
 696       c_start = scm_to_uint (start);
 697
 698       if (count != SCM_UNDEFINED)
 699         {
 700           c_count = scm_to_uint (count);
 701           if (EXPECT_FALSE (c_start + c_count > c_len))
 702             scm_out_of_range (FUNC_NAME, count);
 703         }
 704       else
 705         {
 706           if (EXPECT_FALSE (c_start >= c_len))
 707             scm_out_of_range (FUNC_NAME, start);
 708           else
 709             c_count = c_len - c_start;
 710         }
 711     }
 712   else
 713     c_start = 0, c_count = c_len;
 714
 715   scm_c_write (port, c_bv + c_start, c_count);
 716
 717   return SCM_UNSPECIFIED;
 718 }
 719 #undef FUNC_NAME
 720
 721
 722 \f
 723 /* Bytevector output port ("bop" for short).  */
 724
 725 /* Implementation of "bops".
 726
 727    Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
 728    it.  The procedure returned along with the output port is actually an
 729    applicable SMOB.  The SMOB holds a reference to the port.  When applied,
 730    the SMOB swallows the port's internal buffer, turning it into a
 731    bytevector, and resets it.
 732
 733    XXX: Access to a bop's internal buffer is not thread-safe.  */
 734
 735 static scm_t_bits bytevector_output_port_type = 0;
 736
 737 SCM_SMOB (bytevector_output_port_procedure,
 738           "r6rs-bytevector-output-port-procedure",
 739           0);
 740
 741 #define SCM_GC_BOP "r6rs-bytevector-output-port"
 742 #define SCM_BOP_BUFFER_INITIAL_SIZE 4096
 743
 744 /* Representation of a bop's internal buffer.  */
 745 typedef struct
 746 {
 747   size_t total_len;
 748   size_t len;
 749   size_t pos;
 750   char  *buffer;
 751 } scm_t_bop_buffer;
 752
 753
 754 /* Accessing a bop's buffer.  */
 755 #define SCM_R6RS_BOP_BUFFER(_port)              \
 756   ((scm_t_bop_buffer *) SCM_STREAM (_port))
 757 #define SCM_R6RS_SET_BOP_BUFFER(_port, _buf)            \
 758   (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
 759
 760
 761 static inline void
 762 bop_buffer_init (scm_t_bop_buffer *buf)
 763 {
 764   buf->total_len = buf->len = buf->pos = 0;
 765   buf->buffer = NULL;
 766 }
 767
 768 static inline void
 769 bop_buffer_grow (scm_t_bop_buffer *buf)
 770 {
 771   char *new_buf;
 772
 773   new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
 774                             buf->total_len * 2,
 775                             SCM_GC_BOP);
 776   buf->buffer = new_buf;
 777   buf->total_len *= 2;
 778 }
 779
 780 static inline SCM
 781 make_bop (void)
 782 {
 783   SCM port, bop_proc;
 784   scm_t_port *c_port;
 785   scm_t_bop_buffer *buf;
 786   const unsigned long mode_bits = SCM_OPN | SCM_WRTNG | SCM_BUF0;
 787
 788   port = scm_new_port_table_entry (bytevector_output_port_type);
 789
 790   buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
 791   bop_buffer_init (buf);
 792
 793   c_port = SCM_PTAB_ENTRY (port);
 794   c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
 795
 796   SCM_R6RS_SET_BOP_BUFFER (port, buf);
 797
 798   /* Mark PORT as open and writable.  */
 799   SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
 800
 801   /* Make the bop procedure.  */
 802   SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
 803                SCM_PACK (port));
 804
 805   return (scm_values (scm_list_2 (port, bop_proc)));
 806 }
 807
 808 static size_t
 809 bop_free (SCM port)
 810 {
 811   /* The port itself is necessarily freed _after_ the bop proc, since the bop
 812      proc holds a reference to it.  Thus we can safely free the internal
 813      buffer when the bop becomes unreferenced.  */
 814   scm_t_bop_buffer *buf;
 815
 816   buf = SCM_R6RS_BOP_BUFFER (port);
 817   if (buf->buffer)
 818     scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
 819
 820   scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
 821
 822   return 0;
 823 }
 824
 825 /* Write SIZE octets from DATA to PORT.  */
 826 static void
 827 bop_write (SCM port, const void *data, size_t size)
 828 {
 829   scm_t_bop_buffer *buf;
 830
 831   buf = SCM_R6RS_BOP_BUFFER (port);
 832
 833   while (buf->pos + size > buf->total_len)
 834     {
 835       /* The buffer must be grown.  */
 836       if (buf->total_len == 0)
 837         {
 838           buf->buffer = scm_gc_malloc (SCM_BOP_BUFFER_INITIAL_SIZE,
 839                                        SCM_GC_BOP);
 840           buf->total_len = SCM_BOP_BUFFER_INITIAL_SIZE;
 841         }
 842       else
 843         bop_buffer_grow (buf);
 844     }
 845
 846   memcpy (buf->buffer + buf->pos, data, size);
 847   buf->pos += size;
 848   buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
 849 }
 850
 851 static off_t
 852 bop_seek (SCM port, off_t offset, int whence)
 853 #define FUNC_NAME "bop_seek"
 854 {
 855   scm_t_bop_buffer *buf;
 856
 857   buf = SCM_R6RS_BOP_BUFFER (port);
 858   switch (whence)
 859     {
 860     case SEEK_CUR:
 861       offset += (off_t) buf->pos;
 862       /* Fall through.  */
 863
 864     case SEEK_SET:
 865       if (offset > buf->len)
 866         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 867       else
 868         buf->pos = offset;
 869       break;
 870
 871     case SEEK_END:
 872       if (offset >= buf->len)
 873         scm_out_of_range (FUNC_NAME, scm_from_int (offset));
 874       else
 875         buf->pos = buf->len - offset;
 876       break;
 877
 878     default:
 879       scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
 880                               "invalid `seek' parameter");
 881     }
 882
 883   return buf->pos;
 884 }
 885 #undef FUNC_NAME
 886
 887 /* Fetch data from a bop.  */
 888 SCM_SMOB_APPLY (bytevector_output_port_procedure,
 889                 bop_proc_apply, 0, 0, 0, (SCM bop_proc))
 890 {
 891   SCM port, bv;
 892   scm_t_bop_buffer *buf, result_buf;
 893
 894   port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
 895   buf = SCM_R6RS_BOP_BUFFER (port);
 896
 897   result_buf = *buf;
 898   bop_buffer_init (buf);
 899
 900   if (result_buf.len == 0)
 901     bv = scm_r6rs_c_take_bytevector (NULL, 0);
 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_r6rs_c_take_bytevector ((signed char *) result_buf.buffer,
 912                                        result_buf.len);
 913     }
 914
 915   return bv;
 916 }
 917
 918 SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
 919                bop_proc)
 920 {
 921   /* Mark the port associated to BOP_PROC.  */
 922   return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
 923 }
 924
 925
 926 SCM_DEFINE (scm_r6rs_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 scm_r6rs_open_bytevector_output_port
 933 {
 934   if (transcoder != SCM_UNDEFINED)
 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   scm_set_port_free (bytevector_output_port_type, bop_free);
 950 }
 951
 952
 953 \f
 954 /* Initialization.  */
 955
 956 void
 957 scm_init_r6rs_ports (void)
 958 {
 959 #include "ports.c.x"
 960
 961   initialize_bytevector_input_ports ();
 962   initialize_custom_binary_input_ports ();
 963   initialize_bytevector_output_ports ();
 964 }
 965
 966 /* arch-tag: c041ffd6-8871-40e8-a25a-d0f8768a71dc
 967  */