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 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
63 already, but have this code here in case that wasn't so in past versions,
64 or perhaps to help other minimal DOS environments.
66 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
67 might be possibilities if we've got other systems without ftruncate. */
69 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
70 # define ftruncate(fd, size) chsize (fd, size)
72 #define HAVE_FTRUNCATE 1
75 #if SIZEOF_OFF_T == SIZEOF_INT
76 #define OFF_T_MAX INT_MAX
77 #define OFF_T_MIN INT_MIN
78 #elif SIZEOF_OFF_T == SIZEOF_LONG
79 #define OFF_T_MAX LONG_MAX
80 #define OFF_T_MIN LONG_MIN
81 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
82 #define OFF_T_MAX LONG_LONG_MAX
83 #define OFF_T_MIN LONG_LONG_MIN
85 #error Oops, unknown OFF_T size
88 scm_t_bits scm_tc16_fport
;
91 /* default buffer size, used if the O/S won't supply a value. */
92 static const size_t default_buffer_size
= 1024;
94 /* create FPORT buffer with specified sizes (or -1 to use default size or
97 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
98 #define FUNC_NAME "scm_fport_buffer_add"
100 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
102 if (read_size
== -1 || write_size
== -1)
105 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
107 scm_t_fport
*fp
= SCM_FSTREAM (port
);
109 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
112 default_size
= default_buffer_size
;
115 read_size
= default_size
;
116 if (write_size
== -1)
117 write_size
= default_size
;
120 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
122 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
123 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
124 pt
->read_buf_size
= read_size
;
128 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
129 pt
->read_buf_size
= 1;
132 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
134 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
135 pt
->write_pos
= pt
->write_buf
;
136 pt
->write_buf_size
= write_size
;
140 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
141 pt
->write_buf_size
= 1;
144 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
145 if (read_size
> 0 || write_size
> 0)
146 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
148 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
152 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
153 (SCM port
, SCM mode
, SCM size
),
154 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
161 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
162 "If @var{size} is omitted, a default size will be used.\n"
164 #define FUNC_NAME s_scm_setvbuf
170 port
= SCM_COERCE_OUTPORT (port
);
172 SCM_VALIDATE_OPFPORT (1,port
);
173 cmode
= scm_to_int (mode
);
174 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
175 scm_out_of_range (FUNC_NAME
, mode
);
179 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
184 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
187 if (SCM_UNBNDP (size
))
196 csize
= scm_to_int (size
);
197 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
198 scm_out_of_range (FUNC_NAME
, size
);
201 pt
= SCM_PTAB_ENTRY (port
);
203 /* silently discards buffered and put-back chars. */
204 if (pt
->read_buf
== pt
->putback_buf
)
206 pt
->read_buf
= pt
->saved_read_buf
;
207 pt
->read_pos
= pt
->saved_read_pos
;
208 pt
->read_end
= pt
->saved_read_end
;
209 pt
->read_buf_size
= pt
->saved_read_buf_size
;
211 if (pt
->read_buf
!= &pt
->shortbuf
)
212 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
213 if (pt
->write_buf
!= &pt
->shortbuf
)
214 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
216 scm_fport_buffer_add (port
, csize
, csize
);
217 return SCM_UNSPECIFIED
;
221 /* Move ports with the specified file descriptor to new descriptors,
222 * resetting the revealed count to 0.
225 scm_i_evict_port (void *closure
, SCM port
)
227 int fd
= * (int*) closure
;
229 if (SCM_FPORTP (port
))
234 /* XXX: In some cases, we can encounter a port with no associated ptab
236 p
= SCM_PTAB_ENTRY (port
);
237 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
239 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
243 scm_syserror ("scm_evict_ports");
244 scm_set_port_revealed_x (port
, scm_from_int (0));
250 scm_evict_ports (int fd
)
252 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
256 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
258 "Determine whether @var{obj} is a port that is related to a file.")
259 #define FUNC_NAME s_scm_file_port_p
261 return scm_from_bool (SCM_FPORTP (obj
));
267 * Return a new port open on a given file.
269 * The mode string must match the pattern: [rwa+]** which
270 * is interpreted in the usual unix way.
272 * Return the new port.
274 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
275 (SCM filename
, SCM mode
),
276 "Open the file whose name is @var{filename}, and return a port\n"
277 "representing that file. The attributes of the port are\n"
278 "determined by the @var{mode} string. The way in which this is\n"
279 "interpreted is similar to C stdio. The first character must be\n"
280 "one of the following:\n"
283 "Open an existing file for input.\n"
285 "Open a file for output, creating it if it doesn't already exist\n"
286 "or removing its contents if it does.\n"
288 "Open a file for output, creating it if it doesn't already\n"
289 "exist. All writes to the port will go to the end of the file.\n"
290 "The \"append mode\" can be turned off while the port is in use\n"
291 "@pxref{Ports and File Descriptors, fcntl}\n"
293 "The following additional characters can be appended:\n"
296 "Open the underlying file in binary mode, if supported by the operating system. "
298 "Open the port for both input and output. E.g., @code{r+}: open\n"
299 "an existing file for both input and output.\n"
301 "Create an \"unbuffered\" port. In this case input and output\n"
302 "operations are passed directly to the underlying port\n"
303 "implementation without additional buffering. This is likely to\n"
304 "slow down I/O operations. The buffering mode can be changed\n"
305 "while a port is in use @pxref{Ports and File Descriptors,\n"
308 "Add line-buffering to the port. The port output buffer will be\n"
309 "automatically flushed whenever a newline character is written.\n"
311 "In theory we could create read/write ports which were buffered\n"
312 "in one direction only. However this isn't included in the\n"
313 "current interfaces. If a file cannot be opened with the access\n"
314 "requested, @code{open-file} throws an exception.")
315 #define FUNC_NAME s_scm_open_file
324 scm_dynwind_begin (0);
326 file
= scm_to_locale_string (filename
);
327 scm_dynwind_free (file
);
329 md
= scm_to_locale_string (mode
);
330 scm_dynwind_free (md
);
338 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
341 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
344 scm_out_of_range (FUNC_NAME
, mode
);
352 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
355 #if defined (O_BINARY)
359 case '0': /* unbuffered: handled later. */
360 case 'l': /* line buffered: handled during output. */
363 scm_out_of_range (FUNC_NAME
, mode
);
367 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
372 SCM_SYSERROR_MSG ("~A: ~S",
373 scm_cons (scm_strerror (scm_from_int (en
)),
374 scm_cons (filename
, SCM_EOL
)), en
);
376 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
), filename
);
387 * Try getting the appropiate file flags for a given file descriptor
388 * under Windows. This incorporates some fancy operations because Windows
389 * differentiates between file, pipe and socket descriptors.
392 # define O_ACCMODE 0x0003
395 static int getflags (int fdes
)
399 int error
, optlen
= sizeof (int);
401 /* Is this a socket ? */
402 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
404 /* Maybe a regular file ? */
405 else if (fstat (fdes
, &buf
) < 0)
409 /* Or an anonymous pipe handle ? */
410 if (buf
.st_mode
& _S_IFIFO
)
411 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
412 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
414 else if (fdes
== fileno (stdin
) && isatty (fdes
))
416 /* stdout / stderr ? */
417 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
425 #endif /* __MINGW32__ */
427 /* Building Guile ports from a file descriptor. */
429 /* Build a Scheme port from an open file descriptor `fdes'.
430 MODE indicates whether FILE is open for reading or writing; it uses
431 the same notation as open-file's second argument.
432 NAME is a string to be used as the port's filename.
435 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
436 #define FUNC_NAME "scm_fdes_to_port"
442 /* test that fdes is valid. */
444 flags
= getflags (fdes
);
446 flags
= fcntl (fdes
, F_GETFL
, 0);
452 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
453 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
455 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
458 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
460 port
= scm_new_port_table_entry (scm_tc16_fport
);
461 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
462 pt
= SCM_PTAB_ENTRY(port
);
465 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
469 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
470 SCM_SETSTREAM (port
, fp
);
471 if (mode_bits
& SCM_BUF0
)
472 scm_fport_buffer_add (port
, 0, 0);
474 scm_fport_buffer_add (port
, -1, -1);
476 SCM_SET_FILENAME (port
, name
);
477 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
483 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
485 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
488 /* Return a lower bound on the number of bytes available for input. */
490 fport_input_waiting (SCM port
)
493 int fdes
= SCM_FSTREAM (port
)->fdes
;
494 struct timeval timeout
;
495 SELECT_TYPE read_set
;
496 SELECT_TYPE write_set
;
497 SELECT_TYPE except_set
;
500 FD_ZERO (&write_set
);
501 FD_ZERO (&except_set
);
503 FD_SET (fdes
, &read_set
);
508 if (select (SELECT_SET_SIZE
,
509 &read_set
, &write_set
, &except_set
, &timeout
)
511 scm_syserror ("fport_input_waiting");
512 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
514 #elif HAVE_IOCTL && defined (FIONREAD)
515 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
516 (for use with winsock ioctlsocket()) but not ioctl(). */
517 int fdes
= SCM_FSTREAM (port
)->fdes
;
519 ioctl(fdes
, FIONREAD
, &remir
);
523 scm_misc_error ("fport_input_waiting",
524 "Not fully implemented on this platform",
531 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
533 scm_puts ("#<", port
);
534 scm_print_port_mode (exp
, port
);
535 if (SCM_OPFPORTP (exp
))
538 SCM name
= SCM_FILENAME (exp
);
539 if (scm_is_string (name
) || scm_is_symbol (name
))
540 scm_display (name
, port
);
542 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
543 scm_putc (' ', port
);
544 fdes
= (SCM_FSTREAM (exp
))->fdes
;
548 scm_display (scm_ttyname (exp
), port
);
550 #endif /* HAVE_TTYNAME */
551 scm_intprint (fdes
, 10, port
);
555 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
556 scm_putc (' ', port
);
557 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
559 scm_putc ('>', port
);
564 /* thread-local block for input on fport's fdes. */
566 fport_wait_for_input (SCM port
)
568 int fdes
= SCM_FSTREAM (port
)->fdes
;
570 if (!fport_input_waiting (port
))
574 int flags
= fcntl (fdes
, F_GETFL
);
577 scm_syserror ("scm_fdes_wait_for_input");
578 if (!(flags
& O_NONBLOCK
))
582 FD_SET (fdes
, &readfds
);
583 n
= scm_std_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
585 while (n
== -1 && errno
== EINTR
);
588 #endif /* !__MINGW32__ */
590 static void fport_flush (SCM port
);
592 /* fill a port's read-buffer with a single read. returns the first
593 char or EOF if end of file. */
595 fport_fill_input (SCM port
)
598 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
599 scm_t_fport
*fp
= SCM_FSTREAM (port
);
602 fport_wait_for_input (port
);
603 #endif /* !__MINGW32__ */
604 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
606 scm_syserror ("fport_fill_input");
611 pt
->read_pos
= pt
->read_buf
;
612 pt
->read_end
= pt
->read_buf
+ count
;
613 return *pt
->read_buf
;
617 static off_t_or_off64_t
618 fport_seek_or_seek64 (SCM port
, off_t_or_off64_t offset
, int whence
)
620 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
621 scm_t_fport
*fp
= SCM_FSTREAM (port
);
623 off_t_or_off64_t result
;
625 if (pt
->rw_active
== SCM_PORT_WRITE
)
627 if (offset
!= 0 || whence
!= SEEK_CUR
)
630 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
634 /* read current position without disturbing the buffer. */
635 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
636 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
639 else if (pt
->rw_active
== SCM_PORT_READ
)
641 if (offset
!= 0 || whence
!= SEEK_CUR
)
643 /* could expand to avoid a second seek. */
644 scm_end_input (port
);
645 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
649 /* read current position without disturbing the buffer
650 (particularly the unread-char buffer). */
651 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
652 result
= rv
- (pt
->read_end
- pt
->read_pos
);
654 if (pt
->read_buf
== pt
->putback_buf
)
655 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
658 else /* SCM_PORT_NEITHER */
660 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
664 scm_syserror ("fport_seek");
669 /* If we've got largefile and off_t isn't already off64_t then
670 fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
673 Otherwise if no largefile, or off_t is the same as off64_t (which is the
674 case on NetBSD apparently), then fport_seek_or_seek64 is right to be
675 fport_seek already. */
677 #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
679 fport_seek (SCM port
, off_t offset
, int whence
)
681 off64_t rv
= fport_seek_or_seek64 (port
, (off64_t
) offset
, whence
);
682 if (rv
> OFF_T_MAX
|| rv
< OFF_T_MIN
)
685 scm_syserror ("fport_seek");
691 #define fport_seek fport_seek_or_seek64
694 /* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
696 scm_i_fport_seek (SCM port
, SCM offset
, int how
)
698 return scm_from_off_t_or_off64_t
699 (fport_seek_or_seek64 (port
, scm_to_off_t_or_off64_t (offset
), how
));
703 fport_truncate (SCM port
, off_t length
)
705 scm_t_fport
*fp
= SCM_FSTREAM (port
);
707 if (ftruncate (fp
->fdes
, length
) == -1)
708 scm_syserror ("ftruncate");
712 scm_i_fport_truncate (SCM port
, SCM length
)
714 scm_t_fport
*fp
= SCM_FSTREAM (port
);
715 return ftruncate_or_ftruncate64 (fp
->fdes
, scm_to_off_t_or_off64_t (length
));
718 /* helper for fport_write: try to write data, using multiple system
719 calls if required. */
720 #define FUNC_NAME "write_all"
721 static void write_all (SCM port
, const void *data
, size_t remaining
)
723 int fdes
= SCM_FSTREAM (port
)->fdes
;
725 while (remaining
> 0)
729 SCM_SYSCALL (done
= write (fdes
, data
, remaining
));
734 data
= ((const char *) data
) + done
;
740 fport_write (SCM port
, const void *data
, size_t size
)
742 /* this procedure tries to minimize the number of writes/flushes. */
743 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
745 if (pt
->write_buf
== &pt
->shortbuf
746 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
748 /* "unbuffered" port, or
749 port with empty buffer and data won't fit in buffer. */
750 write_all (port
, data
, size
);
755 off_t space
= pt
->write_end
- pt
->write_pos
;
759 /* data fits in buffer. */
760 memcpy (pt
->write_pos
, data
, size
);
761 pt
->write_pos
+= size
;
762 if (pt
->write_pos
== pt
->write_end
)
765 /* we can skip the line-buffering check if nothing's buffered. */
771 memcpy (pt
->write_pos
, data
, space
);
772 pt
->write_pos
= pt
->write_end
;
775 const void *ptr
= ((const char *) data
) + space
;
776 size_t remaining
= size
- space
;
778 if (size
>= pt
->write_buf_size
)
780 write_all (port
, ptr
, remaining
);
785 memcpy (pt
->write_pos
, ptr
, remaining
);
786 pt
->write_pos
+= remaining
;
791 /* handle line buffering. */
792 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
797 /* becomes 1 when process is exiting: normal exception handling won't
798 work by this time. */
799 extern int scm_i_terminating
;
802 fport_flush (SCM port
)
804 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
805 scm_t_fport
*fp
= SCM_FSTREAM (port
);
806 unsigned char *ptr
= pt
->write_buf
;
807 long init_size
= pt
->write_pos
- pt
->write_buf
;
808 long remaining
= init_size
;
810 while (remaining
> 0)
814 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
817 /* error. assume nothing was written this call, but
818 fix up the buffer for any previous successful writes. */
819 long done
= init_size
- remaining
;
825 for (i
= 0; i
< remaining
; i
++)
827 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
829 pt
->write_pos
= pt
->write_buf
+ remaining
;
831 if (scm_i_terminating
)
833 const char *msg
= "Error: could not flush file-descriptor ";
836 write (2, msg
, strlen (msg
));
837 sprintf (buf
, "%d\n", fp
->fdes
);
838 write (2, buf
, strlen (buf
));
842 else if (scm_gc_running_p
)
844 /* silently ignore the error. scm_error would abort if we
849 scm_syserror ("fport_flush");
854 pt
->write_pos
= pt
->write_buf
;
855 pt
->rw_active
= SCM_PORT_NEITHER
;
858 /* clear the read buffer and adjust the file position for unread bytes. */
860 fport_end_input (SCM port
, int offset
)
862 scm_t_fport
*fp
= SCM_FSTREAM (port
);
863 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
865 offset
+= pt
->read_end
- pt
->read_pos
;
869 pt
->read_pos
= pt
->read_end
;
870 /* will throw error if unread-char used at beginning of file
871 then attempting to write. seems correct. */
872 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
873 scm_syserror ("fport_end_input");
875 pt
->rw_active
= SCM_PORT_NEITHER
;
879 fport_close (SCM port
)
881 scm_t_fport
*fp
= SCM_FSTREAM (port
);
882 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
886 SCM_SYSCALL (rv
= close (fp
->fdes
));
887 if (rv
== -1 && errno
!= EBADF
)
889 if (scm_gc_running_p
)
890 /* silently ignore the error. scm_error would abort if we
894 scm_syserror ("fport_close");
896 if (pt
->read_buf
== pt
->putback_buf
)
897 pt
->read_buf
= pt
->saved_read_buf
;
898 if (pt
->read_buf
!= &pt
->shortbuf
)
899 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
900 if (pt
->write_buf
!= &pt
->shortbuf
)
901 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
902 scm_gc_free (fp
, sizeof (*fp
), "file port");
907 fport_free (SCM port
)
916 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
918 scm_set_port_free (tc
, fport_free
);
919 scm_set_port_print (tc
, fport_print
);
920 scm_set_port_flush (tc
, fport_flush
);
921 scm_set_port_end_input (tc
, fport_end_input
);
922 scm_set_port_close (tc
, fport_close
);
923 scm_set_port_seek (tc
, fport_seek
);
924 scm_set_port_truncate (tc
, fport_truncate
);
925 scm_set_port_input_waiting (tc
, fport_input_waiting
);
933 scm_tc16_fport
= scm_make_fptob ();
935 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
936 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
937 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
939 #include "libguile/fports.x"