1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
2 * 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
23 #define _GNU_SOURCE /* ask for LONG_LONG_MAX/LONG_LONG_MIN */
31 #include "libguile/_scm.h"
32 #include "libguile/strings.h"
33 #include "libguile/validate.h"
34 #include "libguile/gc.h"
35 #include "libguile/posix.h"
36 #include "libguile/dynwind.h"
37 #include "libguile/hashtab.h"
39 #include "libguile/fports.h"
50 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
57 #include <sys/types.h>
59 #include <full-write.h>
61 #include "libguile/iselect.h"
63 /* Some defines for Windows (native port, not Cygwin). */
65 # include <sys/stat.h>
66 # include <winsock2.h>
67 #endif /* __MINGW32__ */
69 #include <full-write.h>
71 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
72 already, but have this code here in case that wasn't so in past versions,
73 or perhaps to help other minimal DOS environments.
75 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
76 might be possibilities if we've got other systems without ftruncate. */
78 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
79 # define ftruncate(fd, size) chsize (fd, size)
80 # undef HAVE_FTRUNCATE
81 # define HAVE_FTRUNCATE 1
84 #if SIZEOF_OFF_T == SIZEOF_INT
85 #define OFF_T_MAX INT_MAX
86 #define OFF_T_MIN INT_MIN
87 #elif SIZEOF_OFF_T == SIZEOF_LONG
88 #define OFF_T_MAX LONG_MAX
89 #define OFF_T_MIN LONG_MIN
90 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
91 #define OFF_T_MAX LONG_LONG_MAX
92 #define OFF_T_MIN LONG_LONG_MIN
94 #error Oops, unknown OFF_T size
97 scm_t_bits scm_tc16_fport
;
100 /* default buffer size, used if the O/S won't supply a value. */
101 static const size_t default_buffer_size
= 1024;
103 /* create FPORT buffer with specified sizes (or -1 to use default size or
106 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
107 #define FUNC_NAME "scm_fport_buffer_add"
109 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
111 if (read_size
== -1 || write_size
== -1)
114 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
116 scm_t_fport
*fp
= SCM_FSTREAM (port
);
118 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
121 default_size
= default_buffer_size
;
124 read_size
= default_size
;
125 if (write_size
== -1)
126 write_size
= default_size
;
129 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
131 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
132 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
133 pt
->read_buf_size
= read_size
;
137 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
138 pt
->read_buf_size
= 1;
141 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
143 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
144 pt
->write_pos
= pt
->write_buf
;
145 pt
->write_buf_size
= write_size
;
149 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
150 pt
->write_buf_size
= 1;
153 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
154 if (read_size
> 0 || write_size
> 0)
155 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
157 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
161 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
162 (SCM port
, SCM mode
, SCM size
),
163 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
170 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
171 "If @var{size} is omitted, a default size will be used.\n"
173 #define FUNC_NAME s_scm_setvbuf
180 port
= SCM_COERCE_OUTPORT (port
);
182 SCM_VALIDATE_OPFPORT (1,port
);
183 cmode
= scm_to_int (mode
);
184 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
185 scm_out_of_range (FUNC_NAME
, mode
);
189 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
194 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
197 if (SCM_UNBNDP (size
))
206 csize
= scm_to_int (size
);
207 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
208 scm_out_of_range (FUNC_NAME
, size
);
211 pt
= SCM_PTAB_ENTRY (port
);
213 if (SCM_INPUT_PORT_P (port
))
214 drained
= scm_drain_input (port
);
216 drained
= scm_nullstr
;
218 if (SCM_OUTPUT_PORT_P (port
))
221 if (pt
->read_buf
== pt
->putback_buf
)
223 pt
->read_buf
= pt
->saved_read_buf
;
224 pt
->read_pos
= pt
->saved_read_pos
;
225 pt
->read_end
= pt
->saved_read_end
;
226 pt
->read_buf_size
= pt
->saved_read_buf_size
;
228 if (pt
->read_buf
!= &pt
->shortbuf
)
229 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
230 if (pt
->write_buf
!= &pt
->shortbuf
)
231 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
233 scm_fport_buffer_add (port
, csize
, csize
);
235 if (scm_is_true (drained
) && scm_c_string_length (drained
))
236 scm_unread_string (drained
, port
);
238 return SCM_UNSPECIFIED
;
242 /* Move ports with the specified file descriptor to new descriptors,
243 * resetting the revealed count to 0.
246 scm_i_evict_port (void *closure
, SCM port
)
248 int fd
= * (int*) closure
;
250 if (SCM_FPORTP (port
))
255 /* XXX: In some cases, we can encounter a port with no associated ptab
257 p
= SCM_PTAB_ENTRY (port
);
258 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
260 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
264 scm_syserror ("scm_evict_ports");
265 scm_set_port_revealed_x (port
, scm_from_int (0));
271 scm_evict_ports (int fd
)
273 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
277 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
279 "Determine whether @var{obj} is a port that is related to a file.")
280 #define FUNC_NAME s_scm_file_port_p
282 return scm_from_bool (SCM_FPORTP (obj
));
287 static SCM sys_file_port_name_canonicalization
;
288 SCM_SYMBOL (sym_relative
, "relative");
289 SCM_SYMBOL (sym_absolute
, "absolute");
292 fport_canonicalize_filename (SCM filename
)
294 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
296 if (!scm_is_string (filename
))
300 else if (scm_is_eq (mode
, sym_relative
))
304 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
306 rel
= scm_i_relativize_path (filename
, path
);
308 return scm_is_true (rel
) ? rel
: filename
;
310 else if (scm_is_eq (mode
, sym_absolute
))
314 str
= scm_to_locale_string (filename
);
315 canon
= canonicalize_file_name (str
);
318 return canon
? scm_take_locale_string (canon
) : filename
;
328 * Return a new port open on a given file.
330 * The mode string must match the pattern: [rwa+]** which
331 * is interpreted in the usual unix way.
333 * Return the new port.
335 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
336 (SCM filename
, SCM mode
),
337 "Open the file whose name is @var{filename}, and return a port\n"
338 "representing that file. The attributes of the port are\n"
339 "determined by the @var{mode} string. The way in which this is\n"
340 "interpreted is similar to C stdio. The first character must be\n"
341 "one of the following:\n"
344 "Open an existing file for input.\n"
346 "Open a file for output, creating it if it doesn't already exist\n"
347 "or removing its contents if it does.\n"
349 "Open a file for output, creating it if it doesn't already\n"
350 "exist. All writes to the port will go to the end of the file.\n"
351 "The \"append mode\" can be turned off while the port is in use\n"
352 "@pxref{Ports and File Descriptors, fcntl}\n"
354 "The following additional characters can be appended:\n"
357 "Open the underlying file in binary mode, if supported by the system.\n"
358 "Also, open the file using the binary-compatible character encoding\n"
359 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
360 "at the top of the input file, if any.\n"
362 "Open the port for both input and output. E.g., @code{r+}: open\n"
363 "an existing file for both input and output.\n"
365 "Create an \"unbuffered\" port. In this case input and output\n"
366 "operations are passed directly to the underlying port\n"
367 "implementation without additional buffering. This is likely to\n"
368 "slow down I/O operations. The buffering mode can be changed\n"
369 "while a port is in use @pxref{Ports and File Descriptors,\n"
372 "Add line-buffering to the port. The port output buffer will be\n"
373 "automatically flushed whenever a newline character is written.\n"
375 "When the file is opened, this procedure will scan for a coding\n"
376 "declaration@pxref{Character Encoding of Source Files}. If present\n"
377 "will use that encoding for interpreting the file. Otherwise, the\n"
378 "port's encoding will be used.\n"
380 "In theory we could create read/write ports which were buffered\n"
381 "in one direction only. However this isn't included in the\n"
382 "current interfaces. If a file cannot be opened with the access\n"
383 "requested, @code{open-file} throws an exception.")
384 #define FUNC_NAME s_scm_open_file
387 int fdes
, flags
= 0, use_encoding
= 1;
388 unsigned int retries
;
389 char *file
, *md
, *ptr
;
391 scm_dynwind_begin (0);
393 file
= scm_to_locale_string (filename
);
394 scm_dynwind_free (file
);
396 md
= scm_to_locale_string (mode
);
397 scm_dynwind_free (md
);
405 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
408 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
411 scm_out_of_range (FUNC_NAME
, mode
);
419 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
423 #if defined (O_BINARY)
427 case '0': /* unbuffered: handled later. */
428 case 'l': /* line buffered: handled during output. */
431 scm_out_of_range (FUNC_NAME
, mode
);
436 for (retries
= 0, fdes
= -1;
437 fdes
< 0 && retries
< 2;
440 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
445 if (en
== EMFILE
&& retries
== 0)
446 /* Run the GC in case it collects open file ports that are no
447 longer referenced. */
448 scm_i_gc (FUNC_NAME
);
450 SCM_SYSERROR_MSG ("~A: ~S",
451 scm_cons (scm_strerror (scm_from_int (en
)),
452 scm_cons (filename
, SCM_EOL
)), en
);
456 /* Create a port from this file descriptor. The port's encoding is initially
457 %default-port-encoding. */
458 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
459 fport_canonicalize_filename (filename
));
463 /* If this file has a coding declaration, use that as the port
465 if (SCM_INPUT_PORT_P (port
))
467 char *enc
= scm_i_scan_for_encoding (port
);
469 scm_i_set_port_encoding_x (port
, enc
);
473 /* If this is a binary file, use the binary-friendly ISO-8859-1
475 scm_i_set_port_encoding_x (port
, NULL
);
486 * Try getting the appropiate file flags for a given file descriptor
487 * under Windows. This incorporates some fancy operations because Windows
488 * differentiates between file, pipe and socket descriptors.
491 # define O_ACCMODE 0x0003
494 static int getflags (int fdes
)
498 int error
, optlen
= sizeof (int);
500 /* Is this a socket ? */
501 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
503 /* Maybe a regular file ? */
504 else if (fstat (fdes
, &buf
) < 0)
508 /* Or an anonymous pipe handle ? */
509 if (buf
.st_mode
& _S_IFIFO
)
510 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
511 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
513 else if (fdes
== fileno (stdin
) && isatty (fdes
))
515 /* stdout / stderr ? */
516 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
524 #endif /* __MINGW32__ */
526 /* Building Guile ports from a file descriptor. */
528 /* Build a Scheme port from an open file descriptor `fdes'.
529 MODE indicates whether FILE is open for reading or writing; it uses
530 the same notation as open-file's second argument.
531 NAME is a string to be used as the port's filename.
534 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
535 #define FUNC_NAME "scm_fdes_to_port"
541 /* test that fdes is valid. */
543 flags
= getflags (fdes
);
545 flags
= fcntl (fdes
, F_GETFL
, 0);
551 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
552 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
554 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
557 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
559 port
= scm_new_port_table_entry (scm_tc16_fport
);
560 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
561 pt
= SCM_PTAB_ENTRY(port
);
564 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
568 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
569 SCM_SETSTREAM (port
, fp
);
570 if (mode_bits
& SCM_BUF0
)
571 scm_fport_buffer_add (port
, 0, 0);
573 scm_fport_buffer_add (port
, -1, -1);
575 SCM_SET_FILENAME (port
, name
);
576 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
582 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
584 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
587 /* Return a lower bound on the number of bytes available for input. */
589 fport_input_waiting (SCM port
)
591 int fdes
= SCM_FSTREAM (port
)->fdes
;
593 /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
594 highest numerical value of file descriptors that can be monitored.
595 Thus, use poll(2) whenever that is possible. */
598 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
600 if (poll (&pollfd
, 1, 0) < 0)
601 scm_syserror ("fport_input_waiting");
603 return pollfd
.revents
& POLLIN
? 1 : 0;
605 #elif defined(HAVE_SELECT)
606 struct timeval timeout
;
607 SELECT_TYPE read_set
;
608 SELECT_TYPE write_set
;
609 SELECT_TYPE except_set
;
612 FD_ZERO (&write_set
);
613 FD_ZERO (&except_set
);
615 FD_SET (fdes
, &read_set
);
620 if (select (SELECT_SET_SIZE
,
621 &read_set
, &write_set
, &except_set
, &timeout
)
623 scm_syserror ("fport_input_waiting");
624 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
626 #elif HAVE_IOCTL && defined (FIONREAD)
627 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
628 (for use with winsock ioctlsocket()) but not ioctl(). */
629 int fdes
= SCM_FSTREAM (port
)->fdes
;
631 ioctl(fdes
, FIONREAD
, &remir
);
635 scm_misc_error ("fport_input_waiting",
636 "Not fully implemented on this platform",
643 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
645 scm_puts ("#<", port
);
646 scm_print_port_mode (exp
, port
);
647 if (SCM_OPFPORTP (exp
))
650 SCM name
= SCM_FILENAME (exp
);
651 if (scm_is_string (name
) || scm_is_symbol (name
))
652 scm_display (name
, port
);
654 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
655 scm_putc (' ', port
);
656 fdes
= (SCM_FSTREAM (exp
))->fdes
;
658 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
660 scm_display (scm_ttyname (exp
), port
);
662 #endif /* HAVE_TTYNAME */
663 scm_intprint (fdes
, 10, port
);
667 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
668 scm_putc (' ', port
);
669 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
671 scm_putc ('>', port
);
675 static void fport_flush (SCM port
);
677 /* fill a port's read-buffer with a single read. returns the first
678 char or EOF if end of file. */
680 fport_fill_input (SCM port
)
683 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
684 scm_t_fport
*fp
= SCM_FSTREAM (port
);
686 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
688 scm_syserror ("fport_fill_input");
690 return (scm_t_wchar
) EOF
;
693 pt
->read_pos
= pt
->read_buf
;
694 pt
->read_end
= pt
->read_buf
+ count
;
695 return *pt
->read_buf
;
700 fport_seek (SCM port
, scm_t_off offset
, int whence
)
702 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
703 scm_t_fport
*fp
= SCM_FSTREAM (port
);
705 off_t_or_off64_t result
;
707 if (pt
->rw_active
== SCM_PORT_WRITE
)
709 if (offset
!= 0 || whence
!= SEEK_CUR
)
712 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
716 /* read current position without disturbing the buffer. */
717 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
718 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
721 else if (pt
->rw_active
== SCM_PORT_READ
)
723 if (offset
!= 0 || whence
!= SEEK_CUR
)
725 /* could expand to avoid a second seek. */
726 scm_end_input (port
);
727 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
731 /* read current position without disturbing the buffer
732 (particularly the unread-char buffer). */
733 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
734 result
= rv
- (pt
->read_end
- pt
->read_pos
);
736 if (pt
->read_buf
== pt
->putback_buf
)
737 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
740 else /* SCM_PORT_NEITHER */
742 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
746 scm_syserror ("fport_seek");
752 fport_truncate (SCM port
, scm_t_off length
)
754 scm_t_fport
*fp
= SCM_FSTREAM (port
);
756 if (ftruncate (fp
->fdes
, length
) == -1)
757 scm_syserror ("ftruncate");
761 fport_write (SCM port
, const void *data
, size_t size
)
762 #define FUNC_NAME "fport_write"
764 /* this procedure tries to minimize the number of writes/flushes. */
765 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
767 if (pt
->write_buf
== &pt
->shortbuf
768 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
770 /* Unbuffered port, or port with empty buffer and data won't fit in
772 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
779 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
783 /* data fits in buffer. */
784 memcpy (pt
->write_pos
, data
, size
);
785 pt
->write_pos
+= size
;
786 if (pt
->write_pos
== pt
->write_end
)
789 /* we can skip the line-buffering check if nothing's buffered. */
795 memcpy (pt
->write_pos
, data
, space
);
796 pt
->write_pos
= pt
->write_end
;
799 const void *ptr
= ((const char *) data
) + space
;
800 size_t remaining
= size
- space
;
802 if (size
>= pt
->write_buf_size
)
804 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
811 memcpy (pt
->write_pos
, ptr
, remaining
);
812 pt
->write_pos
+= remaining
;
817 /* handle line buffering. */
818 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
825 fport_flush (SCM port
)
828 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
829 scm_t_fport
*fp
= SCM_FSTREAM (port
);
830 size_t count
= pt
->write_pos
- pt
->write_buf
;
832 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
834 scm_syserror ("scm_flush");
836 pt
->write_pos
= pt
->write_buf
;
837 pt
->rw_active
= SCM_PORT_NEITHER
;
840 /* clear the read buffer and adjust the file position for unread bytes. */
842 fport_end_input (SCM port
, int offset
)
844 scm_t_fport
*fp
= SCM_FSTREAM (port
);
845 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
847 offset
+= pt
->read_end
- pt
->read_pos
;
851 pt
->read_pos
= pt
->read_end
;
852 /* will throw error if unread-char used at beginning of file
853 then attempting to write. seems correct. */
854 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
855 scm_syserror ("fport_end_input");
857 pt
->rw_active
= SCM_PORT_NEITHER
;
861 fport_close (SCM port
)
863 scm_t_fport
*fp
= SCM_FSTREAM (port
);
864 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
868 SCM_SYSCALL (rv
= close (fp
->fdes
));
869 if (rv
== -1 && errno
!= EBADF
)
871 if (scm_gc_running_p
)
872 /* silently ignore the error. scm_error would abort if we
876 scm_syserror ("fport_close");
878 if (pt
->read_buf
== pt
->putback_buf
)
879 pt
->read_buf
= pt
->saved_read_buf
;
880 if (pt
->read_buf
!= &pt
->shortbuf
)
881 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
882 if (pt
->write_buf
!= &pt
->shortbuf
)
883 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
884 scm_gc_free (fp
, sizeof (*fp
), "file port");
889 fport_free (SCM port
)
898 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
900 scm_set_port_free (tc
, fport_free
);
901 scm_set_port_print (tc
, fport_print
);
902 scm_set_port_flush (tc
, fport_flush
);
903 scm_set_port_end_input (tc
, fport_end_input
);
904 scm_set_port_close (tc
, fport_close
);
905 scm_set_port_seek (tc
, fport_seek
);
906 scm_set_port_truncate (tc
, fport_truncate
);
907 scm_set_port_input_waiting (tc
, fport_input_waiting
);
915 scm_tc16_fport
= scm_make_fptob ();
917 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
918 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
919 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
921 sys_file_port_name_canonicalization
= scm_make_fluid ();
922 scm_c_define ("%file-port-name-canonicalization",
923 sys_file_port_name_canonicalization
);
925 #include "libguile/fports.x"