libguile/ioext.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 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
  48 #include <stdio.h>
  49 #include "libguile/_scm.h"
  50 #include "libguile/ports.h"
  51 #include "libguile/read.h"
  52 #include "libguile/fports.h"
  53 #include "libguile/unif.h"
  54 #include "libguile/chars.h"
  55 #include "libguile/feature.h"
  56 #include "libguile/root.h"
  57 #include "libguile/strings.h"
  58
  59 #include "libguile/validate.h"
  60 #include "libguile/ioext.h"
  61
  62 #include <fcntl.h>
  63
  64 #ifdef HAVE_STRING_H
  65 #include <string.h>
  66 #endif
  67 #ifdef HAVE_UNISTD_H
  68 #include <unistd.h>
  69 #endif
  70 \f
  71
  72 #if defined (EAGAIN)
  73 #define SCM_MAYBE_EAGAIN || errno == EAGAIN
  74 #else
  75 #define SCM_MAYBE_EAGAIN
  76 #endif
  77
  78 #if defined (EWOULDBLOCK)
  79 #define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK
  80 #else
  81 #define SCM_MAYBE_EWOULDBLOCK
  82 #endif
  83
  84 /* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK.  */
  85 #define SCM_EBLOCK(errno) \
  86    (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK)
  87
  88 SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
  89             (SCM str, SCM port_or_fdes, SCM start, SCM end),
  90             "Read characters from an fport or file descriptor into a\n"
  91             "string @var{str}.  This procedure is scsh-compatible\n"
  92             "and can efficiently read large strings.  It will:\n\n"
  93             "@itemize\n"
  94             "@item\n"
  95             "attempt to fill the entire string, unless the @var{start}\n"
  96             "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
  97             "defaults to 0 and @var{end} defaults to\n"
  98             "@code{(string-length str)}\n"
  99             "@item\n"
 100             "use the current input port if @var{port_or_fdes} is not\n"
 101             "supplied.\n"
 102             "@item\n"
 103             "read any characters that are currently available,\n"
 104             "without waiting for the rest (short reads are possible).\n\n"
 105             "@item\n"
 106             "wait for as long as it needs to for the first character to\n"
 107             "become available, unless the port is in non-blocking mode\n"
 108             "@item\n"
 109             "return @code{#f} if end-of-file is encountered before reading\n"
 110             "any characters, otherwise return the number of characters\n"
 111             "read.\n"
 112             "@item\n"
 113             "return 0 if the port is in non-blocking mode and no characters\n"
 114             "are immediately available.\n"
 115             "@item\n"
 116             "return 0 if the request is for 0 bytes, with no\n"
 117             "end-of-file check\n"
 118             "@end itemize")
 119 #define FUNC_NAME s_scm_read_string_x_partial
 120 {
 121   char *dest;
 122   long read_len;
 123   long chars_read = 0;
 124   int fdes;
 125
 126   {
 127     long offset;
 128     long last;
 129
 130     SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset,
 131                                       4, end, last);
 132     dest += offset;
 133     read_len = last - offset;
 134   }
 135
 136   if (SCM_INUMP (port_or_fdes))
 137     fdes = SCM_INUM (port_or_fdes);
 138   else
 139     {
 140       SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes;
 141
 142       SCM_VALIDATE_OPFPORT (2, port);
 143       SCM_VALIDATE_INPUT_PORT (2, port);
 144
 145       /* if there's anything in the port buffers, use it, but then
 146          don't touch the file descriptor.  otherwise the
 147          "return immediately if something is available" rule may
 148          be violated.  */
 149       chars_read = scm_take_from_input_buffers (port, dest, read_len);
 150       fdes = SCM_FPORT_FDES (port);
 151     }
 152
 153   if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
 154                                           EOF.  */
 155     {
 156       SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
 157       if (chars_read == -1)
 158         {
 159           if (SCM_EBLOCK (errno))
 160             chars_read = 0;
 161           else
 162             SCM_SYSERROR;
 163         }
 164       else if (chars_read == 0)
 165         return SCM_BOOL_F;
 166     }
 167   return scm_long2num (chars_read);
 168 }
 169 #undef FUNC_NAME
 170
 171 SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
 172             (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end),
 173             "Read characters from @var{port} into @var{str} until one of the\n"
 174             "characters in the @var{delims} string is encountered.  If @var{gobble}\n"
 175             "is true, discard the delimiter character; otherwise, leave it\n"
 176             "in the input stream for the next read.\n"
 177             "If @var{port} is not specified, use the value of\n"
 178             "@code{(current-input-port)}.  If @var{start} or @var{end} are specified,\n"
 179             "store data only into the substring of @var{str} bounded by @var{start}\n"
 180             "and @var{end} (which default to the beginning and end of the string,\n"
 181             "respectively).\n\n"
 182             "Return a pair consisting of the delimiter that terminated the string and\n"
 183             "the number of characters read.  If reading stopped at the end of file,\n"
 184             "the delimiter returned is the @var{eof-object}; if the string was filled\n"
 185             "without encountering a delimiter, this value is @var{#f}.")
 186 #define FUNC_NAME s_scm_read_delimited_x
 187 {
 188   long j;
 189   char *buf;
 190   long cstart;
 191   long cend;
 192   int c;
 193   char *cdelims;
 194   int num_delims;
 195
 196   SCM_VALIDATE_STRING_COPY (1, delims, cdelims);
 197   num_delims = SCM_STRING_LENGTH (delims);
 198   SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart,
 199                                     6, end, cend);
 200   if (SCM_UNBNDP (port))
 201     port = scm_cur_inp;
 202   else
 203     SCM_VALIDATE_OPINPORT (4,port);
 204
 205   for (j = cstart; j < cend; j++)
 206     {
 207       int k;
 208
 209       c = scm_getc (port);
 210       for (k = 0; k < num_delims; k++)
 211         {
 212           if (cdelims[k] == c)
 213             {
 214               if (SCM_FALSEP (gobble))
 215                 scm_ungetc (c, port);
 216
 217               return scm_cons (SCM_MAKE_CHAR (c),
 218                                scm_long2num (j - cstart));
 219             }
 220         }
 221       if (c == EOF)
 222         return scm_cons (SCM_EOF_VAL,
 223                          scm_long2num (j - cstart));
 224
 225       buf[j] = c;
 226     }
 227   return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
 228 }
 229 #undef FUNC_NAME
 230
 231 static unsigned char *
 232 scm_do_read_line (SCM port, int *len_p)
 233 {
 234   scm_port *pt = SCM_PTAB_ENTRY (port);
 235   unsigned char *end;
 236
 237   /* I thought reading lines was simple.  Mercy me.  */
 238
 239   /* The common case: the buffer contains a complete line.
 240      This needs to be fast.  */
 241   if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
 242            != 0)
 243     {
 244       int buf_len = (end + 1) - pt->read_pos;
 245       /* Allocate a buffer of the perfect size.  */
 246       unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line");
 247
 248       memcpy (buf, pt->read_pos, buf_len);
 249       pt->read_pos += buf_len;
 250
 251       buf[buf_len] = '\0';
 252
 253       *len_p = buf_len;
 254       return buf;
 255     }
 256
 257   /* The buffer contains no newlines.  */
 258   {
 259     /* When live, len is always the number of characters in the
 260        current buffer that are part of the current line.  */
 261     int len = (pt->read_end - pt->read_pos);
 262     int buf_size = (len < 50) ? 60 : len * 2;
 263     /* Invariant: buf always has buf_size + 1 characters allocated;
 264        the `+ 1' is for the final '\0'.  */
 265     unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line");
 266     int buf_len = 0;
 267
 268     for (;;)
 269       {
 270         if (buf_len + len > buf_size)
 271           {
 272             int new_size = (buf_len + len) * 2;
 273             buf = scm_must_realloc (buf, buf_size + 1, new_size + 1,
 274                                     "%read-line");
 275             buf_size = new_size;
 276           }
 277
 278         /* Copy what we've got out of the port, into our buffer.  */
 279         memcpy (buf + buf_len, pt->read_pos, len);
 280         buf_len += len;
 281         pt->read_pos += len;
 282
 283         /* If we had seen a newline, we're done now.  */
 284         if (end)
 285           break;
 286
 287         /* Get more characters.  */
 288         if (scm_fill_input (port) == EOF)
 289           {
 290             /* If we're missing a final newline in the file, return
 291                what we did get, sans newline.  */
 292             if (buf_len > 0)
 293               break;
 294
 295             free (buf);
 296             return 0;
 297           }
 298
 299         /* Search the buffer for newlines.  */
 300         if ((end = memchr (pt->read_pos, '\n',
 301                            (len = (pt->read_end - pt->read_pos))))
 302             != 0)
 303           len = (end - pt->read_pos) + 1;
 304       }
 305
 306     /* I wonder how expensive this realloc is.  */
 307     buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line");
 308     buf[buf_len] = '\0';
 309     *len_p = buf_len;
 310     return buf;
 311   }
 312 }
 313
 314
 315 /*
 316  * %read-line
 317  * truncates any terminating newline from its input, and returns
 318  * a cons of the string read and its terminating character.  Doing
 319  * so makes it easy to implement the hairy `read-line' options
 320  * efficiently in Scheme.
 321  */
 322
 323 SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
 324             (SCM port),
 325             "Read a newline-terminated line from @var{port}, allocating storage as\n"
 326             "necessary.  The newline terminator (if any) is removed from the string,\n"
 327             "and a pair consisting of the line and its delimiter is returned.  The\n"
 328             "delimiter may be either a newline or the @var{eof-object}; if\n"
 329             "@code{%read-line} is called at the end of file, it returns the pair\n"
 330             "@code{(#<eof> . #<eof>)}.")
 331 #define FUNC_NAME s_scm_read_line
 332 {
 333   scm_port *pt;
 334   char *s;
 335   int slen;
 336   SCM line, term;
 337
 338   if (SCM_UNBNDP (port))
 339     port = scm_cur_inp;
 340   SCM_VALIDATE_OPINPORT (1,port);
 341
 342   pt = SCM_PTAB_ENTRY (port);
 343   if (pt->rw_active == SCM_PORT_WRITE)
 344     scm_ptobs[SCM_PTOBNUM (port)].flush (port);
 345
 346   s = (char *) scm_do_read_line (port, &slen);
 347
 348   if (s == NULL)
 349     term = line = SCM_EOF_VAL;
 350   else
 351     {
 352       if (s[slen-1] == '\n')
 353         {
 354           term = SCM_MAKE_CHAR ('\n');
 355           s[slen-1] = '\0';
 356           line = scm_take_str (s, slen-1);
 357           scm_done_malloc (-1);
 358           SCM_INCLINE (port);
 359         }
 360       else
 361         {
 362           /* Fix: we should check for eof on the port before assuming this. */
 363           term = SCM_EOF_VAL;
 364           line = scm_take_str (s, slen);
 365           SCM_COL (port) += slen;
 366         }
 367     }
 368
 369   if (pt->rw_random)
 370     pt->rw_active = SCM_PORT_READ;
 371
 372   return scm_cons (line, term);
 373 }
 374 #undef FUNC_NAME
 375
 376 SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
 377             (SCM obj, SCM port),
 378             "Display @var{obj} and a newline character to @var{port}.  If @var{port}\n"
 379             "is not specified, @code{(current-output-port)} is used.  This function\n"
 380             "is equivalent to:\n\n"
 381             "@smalllisp\n"
 382             "(display obj [port])\n"
 383             "(newline [port])\n"
 384             "@end smalllisp")
 385 #define FUNC_NAME s_scm_write_line
 386 {
 387   scm_display (obj, port);
 388   return scm_newline (port);
 389 }
 390 #undef FUNC_NAME
 391
 392 SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
 393             (SCM object),
 394             "Returns an integer representing the current position of @var{fd/port},\n"
 395             "measured from the beginning.  Equivalent to:\n"
 396             "@smalllisp\n"
 397             "(seek port 0 SEEK_CUR)\n"
 398             "@end smalllisp")
 399 #define FUNC_NAME s_scm_ftell
 400 {
 401   return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 402 }
 403 #undef FUNC_NAME
 404
 405
 406 #if (SCM_DEBUG_DEPRECATED == 0)
 407
 408 SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0,
 409             (SCM object, SCM offset, SCM whence),
 410             "Obsolete.  Almost the same as seek, above, but the return value is\n"
 411             "unspecified.")
 412 #define FUNC_NAME s_scm_fseek
 413 {
 414   scm_seek (object, offset, whence);
 415   return SCM_UNSPECIFIED;
 416 }
 417 #undef FUNC_NAME
 418
 419 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 420
 421
 422 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
 423             (SCM old, SCM new),
 424             "This procedure takes two ports and duplicates the underlying file\n"
 425             "descriptor from @var{old-port} into @var{new-port}.  The\n"
 426             "current file descriptor in @var{new-port} will be closed.\n"
 427             "After the redirection the two ports will share a file position\n"
 428             "and file status flags.\n\n"
 429             "The return value is unspecified.\n\n"
 430             "Unexpected behaviour can result if both ports are subsequently used\n"
 431             "and the original and/or duplicate ports are buffered.\n\n"
 432             "This procedure does not have any side effects on other ports or\n"
 433             "revealed counts.")
 434 #define FUNC_NAME s_scm_redirect_port
 435 {
 436   int ans, oldfd, newfd;
 437   struct scm_fport *fp;
 438
 439   old = SCM_COERCE_OUTPORT (old);
 440   new = SCM_COERCE_OUTPORT (new);
 441
 442   SCM_VALIDATE_OPFPORT (1,old);
 443   SCM_VALIDATE_OPFPORT (2,new);
 444   oldfd = SCM_FPORT_FDES (old);
 445   fp = SCM_FSTREAM (new);
 446   newfd = fp->fdes;
 447   if (oldfd != newfd)
 448     {
 449       scm_port *pt = SCM_PTAB_ENTRY (new);
 450       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 451       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 452
 453       /* must flush to old fdes.  */
 454       if (pt->rw_active == SCM_PORT_WRITE)
 455         ptob->flush (new);
 456       else if (pt->rw_active == SCM_PORT_READ)
 457         scm_end_input (new);
 458       ans = dup2 (oldfd, newfd);
 459       if (ans == -1)
 460         SCM_SYSERROR;
 461       pt->rw_random = old_pt->rw_random;
 462       /* continue using existing buffers, even if inappropriate.  */
 463     }
 464   return SCM_UNSPECIFIED;
 465 }
 466 #undef FUNC_NAME
 467
 468 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 469             (SCM fd_or_port, SCM fd),
 470             "Returns an integer file descriptor.")
 471 #define FUNC_NAME s_scm_dup_to_fdes
 472 {
 473   int oldfd, newfd, rv;
 474
 475   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 476
 477   if (SCM_INUMP (fd_or_port))
 478     oldfd = SCM_INUM (fd_or_port);
 479   else
 480     {
 481       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 482       oldfd = SCM_FPORT_FDES (fd_or_port);
 483     }
 484
 485   if (SCM_UNBNDP (fd))
 486     {
 487       newfd = dup (oldfd);
 488       if (newfd == -1)
 489         SCM_SYSERROR;
 490       fd = SCM_MAKINUM (newfd);
 491     }
 492   else
 493     {
 494       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 495       if (oldfd != newfd)
 496         {
 497           scm_evict_ports (newfd);      /* see scsh manual.  */
 498           rv = dup2 (oldfd, newfd);
 499           if (rv == -1)
 500             SCM_SYSERROR;
 501         }
 502     }
 503   return fd;
 504 }
 505 #undef FUNC_NAME
 506
 507
 508 SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
 509             (SCM oldfd, SCM newfd),
 510             "A simple wrapper for the @code{dup2} system call.\n"
 511             "Copies the file descriptor @var{oldfd} to descriptor\n"
 512             "number @var{newfd}, replacing the previous meaning\n"
 513             "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
 514             "be integers.\n"
 515             "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
 516             "is made to move away ports which are using @var{newfd}.\n"
 517             "The return value is unspecified.")
 518 #define FUNC_NAME s_scm_dup2
 519 {
 520   int c_oldfd;
 521   int c_newfd;
 522   int rv;
 523
 524   SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd);
 525   SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd);
 526   rv = dup2 (c_oldfd, c_newfd);
 527   if (rv == -1)
 528     SCM_SYSERROR;
 529   return SCM_UNSPECIFIED;
 530 }
 531 #undef FUNC_NAME
 532
 533 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 534             (SCM port),
 535             "Returns the integer file descriptor underlying @var{port}.\n"
 536             "Does not change its revealed count.")
 537 #define FUNC_NAME s_scm_fileno
 538 {
 539   port = SCM_COERCE_OUTPORT (port);
 540   SCM_VALIDATE_OPFPORT (1,port);
 541   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 542 }
 543 #undef FUNC_NAME
 544
 545 /* GJB:FIXME:: why does this not throw
 546    an error if the arg is not a port?
 547    This proc as is would be better names isattyport?
 548    if it is not going to assume that the arg is a port */
 549 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 550             (SCM port),
 551             "Returns @code{#t} if @var{port} is using a serial\n"
 552             "non-file device, otherwise @code{#f}.")
 553 #define FUNC_NAME s_scm_isatty_p
 554 {
 555   int rv;
 556
 557   port = SCM_COERCE_OUTPORT (port);
 558
 559   if (!SCM_OPFPORTP (port))
 560     return SCM_BOOL_F;
 561
 562   rv = isatty (SCM_FPORT_FDES (port));
 563   return  SCM_BOOL(rv);
 564 }
 565 #undef FUNC_NAME
 566
 567
 568
 569 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 570             (SCM fdes, SCM modes),
 571             "Returns a new port based on the file descriptor @var{fdes}.\n"
 572             "Modes are given by the string @var{modes}.  The revealed count of the port\n"
 573             "is initialized to zero.  The modes string is the same as that accepted\n"
 574             "by @ref{File Ports, open-file}.")
 575 #define FUNC_NAME s_scm_fdopen
 576 {
 577   SCM_VALIDATE_INUM (1,fdes);
 578   SCM_VALIDATE_STRING (2, modes);
 579   SCM_STRING_COERCE_0TERMINATION_X (modes);
 580
 581   return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F);
 582 }
 583 #undef FUNC_NAME
 584
 585
 586
 587 /* Move a port's underlying file descriptor to a given value.
 588  * Returns  #f if fdes is already the given value.
 589  *          #t if fdes moved.
 590  * MOVE->FDES is implemented in Scheme and calls this primitive.
 591  */
 592 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 593             (SCM port, SCM fd),
 594             "Moves the underlying file descriptor for @var{port} to the integer\n"
 595             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 596             "Any other ports already using this descriptor will be automatically\n"
 597             "shifted to new descriptors and their revealed counts reset to zero.\n"
 598             "The return value is @code{#f} if the file descriptor already had the\n"
 599             "required value or @code{#t} if it was moved.")
 600 #define FUNC_NAME s_scm_primitive_move_to_fdes
 601 {
 602   struct scm_fport *stream;
 603   int old_fd;
 604   int new_fd;
 605   int rv;
 606
 607   port = SCM_COERCE_OUTPORT (port);
 608
 609   SCM_VALIDATE_OPFPORT (1,port);
 610   SCM_VALIDATE_INUM (2,fd);
 611   stream = SCM_FSTREAM (port);
 612   old_fd = stream->fdes;
 613   new_fd = SCM_INUM (fd);
 614   if  (old_fd == new_fd)
 615     {
 616       return SCM_BOOL_F;
 617     }
 618   scm_evict_ports (new_fd);
 619   rv = dup2 (old_fd, new_fd);
 620   if (rv == -1)
 621     SCM_SYSERROR;
 622   stream->fdes = new_fd;
 623   SCM_SYSCALL (close (old_fd));
 624   return SCM_BOOL_T;
 625 }
 626 #undef FUNC_NAME
 627
 628 /* Return a list of ports using a given file descriptor.  */
 629 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 630            (SCM fd),
 631             "Returns a list of existing ports which have @var{fdes} as an\n"
 632             "underlying file descriptor, without changing their revealed counts.")
 633 #define FUNC_NAME s_scm_fdes_to_ports
 634 {
 635   SCM result = SCM_EOL;
 636   int int_fd;
 637   int i;
 638
 639   SCM_VALIDATE_INUM_COPY (1,fd,int_fd);
 640
 641   for (i = 0; i < scm_port_table_size; i++)
 642     {
 643       if (SCM_OPFPORTP (scm_port_table[i]->port)
 644           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 645         result = scm_cons (scm_port_table[i]->port, result);
 646     }
 647   return result;
 648 }
 649 #undef FUNC_NAME
 650
 651
 652 void
 653 scm_init_ioext ()
 654 {
 655   scm_add_feature ("i/o-extensions");
 656
 657 #ifndef SCM_MAGIC_SNARFER
 658 #include "libguile/ioext.x"
 659 #endif
 660 }
 661
 662
 663 /*
 664   Local Variables:
 665   c-file-style: "gnu"
 666   End:
 667 */