libguile/ports.c

   1 /*      Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 /* Headers.  */
  47
  48 #include <stdio.h>
  49 #include "_scm.h"
  50 #include "objects.h"
  51 #include "smob.h"
  52 #include "chars.h"
  53
  54 #include "keywords.h"
  55
  56 #include "scm_validate.h"
  57 #include "ports.h"
  58
  59 #ifdef HAVE_MALLOC_H
  60 #include <malloc.h>
  61 #endif
  62
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>
  65 #endif
  66
  67 #ifdef HAVE_SYS_IOCTL_H
  68 #include <sys/ioctl.h>
  69 #endif
  70
  71 \f
  72 /* The port kind table --- a dynamically resized array of port types.  */
  73
  74
  75 /* scm_ptobs scm_numptob
  76  * implement a dynamicly resized array of ptob records.
  77  * Indexes into this table are used when generating type
  78  * tags for smobjects (if you know a tag you can get an index and conversely).
  79  */
  80 scm_ptob_descriptor *scm_ptobs;
  81 int scm_numptob;
  82
  83 /* GC marker for a port with stream of SCM type.  */
  84 SCM
  85 scm_markstream (SCM ptr)
  86 {
  87   int openp;
  88   openp = SCM_CAR (ptr) & SCM_OPN;
  89   if (openp)
  90     return SCM_STREAM  (ptr);
  91   else
  92     return SCM_BOOL_F;
  93 }
  94
  95 /*
  96  * We choose to use an interface similar to the smob interface with
  97  * fill_input and write as standard fields, passed to the port
  98  * type constructor, and optional fields set by setters.
  99  */
 100
 101 static void flush_void_port (SCM port);
 102 static void end_input_void_port (SCM port, int offset);
 103 static void write_void_port (SCM port, void *data, size_t size);
 104
 105 long
 106 scm_make_port_type (char *name,
 107                     int (*fill_input) (SCM port),
 108                     void (*write) (SCM port, void *data, size_t size))
 109 {
 110   char *tmp;
 111   if (255 <= scm_numptob)
 112     goto ptoberr;
 113   SCM_DEFER_INTS;
 114   SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
 115                                        (1 + scm_numptob)
 116                                        * sizeof (scm_ptob_descriptor)));
 117   if (tmp)
 118     {
 119       scm_ptobs = (scm_ptob_descriptor *) tmp;
 120
 121       scm_ptobs[scm_numptob].name = name;
 122       scm_ptobs[scm_numptob].mark = 0;
 123       scm_ptobs[scm_numptob].free = scm_free0;
 124       scm_ptobs[scm_numptob].print = scm_port_print;
 125       scm_ptobs[scm_numptob].equalp = 0;
 126       scm_ptobs[scm_numptob].close = 0;
 127
 128       scm_ptobs[scm_numptob].write = write;
 129       scm_ptobs[scm_numptob].flush = flush_void_port;
 130
 131       scm_ptobs[scm_numptob].end_input = end_input_void_port;
 132       scm_ptobs[scm_numptob].fill_input = fill_input;
 133       scm_ptobs[scm_numptob].input_waiting = 0;
 134
 135       scm_ptobs[scm_numptob].seek = 0;
 136       scm_ptobs[scm_numptob].truncate = 0;
 137
 138       scm_numptob++;
 139     }
 140   SCM_ALLOW_INTS;
 141   if (!tmp)
 142   ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob),
 143                    (char *) SCM_NALLOC, "scm_make_port_type");
 144   /* Make a class object if Goops is present */
 145   if (scm_port_class)
 146     scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
 147   return scm_tc7_port + (scm_numptob - 1) * 256;
 148 }
 149
 150 void
 151 scm_set_port_mark (long tc, SCM (*mark) (SCM))
 152 {
 153   scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark;
 154 }
 155
 156 void
 157 scm_set_port_free (long tc, scm_sizet (*free) (SCM))
 158 {
 159   scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
 160 }
 161
 162 void
 163 scm_set_port_print (long tc, int (*print) (SCM exp, SCM port,
 164                                            scm_print_state *pstate))
 165 {
 166   scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print;
 167 }
 168
 169 void
 170 scm_set_port_equalp (long tc, SCM (*equalp) (SCM, SCM))
 171 {
 172   scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp;
 173 }
 174
 175 void
 176 scm_set_port_flush (long tc, void (*flush) (SCM port))
 177 {
 178    scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush;
 179 }
 180
 181 void
 182 scm_set_port_end_input (long tc, void (*end_input) (SCM port, int offset))
 183 {
 184   scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input;
 185 }
 186
 187 void
 188 scm_set_port_close (long tc, int (*close) (SCM))
 189 {
 190   scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close;
 191 }
 192
 193 void
 194 scm_set_port_seek (long tc, off_t (*seek) (SCM port,
 195                                            off_t OFFSET,
 196                                            int WHENCE))
 197 {
 198   scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek;
 199 }
 200
 201 void
 202 scm_set_port_truncate (long tc, void (*truncate) (SCM port, off_t length))
 203 {
 204   scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
 205 }
 206
 207 void
 208 scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM))
 209 {
 210   scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
 211 }
 212
 213 \f
 214
 215 GUILE_PROC(scm_char_ready_p, "char-ready?", 0, 1, 0,
 216            (SCM port),
 217 "")
 218 #define FUNC_NAME s_scm_char_ready_p
 219 {
 220   scm_port *pt;
 221
 222   if (SCM_UNBNDP (port))
 223     port = scm_cur_inp;
 224   else
 225     SCM_VALIDATE_OPINPORT(1,port);
 226
 227   pt = SCM_PTAB_ENTRY (port);
 228
 229   /* if the current read buffer is filled, or the
 230      last pushed-back char has been read and the saved buffer is
 231      filled, result is true.  */
 232   if (pt->read_pos < pt->read_end
 233       || (pt->read_buf == pt->putback_buf
 234           && pt->saved_read_pos < pt->saved_read_end))
 235     return SCM_BOOL_T;
 236   else
 237     {
 238       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
 239
 240       if (ptob->input_waiting)
 241         return SCM_BOOL(ptob->input_waiting (port));
 242       else
 243         return SCM_BOOL_T;
 244     }
 245 }
 246 #undef FUNC_NAME
 247
 248 /* Clear a port's read buffers, returning the contents.  */
 249 GUILE_PROC (scm_drain_input, "drain-input", 1, 0, 0,
 250             (SCM port),
 251             "")
 252 #define FUNC_NAME s_scm_drain_input
 253 {
 254   SCM result;
 255   scm_port *pt = SCM_PTAB_ENTRY (port);
 256   int count;
 257   char *dst;
 258
 259   SCM_VALIDATE_OPINPORT(1,port);
 260
 261   count = pt->read_end - pt->read_pos;
 262   if (pt->read_buf == pt->putback_buf)
 263     count += pt->saved_read_end - pt->saved_read_pos;
 264
 265   result = scm_makstr (count, 0);
 266   dst = SCM_CHARS (result);
 267
 268   while (pt->read_pos < pt->read_end)
 269     *dst++ = *(pt->read_pos++);
 270
 271   if (pt->read_buf == pt->putback_buf)
 272     {
 273       while (pt->saved_read_pos < pt->saved_read_end)
 274         *dst++ = *(pt->saved_read_pos++);
 275     }
 276
 277   return result;
 278 }
 279 #undef FUNC_NAME
 280
 281 \f
 282 /* Standard ports --- current input, output, error, and more(!).  */
 283
 284 GUILE_PROC(scm_current_input_port, "current-input-port", 0, 0, 0,
 285            (),
 286 "")
 287 #define FUNC_NAME s_scm_current_input_port
 288 {
 289   return scm_cur_inp;
 290 }
 291 #undef FUNC_NAME
 292
 293 GUILE_PROC(scm_current_output_port, "current-output-port", 0, 0, 0,
 294            (),
 295 "")
 296 #define FUNC_NAME s_scm_current_output_port
 297 {
 298   return scm_cur_outp;
 299 }
 300 #undef FUNC_NAME
 301
 302 GUILE_PROC(scm_current_error_port, "current-error-port", 0, 0, 0,
 303            (),
 304 "")
 305 #define FUNC_NAME s_scm_current_error_port
 306 {
 307   return scm_cur_errp;
 308 }
 309 #undef FUNC_NAME
 310
 311 GUILE_PROC(scm_current_load_port, "current-load-port", 0, 0, 0,
 312            (),
 313 "")
 314 #define FUNC_NAME s_scm_current_load_port
 315 {
 316   return scm_cur_loadp;
 317 }
 318 #undef FUNC_NAME
 319
 320 GUILE_PROC(scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
 321            (SCM port),
 322 "")
 323 #define FUNC_NAME s_scm_set_current_input_port
 324 {
 325   SCM oinp = scm_cur_inp;
 326   SCM_VALIDATE_OPINPORT(1,port);
 327   scm_cur_inp = port;
 328   return oinp;
 329 }
 330 #undef FUNC_NAME
 331
 332
 333 GUILE_PROC(scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
 334            (SCM port),
 335 "")
 336 #define FUNC_NAME s_scm_set_current_output_port
 337 {
 338   SCM ooutp = scm_cur_outp;
 339   port = SCM_COERCE_OUTPORT (port);
 340   SCM_VALIDATE_OPOUTPORT(1,port);
 341   scm_cur_outp = port;
 342   return ooutp;
 343 }
 344 #undef FUNC_NAME
 345
 346
 347 GUILE_PROC(scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 348            (SCM port),
 349 "")
 350 #define FUNC_NAME s_scm_set_current_error_port
 351 {
 352   SCM oerrp = scm_cur_errp;
 353   port = SCM_COERCE_OUTPORT (port);
 354   SCM_VALIDATE_OPOUTPORT(1,port);
 355   scm_cur_errp = port;
 356   return oerrp;
 357 }
 358 #undef FUNC_NAME
 359
 360 \f
 361 /* The port table --- an array of pointers to ports.  */
 362
 363 scm_port **scm_port_table;
 364
 365 int scm_port_table_size = 0;    /* Number of ports in scm_port_table.  */
 366 int scm_port_table_room = 20;   /* Size of the array.  */
 367
 368 /* Add a port to the table.  */
 369
 370 scm_port *
 371 scm_add_to_port_table (SCM port)
 372 {
 373   scm_port *entry;
 374
 375   if (scm_port_table_size == scm_port_table_room)
 376     {
 377       void *newt = realloc ((char *) scm_port_table,
 378                             (scm_sizet) (sizeof (scm_port *)
 379                                          * scm_port_table_room * 2));
 380       if (newt == NULL)
 381         scm_memory_error ("scm_add_to_port_table");
 382       scm_port_table = (scm_port **) newt;
 383       scm_port_table_room *= 2;
 384     }
 385   entry = (scm_port *) malloc (sizeof (scm_port));
 386   if (entry == NULL)
 387     scm_memory_error ("scm_add_to_port_table");
 388
 389   entry->port = port;
 390   entry->entry = scm_port_table_size;
 391   entry->revealed = 0;
 392   entry->stream = 0;
 393   entry->file_name = SCM_BOOL_F;
 394   entry->line_number = 0;
 395   entry->column_number = 0;
 396   entry->putback_buf = 0;
 397   entry->putback_buf_size = 0;
 398   entry->rw_active = SCM_PORT_NEITHER;
 399   entry->rw_random = 0;
 400
 401   scm_port_table[scm_port_table_size] = entry;
 402   scm_port_table_size++;
 403
 404   return entry;
 405 }
 406
 407 /* Remove a port from the table and destroy it.  */
 408
 409 void
 410 scm_remove_from_port_table (SCM port)
 411 {
 412   scm_port *p = SCM_PTAB_ENTRY (port);
 413   int i = p->entry;
 414
 415   if (i >= scm_port_table_size)
 416     scm_wta (port, "Port not in table", "scm_remove_from_port_table");
 417   if (p->putback_buf)
 418     free (p->putback_buf);
 419   free (p);
 420   /* Since we have just freed slot i we can shrink the table by moving
 421      the last entry to that slot... */
 422   if (i < scm_port_table_size - 1)
 423     {
 424       scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
 425       scm_port_table[i]->entry = i;
 426     }
 427   SCM_SETPTAB_ENTRY (port, 0);
 428   scm_port_table_size--;
 429 }
 430
 431 #ifdef GUILE_DEBUG
 432 /* Undocumented functions for debugging.  */
 433 /* Return the number of ports in the table.  */
 434
 435 GUILE_PROC(scm_pt_size, "pt-size", 0, 0, 0,
 436            (),
 437 "")
 438 #define FUNC_NAME s_scm_pt_size
 439 {
 440   return SCM_MAKINUM (scm_port_table_size);
 441 }
 442 #undef FUNC_NAME
 443
 444 /* Return the ith member of the port table.  */
 445 GUILE_PROC(scm_pt_member, "pt-member", 1, 0, 0,
 446            (SCM member),
 447 "")
 448 #define FUNC_NAME s_scm_pt_member
 449 {
 450   int i;
 451   SCM_VALIDATE_INT_copy(1,member,i);
 452   if (i < 0 || i >= scm_port_table_size)
 453     return SCM_BOOL_F;
 454   else
 455     return scm_port_table[i]->port;
 456 }
 457 #undef FUNC_NAME
 458 #endif
 459
 460
 461 \f
 462 /* Revealed counts --- an oddity inherited from SCSH.  */
 463
 464 /* Find a port in the table and return its revealed count.
 465    Also used by the garbage collector.
 466  */
 467
 468 int
 469 scm_revealed_count (SCM port)
 470 {
 471   return SCM_REVEALED(port);
 472 }
 473
 474
 475
 476 /* Return the revealed count for a port.  */
 477
 478 GUILE_PROC(scm_port_revealed, "port-revealed", 1, 0, 0,
 479            (SCM port),
 480 "")
 481 #define FUNC_NAME s_scm_port_revealed
 482 {
 483   port = SCM_COERCE_OUTPORT (port);
 484   SCM_VALIDATE_PORT(1,port);
 485   return SCM_MAKINUM (scm_revealed_count (port));
 486 }
 487 #undef FUNC_NAME
 488
 489 /* Set the revealed count for a port.  */
 490 GUILE_PROC(scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
 491            (SCM port, SCM rcount),
 492 "")
 493 #define FUNC_NAME s_scm_set_port_revealed_x
 494 {
 495   port = SCM_COERCE_OUTPORT (port);
 496   SCM_VALIDATE_PORT(1,port);
 497   SCM_VALIDATE_INT(2,rcount);
 498   SCM_REVEALED (port) = SCM_INUM (rcount);
 499   return SCM_UNSPECIFIED;
 500 }
 501 #undef FUNC_NAME
 502
 503
 504 \f
 505 /* Retrieving a port's mode.  */
 506
 507 /* Return the flags that characterize a port based on the mode
 508  * string used to open a file for that port.
 509  *
 510  * See PORT FLAGS in scm.h
 511  */
 512
 513 long
 514 scm_mode_bits (char *modes)
 515 {
 516   return (SCM_OPN
 517           | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
 518           | (   strchr (modes, 'w')
 519              || strchr (modes, 'a')
 520              || strchr (modes, '+') ? SCM_WRTNG : 0)
 521           | (strchr (modes, '0') ? SCM_BUF0 : 0)
 522           | (strchr (modes, 'l') ? SCM_BUFLINE : 0));
 523 }
 524
 525
 526 /* Return the mode flags from an open port.
 527  * Some modes such as "append" are only used when opening
 528  * a file and are not returned here.  */
 529
 530 GUILE_PROC(scm_port_mode, "port-mode", 1, 0, 0,
 531            (SCM port),
 532 "")
 533 #define FUNC_NAME s_scm_port_mode
 534 {
 535   char modes[3];
 536   modes[0] = '\0';
 537
 538   port = SCM_COERCE_OUTPORT (port);
 539   SCM_VALIDATE_OPPORT(1,port);
 540   if (SCM_CAR (port) & SCM_RDNG) {
 541     if (SCM_CAR (port) & SCM_WRTNG)
 542       strcpy (modes, "r+");
 543     else
 544       strcpy (modes, "r");
 545   }
 546   else if (SCM_CAR (port) & SCM_WRTNG)
 547     strcpy (modes, "w");
 548   if (SCM_CAR (port) & SCM_BUF0)
 549     strcat (modes, "0");
 550   return scm_makfromstr (modes, strlen (modes), 0);
 551 }
 552 #undef FUNC_NAME
 553
 554
 555 \f
 556 /* Closing ports.  */
 557
 558 /* scm_close_port
 559  * Call the close operation on a port object.
 560  * see also scm_close.
 561  */
 562 GUILE_PROC(scm_close_port, "close-port", 1, 0, 0,
 563            (SCM port),
 564 "")
 565 #define FUNC_NAME s_scm_close_port
 566 {
 567   scm_sizet i;
 568   int rv;
 569
 570   port = SCM_COERCE_OUTPORT (port);
 571
 572   SCM_VALIDATE_PORT(1,port);
 573   if (SCM_CLOSEDP (port))
 574     return SCM_BOOL_F;
 575   i = SCM_PTOBNUM (port);
 576   if (scm_ptobs[i].close)
 577     rv = (scm_ptobs[i].close) (port);
 578   else
 579     rv = 0;
 580   scm_remove_from_port_table (port);
 581   SCM_SETAND_CAR (port, ~SCM_OPN);
 582   return SCM_NEGATE_BOOL(rv < 0);
 583 }
 584 #undef FUNC_NAME
 585
 586 GUILE_PROC(scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
 587            (SCM ports),
 588 "")
 589 #define FUNC_NAME s_scm_close_all_ports_except
 590 {
 591   int i = 0;
 592   SCM_VALIDATE_NIMCONS(1,ports);
 593   while (i < scm_port_table_size)
 594     {
 595       SCM thisport = scm_port_table[i]->port;
 596       int found = 0;
 597       SCM ports_ptr = ports;
 598
 599       while (SCM_NNULLP (ports_ptr))
 600         {
 601           SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr));
 602           if (i == 0)
 603             SCM_VALIDATE_OPPORT(1,port);
 604           if (port == thisport)
 605             found = 1;
 606           ports_ptr = SCM_CDR (ports_ptr);
 607         }
 608       if (found)
 609         i++;
 610       else
 611         /* i is not to be incremented here.  */
 612         scm_close_port (thisport);
 613     }
 614   return SCM_UNSPECIFIED;
 615 }
 616 #undef FUNC_NAME
 617
 618
 619 \f
 620 /* Utter miscellany.  Gosh, we should clean this up some time.  */
 621
 622 GUILE_PROC(scm_input_port_p, "input-port?", 1, 0, 0,
 623            (SCM x),
 624 "")
 625 #define FUNC_NAME s_scm_input_port_p
 626 {
 627   if (SCM_IMP (x))
 628     return SCM_BOOL_F;
 629   return SCM_BOOL(SCM_INPORTP (x));
 630 }
 631 #undef FUNC_NAME
 632
 633 GUILE_PROC(scm_output_port_p, "output-port?", 1, 0, 0,
 634            (SCM x),
 635 "")
 636 #define FUNC_NAME s_scm_output_port_p
 637 {
 638   if (SCM_IMP (x))
 639     return SCM_BOOL_F;
 640   if (SCM_PORT_WITH_PS_P (x))
 641     x = SCM_PORT_WITH_PS_PORT (x);
 642   return SCM_BOOL(SCM_OUTPORTP (x));
 643 }
 644 #undef FUNC_NAME
 645
 646 GUILE_PROC(scm_port_closed_p, "port-closed?", 1, 0, 0,
 647            (SCM port),
 648 "")
 649 #define FUNC_NAME s_scm_port_closed_p
 650 {
 651   SCM_VALIDATE_OPPORT(1,port);
 652   return SCM_NEGATE_BOOL(SCM_OPPORTP (port));
 653 }
 654 #undef FUNC_NAME
 655
 656 GUILE_PROC(scm_eof_object_p, "eof-object?", 1, 0, 0,
 657            (SCM x),
 658 "")
 659 #define FUNC_NAME s_scm_eof_object_p
 660 {
 661   return SCM_BOOL(SCM_EOF_OBJECT_P (x));
 662 }
 663 #undef FUNC_NAME
 664
 665 GUILE_PROC(scm_force_output, "force-output", 0, 1, 0,
 666            (SCM port),
 667 "")
 668 #define FUNC_NAME s_scm_force_output
 669 {
 670   if (SCM_UNBNDP (port))
 671     port = scm_cur_outp;
 672   else
 673     {
 674       port = SCM_COERCE_OUTPORT (port);
 675       SCM_VALIDATE_OPOUTPORT(1,port);
 676     }
 677   scm_flush (port);
 678   return SCM_UNSPECIFIED;
 679 }
 680 #undef FUNC_NAME
 681
 682 GUILE_PROC (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
 683             (),
 684 "")
 685 #define FUNC_NAME s_scm_flush_all_ports
 686 {
 687   int i;
 688
 689   for (i = 0; i < scm_port_table_size; i++)
 690     {
 691       if (SCM_OPOUTPORTP (scm_port_table[i]->port))
 692         scm_flush (scm_port_table[i]->port);
 693     }
 694   return SCM_UNSPECIFIED;
 695 }
 696 #undef FUNC_NAME
 697
 698 GUILE_PROC(scm_read_char, "read-char", 0, 1, 0,
 699            (SCM port),
 700 "")
 701 #define FUNC_NAME s_scm_read_char
 702 {
 703   int c;
 704   if (SCM_UNBNDP (port))
 705     port = scm_cur_inp;
 706   SCM_VALIDATE_OPINPORT(1,port);
 707   c = scm_getc (port);
 708   if (EOF == c)
 709     return SCM_EOF_VAL;
 710   return SCM_MAKICHR (c);
 711 }
 712 #undef FUNC_NAME
 713
 714 /* this should only be called when the read buffer is empty.  it
 715    tries to refill the read buffer.  it returns the first char from
 716    the port, which is either EOF or *(pt->read_pos).  */
 717 int
 718 scm_fill_input (SCM port)
 719 {
 720   scm_port *pt = SCM_PTAB_ENTRY (port);
 721
 722   if (pt->read_buf == pt->putback_buf)
 723     {
 724       /* finished reading put-back chars.  */
 725       pt->read_buf = pt->saved_read_buf;
 726       pt->read_pos = pt->saved_read_pos;
 727       pt->read_end = pt->saved_read_end;
 728       pt->read_buf_size = pt->saved_read_buf_size;
 729       if (pt->read_pos < pt->read_end)
 730         return *(pt->read_pos);
 731     }
 732   return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port);
 733 }
 734
 735 int
 736 scm_getc (SCM port)
 737 {
 738   int c;
 739   scm_port *pt = SCM_PTAB_ENTRY (port);
 740
 741   if (pt->rw_active == SCM_PORT_WRITE)
 742     {
 743       /* may be marginally faster than calling scm_flush.  */
 744       scm_ptobs[SCM_PTOBNUM (port)].flush (port);
 745     }
 746
 747   if (pt->rw_random)
 748     pt->rw_active = SCM_PORT_READ;
 749
 750   if (pt->read_pos >= pt->read_end)
 751     {
 752       if (scm_fill_input (port) == EOF)
 753         return EOF;
 754     }
 755
 756   c = *(pt->read_pos++);
 757
 758   if (c == '\n')
 759     {
 760       SCM_INCLINE (port);
 761     }
 762   else if (c == '\t')
 763     {
 764       SCM_TABCOL (port);
 765     }
 766   else
 767     {
 768       SCM_INCCOL (port);
 769     }
 770
 771   return c;
 772 }
 773
 774 void
 775 scm_putc (char c, SCM port)
 776 {
 777   scm_lfwrite (&c, 1, port);
 778 }
 779
 780 void
 781 scm_puts (char *s, SCM port)
 782 {
 783   scm_lfwrite (s, strlen (s), port);
 784 }
 785
 786 void
 787 scm_lfwrite (char *ptr, scm_sizet size, SCM port)
 788 {
 789   scm_port *pt = SCM_PTAB_ENTRY (port);
 790   scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
 791
 792   if (pt->rw_active == SCM_PORT_READ)
 793     scm_end_input (port);
 794
 795   ptob->write (port, ptr, size);
 796
 797   if (pt->rw_random)
 798     pt->rw_active = SCM_PORT_WRITE;
 799 }
 800
 801
 802 void
 803 scm_flush (SCM port)
 804 {
 805   scm_sizet i = SCM_PTOBNUM (port);
 806   (scm_ptobs[i].flush) (port);
 807 }
 808
 809 void
 810 scm_end_input (SCM port)
 811 {
 812   int offset;
 813   scm_port *pt = SCM_PTAB_ENTRY (port);
 814
 815   if (pt->read_buf == pt->putback_buf)
 816     {
 817       offset = pt->read_end - pt->read_pos;
 818       pt->read_buf = pt->saved_read_buf;
 819       pt->read_pos = pt->saved_read_pos;
 820       pt->read_end = pt->saved_read_end;
 821       pt->read_buf_size = pt->saved_read_buf_size;
 822     }
 823   else
 824     offset = 0;
 825
 826   scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
 827 }
 828
 829 \f
 830
 831
 832 void
 833 scm_ungetc (int c, SCM port)
 834 {
 835   scm_port *pt = SCM_PTAB_ENTRY (port);
 836
 837   if (pt->read_buf == pt->putback_buf)
 838     /* already using the put-back buffer.  */
 839     {
 840       /* enlarge putback_buf if necessary.  */
 841       if (pt->read_end == pt->read_buf + pt->read_buf_size
 842           && pt->read_buf == pt->read_pos)
 843         {
 844           int new_size = pt->read_buf_size * 2;
 845           unsigned char *tmp =
 846             (unsigned char *) realloc (pt->putback_buf, new_size);
 847
 848           if (tmp == NULL)
 849             scm_memory_error ("scm_ungetc");
 850           pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
 851           pt->read_end = pt->read_buf + pt->read_buf_size;
 852           pt->read_buf_size = pt->putback_buf_size = new_size;
 853         }
 854
 855       /* shift any existing bytes to buffer + 1.  */
 856       if (pt->read_pos == pt->read_end)
 857         pt->read_end = pt->read_buf + 1;
 858       else if (pt->read_pos != pt->read_buf + 1)
 859         {
 860           int count = pt->read_end - pt->read_pos;
 861
 862           memmove (pt->read_buf + 1, pt->read_pos, count);
 863           pt->read_end = pt->read_buf + 1 + count;
 864         }
 865
 866       pt->read_pos = pt->read_buf;
 867     }
 868   else
 869     /* switch to the put-back buffer.  */
 870     {
 871       if (pt->putback_buf == NULL)
 872         {
 873           pt->putback_buf = (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE);
 874           if (pt->putback_buf == NULL)
 875             scm_memory_error ("scm_ungetc");
 876           pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
 877         }
 878
 879       pt->saved_read_buf = pt->read_buf;
 880       pt->saved_read_pos = pt->read_pos;
 881       pt->saved_read_end = pt->read_end;
 882       pt->saved_read_buf_size = pt->read_buf_size;
 883
 884       pt->read_pos = pt->read_buf = pt->putback_buf;
 885       pt->read_end = pt->read_buf + 1;
 886       pt->read_buf_size = pt->putback_buf_size;
 887     }
 888
 889   *pt->read_buf = c;
 890
 891   if (pt->rw_random)
 892     pt->rw_active = SCM_PORT_READ;
 893
 894   if (c == '\n')
 895     {
 896       /* What should col be in this case?
 897        * We'll leave it at -1.
 898        */
 899       SCM_LINUM (port) -= 1;
 900     }
 901   else
 902     SCM_COL(port) -= 1;
 903 }
 904
 905
 906 void
 907 scm_ungets (char *s, int n, SCM port)
 908 {
 909   /* This is simple minded and inefficient, but unreading strings is
 910    * probably not a common operation, and remember that line and
 911    * column numbers have to be handled...
 912    *
 913    * Please feel free to write an optimized version!
 914    */
 915   while (n--)
 916     scm_ungetc (s[n], port);
 917 }
 918
 919
 920 GUILE_PROC(scm_peek_char, "peek-char", 0, 1, 0,
 921            (SCM port),
 922 "")
 923 #define FUNC_NAME s_scm_peek_char
 924 {
 925   int c;
 926   if (SCM_UNBNDP (port))
 927     port = scm_cur_inp;
 928   else
 929     SCM_VALIDATE_OPINPORT(1,port);
 930   c = scm_getc (port);
 931   if (EOF == c)
 932     return SCM_EOF_VAL;
 933   scm_ungetc (c, port);
 934   return SCM_MAKICHR (c);
 935 }
 936 #undef FUNC_NAME
 937
 938 GUILE_PROC (scm_unread_char, "unread-char", 2, 0, 0,
 939             (SCM cobj, SCM port),
 940 "")
 941 #define FUNC_NAME s_scm_unread_char
 942 {
 943   int c;
 944
 945   SCM_VALIDATE_CHAR(1,cobj);
 946   if (SCM_UNBNDP (port))
 947     port = scm_cur_inp;
 948   else
 949     SCM_VALIDATE_OPINPORT(1,port);
 950
 951   c = SCM_ICHR (cobj);
 952
 953   scm_ungetc (c, port);
 954   return cobj;
 955 }
 956 #undef FUNC_NAME
 957
 958 GUILE_PROC (scm_unread_string, "unread-string", 2, 0, 0,
 959             (SCM str, SCM port),
 960 "")
 961 #define FUNC_NAME s_scm_unread_string
 962 {
 963   SCM_VALIDATE_STRING(1,str);
 964   if (SCM_UNBNDP (port))
 965     port = scm_cur_inp;
 966   else
 967     SCM_VALIDATE_OPINPORT(1,port);
 968
 969   scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port);
 970
 971   return str;
 972 }
 973 #undef FUNC_NAME
 974
 975 GUILE_PROC (scm_seek, "seek", 3, 0, 0,
 976             (SCM object, SCM offset, SCM whence),
 977 "")
 978 #define FUNC_NAME s_scm_seek
 979 {
 980   off_t off;
 981   off_t rv;
 982   int how;
 983
 984   object = SCM_COERCE_OUTPORT (object);
 985
 986   off = SCM_NUM2LONG (2,offset);
 987   SCM_VALIDATE_INT_COPY(3,whence,how);
 988   if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
 989     SCM_OUT_OF_RANGE (3, whence);
 990   if (SCM_NIMP (object) && SCM_OPPORTP (object))
 991     {
 992       scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
 993
 994       if (!ptob->seek)
 995         SCM_MISC_ERROR ("port is not seekable",
 996                         scm_cons (object, SCM_EOL));
 997       else
 998         rv = ptob->seek (object, off, how);
 999     }
1000   else /* file descriptor?.  */
1001     {
1002       SCM_VALIDATE_INT(1,object);
1003       rv = lseek (SCM_INUM (object), off, how);
1004       if (rv == -1)
1005         SCM_SYSERROR;
1006     }
1007   return scm_long2num (rv);
1008 }
1009 #undef FUNC_NAME
1010
1011 GUILE_PROC (scm_truncate_file, "truncate-file", 1, 1, 0,
1012             (SCM object, SCM length),
1013 "")
1014 #define FUNC_NAME s_scm_truncate_file
1015 {
1016   int rv;
1017   off_t c_length;
1018
1019   /* object can be a port, fdes or filename.  */
1020
1021   if (SCM_UNBNDP (length))
1022     {
1023       /* must supply length if object is a filename.  */
1024       if (SCM_NIMP (object) && SCM_ROSTRINGP (object))
1025         scm_wrong_num_args (SCM_FUNC_NAME);
1026
1027       length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
1028     }
1029   c_length = SCM_NUM2LONG (2,length);
1030   if (c_length < 0)
1031     SCM_MISC_ERROR ("negative offset", SCM_EOL);
1032
1033   object = SCM_COERCE_OUTPORT (object);
1034   if (SCM_INUMP (object))
1035     {
1036       SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length));
1037     }
1038   else if (SCM_NIMP (object) && SCM_OPOUTPORTP (object))
1039     {
1040       scm_port *pt = SCM_PTAB_ENTRY (object);
1041       scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
1042
1043       if (!ptob->truncate)
1044         SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
1045       if (pt->rw_active == SCM_PORT_READ)
1046         scm_end_input (object);
1047       else if (pt->rw_active == SCM_PORT_WRITE)
1048         ptob->flush (object);
1049
1050       ptob->truncate (object, c_length);
1051       rv = 0;
1052     }
1053   else
1054     {
1055       SCM_VALIDATE_ROSTRING(1,object);
1056       SCM_COERCE_SUBSTR (object);
1057       SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length));
1058     }
1059   if (rv == -1)
1060     SCM_SYSERROR;
1061   return SCM_UNSPECIFIED;
1062 }
1063 #undef FUNC_NAME
1064
1065 GUILE_PROC (scm_port_line, "port-line", 1, 0, 0,
1066             (SCM port),
1067 "")
1068 #define FUNC_NAME s_scm_port_line
1069 {
1070   port = SCM_COERCE_OUTPORT (port);
1071   SCM_VALIDATE_OPENPORT(1,port);
1072   return SCM_MAKINUM (SCM_LINUM (port));
1073 }
1074 #undef FUNC_NAME
1075
1076 GUILE_PROC (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
1077             (SCM port, SCM line),
1078 "")
1079 #define FUNC_NAME s_scm_set_port_line_x
1080 {
1081   port = SCM_COERCE_OUTPORT (port);
1082   SCM_VALIDATE_OPENPORT(1,port);
1083   SCM_VALIDATE_INT(2,line);
1084   return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
1085 }
1086 #undef FUNC_NAME
1087
1088 GUILE_PROC (scm_port_column, "port-column", 1, 0, 0,
1089             (SCM port),
1090 "")
1091 #define FUNC_NAME s_scm_port_column
1092 {
1093   port = SCM_COERCE_OUTPORT (port);
1094   SCM_VALIDATE_OPENPORT(1,port);
1095   return SCM_MAKINUM (SCM_COL (port));
1096 }
1097 #undef FUNC_NAME
1098
1099 GUILE_PROC (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
1100             (SCM port, SCM column),
1101 "")
1102 #define FUNC_NAME s_scm_set_port_column_x
1103 {
1104   port = SCM_COERCE_OUTPORT (port);
1105   SCM_VALIDATE_OPENPORT(1,port);
1106   SCM_VALIDATE_INT(2,column);
1107   return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
1108 }
1109 #undef FUNC_NAME
1110
1111 GUILE_PROC (scm_port_filename, "port-filename", 1, 0, 0,
1112             (SCM port),
1113 "")
1114 #define FUNC_NAME s_scm_port_filename
1115 {
1116   port = SCM_COERCE_OUTPORT (port);
1117   SCM_VALIDATE_OPENPORT(1,port);
1118   return SCM_PTAB_ENTRY (port)->file_name;
1119 }
1120 #undef FUNC_NAME
1121
1122 GUILE_PROC (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
1123             (SCM port, SCM filename),
1124 "")
1125 #define FUNC_NAME s_scm_set_port_filename_x
1126 {
1127   port = SCM_COERCE_OUTPORT (port);
1128   SCM_VALIDATE_OPENPORT(1,port);
1129   /* We allow the user to set the filename to whatever he likes.  */
1130   return SCM_PTAB_ENTRY (port)->file_name = filename;
1131 }
1132 #undef FUNC_NAME
1133
1134 #ifndef ttyname
1135 extern char * ttyname();
1136 #endif
1137
1138 void
1139 scm_print_port_mode (SCM exp, SCM port)
1140 {
1141   scm_puts (SCM_CLOSEDP (exp)
1142             ? "closed: "
1143             : (SCM_RDNG & SCM_CAR (exp)
1144                ? (SCM_WRTNG & SCM_CAR (exp)
1145                   ? "input-output: "
1146                   : "input: ")
1147                : (SCM_WRTNG & SCM_CAR (exp)
1148                   ? "output: "
1149                   : "bogus: ")),
1150             port);
1151 }
1152
1153 int
1154 scm_port_print (SCM exp, SCM port, scm_print_state *pstate)
1155 {
1156   char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
1157   if (!type)
1158     type = "port";
1159   scm_puts ("#<", port);
1160   scm_print_port_mode (exp, port);
1161   scm_puts (type, port);
1162   scm_putc (' ', port);
1163   scm_intprint (SCM_CDR (exp), 16, port);
1164   scm_putc ('>', port);
1165   return 1;
1166 }
1167
1168 extern void scm_make_fptob ();
1169 extern void scm_make_stptob ();
1170 extern void scm_make_sfptob ();
1171
1172 void
1173 scm_ports_prehistory ()
1174 {
1175   scm_numptob = 0;
1176   scm_ptobs = (scm_ptob_descriptor *) malloc (sizeof (scm_ptob_descriptor));
1177
1178   /* WARNING: These scm_newptob calls must be done in this order.
1179    * They must agree with the port declarations in tags.h.
1180    */
1181   /* scm_tc16_fport = */ scm_make_fptob ();
1182   /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy.  */
1183   /* scm_tc16_strport = */ scm_make_stptob ();
1184   /* scm_tc16_sfport = */ scm_make_sfptob ();
1185 }
1186
1187 \f
1188
1189 /* Void ports.   */
1190
1191 long scm_tc16_void_port = 0;
1192
1193 static void
1194 flush_void_port (SCM port)
1195 {
1196 }
1197
1198 static void
1199 end_input_void_port (SCM port, int offset)
1200 {
1201 }
1202
1203 static void
1204 write_void_port (SCM port, void *data, size_t size)
1205 {
1206 }
1207
1208 SCM
1209 scm_void_port (char *mode_str)
1210 {
1211   int mode_bits;
1212   SCM answer;
1213   scm_port * pt;
1214
1215   SCM_NEWCELL (answer);
1216   SCM_DEFER_INTS;
1217   mode_bits = scm_mode_bits (mode_str);
1218   pt = scm_add_to_port_table (answer);
1219   SCM_SETPTAB_ENTRY (answer, pt);
1220   SCM_SETSTREAM (answer, 0);
1221   SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
1222   SCM_ALLOW_INTS;
1223   return answer;
1224 }
1225
1226
1227 GUILE_PROC (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
1228             (SCM mode),
1229 "")
1230 #define FUNC_NAME s_scm_sys_make_void_port
1231 {
1232   SCM_VALIDATE_ROSTRING(1,mode);
1233   SCM_COERCE_SUBSTR (mode);
1234   return scm_void_port (SCM_ROCHARS (mode));
1235 }
1236 #undef FUNC_NAME
1237
1238 \f
1239 /* Initialization.  */
1240
1241 void
1242 scm_init_ports ()
1243 {
1244   /* lseek() symbols.  */
1245   scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
1246   scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
1247   scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END));
1248
1249   scm_tc16_void_port = scm_make_port_type ("void", 0, write_void_port);
1250 #include "ports.x"
1251 }