1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
21 #define _LARGEFILE64_SOURCE /* ask for stat64 etc */
29 #include "libguile/_scm.h"
30 #include "libguile/strings.h"
31 #include "libguile/validate.h"
32 #include "libguile/gc.h"
33 #include "libguile/posix.h"
34 #include "libguile/dynwind.h"
35 #include "libguile/hashtab.h"
37 #include "libguile/fports.h"
48 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
53 #include <sys/types.h>
55 #include "libguile/iselect.h"
57 /* Some defines for Windows (native port, not Cygwin). */
59 # include <sys/stat.h>
60 # include <winsock2.h>
61 #endif /* __MINGW32__ */
63 #include <full-write.h>
65 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
66 already, but have this code here in case that wasn't so in past versions,
67 or perhaps to help other minimal DOS environments.
69 gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
70 might be possibilities if we've got other systems without ftruncate. */
72 #if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
73 # define ftruncate(fd, size) chsize (fd, size)
74 # undef HAVE_FTRUNCATE
75 # define HAVE_FTRUNCATE 1
78 #if SIZEOF_OFF_T == SIZEOF_INT
79 #define OFF_T_MAX INT_MAX
80 #define OFF_T_MIN INT_MIN
81 #elif SIZEOF_OFF_T == SIZEOF_LONG
82 #define OFF_T_MAX LONG_MAX
83 #define OFF_T_MIN LONG_MIN
84 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
85 #define OFF_T_MAX LONG_LONG_MAX
86 #define OFF_T_MIN LONG_LONG_MIN
88 #error Oops, unknown OFF_T size
91 scm_t_bits scm_tc16_fport
;
94 /* default buffer size, used if the O/S won't supply a value. */
95 static const size_t default_buffer_size
= 1024;
97 /* create FPORT buffer with specified sizes (or -1 to use default size or
100 scm_fport_buffer_add (SCM port
, long read_size
, int write_size
)
101 #define FUNC_NAME "scm_fport_buffer_add"
103 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
105 if (read_size
== -1 || write_size
== -1)
108 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
110 scm_t_fport
*fp
= SCM_FSTREAM (port
);
112 default_size
= (fstat (fp
->fdes
, &st
) == -1) ? default_buffer_size
115 default_size
= default_buffer_size
;
118 read_size
= default_size
;
119 if (write_size
== -1)
120 write_size
= default_size
;
123 if (SCM_INPUT_PORT_P (port
) && read_size
> 0)
125 pt
->read_buf
= scm_gc_malloc_pointerless (read_size
, "port buffer");
126 pt
->read_pos
= pt
->read_end
= pt
->read_buf
;
127 pt
->read_buf_size
= read_size
;
131 pt
->read_pos
= pt
->read_buf
= pt
->read_end
= &pt
->shortbuf
;
132 pt
->read_buf_size
= 1;
135 if (SCM_OUTPUT_PORT_P (port
) && write_size
> 0)
137 pt
->write_buf
= scm_gc_malloc_pointerless (write_size
, "port buffer");
138 pt
->write_pos
= pt
->write_buf
;
139 pt
->write_buf_size
= write_size
;
143 pt
->write_buf
= pt
->write_pos
= &pt
->shortbuf
;
144 pt
->write_buf_size
= 1;
147 pt
->write_end
= pt
->write_buf
+ pt
->write_buf_size
;
148 if (read_size
> 0 || write_size
> 0)
149 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~SCM_BUF0
);
151 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUF0
);
155 SCM_DEFINE (scm_setvbuf
, "setvbuf", 2, 1, 0,
156 (SCM port
, SCM mode
, SCM size
),
157 "Set the buffering mode for @var{port}. @var{mode} can be:\n"
164 "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
165 "If @var{size} is omitted, a default size will be used.\n"
167 #define FUNC_NAME s_scm_setvbuf
173 port
= SCM_COERCE_OUTPORT (port
);
175 SCM_VALIDATE_OPFPORT (1,port
);
176 cmode
= scm_to_int (mode
);
177 if (cmode
!= _IONBF
&& cmode
!= _IOFBF
&& cmode
!= _IOLBF
)
178 scm_out_of_range (FUNC_NAME
, mode
);
182 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) | SCM_BUFLINE
);
187 SCM_SET_CELL_WORD_0 (port
, SCM_CELL_WORD_0 (port
) & ~(scm_t_bits
)SCM_BUFLINE
);
190 if (SCM_UNBNDP (size
))
199 csize
= scm_to_int (size
);
200 if (csize
< 0 || (cmode
== _IONBF
&& csize
> 0))
201 scm_out_of_range (FUNC_NAME
, size
);
204 pt
= SCM_PTAB_ENTRY (port
);
206 /* silently discards buffered and put-back chars. */
207 if (pt
->read_buf
== pt
->putback_buf
)
209 pt
->read_buf
= pt
->saved_read_buf
;
210 pt
->read_pos
= pt
->saved_read_pos
;
211 pt
->read_end
= pt
->saved_read_end
;
212 pt
->read_buf_size
= pt
->saved_read_buf_size
;
214 if (pt
->read_buf
!= &pt
->shortbuf
)
215 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
216 if (pt
->write_buf
!= &pt
->shortbuf
)
217 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
219 scm_fport_buffer_add (port
, csize
, csize
);
220 return SCM_UNSPECIFIED
;
224 /* Move ports with the specified file descriptor to new descriptors,
225 * resetting the revealed count to 0.
228 scm_i_evict_port (void *closure
, SCM port
)
230 int fd
= * (int*) closure
;
232 if (SCM_FPORTP (port
))
237 /* XXX: In some cases, we can encounter a port with no associated ptab
239 p
= SCM_PTAB_ENTRY (port
);
240 fp
= (p
!= NULL
) ? (scm_t_fport
*) p
->stream
: NULL
;
242 if ((fp
!= NULL
) && (fp
->fdes
== fd
))
246 scm_syserror ("scm_evict_ports");
247 scm_set_port_revealed_x (port
, scm_from_int (0));
253 scm_evict_ports (int fd
)
255 scm_c_port_for_each (scm_i_evict_port
, (void *) &fd
);
259 SCM_DEFINE (scm_file_port_p
, "file-port?", 1, 0, 0,
261 "Determine whether @var{obj} is a port that is related to a file.")
262 #define FUNC_NAME s_scm_file_port_p
264 return scm_from_bool (SCM_FPORTP (obj
));
269 static SCM sys_file_port_name_canonicalization
;
270 SCM_SYMBOL (sym_relative
, "relative");
271 SCM_SYMBOL (sym_absolute
, "absolute");
274 fport_canonicalize_filename (SCM filename
)
276 SCM mode
= scm_fluid_ref (sys_file_port_name_canonicalization
);
278 if (!scm_is_string (filename
))
282 else if (scm_is_eq (mode
, sym_relative
))
286 path
= scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
288 rel
= scm_i_relativize_path (filename
, path
);
290 return scm_is_true (rel
) ? rel
: filename
;
292 else if (scm_is_eq (mode
, sym_absolute
))
296 str
= scm_to_locale_string (filename
);
297 canon
= canonicalize_file_name (str
);
300 return canon
? scm_take_locale_string (canon
) : filename
;
310 * Return a new port open on a given file.
312 * The mode string must match the pattern: [rwa+]** which
313 * is interpreted in the usual unix way.
315 * Return the new port.
317 SCM_DEFINE (scm_open_file
, "open-file", 2, 0, 0,
318 (SCM filename
, SCM mode
),
319 "Open the file whose name is @var{filename}, and return a port\n"
320 "representing that file. The attributes of the port are\n"
321 "determined by the @var{mode} string. The way in which this is\n"
322 "interpreted is similar to C stdio. The first character must be\n"
323 "one of the following:\n"
326 "Open an existing file for input.\n"
328 "Open a file for output, creating it if it doesn't already exist\n"
329 "or removing its contents if it does.\n"
331 "Open a file for output, creating it if it doesn't already\n"
332 "exist. All writes to the port will go to the end of the file.\n"
333 "The \"append mode\" can be turned off while the port is in use\n"
334 "@pxref{Ports and File Descriptors, fcntl}\n"
336 "The following additional characters can be appended:\n"
339 "Open the underlying file in binary mode, if supported by the system.\n"
340 "Also, open the file using the binary-compatible character encoding\n"
341 "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
342 "at the top of the input file, if any.\n"
344 "Open the port for both input and output. E.g., @code{r+}: open\n"
345 "an existing file for both input and output.\n"
347 "Create an \"unbuffered\" port. In this case input and output\n"
348 "operations are passed directly to the underlying port\n"
349 "implementation without additional buffering. This is likely to\n"
350 "slow down I/O operations. The buffering mode can be changed\n"
351 "while a port is in use @pxref{Ports and File Descriptors,\n"
354 "Add line-buffering to the port. The port output buffer will be\n"
355 "automatically flushed whenever a newline character is written.\n"
357 "When the file is opened, this procedure will scan for a coding\n"
358 "declaration@pxref{Character Encoding of Source Files}. If present\n"
359 "will use that encoding for interpreting the file. Otherwise, the\n"
360 "port's encoding will be used.\n"
362 "In theory we could create read/write ports which were buffered\n"
363 "in one direction only. However this isn't included in the\n"
364 "current interfaces. If a file cannot be opened with the access\n"
365 "requested, @code{open-file} throws an exception.")
366 #define FUNC_NAME s_scm_open_file
369 int fdes
, flags
= 0, use_encoding
= 1;
370 unsigned int retries
;
371 char *file
, *md
, *ptr
;
373 scm_dynwind_begin (0);
375 file
= scm_to_locale_string (filename
);
376 scm_dynwind_free (file
);
378 md
= scm_to_locale_string (mode
);
379 scm_dynwind_free (md
);
387 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
390 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
393 scm_out_of_range (FUNC_NAME
, mode
);
401 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
405 #if defined (O_BINARY)
409 case '0': /* unbuffered: handled later. */
410 case 'l': /* line buffered: handled during output. */
413 scm_out_of_range (FUNC_NAME
, mode
);
418 for (retries
= 0, fdes
= -1;
419 fdes
< 0 && retries
< 2;
422 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
427 if (en
== EMFILE
&& retries
== 0)
428 /* Run the GC in case it collects open file ports that are no
429 longer referenced. */
430 scm_i_gc (FUNC_NAME
);
432 SCM_SYSERROR_MSG ("~A: ~S",
433 scm_cons (scm_strerror (scm_from_int (en
)),
434 scm_cons (filename
, SCM_EOL
)), en
);
438 /* Create a port from this file descriptor. The port's encoding is initially
439 %default-port-encoding. */
440 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
441 fport_canonicalize_filename (filename
));
445 /* If this file has a coding declaration, use that as the port
447 if (SCM_INPUT_PORT_P (port
))
449 char *enc
= scm_i_scan_for_encoding (port
);
451 scm_i_set_port_encoding_x (port
, enc
);
455 /* If this is a binary file, use the binary-friendly ISO-8859-1
457 scm_i_set_port_encoding_x (port
, NULL
);
468 * Try getting the appropiate file flags for a given file descriptor
469 * under Windows. This incorporates some fancy operations because Windows
470 * differentiates between file, pipe and socket descriptors.
473 # define O_ACCMODE 0x0003
476 static int getflags (int fdes
)
480 int error
, optlen
= sizeof (int);
482 /* Is this a socket ? */
483 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
485 /* Maybe a regular file ? */
486 else if (fstat (fdes
, &buf
) < 0)
490 /* Or an anonymous pipe handle ? */
491 if (buf
.st_mode
& _S_IFIFO
)
492 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
493 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
495 else if (fdes
== fileno (stdin
) && isatty (fdes
))
497 /* stdout / stderr ? */
498 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
506 #endif /* __MINGW32__ */
508 /* Building Guile ports from a file descriptor. */
510 /* Build a Scheme port from an open file descriptor `fdes'.
511 MODE indicates whether FILE is open for reading or writing; it uses
512 the same notation as open-file's second argument.
513 NAME is a string to be used as the port's filename.
516 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
517 #define FUNC_NAME "scm_fdes_to_port"
523 /* test that fdes is valid. */
525 flags
= getflags (fdes
);
527 flags
= fcntl (fdes
, F_GETFL
, 0);
533 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
534 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
536 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
539 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
541 port
= scm_new_port_table_entry (scm_tc16_fport
);
542 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
543 pt
= SCM_PTAB_ENTRY(port
);
546 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
550 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
551 SCM_SETSTREAM (port
, fp
);
552 if (mode_bits
& SCM_BUF0
)
553 scm_fport_buffer_add (port
, 0, 0);
555 scm_fport_buffer_add (port
, -1, -1);
557 SCM_SET_FILENAME (port
, name
);
558 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
564 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
566 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
569 /* Return a lower bound on the number of bytes available for input. */
571 fport_input_waiting (SCM port
)
574 int fdes
= SCM_FSTREAM (port
)->fdes
;
575 struct timeval timeout
;
576 SELECT_TYPE read_set
;
577 SELECT_TYPE write_set
;
578 SELECT_TYPE except_set
;
581 FD_ZERO (&write_set
);
582 FD_ZERO (&except_set
);
584 FD_SET (fdes
, &read_set
);
589 if (select (SELECT_SET_SIZE
,
590 &read_set
, &write_set
, &except_set
, &timeout
)
592 scm_syserror ("fport_input_waiting");
593 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
595 #elif HAVE_IOCTL && defined (FIONREAD)
596 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
597 (for use with winsock ioctlsocket()) but not ioctl(). */
598 int fdes
= SCM_FSTREAM (port
)->fdes
;
600 ioctl(fdes
, FIONREAD
, &remir
);
604 scm_misc_error ("fport_input_waiting",
605 "Not fully implemented on this platform",
612 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
614 scm_puts ("#<", port
);
615 scm_print_port_mode (exp
, port
);
616 if (SCM_OPFPORTP (exp
))
619 SCM name
= SCM_FILENAME (exp
);
620 if (scm_is_string (name
) || scm_is_symbol (name
))
621 scm_display (name
, port
);
623 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
624 scm_putc (' ', port
);
625 fdes
= (SCM_FSTREAM (exp
))->fdes
;
629 scm_display (scm_ttyname (exp
), port
);
631 #endif /* HAVE_TTYNAME */
632 scm_intprint (fdes
, 10, port
);
636 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
637 scm_putc (' ', port
);
638 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
640 scm_putc ('>', port
);
645 /* thread-local block for input on fport's fdes. */
647 fport_wait_for_input (SCM port
)
649 int fdes
= SCM_FSTREAM (port
)->fdes
;
651 if (!fport_input_waiting (port
))
655 int flags
= fcntl (fdes
, F_GETFL
);
658 scm_syserror ("scm_fdes_wait_for_input");
659 if (!(flags
& O_NONBLOCK
))
663 FD_SET (fdes
, &readfds
);
664 n
= scm_std_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
666 while (n
== -1 && errno
== EINTR
);
669 #endif /* !__MINGW32__ */
671 static void fport_flush (SCM port
);
673 /* fill a port's read-buffer with a single read. returns the first
674 char or EOF if end of file. */
676 fport_fill_input (SCM port
)
679 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
680 scm_t_fport
*fp
= SCM_FSTREAM (port
);
683 fport_wait_for_input (port
);
684 #endif /* !__MINGW32__ */
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
)
826 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
827 scm_t_fport
*fp
= SCM_FSTREAM (port
);
828 unsigned char *ptr
= pt
->write_buf
;
829 long init_size
= pt
->write_pos
- pt
->write_buf
;
830 long remaining
= init_size
;
832 while (remaining
> 0)
836 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
839 /* error. assume nothing was written this call, but
840 fix up the buffer for any previous successful writes. */
841 long done
= init_size
- remaining
;
847 for (i
= 0; i
< remaining
; i
++)
849 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
851 pt
->write_pos
= pt
->write_buf
+ remaining
;
853 if (scm_gc_running_p
)
855 /* silently ignore the error. scm_error would abort if we
860 scm_syserror ("fport_flush");
865 pt
->write_pos
= pt
->write_buf
;
866 pt
->rw_active
= SCM_PORT_NEITHER
;
869 /* clear the read buffer and adjust the file position for unread bytes. */
871 fport_end_input (SCM port
, int offset
)
873 scm_t_fport
*fp
= SCM_FSTREAM (port
);
874 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
876 offset
+= pt
->read_end
- pt
->read_pos
;
880 pt
->read_pos
= pt
->read_end
;
881 /* will throw error if unread-char used at beginning of file
882 then attempting to write. seems correct. */
883 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
884 scm_syserror ("fport_end_input");
886 pt
->rw_active
= SCM_PORT_NEITHER
;
890 fport_close (SCM port
)
892 scm_t_fport
*fp
= SCM_FSTREAM (port
);
893 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
897 SCM_SYSCALL (rv
= close (fp
->fdes
));
898 if (rv
== -1 && errno
!= EBADF
)
900 if (scm_gc_running_p
)
901 /* silently ignore the error. scm_error would abort if we
905 scm_syserror ("fport_close");
907 if (pt
->read_buf
== pt
->putback_buf
)
908 pt
->read_buf
= pt
->saved_read_buf
;
909 if (pt
->read_buf
!= &pt
->shortbuf
)
910 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
911 if (pt
->write_buf
!= &pt
->shortbuf
)
912 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
913 scm_gc_free (fp
, sizeof (*fp
), "file port");
918 fport_free (SCM port
)
927 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
929 scm_set_port_free (tc
, fport_free
);
930 scm_set_port_print (tc
, fport_print
);
931 scm_set_port_flush (tc
, fport_flush
);
932 scm_set_port_end_input (tc
, fport_end_input
);
933 scm_set_port_close (tc
, fport_close
);
934 scm_set_port_seek (tc
, fport_seek
);
935 scm_set_port_truncate (tc
, fport_truncate
);
936 scm_set_port_input_waiting (tc
, fport_input_waiting
);
944 scm_tc16_fport
= scm_make_fptob ();
946 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
947 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
948 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
950 sys_file_port_name_canonicalization
= scm_make_fluid ();
951 scm_c_define ("%file-port-name-canonicalization",
952 sys_file_port_name_canonicalization
);
954 #include "libguile/fports.x"