-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
#include <stdio.h>
#include <errno.h>
+#include <fcntl.h> /* for chsize on mingw */
#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
+#include "libguile/fports.h" /* direct access for seek and truncate */
#include "libguile/objects.h"
#include "libguile/goops.h"
#include "libguile/smob.h"
#include <sys/ioctl.h>
#endif
-#ifdef __MINGW32__
-#include <fcntl.h>
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
#define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
#endif
\f
scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-/* This function is not and should not be thread safe. */
+\f
+/* Port finalization. */
+
+
+static void finalize_port (GC_PTR, GC_PTR);
+
+/* Register a finalizer for PORT, if needed by its port type. */
+static SCM_C_INLINE_KEYWORD void
+register_finalizer_for_port (SCM port)
+{
+ long port_type;
+
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (scm_ptobs[port_type].free)
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalization_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
+ &prev_finalizer,
+ &prev_finalization_data);
+ }
+}
+
+/* Finalize the object (a port) pointed to by PTR. */
+static void
+finalize_port (GC_PTR ptr, GC_PTR data)
+{
+ long port_type;
+ SCM port = PTR2SCM (ptr);
+
+ if (!SCM_PORTP (port))
+ abort ();
+
+ if (SCM_OPENP (port))
+ {
+ if (SCM_REVEALED (port) > 0)
+ /* Keep "revealed" ports alive and re-register a finalizer. */
+ register_finalizer_for_port (port);
+ else
+ {
+ port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
+ if (port_type >= scm_numptob)
+ abort ();
+
+ if (scm_ptobs[port_type].free)
+ /* Yes, I really do mean `.free' rather than `.close'. `.close'
+ is for explicit `close-port' by user. */
+ scm_ptobs[port_type].free (port);
+
+ SCM_SETSTREAM (port, 0);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ scm_remove_from_port_table (port);
+ scm_gc_ports_collected++;
+ }
+ }
+}
+
+
+
+\f
+
+/* This function is not and should not be thread safe. */
SCM
scm_new_port_table_entry (scm_t_bits tag)
#define FUNC_NAME "scm_new_port_table_entry"
since it can never be freed during gc. */
/* XXX (Ludo): Why not do it actually? */
size_t new_size = scm_i_port_table_room * 2;
+ /* XXX (Ludo): Can we use `GC_REALLOC' with
+ `GC_MALLOC_ATOMIC'-allocated data? */
void *newt = scm_gc_realloc ((char *) scm_i_port_table,
scm_i_port_table_room * sizeof (scm_t_port *),
new_size * sizeof (scm_t_port *),
entry->port = z;
SCM_SET_CELL_TYPE(z, tag);
SCM_SETPTAB_ENTRY(z, entry);
-
+
+ /* For each new port, register a finalizer so that it port type's free
+ function can be invoked eventually. */
+ register_finalizer_for_port (z);
+
return z;
}
#undef FUNC_NAME
{
size_t new_size = pt->read_buf_size * 2;
unsigned char *tmp = (unsigned char *)
+ /* XXX: Can we use `GC_REALLOC' with `GC_MALLOC_ATOMIC'-allocated
+ data? (Ludo) */
scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
"putback buffer");
if (pt->putback_buf == NULL)
{
pt->putback_buf
- = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
- "putback buffer");
+ = (unsigned char *) scm_gc_malloc_pointerless
+ (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
}
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
- if (SCM_OPPORTP (fd_port))
+ if (SCM_OPFPORTP (fd_port))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ return scm_i_fport_seek (fd_port, offset, how);
+ }
+ else if (SCM_OPPORTP (fd_port))
{
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
off_t off = scm_to_off_t (offset);
}
#undef FUNC_NAME
-#ifdef __MINGW32__
-/* Define this function since it is not supported under Windows. */
-static int truncate (char *file, int length)
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
{
- int ret = -1, fdes;
- if ((fdes = open (file, O_BINARY | O_WRONLY)) != -1)
+ int ret, fdes;
+
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
+
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
{
- ret = chsize (fdes, length);
+ int save_errno = errno;
close (fdes);
+ errno = save_errno;
+ return -1;
}
- return ret;
+
+ return close (fdes);
}
-#endif /* __MINGW32__ */
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
- "Truncates the object referred to by @var{object} to at most\n"
- "@var{length} bytes. @var{object} can be a string containing a\n"
- "file name or an integer file descriptor or a port.\n"
- "@var{length} may be omitted if @var{object} is not a file name,\n"
- "in which case the truncation occurs at the current port\n"
- "position. The return value is unspecified.")
+ "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
+ "filename string, a port object, or an integer file descriptor.\n"
+ "The return value is unspecified.\n"
+ "\n"
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
#define FUNC_NAME s_scm_truncate_file
{
int rv;
SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
c_length));
}
+ else if (SCM_OPOUTFPORTP (object))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ rv = scm_i_fport_truncate (object, length);
+ }
else if (SCM_OPOUTPORTP (object))
{
off_t c_length = scm_to_off_t (length);
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (SCM_LINUM (port));
+ return scm_from_long (SCM_LINUM (port));
}
#undef FUNC_NAME
{
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->line_number = scm_to_int (line);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
scm_numptob = 0;
scm_ptobs = NULL;
- scm_i_port_table = scm_gc_malloc (scm_i_port_table_room
- * sizeof (scm_t_port *),
- "port-table");
+ /* In order for the ports to be collectable, the port table must not be
+ scanned by the GC. */
+ scm_i_port_table =
+ scm_gc_malloc_pointerless (scm_i_port_table_room
+ * sizeof (scm_t_port *),
+ "port-table");
}
\f
HCoop / bpt / guile.git / blobdiff