libguile/r6rs-ports.c

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