1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
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 02110-1301 USA
20 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
28 #include "libguile/_scm.h"
29 #include "libguile/strings.h"
30 #include "libguile/validate.h"
31 #include "libguile/gc.h"
32 #include "libguile/posix.h"
33 #include "libguile/dynwind.h"
34 #include "libguile/hashtab.h"
36 #include "libguile/fports.h"
47 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
52 #include <sys/types.h>
54 #include "libguile/iselect.h"
56 /* Some defines for Windows (native port, not Cygwin). */
58 # include <sys/stat.h>
59 # include <winsock2.h>
60 #endif /* __MINGW32__ */
62 #include <full-write.h>
64 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
65 already, but have this code here in case that wasn't so in past versions,
66 or perhaps to help other minimal DOS environments.
68 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
69 might be possibilities if we've got other systems without ftruncate. */
71 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
72 # define ftruncate(fd, size) chsize (fd, size)
74 #define HAVE_FTRUNCATE 1
77 #if SIZEOF_OFF_T == SIZEOF_INT
78 #define OFF_T_MAX INT_MAX
79 #define OFF_T_MIN INT_MIN
80 #elif SIZEOF_OFF_T == SIZEOF_LONG
81 #define OFF_T_MAX LONG_MAX
82 #define OFF_T_MIN LONG_MIN
83 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
84 #define OFF_T_MAX LONG_LONG_MAX
85 #define OFF_T_MIN LONG_LONG_MIN
87 #error Oops, unknown OFF_T size
90 scm_t_bits scm_tc16_fport
;
93 /* default buffer size, used if the O/S won't supply a value. */
94 static const size_t default_buffer_size
= 1024;
96 /* create FPORT buffer with specified sizes (or -1 to use default size or
99 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
100 #define FUNC_NAME "scm_fport_buffer_add"
102 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
104 if (read_size
== -1 || write_size
== -1)
107 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
109 scm_t_fport
*fp
= SCM_FSTREAM (port
);
111 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
114 default_size
= default_buffer_size
;
117 read_size
= default_size
;
118 if (write_size
== -1)
119 write_size
= default_size
;
122 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
124 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
125 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
126 pt
->read_buf_size
= read_size
;
130 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
131 pt
->read_buf_size
= 1;
134 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
136 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
137 pt
->write_pos
= pt
->write_buf
;
138 pt
->write_buf_size
= write_size
;
142 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
143 pt
->write_buf_size
= 1;
146 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
147 if (read_size
> 0 || write_size
> 0)
148 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
150 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
154 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
155 (SCM port
, SCM mode
, SCM size
),
156 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
163 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
164 "If @var{size} is omitted, a default size will be used.\n"
166 #define FUNC_NAME s_scm_setvbuf
172 port
= SCM_COERCE_OUTPORT (port
);
174 SCM_VALIDATE_OPFPORT (1,port
);
175 cmode
= scm_to_int (mode
);
176 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
177 scm_out_of_range (FUNC_NAME
, mode
);
181 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
186 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
189 if (SCM_UNBNDP (size
))
198 csize
= scm_to_int (size
);
199 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
200 scm_out_of_range (FUNC_NAME
, size
);
203 pt
= SCM_PTAB_ENTRY (port
);
205 /* silently discards buffered and put-back chars. */
206 if (pt
->read_buf
== pt
->putback_buf
)
208 pt
->read_buf
= pt
->saved_read_buf
;
209 pt
->read_pos
= pt
->saved_read_pos
;
210 pt
->read_end
= pt
->saved_read_end
;
211 pt
->read_buf_size
= pt
->saved_read_buf_size
;
213 if (pt
->read_buf
!= &pt
->shortbuf
)
214 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
215 if (pt
->write_buf
!= &pt
->shortbuf
)
216 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
218 scm_fport_buffer_add (port
, csize
, csize
);
219 return SCM_UNSPECIFIED
;
223 /* Move ports with the specified file descriptor to new descriptors,
224 * resetting the revealed count to 0.
227 scm_i_evict_port (void *closure
, SCM port
)
229 int fd
= * (int*) closure
;
231 if (SCM_FPORTP (port
))
236 /* XXX: In some cases, we can encounter a port with no associated ptab
238 p
= SCM_PTAB_ENTRY (port
);
239 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
241 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
245 scm_syserror ("scm_evict_ports");
246 scm_set_port_revealed_x (port
, scm_from_int (0));
252 scm_evict_ports (int fd
)
254 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
258 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
260 "Determine whether @var{obj} is a port that is related to a file.")
261 #define FUNC_NAME s_scm_file_port_p
263 return scm_from_bool (SCM_FPORTP (obj
));
269 * Return a new port open on a given file.
271 * The mode string must match the pattern: [rwa+]** which
272 * is interpreted in the usual unix way.
274 * Return the new port.
276 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
277 (SCM filename
, SCM mode
),
278 "Open the file whose name is @var{filename}, and return a port\n"
279 "representing that file. The attributes of the port are\n"
280 "determined by the @var{mode} string. The way in which this is\n"
281 "interpreted is similar to C stdio. The first character must be\n"
282 "one of the following:\n"
285 "Open an existing file for input.\n"
287 "Open a file for output, creating it if it doesn't already exist\n"
288 "or removing its contents if it does.\n"
290 "Open a file for output, creating it if it doesn't already\n"
291 "exist. All writes to the port will go to the end of the file.\n"
292 "The \"append mode\" can be turned off while the port is in use\n"
293 "@pxref{Ports and File Descriptors, fcntl}\n"
295 "The following additional characters can be appended:\n"
298 "Open the underlying file in binary mode, if supported by the operating system. "
300 "Open the port for both input and output. E.g., @code{r+}: open\n"
301 "an existing file for both input and output.\n"
303 "Create an \"unbuffered\" port. In this case input and output\n"
304 "operations are passed directly to the underlying port\n"
305 "implementation without additional buffering. This is likely to\n"
306 "slow down I/O operations. The buffering mode can be changed\n"
307 "while a port is in use @pxref{Ports and File Descriptors,\n"
310 "Add line-buffering to the port. The port output buffer will be\n"
311 "automatically flushed whenever a newline character is written.\n"
313 "In theory we could create read/write ports which were buffered\n"
314 "in one direction only. However this isn't included in the\n"
315 "current interfaces. If a file cannot be opened with the access\n"
316 "requested, @code{open-file} throws an exception.")
317 #define FUNC_NAME s_scm_open_file
326 scm_dynwind_begin (0);
328 file
= scm_to_locale_string (filename
);
329 scm_dynwind_free (file
);
331 md
= scm_to_locale_string (mode
);
332 scm_dynwind_free (md
);
340 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
343 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
346 scm_out_of_range (FUNC_NAME
, mode
);
354 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
357 #if defined (O_BINARY)
361 case '0': /* unbuffered: handled later. */
362 case 'l': /* line buffered: handled during output. */
365 scm_out_of_range (FUNC_NAME
, mode
);
369 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
374 SCM_SYSERROR_MSG ("~A: ~S",
375 scm_cons (scm_strerror (scm_from_int (en
)),
376 scm_cons (filename
, SCM_EOL
)), en
);
378 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
), filename
);
389 * Try getting the appropiate file flags for a given file descriptor
390 * under Windows. This incorporates some fancy operations because Windows
391 * differentiates between file, pipe and socket descriptors.
394 # define O_ACCMODE 0x0003
397 static int getflags (int fdes
)
401 int error
, optlen
= sizeof (int);
403 /* Is this a socket ? */
404 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
406 /* Maybe a regular file ? */
407 else if (fstat (fdes
, &buf
) < 0)
411 /* Or an anonymous pipe handle ? */
412 if (buf
.st_mode
& _S_IFIFO
)
413 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
414 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
416 else if (fdes
== fileno (stdin
) && isatty (fdes
))
418 /* stdout / stderr ? */
419 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
427 #endif /* __MINGW32__ */
429 /* Building Guile ports from a file descriptor. */
431 /* Build a Scheme port from an open file descriptor `fdes'.
432 MODE indicates whether FILE is open for reading or writing; it uses
433 the same notation as open-file's second argument.
434 NAME is a string to be used as the port's filename.
437 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
438 #define FUNC_NAME "scm_fdes_to_port"
444 /* test that fdes is valid. */
446 flags
= getflags (fdes
);
448 flags
= fcntl (fdes
, F_GETFL
, 0);
454 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
455 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
457 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
460 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
462 port
= scm_new_port_table_entry (scm_tc16_fport
);
463 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
464 pt
= SCM_PTAB_ENTRY(port
);
467 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
471 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
472 SCM_SETSTREAM (port
, fp
);
473 if (mode_bits
& SCM_BUF0
)
474 scm_fport_buffer_add (port
, 0, 0);
476 scm_fport_buffer_add (port
, -1, -1);
478 SCM_SET_FILENAME (port
, name
);
479 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
485 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
487 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
490 /* Return a lower bound on the number of bytes available for input. */
492 fport_input_waiting (SCM port
)
495 int fdes
= SCM_FSTREAM (port
)->fdes
;
496 struct timeval timeout
;
497 SELECT_TYPE read_set
;
498 SELECT_TYPE write_set
;
499 SELECT_TYPE except_set
;
502 FD_ZERO (&write_set
);
503 FD_ZERO (&except_set
);
505 FD_SET (fdes
, &read_set
);
510 if (select (SELECT_SET_SIZE
,
511 &read_set
, &write_set
, &except_set
, &timeout
)
513 scm_syserror ("fport_input_waiting");
514 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
516 #elif HAVE_IOCTL && defined (FIONREAD)
517 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
518 (for use with winsock ioctlsocket()) but not ioctl(). */
519 int fdes
= SCM_FSTREAM (port
)->fdes
;
521 ioctl(fdes
, FIONREAD
, &remir
);
525 scm_misc_error ("fport_input_waiting",
526 "Not fully implemented on this platform",
533 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
535 scm_puts ("#<", port
);
536 scm_print_port_mode (exp
, port
);
537 if (SCM_OPFPORTP (exp
))
540 SCM name
= SCM_FILENAME (exp
);
541 if (scm_is_string (name
) || scm_is_symbol (name
))
542 scm_display (name
, port
);
544 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
545 scm_putc (' ', port
);
546 fdes
= (SCM_FSTREAM (exp
))->fdes
;
550 scm_display (scm_ttyname (exp
), port
);
552 #endif /* HAVE_TTYNAME */
553 scm_intprint (fdes
, 10, port
);
557 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
558 scm_putc (' ', port
);
559 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
561 scm_putc ('>', port
);
566 /* thread-local block for input on fport's fdes. */
568 fport_wait_for_input (SCM port
)
570 int fdes
= SCM_FSTREAM (port
)->fdes
;
572 if (!fport_input_waiting (port
))
576 int flags
= fcntl (fdes
, F_GETFL
);
579 scm_syserror ("scm_fdes_wait_for_input");
580 if (!(flags
& O_NONBLOCK
))
584 FD_SET (fdes
, &readfds
);
585 n
= scm_std_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
587 while (n
== -1 && errno
== EINTR
);
590 #endif /* !__MINGW32__ */
592 static void fport_flush (SCM port
);
594 /* fill a port's read-buffer with a single read. returns the first
595 char or EOF if end of file. */
597 fport_fill_input (SCM port
)
600 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
601 scm_t_fport
*fp
= SCM_FSTREAM (port
);
604 fport_wait_for_input (port
);
605 #endif /* !__MINGW32__ */
606 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
608 scm_syserror ("fport_fill_input");
613 pt
->read_pos
= pt
->read_buf
;
614 pt
->read_end
= pt
->read_buf
+ count
;
615 return *pt
->read_buf
;
619 static off_t_or_off64_t
620 fport_seek_or_seek64 (SCM port
, off_t_or_off64_t offset
, int whence
)
622 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
623 scm_t_fport
*fp
= SCM_FSTREAM (port
);
625 off_t_or_off64_t result
;
627 if (pt
->rw_active
== SCM_PORT_WRITE
)
629 if (offset
!= 0 || whence
!= SEEK_CUR
)
632 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
636 /* read current position without disturbing the buffer. */
637 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
638 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
641 else if (pt
->rw_active
== SCM_PORT_READ
)
643 if (offset
!= 0 || whence
!= SEEK_CUR
)
645 /* could expand to avoid a second seek. */
646 scm_end_input (port
);
647 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
651 /* read current position without disturbing the buffer
652 (particularly the unread-char buffer). */
653 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
654 result
= rv
- (pt
->read_end
- pt
->read_pos
);
656 if (pt
->read_buf
== pt
->putback_buf
)
657 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
660 else /* SCM_PORT_NEITHER */
662 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
666 scm_syserror ("fport_seek");
671 /* If we've got largefile and off_t isn't already off64_t then
672 fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
675 Otherwise if no largefile, or off_t is the same as off64_t (which is the
676 case on NetBSD apparently), then fport_seek_or_seek64 is right to be
677 fport_seek already. */
679 #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
681 fport_seek (SCM port
, off_t offset
, int whence
)
683 off64_t rv
= fport_seek_or_seek64 (port
, (off64_t
) offset
, whence
);
684 if (rv
> OFF_T_MAX
|| rv
< OFF_T_MIN
)
687 scm_syserror ("fport_seek");
693 #define fport_seek fport_seek_or_seek64
696 /* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
698 scm_i_fport_seek (SCM port
, SCM offset
, int how
)
700 return scm_from_off_t_or_off64_t
701 (fport_seek_or_seek64 (port
, scm_to_off_t_or_off64_t (offset
), how
));
705 fport_truncate (SCM port
, off_t length
)
707 scm_t_fport
*fp
= SCM_FSTREAM (port
);
709 if (ftruncate (fp
->fdes
, length
) == -1)
710 scm_syserror ("ftruncate");
714 scm_i_fport_truncate (SCM port
, SCM length
)
716 scm_t_fport
*fp
= SCM_FSTREAM (port
);
717 return ftruncate_or_ftruncate64 (fp
->fdes
, scm_to_off_t_or_off64_t (length
));
720 /* helper for fport_write: try to write data, using multiple system
721 calls if required. */
722 #define FUNC_NAME "write_all"
723 static void write_all (SCM port
, const void *data
, size_t remaining
)
725 int fdes
= SCM_FSTREAM (port
)->fdes
;
727 while (remaining
> 0)
731 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
736 data
= ((const char *) data
) + done
;
742 fport_write (SCM port
, const void *data
, size_t size
)
744 /* this procedure tries to minimize the number of writes/flushes. */
745 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
747 if (pt
->write_buf
== &pt
->shortbuf
748 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
750 /* "unbuffered" port, or
751 port with empty buffer and data won't fit in buffer. */
752 write_all (port
, data
, size
);
757 off_t space
= pt
->write_end
- pt
->write_pos
;
761 /* data fits in buffer. */
762 memcpy (pt
->write_pos
, data
, size
);
763 pt
->write_pos
+= size
;
764 if (pt
->write_pos
== pt
->write_end
)
767 /* we can skip the line-buffering check if nothing's buffered. */
773 memcpy (pt
->write_pos
, data
, space
);
774 pt
->write_pos
= pt
->write_end
;
777 const void *ptr
= ((const char *) data
) + space
;
778 size_t remaining
= size
- space
;
780 if (size
>= pt
->write_buf_size
)
782 write_all (port
, ptr
, remaining
);
787 memcpy (pt
->write_pos
, ptr
, remaining
);
788 pt
->write_pos
+= remaining
;
793 /* handle line buffering. */
794 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
799 /* becomes 1 when process is exiting: normal exception handling won't
800 work by this time. */
801 extern int scm_i_terminating
;
804 fport_flush (SCM port
)
806 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
807 scm_t_fport
*fp
= SCM_FSTREAM (port
);
808 unsigned char *ptr
= pt
->write_buf
;
809 long init_size
= pt
->write_pos
- pt
->write_buf
;
810 long remaining
= init_size
;
812 while (remaining
> 0)
816 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
819 /* error. assume nothing was written this call, but
820 fix up the buffer for any previous successful writes. */
821 long done
= init_size
- remaining
;
827 for (i
= 0; i
< remaining
; i
++)
829 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
831 pt
->write_pos
= pt
->write_buf
+ remaining
;
833 if (scm_i_terminating
)
835 const char *msg
= "Error: could not flush file-descriptor ";
838 full_write (2, msg
, strlen (msg
));
839 sprintf (buf
, "%d\n", fp
->fdes
);
840 full_write (2, buf
, strlen (buf
));
844 else if (scm_gc_running_p
)
846 /* silently ignore the error. scm_error would abort if we
851 scm_syserror ("fport_flush");
856 pt
->write_pos
= pt
->write_buf
;
857 pt
->rw_active
= SCM_PORT_NEITHER
;
860 /* clear the read buffer and adjust the file position for unread bytes. */
862 fport_end_input (SCM port
, int offset
)
864 scm_t_fport
*fp
= SCM_FSTREAM (port
);
865 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
867 offset
+= pt
->read_end
- pt
->read_pos
;
871 pt
->read_pos
= pt
->read_end
;
872 /* will throw error if unread-char used at beginning of file
873 then attempting to write. seems correct. */
874 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
875 scm_syserror ("fport_end_input");
877 pt
->rw_active
= SCM_PORT_NEITHER
;
881 fport_close (SCM port
)
883 scm_t_fport
*fp
= SCM_FSTREAM (port
);
884 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
888 SCM_SYSCALL (rv
= close (fp
->fdes
));
889 if (rv
== -1 && errno
!= EBADF
)
891 if (scm_gc_running_p
)
892 /* silently ignore the error. scm_error would abort if we
896 scm_syserror ("fport_close");
898 if (pt
->read_buf
== pt
->putback_buf
)
899 pt
->read_buf
= pt
->saved_read_buf
;
900 if (pt
->read_buf
!= &pt
->shortbuf
)
901 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
902 if (pt
->write_buf
!= &pt
->shortbuf
)
903 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
904 scm_gc_free (fp
, sizeof (*fp
), "file port");
909 fport_free (SCM port
)
918 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
920 scm_set_port_free (tc
, fport_free
);
921 scm_set_port_print (tc
, fport_print
);
922 scm_set_port_flush (tc
, fport_flush
);
923 scm_set_port_end_input (tc
, fport_end_input
);
924 scm_set_port_close (tc
, fport_close
);
925 scm_set_port_seek (tc
, fport_seek
);
926 scm_set_port_truncate (tc
, fport_truncate
);
927 scm_set_port_input_waiting (tc
, fport_input_waiting
);
935 scm_tc16_fport
= scm_make_fptob ();
937 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
938 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
939 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
941 #include "libguile/fports.x"