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
))
285 SCM scanon
, load_path
;
287 str
= scm_to_locale_string (filename
);
288 canon
= canonicalize_file_name (str
);
294 scanon
= scm_take_locale_string (canon
);
296 for (load_path
= scm_variable_ref
297 (scm_c_module_lookup (scm_the_root_module (), "%load-path"));
298 scm_is_pair (load_path
);
299 load_path
= scm_cdr (load_path
))
300 if (scm_is_true (scm_string_prefix_p (scm_car (load_path
),
302 SCM_UNDEFINED
, SCM_UNDEFINED
,
303 SCM_UNDEFINED
, SCM_UNDEFINED
)))
304 return scm_substring (scanon
,
305 scm_string_length (scm_car (load_path
)),
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 operating system. "
358 "Open the port for both input and output. E.g., @code{r+}: open\n"
359 "an existing file for both input and output.\n"
361 "Create an \"unbuffered\" port. In this case input and output\n"
362 "operations are passed directly to the underlying port\n"
363 "implementation without additional buffering. This is likely to\n"
364 "slow down I/O operations. The buffering mode can be changed\n"
365 "while a port is in use @pxref{Ports and File Descriptors,\n"
368 "Add line-buffering to the port. The port output buffer will be\n"
369 "automatically flushed whenever a newline character is written.\n"
371 "In theory we could create read/write ports which were buffered\n"
372 "in one direction only. However this isn't included in the\n"
373 "current interfaces. If a file cannot be opened with the access\n"
374 "requested, @code{open-file} throws an exception.")
375 #define FUNC_NAME s_scm_open_file
379 unsigned int retries
;
380 char *file
, *md
, *ptr
;
382 scm_dynwind_begin (0);
384 file
= scm_to_locale_string (filename
);
385 scm_dynwind_free (file
);
387 md
= scm_to_locale_string (mode
);
388 scm_dynwind_free (md
);
396 flags
|= O_WRONLY
| O_CREAT
| O_TRUNC
;
399 flags
|= O_WRONLY
| O_CREAT
| O_APPEND
;
402 scm_out_of_range (FUNC_NAME
, mode
);
410 flags
= (flags
& ~(O_RDONLY
| O_WRONLY
)) | O_RDWR
;
413 #if defined (O_BINARY)
417 case '0': /* unbuffered: handled later. */
418 case 'l': /* line buffered: handled during output. */
421 scm_out_of_range (FUNC_NAME
, mode
);
426 for (retries
= 0, fdes
= -1;
427 fdes
< 0 && retries
< 2;
430 SCM_SYSCALL (fdes
= open_or_open64 (file
, flags
, 0666));
435 if (en
== EMFILE
&& retries
== 0)
436 /* Run the GC in case it collects open file ports that are no
437 longer referenced. */
438 scm_i_gc (FUNC_NAME
);
440 SCM_SYSERROR_MSG ("~A: ~S",
441 scm_cons (scm_strerror (scm_from_int (en
)),
442 scm_cons (filename
, SCM_EOL
)), en
);
446 port
= scm_i_fdes_to_port (fdes
, scm_i_mode_bits (mode
),
447 fport_canonicalize_filename (filename
));
458 * Try getting the appropiate file flags for a given file descriptor
459 * under Windows. This incorporates some fancy operations because Windows
460 * differentiates between file, pipe and socket descriptors.
463 # define O_ACCMODE 0x0003
466 static int getflags (int fdes
)
470 int error
, optlen
= sizeof (int);
472 /* Is this a socket ? */
473 if (getsockopt (fdes
, SOL_SOCKET
, SO_ERROR
, (void *) &error
, &optlen
) >= 0)
475 /* Maybe a regular file ? */
476 else if (fstat (fdes
, &buf
) < 0)
480 /* Or an anonymous pipe handle ? */
481 if (buf
.st_mode
& _S_IFIFO
)
482 flags
= PeekNamedPipe ((HANDLE
) _get_osfhandle (fdes
), NULL
, 0,
483 NULL
, NULL
, NULL
) ? O_RDONLY
: O_WRONLY
;
485 else if (fdes
== fileno (stdin
) && isatty (fdes
))
487 /* stdout / stderr ? */
488 else if ((fdes
== fileno (stdout
) || fdes
== fileno (stderr
)) &&
496 #endif /* __MINGW32__ */
498 /* Building Guile ports from a file descriptor. */
500 /* Build a Scheme port from an open file descriptor `fdes'.
501 MODE indicates whether FILE is open for reading or writing; it uses
502 the same notation as open-file's second argument.
503 NAME is a string to be used as the port's filename.
506 scm_i_fdes_to_port (int fdes
, long mode_bits
, SCM name
)
507 #define FUNC_NAME "scm_fdes_to_port"
513 /* test that fdes is valid. */
515 flags
= getflags (fdes
);
517 flags
= fcntl (fdes
, F_GETFL
, 0);
523 && ((flags
!= O_WRONLY
&& (mode_bits
& SCM_WRTNG
))
524 || (flags
!= O_RDONLY
&& (mode_bits
& SCM_RDNG
))))
526 SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL
);
529 scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex
);
531 port
= scm_new_port_table_entry (scm_tc16_fport
);
532 SCM_SET_CELL_TYPE(port
, scm_tc16_fport
| mode_bits
);
533 pt
= SCM_PTAB_ENTRY(port
);
536 = (scm_t_fport
*) scm_gc_malloc_pointerless (sizeof (scm_t_fport
),
540 pt
->rw_random
= SCM_FDES_RANDOM_P (fdes
);
541 SCM_SETSTREAM (port
, fp
);
542 if (mode_bits
& SCM_BUF0
)
543 scm_fport_buffer_add (port
, 0, 0);
545 scm_fport_buffer_add (port
, -1, -1);
547 SCM_SET_FILENAME (port
, name
);
548 scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex
);
554 scm_fdes_to_port (int fdes
, char *mode
, SCM name
)
556 return scm_i_fdes_to_port (fdes
, scm_mode_bits (mode
), name
);
559 /* Return a lower bound on the number of bytes available for input. */
561 fport_input_waiting (SCM port
)
564 int fdes
= SCM_FSTREAM (port
)->fdes
;
565 struct timeval timeout
;
566 SELECT_TYPE read_set
;
567 SELECT_TYPE write_set
;
568 SELECT_TYPE except_set
;
571 FD_ZERO (&write_set
);
572 FD_ZERO (&except_set
);
574 FD_SET (fdes
, &read_set
);
579 if (select (SELECT_SET_SIZE
,
580 &read_set
, &write_set
, &except_set
, &timeout
)
582 scm_syserror ("fport_input_waiting");
583 return FD_ISSET (fdes
, &read_set
) ? 1 : 0;
585 #elif HAVE_IOCTL && defined (FIONREAD)
586 /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
587 (for use with winsock ioctlsocket()) but not ioctl(). */
588 int fdes
= SCM_FSTREAM (port
)->fdes
;
590 ioctl(fdes
, FIONREAD
, &remir
);
594 scm_misc_error ("fport_input_waiting",
595 "Not fully implemented on this platform",
602 fport_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
604 scm_puts ("#<", port
);
605 scm_print_port_mode (exp
, port
);
606 if (SCM_OPFPORTP (exp
))
609 SCM name
= SCM_FILENAME (exp
);
610 if (scm_is_string (name
) || scm_is_symbol (name
))
611 scm_display (name
, port
);
613 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
614 scm_putc (' ', port
);
615 fdes
= (SCM_FSTREAM (exp
))->fdes
;
619 scm_display (scm_ttyname (exp
), port
);
621 #endif /* HAVE_TTYNAME */
622 scm_intprint (fdes
, 10, port
);
626 scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp
)), port
);
627 scm_putc (' ', port
);
628 scm_uintprint ((scm_t_bits
) SCM_PTAB_ENTRY (exp
), 16, port
);
630 scm_putc ('>', port
);
635 /* thread-local block for input on fport's fdes. */
637 fport_wait_for_input (SCM port
)
639 int fdes
= SCM_FSTREAM (port
)->fdes
;
641 if (!fport_input_waiting (port
))
645 int flags
= fcntl (fdes
, F_GETFL
);
648 scm_syserror ("scm_fdes_wait_for_input");
649 if (!(flags
& O_NONBLOCK
))
653 FD_SET (fdes
, &readfds
);
654 n
= scm_std_select (fdes
+ 1, &readfds
, NULL
, NULL
, NULL
);
656 while (n
== -1 && errno
== EINTR
);
659 #endif /* !__MINGW32__ */
661 static void fport_flush (SCM port
);
663 /* fill a port's read-buffer with a single read. returns the first
664 char or EOF if end of file. */
666 fport_fill_input (SCM port
)
669 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
670 scm_t_fport
*fp
= SCM_FSTREAM (port
);
673 fport_wait_for_input (port
);
674 #endif /* !__MINGW32__ */
675 SCM_SYSCALL (count
= read (fp
->fdes
, pt
->read_buf
, pt
->read_buf_size
));
677 scm_syserror ("fport_fill_input");
679 return (scm_t_wchar
) EOF
;
682 pt
->read_pos
= pt
->read_buf
;
683 pt
->read_end
= pt
->read_buf
+ count
;
684 return *pt
->read_buf
;
689 fport_seek (SCM port
, scm_t_off offset
, int whence
)
691 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
692 scm_t_fport
*fp
= SCM_FSTREAM (port
);
694 off_t_or_off64_t result
;
696 if (pt
->rw_active
== SCM_PORT_WRITE
)
698 if (offset
!= 0 || whence
!= SEEK_CUR
)
701 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
705 /* read current position without disturbing the buffer. */
706 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
707 result
= rv
+ (pt
->write_pos
- pt
->write_buf
);
710 else if (pt
->rw_active
== SCM_PORT_READ
)
712 if (offset
!= 0 || whence
!= SEEK_CUR
)
714 /* could expand to avoid a second seek. */
715 scm_end_input (port
);
716 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
720 /* read current position without disturbing the buffer
721 (particularly the unread-char buffer). */
722 rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
723 result
= rv
- (pt
->read_end
- pt
->read_pos
);
725 if (pt
->read_buf
== pt
->putback_buf
)
726 result
-= pt
->saved_read_end
- pt
->saved_read_pos
;
729 else /* SCM_PORT_NEITHER */
731 result
= rv
= lseek_or_lseek64 (fp
->fdes
, offset
, whence
);
735 scm_syserror ("fport_seek");
741 fport_truncate (SCM port
, scm_t_off length
)
743 scm_t_fport
*fp
= SCM_FSTREAM (port
);
745 if (ftruncate (fp
->fdes
, length
) == -1)
746 scm_syserror ("ftruncate");
750 fport_write (SCM port
, const void *data
, size_t size
)
751 #define FUNC_NAME "fport_write"
753 /* this procedure tries to minimize the number of writes/flushes. */
754 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
756 if (pt
->write_buf
== &pt
->shortbuf
757 || (pt
->write_pos
== pt
->write_buf
&& size
>= pt
->write_buf_size
))
759 /* Unbuffered port, or port with empty buffer and data won't fit in
761 if (full_write (SCM_FPORT_FDES (port
), data
, size
) < size
)
768 scm_t_off space
= pt
->write_end
- pt
->write_pos
;
772 /* data fits in buffer. */
773 memcpy (pt
->write_pos
, data
, size
);
774 pt
->write_pos
+= size
;
775 if (pt
->write_pos
== pt
->write_end
)
778 /* we can skip the line-buffering check if nothing's buffered. */
784 memcpy (pt
->write_pos
, data
, space
);
785 pt
->write_pos
= pt
->write_end
;
788 const void *ptr
= ((const char *) data
) + space
;
789 size_t remaining
= size
- space
;
791 if (size
>= pt
->write_buf_size
)
793 if (full_write (SCM_FPORT_FDES (port
), ptr
, remaining
)
800 memcpy (pt
->write_pos
, ptr
, remaining
);
801 pt
->write_pos
+= remaining
;
806 /* handle line buffering. */
807 if ((SCM_CELL_WORD_0 (port
) & SCM_BUFLINE
) && memchr (data
, '\n', size
))
813 /* becomes 1 when process is exiting: normal exception handling won't
814 work by this time. */
815 extern int scm_i_terminating
;
818 fport_flush (SCM port
)
820 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
821 scm_t_fport
*fp
= SCM_FSTREAM (port
);
822 unsigned char *ptr
= pt
->write_buf
;
823 long init_size
= pt
->write_pos
- pt
->write_buf
;
824 long remaining
= init_size
;
826 while (remaining
> 0)
830 SCM_SYSCALL (count
= write (fp
->fdes
, ptr
, remaining
));
833 /* error. assume nothing was written this call, but
834 fix up the buffer for any previous successful writes. */
835 long done
= init_size
- remaining
;
841 for (i
= 0; i
< remaining
; i
++)
843 *(pt
->write_buf
+ i
) = *(pt
->write_buf
+ done
+ i
);
845 pt
->write_pos
= pt
->write_buf
+ remaining
;
847 if (scm_i_terminating
)
849 const char *msg
= "Error: could not flush file-descriptor ";
852 full_write (2, msg
, strlen (msg
));
853 sprintf (buf
, "%d\n", fp
->fdes
);
854 full_write (2, buf
, strlen (buf
));
858 else if (scm_gc_running_p
)
860 /* silently ignore the error. scm_error would abort if we
865 scm_syserror ("fport_flush");
870 pt
->write_pos
= pt
->write_buf
;
871 pt
->rw_active
= SCM_PORT_NEITHER
;
874 /* clear the read buffer and adjust the file position for unread bytes. */
876 fport_end_input (SCM port
, int offset
)
878 scm_t_fport
*fp
= SCM_FSTREAM (port
);
879 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
881 offset
+= pt
->read_end
- pt
->read_pos
;
885 pt
->read_pos
= pt
->read_end
;
886 /* will throw error if unread-char used at beginning of file
887 then attempting to write. seems correct. */
888 if (lseek (fp
->fdes
, -offset
, SEEK_CUR
) == -1)
889 scm_syserror ("fport_end_input");
891 pt
->rw_active
= SCM_PORT_NEITHER
;
895 fport_close (SCM port
)
897 scm_t_fport
*fp
= SCM_FSTREAM (port
);
898 scm_t_port
*pt
= SCM_PTAB_ENTRY (port
);
902 SCM_SYSCALL (rv
= close (fp
->fdes
));
903 if (rv
== -1 && errno
!= EBADF
)
905 if (scm_gc_running_p
)
906 /* silently ignore the error. scm_error would abort if we
910 scm_syserror ("fport_close");
912 if (pt
->read_buf
== pt
->putback_buf
)
913 pt
->read_buf
= pt
->saved_read_buf
;
914 if (pt
->read_buf
!= &pt
->shortbuf
)
915 scm_gc_free (pt
->read_buf
, pt
->read_buf_size
, "port buffer");
916 if (pt
->write_buf
!= &pt
->shortbuf
)
917 scm_gc_free (pt
->write_buf
, pt
->write_buf_size
, "port buffer");
918 scm_gc_free (fp
, sizeof (*fp
), "file port");
923 fport_free (SCM port
)
932 scm_t_bits tc
= scm_make_port_type ("file", fport_fill_input
, fport_write
);
934 scm_set_port_free (tc
, fport_free
);
935 scm_set_port_print (tc
, fport_print
);
936 scm_set_port_flush (tc
, fport_flush
);
937 scm_set_port_end_input (tc
, fport_end_input
);
938 scm_set_port_close (tc
, fport_close
);
939 scm_set_port_seek (tc
, fport_seek
);
940 scm_set_port_truncate (tc
, fport_truncate
);
941 scm_set_port_input_waiting (tc
, fport_input_waiting
);
949 scm_tc16_fport
= scm_make_fptob ();
951 scm_c_define ("_IOFBF", scm_from_int (_IOFBF
));
952 scm_c_define ("_IOLBF", scm_from_int (_IOLBF
));
953 scm_c_define ("_IONBF", scm_from_int (_IONBF
));
955 sys_file_port_name_canonicalization
= scm_make_fluid ();
956 scm_c_define ("%file-port-name-canonicalization",
957 sys_file_port_name_canonicalization
);
959 #include "libguile/fports.x"