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 */
30 #include "libguile/_scm.h"
31 #include "libguile/strings.h"
32 #include "libguile/validate.h"
33 #include "libguile/gc.h"
34 #include "libguile/posix.h"
35 #include "libguile/dynwind.h"
36 #include "libguile/hashtab.h"
38 #include "libguile/fports.h"
49 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
56 #include <sys/types.h>
58 #include <full-write.h>
60 #include "libguile/iselect.h"
62 /* Some defines for Windows (native port, not Cygwin). */
64 # include <sys/stat.h>
65 # include <winsock2.h>
66 #endif /* __MINGW32__ */
68 #include <full-write.h>
70 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
71 already, but have this code here in case that wasn't so in past versions,
72 or perhaps to help other minimal DOS environments.
74 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
75 might be possibilities if we've got other systems without ftruncate. */
77 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
78 # define ftruncate(fd, size) chsize (fd, size)
79 # undef HAVE_FTRUNCATE
80 # define HAVE_FTRUNCATE 1
83 #if SIZEOF_OFF_T == SIZEOF_INT
84 #define OFF_T_MAX INT_MAX
85 #define OFF_T_MIN INT_MIN
86 #elif SIZEOF_OFF_T == SIZEOF_LONG
87 #define OFF_T_MAX LONG_MAX
88 #define OFF_T_MIN LONG_MIN
89 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
90 #define OFF_T_MAX LONG_LONG_MAX
91 #define OFF_T_MIN LONG_LONG_MIN
93 #error Oops, unknown OFF_T size
96 scm_t_bits scm_tc16_fport
;
99 /* default buffer size, used if the O/S won't supply a value. */
100 static const size_t default_buffer_size
= 1024;
102 /* create FPORT buffer with specified sizes (or -1 to use default size or
105 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
106 #define FUNC_NAME "scm_fport_buffer_add"
108 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
110 if (read_size
== -1 || write_size
== -1)
113 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
115 scm_t_fport
*fp
= SCM_FSTREAM (port
);
117 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
120 default_size
= default_buffer_size
;
123 read_size
= default_size
;
124 if (write_size
== -1)
125 write_size
= default_size
;
128 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
130 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
131 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
132 pt
->read_buf_size
= read_size
;
136 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
137 pt
->read_buf_size
= 1;
140 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
142 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
143 pt
->write_pos
= pt
->write_buf
;
144 pt
->write_buf_size
= write_size
;
148 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
149 pt
->write_buf_size
= 1;
152 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
153 if (read_size
> 0 || write_size
> 0)
154 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
156 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
160 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
161 (SCM port
, SCM mode
, SCM size
),
162 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
169 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
170 "If @var{size} is omitted, a default size will be used.\n"
172 #define FUNC_NAME s_scm_setvbuf
179 port
= SCM_COERCE_OUTPORT (port
);
181 SCM_VALIDATE_OPFPORT (1,port
);
182 cmode
= scm_to_int (mode
);
183 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
184 scm_out_of_range (FUNC_NAME
, mode
);
188 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
193 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
196 if (SCM_UNBNDP (size
))
205 csize
= scm_to_int (size
);
206 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
207 scm_out_of_range (FUNC_NAME
, size
);
210 pt
= SCM_PTAB_ENTRY (port
);
212 if (SCM_INPUT_PORT_P (port
))
213 drained
= scm_drain_input (port
);
215 drained
= scm_nullstr
;
217 if (SCM_OUTPUT_PORT_P (port
))
220 if (pt
->read_buf
== pt
->putback_buf
)
222 pt
->read_buf
= pt
->saved_read_buf
;
223 pt
->read_pos
= pt
->saved_read_pos
;
224 pt
->read_end
= pt
->saved_read_end
;
225 pt
->read_buf_size
= pt
->saved_read_buf_size
;
227 if (pt
->read_buf
!= &pt
->shortbuf
)
228 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
229 if (pt
->write_buf
!= &pt
->shortbuf
)
230 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
232 scm_fport_buffer_add (port
, csize
, csize
);
234 if (scm_is_true (drained
) && scm_c_string_length (drained
))
235 scm_unread_string (drained
, port
);
237 return SCM_UNSPECIFIED
;
241 /* Move ports with the specified file descriptor to new descriptors,
242 * resetting the revealed count to 0.
245 scm_i_evict_port (void *closure
, SCM port
)
247 int fd
= * (int*) closure
;
249 if (SCM_FPORTP (port
))
254 /* XXX: In some cases, we can encounter a port with no associated ptab
256 p
= SCM_PTAB_ENTRY (port
);
257 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
259 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
263 scm_syserror ("scm_evict_ports");
264 scm_set_port_revealed_x (port
, scm_from_int (0));
270 scm_evict_ports (int fd
)
272 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
276 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
278 "Determine whether @var{obj} is a port that is related to a file.")
279 #define FUNC_NAME s_scm_file_port_p
281 return scm_from_bool (SCM_FPORTP (obj
));
286 static SCM sys_file_port_name_canonicalization
;
287 SCM_SYMBOL (sym_relative
, "relative");
288 SCM_SYMBOL (sym_absolute
, "absolute");
291 fport_canonicalize_filename (SCM filename
)
293 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
295 if (!scm_is_string (filename
))
299 else if (scm_is_eq (mode
, sym_relative
))
303 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
305 rel
= scm_i_relativize_path (filename
, path
);
307 return scm_is_true (rel
) ? rel
: filename
;
309 else if (scm_is_eq (mode
, sym_absolute
))
313 str
= scm_to_locale_string (filename
);
314 canon
= canonicalize_file_name (str
);
317 return canon
? scm_take_locale_string (canon
) : filename
;
327 * Return a new port open on a given file.
329 * The mode string must match the pattern: [rwa+]** which
330 * is interpreted in the usual unix way.
332 * Return the new port.
334 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
335 (SCM filename
, SCM mode
),
336 "Open the file whose name is @var{filename}, and return a port\n"
337 "representing that file. The attributes of the port are\n"
338 "determined by the @var{mode} string. The way in which this is\n"
339 "interpreted is similar to C stdio. The first character must be\n"
340 "one of the following:\n"
343 "Open an existing file for input.\n"
345 "Open a file for output, creating it if it doesn't already exist\n"
346 "or removing its contents if it does.\n"
348 "Open a file for output, creating it if it doesn't already\n"
349 "exist. All writes to the port will go to the end of the file.\n"
350 "The \"append mode\" can be turned off while the port is in use\n"
351 "@pxref{Ports and File Descriptors, fcntl}\n"
353 "The following additional characters can be appended:\n"
356 "Open the underlying file in binary mode, if supported by the system.\n"
357 "Also, open the file using the binary-compatible character encoding\n"
358 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
359 "at the top of the input file, if any.\n"
361 "Open the port for both input and output. E.g., @code{r+}: open\n"
362 "an existing file for both input and output.\n"
364 "Create an \"unbuffered\" port. In this case input and output\n"
365 "operations are passed directly to the underlying port\n"
366 "implementation without additional buffering. This is likely to\n"
367 "slow down I/O operations. The buffering mode can be changed\n"
368 "while a port is in use @pxref{Ports and File Descriptors,\n"
371 "Add line-buffering to the port. The port output buffer will be\n"
372 "automatically flushed whenever a newline character is written.\n"
374 "When the file is opened, this procedure will scan for a coding\n"
375 "declaration@pxref{Character Encoding of Source Files}. If present\n"
376 "will use that encoding for interpreting the file. Otherwise, the\n"
377 "port's encoding will be used.\n"
379 "In theory we could create read/write ports which were buffered\n"
380 "in one direction only. However this isn't included in the\n"
381 "current interfaces. If a file cannot be opened with the access\n"
382 "requested, @code{open-file} throws an exception.")
383 #define FUNC_NAME s_scm_open_file
386 int fdes
, flags
= 0, use_encoding
= 1;
387 unsigned int retries
;
388 char *file
, *md
, *ptr
;
390 scm_dynwind_begin (0);
392 file
= scm_to_locale_string (filename
);
393 scm_dynwind_free (file
);
395 md
= scm_to_locale_string (mode
);
396 scm_dynwind_free (md
);
404 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
407 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
410 scm_out_of_range (FUNC_NAME
, mode
);
418 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
422 #if defined (O_BINARY)
426 case '0': /* unbuffered: handled later. */
427 case 'l': /* line buffered: handled during output. */
430 scm_out_of_range (FUNC_NAME
, mode
);
435 for (retries
= 0, fdes
= -1;
436 fdes
< 0 && retries
< 2;
439 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
444 if (en
== EMFILE
&& retries
== 0)
445 /* Run the GC in case it collects open file ports that are no
446 longer referenced. */
447 scm_i_gc (FUNC_NAME
);
449 SCM_SYSERROR_MSG ("~A: ~S",
450 scm_cons (scm_strerror (scm_from_int (en
)),
451 scm_cons (filename
, SCM_EOL
)), en
);
455 /* Create a port from this file descriptor. The port's encoding is initially
456 %default-port-encoding. */
457 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
458 fport_canonicalize_filename (filename
));
462 /* If this file has a coding declaration, use that as the port
464 if (SCM_INPUT_PORT_P (port
))
466 char *enc
= scm_i_scan_for_encoding (port
);
468 scm_i_set_port_encoding_x (port
, enc
);
472 /* If this is a binary file, use the binary-friendly ISO-8859-1
474 scm_i_set_port_encoding_x (port
, NULL
);
485 * Try getting the appropiate file flags for a given file descriptor
486 * under Windows. This incorporates some fancy operations because Windows
487 * differentiates between file, pipe and socket descriptors.
490 # define O_ACCMODE 0x0003
493 static int getflags (int fdes
)
497 int error
, optlen
= sizeof (int);
499 /* Is this a socket ? */
500 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
502 /* Maybe a regular file ? */
503 else if (fstat (fdes
, &buf
) < 0)
507 /* Or an anonymous pipe handle ? */
508 if (buf
.st_mode
& _S_IFIFO
)
509 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
510 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
512 else if (fdes
== fileno (stdin
) && isatty (fdes
))
514 /* stdout / stderr ? */
515 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
523 #endif /* __MINGW32__ */
525 /* Building Guile ports from a file descriptor. */
527 /* Build a Scheme port from an open file descriptor `fdes'.
528 MODE indicates whether FILE is open for reading or writing; it uses
529 the same notation as open-file's second argument.
530 NAME is a string to be used as the port's filename.
533 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
534 #define FUNC_NAME "scm_fdes_to_port"
540 /* test that fdes is valid. */
542 flags
= getflags (fdes
);
544 flags
= fcntl (fdes
, F_GETFL
, 0);
550 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
551 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
553 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
556 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
558 port
= scm_new_port_table_entry (scm_tc16_fport
);
559 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
560 pt
= SCM_PTAB_ENTRY(port
);
563 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
567 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
568 SCM_SETSTREAM (port
, fp
);
569 if (mode_bits
& SCM_BUF0
)
570 scm_fport_buffer_add (port
, 0, 0);
572 scm_fport_buffer_add (port
, -1, -1);
574 SCM_SET_FILENAME (port
, name
);
575 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
581 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
583 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
586 /* Return a lower bound on the number of bytes available for input. */
588 fport_input_waiting (SCM port
)
590 int fdes
= SCM_FSTREAM (port
)->fdes
;
592 /* `FD_SETSIZE', which is 1024 on GNU systems, effectively limits the
593 highest numerical value of file descriptors that can be monitored.
594 Thus, use poll(2) whenever that is possible. */
597 struct pollfd pollfd
= { fdes
, POLLIN
, 0 };
599 if (poll (&pollfd
, 1, 0) < 0)
600 scm_syserror ("fport_input_waiting");
602 return pollfd
.revents
& POLLIN
? 1 : 0;
604 #elif defined(HAVE_SELECT)
605 struct timeval timeout
;
606 SELECT_TYPE read_set
;
607 SELECT_TYPE write_set
;
608 SELECT_TYPE except_set
;
611 FD_ZERO (&write_set
);
612 FD_ZERO (&except_set
);
614 FD_SET (fdes
, &read_set
);
619 if (select (SELECT_SET_SIZE
,
620 &read_set
, &write_set
, &except_set
, &timeout
)
622 scm_syserror ("fport_input_waiting");
623 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
625 #elif HAVE_IOCTL && defined (FIONREAD)
626 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
627 (for use with winsock ioctlsocket()) but not ioctl(). */
628 int fdes
= SCM_FSTREAM (port
)->fdes
;
630 ioctl(fdes
, FIONREAD
, &remir
);
634 scm_misc_error ("fport_input_waiting",
635 "Not fully implemented on this platform",
642 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
644 scm_puts ("#<", port
);
645 scm_print_port_mode (exp
, port
);
646 if (SCM_OPFPORTP (exp
))
649 SCM name
= SCM_FILENAME (exp
);
650 if (scm_is_string (name
) || scm_is_symbol (name
))
651 scm_display (name
, port
);
653 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
654 scm_putc (' ', port
);
655 fdes
= (SCM_FSTREAM (exp
))->fdes
;
657 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
659 scm_display (scm_ttyname (exp
), port
);
661 #endif /* HAVE_TTYNAME */
662 scm_intprint (fdes
, 10, port
);
666 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
667 scm_putc (' ', port
);
668 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
670 scm_putc ('>', port
);
674 static void fport_flush (SCM port
);
676 /* fill a port's read-buffer with a single read. returns the first
677 char or EOF if end of file. */
679 fport_fill_input (SCM port
)
682 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
683 scm_t_fport
*fp
= SCM_FSTREAM (port
);
685 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
687 scm_syserror ("fport_fill_input");
689 return (scm_t_wchar
) EOF
;
692 pt
->read_pos
= pt
->read_buf
;
693 pt
->read_end
= pt
->read_buf
+ count
;
694 return *pt
->read_buf
;
699 fport_seek (SCM port
, scm_t_off offset
, int whence
)
701 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
702 scm_t_fport
*fp
= SCM_FSTREAM (port
);
704 off_t_or_off64_t result
;
706 if (pt
->rw_active
== SCM_PORT_WRITE
)
708 if (offset
!= 0 || whence
!= SEEK_CUR
)
711 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
715 /* read current position without disturbing the buffer. */
716 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
717 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
720 else if (pt
->rw_active
== SCM_PORT_READ
)
722 if (offset
!= 0 || whence
!= SEEK_CUR
)
724 /* could expand to avoid a second seek. */
725 scm_end_input (port
);
726 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
730 /* read current position without disturbing the buffer
731 (particularly the unread-char buffer). */
732 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
733 result
= rv
- (pt
->read_end
- pt
->read_pos
);
735 if (pt
->read_buf
== pt
->putback_buf
)
736 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
739 else /* SCM_PORT_NEITHER */
741 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
745 scm_syserror ("fport_seek");
751 fport_truncate (SCM port
, scm_t_off length
)
753 scm_t_fport
*fp
= SCM_FSTREAM (port
);
755 if (ftruncate (fp
->fdes
, length
) == -1)
756 scm_syserror ("ftruncate");
760 fport_write (SCM port
, const void *data
, size_t size
)
761 #define FUNC_NAME "fport_write"
763 /* this procedure tries to minimize the number of writes/flushes. */
764 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
766 if (pt
->write_buf
== &pt
->shortbuf
767 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
769 /* Unbuffered port, or port with empty buffer and data won't fit in
771 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
778 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
782 /* data fits in buffer. */
783 memcpy (pt
->write_pos
, data
, size
);
784 pt
->write_pos
+= size
;
785 if (pt
->write_pos
== pt
->write_end
)
788 /* we can skip the line-buffering check if nothing's buffered. */
794 memcpy (pt
->write_pos
, data
, space
);
795 pt
->write_pos
= pt
->write_end
;
798 const void *ptr
= ((const char *) data
) + space
;
799 size_t remaining
= size
- space
;
801 if (size
>= pt
->write_buf_size
)
803 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
810 memcpy (pt
->write_pos
, ptr
, remaining
);
811 pt
->write_pos
+= remaining
;
816 /* handle line buffering. */
817 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
824 fport_flush (SCM port
)
827 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
828 scm_t_fport
*fp
= SCM_FSTREAM (port
);
829 size_t count
= pt
->write_pos
- pt
->write_buf
;
831 written
= full_write (fp
->fdes
, pt
->write_buf
, count
);
833 scm_syserror ("scm_flush");
835 pt
->write_pos
= pt
->write_buf
;
836 pt
->rw_active
= SCM_PORT_NEITHER
;
839 /* clear the read buffer and adjust the file position for unread bytes. */
841 fport_end_input (SCM port
, int offset
)
843 scm_t_fport
*fp
= SCM_FSTREAM (port
);
844 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
846 offset
+= pt
->read_end
- pt
->read_pos
;
850 pt
->read_pos
= pt
->read_end
;
851 /* will throw error if unread-char used at beginning of file
852 then attempting to write. seems correct. */
853 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
854 scm_syserror ("fport_end_input");
856 pt
->rw_active
= SCM_PORT_NEITHER
;
860 fport_close (SCM port
)
862 scm_t_fport
*fp
= SCM_FSTREAM (port
);
863 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
867 SCM_SYSCALL (rv
= close (fp
->fdes
));
868 if (rv
== -1 && errno
!= EBADF
)
870 if (scm_gc_running_p
)
871 /* silently ignore the error. scm_error would abort if we
875 scm_syserror ("fport_close");
877 if (pt
->read_buf
== pt
->putback_buf
)
878 pt
->read_buf
= pt
->saved_read_buf
;
879 if (pt
->read_buf
!= &pt
->shortbuf
)
880 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
881 if (pt
->write_buf
!= &pt
->shortbuf
)
882 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
883 scm_gc_free (fp
, sizeof (*fp
), "file port");
888 fport_free (SCM port
)
897 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
899 scm_set_port_free (tc
, fport_free
);
900 scm_set_port_print (tc
, fport_print
);
901 scm_set_port_flush (tc
, fport_flush
);
902 scm_set_port_end_input (tc
, fport_end_input
);
903 scm_set_port_close (tc
, fport_close
);
904 scm_set_port_seek (tc
, fport_seek
);
905 scm_set_port_truncate (tc
, fport_truncate
);
906 scm_set_port_input_waiting (tc
, fport_input_waiting
);
914 scm_tc16_fport
= scm_make_fptob ();
916 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
917 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
918 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
920 sys_file_port_name_canonicalization
= scm_make_fluid ();
921 scm_c_define ("%file-port-name-canonicalization",
922 sys_file_port_name_canonicalization
);
924 #include "libguile/fports.x"