libguile/fports.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
  47 #include <stdio.h>
  48 #include <fcntl.h>
  49 #include "_scm.h"
  50
  51 #include "scm_validate.h"
  52 #include "fports.h"
  53
  54 #ifdef HAVE_STRING_H
  55 #include <string.h>
  56 #endif
  57 #ifdef HAVE_UNISTD_H
  58 #include <unistd.h>
  59 #else
  60 scm_sizet fwrite ();
  61 #endif
  62 #ifdef HAVE_ST_BLKSIZE
  63 #include <sys/stat.h>
  64 #endif
  65
  66 #include <errno.h>
  67
  68 #include "iselect.h"
  69
  70 /* create FPORT buffer with specified sizes (or -1 to use default size or
  71    0 for no buffer.  */
  72 static void
  73 scm_fport_buffer_add (SCM port, int read_size, int write_size)
  74 {
  75   struct scm_fport *fp = SCM_FSTREAM (port);
  76    scm_port *pt = SCM_PTAB_ENTRY (port);
  77   char *s_scm_fport_buffer_add = "scm_fport_buffer_add";
  78
  79   if (read_size == -1 || write_size == -1)
  80     {
  81       int default_size;
  82 #ifdef HAVE_ST_BLKSIZE
  83       struct stat st;
  84
  85       if (fstat (fp->fdes, &st) == -1)
  86         scm_syserror (s_scm_fport_buffer_add);
  87       default_size = st.st_blksize;
  88 #else
  89       default_size = 1024;
  90 #endif
  91       if (read_size == -1)
  92         read_size = default_size;
  93       if (write_size == -1)
  94         write_size = default_size;
  95     }
  96
  97   if (SCM_INPORTP (port) && read_size > 0)
  98     {
  99       pt->read_buf = malloc (read_size);
 100       if (pt->read_buf == NULL)
 101         scm_memory_error (s_scm_fport_buffer_add);
 102       pt->read_pos = pt->read_end = pt->read_buf;
 103       pt->read_buf_size = read_size;
 104     }
 105   else
 106     {
 107       pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
 108       pt->read_buf_size = 1;
 109     }
 110
 111   if (SCM_OUTPORTP (port) && write_size > 0)
 112     {
 113       pt->write_buf = malloc (write_size);
 114       if (pt->write_buf == NULL)
 115         scm_memory_error (s_scm_fport_buffer_add);
 116       pt->write_pos = pt->write_buf;
 117       pt->write_buf_size = write_size;
 118     }
 119   else
 120     {
 121       pt->write_buf = pt->write_pos = &pt->shortbuf;
 122       pt->write_buf_size = 1;
 123     }
 124
 125   pt->write_end = pt->write_buf + pt->write_buf_size;
 126   if (read_size > 0 || write_size > 0)
 127     SCM_SETCAR (port, SCM_CAR (port) & ~SCM_BUF0);
 128   else
 129     SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0));
 130 }
 131
 132 SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 133             (SCM port, SCM mode, SCM size),
 134 "Set the buffering mode for @var{port}.  @var{mode} can be:
 135 @table @code
 136 @item _IONBF
 137 non-buffered
 138 @item _IOLBF
 139 line buffered
 140 @item _IOFBF
 141 block buffered, using a newly allocated buffer of @var{size} bytes.
 142 If @var{size} is omitted, a default size will be used.
 143 @end table
 144
 145
 146 @deffn primitive fcntl fd/port command [value]
 147 Apply @var{command} to the specified file descriptor or the underlying
 148 file descriptor of the specified port.  @var{value} is an optional
 149 integer argument.
 150
 151 Values for @var{command} are:
 152
 153 @table @code
 154 @item F_DUPFD
 155 Duplicate a file descriptor
 156 @item F_GETFD
 157 Get flags associated with the file descriptor.
 158 @item F_SETFD
 159 Set flags associated with the file descriptor to @var{value}.
 160 @item F_GETFL
 161 Get flags associated with the open file.
 162 @item F_SETFL
 163 Set flags associated with the open file to @var{value}
 164 @item F_GETOWN
 165 Get the process ID of a socket's owner, for @code{SIGIO} signals.
 166 @item F_SETOWN
 167 Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.
 168 @item FD_CLOEXEC
 169 The value used to indicate the "close on exec" flag with @code{F_GETFL} or
 170 @code{F_SETFL}.
 171 @end table
 172 ")
 173 #define FUNC_NAME s_scm_setvbuf
 174 {
 175   int cmode, csize;
 176   scm_port *pt;
 177
 178   port = SCM_COERCE_OUTPORT (port);
 179
 180   SCM_VALIDATE_OPFPORT (1,port);
 181   SCM_VALIDATE_INUM_COPY (2,mode,cmode);
 182   if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
 183     scm_out_of_range (FUNC_NAME, mode);
 184
 185   if (cmode == _IOLBF)
 186     {
 187       SCM_SETCAR (port, SCM_CAR (port) | SCM_BUFLINE);
 188       cmode = _IOFBF;
 189     }
 190   else
 191     {
 192       SCM_SETCAR (port, SCM_CAR (port) ^ SCM_BUFLINE);
 193     }
 194
 195   if (SCM_UNBNDP (size))
 196     {
 197       if (cmode == _IOFBF)
 198         csize = -1;
 199       else
 200         csize = 0;
 201     }
 202   else
 203     {
 204       SCM_VALIDATE_INUM_COPY (3,size,csize);
 205       if (csize < 0 || (cmode == _IONBF && csize > 0))
 206         scm_out_of_range (FUNC_NAME, size);
 207     }
 208
 209   pt = SCM_PTAB_ENTRY (port);
 210
 211   /* silently discards buffered chars.  */
 212   if (pt->read_buf != &pt->shortbuf)
 213     scm_must_free (pt->read_buf);
 214   if (pt->write_buf != &pt->shortbuf)
 215     scm_must_free (pt->write_buf);
 216
 217   scm_fport_buffer_add (port, csize, csize);
 218   return SCM_UNSPECIFIED;
 219 }
 220 #undef FUNC_NAME
 221
 222 /* Move ports with the specified file descriptor to new descriptors,
 223  * reseting the revealed count to 0.
 224  */
 225
 226 void
 227 scm_evict_ports (int fd)
 228 {
 229   int i;
 230
 231   for (i = 0; i < scm_port_table_size; i++)
 232     {
 233       SCM port = scm_port_table[i]->port;
 234
 235       if (SCM_FPORTP (port))
 236         {
 237           struct scm_fport *fp = SCM_FSTREAM (port);
 238
 239           if (fp->fdes == fd)
 240             {
 241               fp->fdes = dup (fd);
 242               if (fp->fdes == -1)
 243                 scm_syserror ("scm_evict_ports");
 244               scm_set_port_revealed_x (port, SCM_MAKINUM (0));
 245             }
 246         }
 247     }
 248 }
 249
 250 /* scm_open_file
 251  * Return a new port open on a given file.
 252  *
 253  * The mode string must match the pattern: [rwa+]** which
 254  * is interpreted in the usual unix way.
 255  *
 256  * Return the new port.
 257  */
 258 SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
 259            (SCM filename, SCM modes),
 260 "Open the file whose name is @var{string}, and return a port
 261 representing that file.  The attributes of the port are
 262 determined by the @var{mode} string.  The way in
 263 which this is interpreted is similar to C stdio:
 264
 265 The first character must be one of the following:
 266
 267 @table @samp
 268 @item r
 269 Open an existing file for input.
 270 @item w
 271 Open a file for output, creating it if it doesn't already exist
 272 or removing its contents if it does.
 273 @item a
 274 Open a file for output, creating it if it doesn't already exist.
 275 All writes to the port will go to the end of the file.
 276 The "append mode" can be turned off while the port is in use
 277 @pxref{Ports and File Descriptors, fcntl}
 278 @end table
 279
 280 The following additional characters can be appended:
 281
 282 @table @samp
 283 @item +
 284 Open the port for both input and output.  E.g., @code{r+}: open
 285 an existing file for both input and output.
 286 @item 0
 287 Create an "unbuffered" port.  In this case input and output operations
 288 are passed directly to the underlying port implementation without
 289 additional buffering.  This is likely to slow down I/O operations.
 290 The buffering mode can be changed while a port is in use
 291 @pxref{Ports and File Descriptors, setvbuf}
 292 @item l
 293 Add line-buffering to the port.  The port output buffer will be
 294 automatically flushed whenever a newline character is written.
 295 @end table
 296
 297 In theory we could create read/write ports which were buffered in one
 298 direction only.  However this isn't included in the current interfaces.
 299
 300 If a file cannot be opened with the access requested,
 301 @code{open-file} throws an exception.")
 302 #define FUNC_NAME s_scm_open_file
 303 {
 304   SCM port;
 305   int fdes;
 306   int flags = 0;
 307   char *file;
 308   char *mode;
 309   char *ptr;
 310
 311   SCM_VALIDATE_ROSTRING (1,filename);
 312   SCM_VALIDATE_ROSTRING (2,modes);
 313   if (SCM_SUBSTRP (filename))
 314     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 315   if (SCM_SUBSTRP (modes))
 316     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 317
 318   file = SCM_ROCHARS (filename);
 319   mode = SCM_ROCHARS (modes);
 320
 321   switch (*mode)
 322     {
 323     case 'r':
 324       flags |= O_RDONLY;
 325       break;
 326     case 'w':
 327       flags |= O_WRONLY | O_CREAT | O_TRUNC;
 328       break;
 329     case 'a':
 330       flags |= O_WRONLY | O_CREAT | O_APPEND;
 331       break;
 332     default:
 333       scm_out_of_range (FUNC_NAME, modes);
 334     }
 335   ptr = mode + 1;
 336   while (*ptr != '\0')
 337     {
 338       switch (*ptr)
 339         {
 340         case '+':
 341           flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
 342           break;
 343         case '0':  /* unbuffered: handled later.  */
 344         case 'b':  /* 'binary' mode: ignored.  */
 345         case 'l':  /* line buffered: handled during output.  */
 346           break;
 347         default:
 348           scm_out_of_range (FUNC_NAME, modes);
 349         }
 350       ptr++;
 351     }
 352   SCM_SYSCALL (fdes = open (file, flags, 0666));
 353   if (fdes == -1)
 354     {
 355       int en = errno;
 356
 357       scm_syserror_msg (FUNC_NAME, "%s: %S",
 358                         scm_cons (scm_makfrom0str (strerror (en)),
 359                                   scm_cons (filename, SCM_EOL)),
 360                         en);
 361     }
 362   port = scm_fdes_to_port (fdes, mode, filename);
 363   return port;
 364 }
 365 #undef FUNC_NAME
 366
 367 \f
 368 /* Building Guile ports from a file descriptor.  */
 369
 370 /* Build a Scheme port from an open file descriptor `fdes'.
 371    MODE indicates whether FILE is open for reading or writing; it uses
 372       the same notation as open-file's second argument.
 373    Use NAME as the port's filename.  */
 374
 375 SCM
 376 scm_fdes_to_port (int fdes, char *mode, SCM name)
 377 {
 378   long mode_bits = scm_mode_bits (mode);
 379   SCM port;
 380   scm_port *pt;
 381
 382   SCM_NEWCELL (port);
 383   SCM_DEFER_INTS;
 384   pt = scm_add_to_port_table (port);
 385   SCM_SETPTAB_ENTRY (port, pt);
 386   SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 387
 388   {
 389     struct scm_fport *fp
 390       = (struct scm_fport *) malloc (sizeof (struct scm_fport));
 391     if (fp == NULL)
 392       scm_memory_error ("scm_fdes_to_port");
 393     fp->fdes = fdes;
 394     pt->rw_random = SCM_FDES_RANDOM_P (fdes);
 395     SCM_SETSTREAM (port, fp);
 396     if (mode_bits & SCM_BUF0)
 397       scm_fport_buffer_add (port, 0, 0);
 398     else
 399       scm_fport_buffer_add (port, -1, -1);
 400   }
 401   SCM_PTAB_ENTRY (port)->file_name = name;
 402   SCM_ALLOW_INTS;
 403   return port;
 404 }
 405
 406
 407 /* Return a lower bound on the number of bytes available for input.  */
 408 static int
 409 fport_input_waiting (SCM port)
 410 {
 411   int fdes = SCM_FSTREAM (port)->fdes;
 412
 413 #ifdef HAVE_SELECT
 414   struct timeval timeout;
 415   SELECT_TYPE read_set;
 416   SELECT_TYPE write_set;
 417   SELECT_TYPE except_set;
 418
 419   FD_ZERO (&read_set);
 420   FD_ZERO (&write_set);
 421   FD_ZERO (&except_set);
 422
 423   FD_SET (fdes, &read_set);
 424
 425   timeout.tv_sec = 0;
 426   timeout.tv_usec = 0;
 427
 428   if (select (SELECT_SET_SIZE,
 429               &read_set, &write_set, &except_set, &timeout)
 430       < 0)
 431     scm_syserror ("fport_input_waiting");
 432   return FD_ISSET (fdes, &read_set) ? 1 : 0;
 433 #elif defined (FIONREAD)
 434   int remir;
 435   ioctl(fdes, FIONREAD, &remir);
 436   return remir;
 437 #else
 438   scm_misc_error ("fport_input_waiting",
 439                   "Not fully implemented on this platform",
 440                   SCM_EOL);
 441 #endif
 442 }
 443
 444 \f
 445 static int
 446 prinfport (SCM exp,SCM port,scm_print_state *pstate)
 447 {
 448   scm_puts ("#<", port);
 449   scm_print_port_mode (exp, port);
 450   if (SCM_OPFPORTP (exp))
 451     {
 452       int fdes;
 453       SCM name = SCM_PTAB_ENTRY (exp)->file_name;
 454       scm_puts (SCM_ROSTRINGP (name)
 455                 ? SCM_ROCHARS (name)
 456                 : SCM_PTOBNAME (SCM_PTOBNUM (exp)),
 457                 port);
 458       scm_putc (' ', port);
 459       fdes = (SCM_FSTREAM (exp))->fdes;
 460
 461       if (isatty (fdes))
 462         scm_puts (ttyname (fdes), port);
 463       else
 464         scm_intprint (fdes, 10, port);
 465     }
 466   else
 467     {
 468       scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 469       scm_putc (' ', port);
 470       scm_intprint (SCM_CDR (exp), 16, port);
 471     }
 472   scm_putc ('>', port);
 473   return 1;
 474 }
 475
 476 #ifdef GUILE_ISELECT
 477 /* thread-local block for input on fport's fdes.  */
 478 static void
 479 fport_wait_for_input (SCM port)
 480 {
 481   int fdes = SCM_FSTREAM (port)->fdes;
 482
 483   if (!fport_input_waiting (port))
 484     {
 485       int n;
 486       SELECT_TYPE readfds;
 487       int flags = fcntl (fdes, F_GETFL);
 488
 489       if (flags == -1)
 490         scm_syserror ("scm_fdes_wait_for_input");
 491       if (!(flags & O_NONBLOCK))
 492         do
 493           {
 494             FD_ZERO (&readfds);
 495             FD_SET (fdes, &readfds);
 496             n = scm_internal_select (fdes + 1, &readfds, NULL, NULL, NULL);
 497           }
 498         while (n == -1 && errno == EINTR);
 499     }
 500 }
 501 #endif
 502
 503 static void fport_flush (SCM port);
 504
 505 /* fill a port's read-buffer with a single read.
 506    returns the first char and moves the read_pos pointer past it.
 507    or returns EOF if end of file.  */
 508 static int
 509 fport_fill_input (SCM port)
 510 {
 511   int count;
 512   scm_port *pt = SCM_PTAB_ENTRY (port);
 513   struct scm_fport *fp = SCM_FSTREAM (port);
 514
 515 #ifdef GUILE_ISELECT
 516   fport_wait_for_input (port);
 517 #endif
 518   SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
 519   if (count == -1)
 520     scm_syserror ("fport_fill_input");
 521   if (count == 0)
 522     return EOF;
 523   else
 524     {
 525       pt->read_pos = pt->read_buf;
 526       pt->read_end = pt->read_buf + count;
 527       return *pt->read_buf;
 528     }
 529 }
 530
 531 static off_t
 532 fport_seek (SCM port, off_t offset, int whence)
 533 {
 534   scm_port *pt = SCM_PTAB_ENTRY (port);
 535   struct scm_fport *fp = SCM_FSTREAM (port);
 536   off_t rv;
 537   off_t result;
 538
 539   if (pt->rw_active == SCM_PORT_WRITE)
 540     {
 541       if (offset != 0 || whence != SEEK_CUR)
 542         {
 543           fport_flush (port);
 544           result = rv = lseek (fp->fdes, offset, whence);
 545         }
 546       else
 547         {
 548           /* read current position without disturbing the buffer.  */
 549           rv = lseek (fp->fdes, offset, whence);
 550           result = rv + (pt->write_pos - pt->write_buf);
 551         }
 552     }
 553   else if (pt->rw_active == SCM_PORT_READ)
 554     {
 555       if (offset != 0 || whence != SEEK_CUR)
 556         {
 557           /* could expand to avoid a second seek.  */
 558           scm_end_input (port);
 559           result = rv = lseek (fp->fdes, offset, whence);
 560         }
 561       else
 562         {
 563           /* read current position without disturbing the buffer
 564              (particularly the unread-char buffer).  */
 565           rv = lseek (fp->fdes, offset, whence);
 566           result = rv - (pt->read_end - pt->read_pos);
 567
 568           if (pt->read_buf == pt->putback_buf)
 569             result -= pt->saved_read_end - pt->saved_read_pos;
 570         }
 571     }
 572   else /* SCM_PORT_NEITHER */
 573     {
 574       result = rv = lseek (fp->fdes, offset, whence);
 575     }
 576
 577   if (rv == -1)
 578     scm_syserror ("fport_seek");
 579
 580   return result;
 581 }
 582
 583 static void
 584 fport_truncate (SCM port, off_t length)
 585 {
 586   struct scm_fport *fp = SCM_FSTREAM (port);
 587
 588   if (ftruncate (fp->fdes, length) == -1)
 589     scm_syserror ("ftruncate");
 590 }
 591
 592 static void
 593 fport_write (SCM port, void *data, size_t size)
 594 {
 595   scm_port *pt = SCM_PTAB_ENTRY (port);
 596
 597   if (pt->write_buf == &pt->shortbuf)
 598     {
 599       /* "unbuffered" port.  */
 600       int fdes = SCM_FSTREAM (port)->fdes;
 601
 602       if (write (fdes, data, size) == -1)
 603         scm_syserror ("fport_write");
 604     }
 605   else
 606     {
 607       const char *input = (char *) data;
 608       size_t remaining = size;
 609
 610       while (remaining > 0)
 611         {
 612           int space = pt->write_end - pt->write_pos;
 613           int write_len = (remaining > space) ? space : remaining;
 614
 615           memcpy (pt->write_pos, input, write_len);
 616           pt->write_pos += write_len;
 617           remaining -= write_len;
 618           input += write_len;
 619           if (write_len == space)
 620             fport_flush (port);
 621         }
 622
 623       /* handle line buffering.  */
 624       if ((SCM_CAR (port) & SCM_BUFLINE) && memchr (data, '\n', size))
 625         fport_flush (port);
 626     }
 627 }
 628
 629 /* becomes 1 when process is exiting: normal exception handling won't
 630    work by this time.  */
 631 extern int terminating;
 632
 633 static void
 634 fport_flush (SCM port)
 635 {
 636   scm_port *pt = SCM_PTAB_ENTRY (port);
 637   struct scm_fport *fp = SCM_FSTREAM (port);
 638   char *ptr = pt->write_buf;
 639   int init_size = pt->write_pos - pt->write_buf;
 640   int remaining = init_size;
 641
 642   while (remaining > 0)
 643     {
 644       int count;
 645
 646       SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
 647       if (count < 0)
 648         {
 649           /* error.  assume nothing was written this call, but
 650              fix up the buffer for any previous successful writes.  */
 651           int done = init_size - remaining;
 652
 653           if (done > 0)
 654             {
 655               int i;
 656
 657               for (i = 0; i < remaining; i++)
 658                 {
 659                   *(pt->write_buf + i) = *(pt->write_buf + done + i);
 660                 }
 661               pt->write_pos = pt->write_buf + remaining;
 662             }
 663           if (!terminating)
 664             scm_syserror ("fport_flush");
 665           else
 666             {
 667               const char *msg = "Error: could not flush file-descriptor ";
 668               char buf[11];
 669
 670               write (2, msg, strlen (msg));
 671               sprintf (buf, "%d\n", fp->fdes);
 672               write (2, buf, strlen (buf));
 673
 674               count = remaining;
 675             }
 676         }
 677       ptr += count;
 678       remaining -= count;
 679     }
 680   pt->write_pos = pt->write_buf;
 681   pt->rw_active = SCM_PORT_NEITHER;
 682 }
 683
 684 /* clear the read buffer and adjust the file position for unread bytes. */
 685 static void
 686 fport_end_input (SCM port, int offset)
 687 {
 688   struct scm_fport *fp = SCM_FSTREAM (port);
 689   scm_port *pt = SCM_PTAB_ENTRY (port);
 690
 691   offset += pt->read_end - pt->read_pos;
 692
 693   if (offset > 0)
 694     {
 695       pt->read_pos = pt->read_end;
 696       /* will throw error if unread-char used at beginning of file
 697          then attempting to write.  seems correct.  */
 698       if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
 699         scm_syserror ("fport_end_input");
 700     }
 701   pt->rw_active = SCM_PORT_NEITHER;
 702 }
 703
 704 static int
 705 fport_close (SCM port)
 706 {
 707   struct scm_fport *fp = SCM_FSTREAM (port);
 708   scm_port *pt = SCM_PTAB_ENTRY (port);
 709   int rv;
 710
 711   fport_flush (port);
 712   SCM_SYSCALL (rv = close (fp->fdes));
 713   if (rv == -1 && errno != EBADF)
 714     scm_syserror ("fport_close");
 715   if (pt->read_buf == pt->putback_buf)
 716     pt->read_buf = pt->saved_read_buf;
 717   if (pt->read_buf != &pt->shortbuf)
 718     free (pt->read_buf);
 719   if (pt->write_buf != &pt->shortbuf)
 720     free (pt->write_buf);
 721   free ((char *) fp);
 722   return rv;
 723 }
 724
 725 static scm_sizet
 726 fport_free (SCM port)
 727 {
 728   fport_close (port);
 729   return 0;
 730 }
 731
 732 void scm_make_fptob (void); /* Called from ports.c */
 733
 734 void
 735 scm_make_fptob ()
 736 {
 737   long tc = scm_make_port_type ("file", fport_fill_input, fport_write);
 738   scm_set_port_free            (tc, fport_free);
 739   scm_set_port_print           (tc, prinfport);
 740   scm_set_port_flush           (tc, fport_flush);
 741   scm_set_port_end_input       (tc, fport_end_input);
 742   scm_set_port_close           (tc, fport_close);
 743   scm_set_port_seek            (tc, fport_seek);
 744   scm_set_port_truncate        (tc, fport_truncate);
 745   scm_set_port_input_waiting   (tc, fport_input_waiting);
 746 }
 747
 748 void
 749 scm_init_fports ()
 750 {
 751 #include "fports.x"
 752   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 753   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 754   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 755 }