(ice-9 optargs) based on the new lambda* work
[bpt/guile.git] / libguile / fports.c
index b89a199..5d37495 100644 (file)
@@ -1,23 +1,26 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 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
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
  *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  * Lesser General Public License for more details.
  *
  * You should have received a copy of the GNU Lesser General Public
  * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
  */
 
 
 \f
-#if HAVE_CONFIG_H
+#define _LARGEFILE64_SOURCE      /* ask for stat64 etc */
+
+#ifdef HAVE_CONFIG_H
 #  include <config.h>
 #endif
 
@@ -27,6 +30,9 @@
 #include "libguile/strings.h"
 #include "libguile/validate.h"
 #include "libguile/gc.h"
+#include "libguile/posix.h"
+#include "libguile/dynwind.h"
+#include "libguile/hashtab.h"
 
 #include "libguile/fports.h"
 
@@ -35,8 +41,6 @@
 #endif
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
-#else
-size_t fwrite ();
 #endif
 #ifdef HAVE_IO_H
 #include <io.h>
@@ -46,6 +50,7 @@ size_t fwrite ();
 #endif
 
 #include <errno.h>
+#include <sys/types.h>
 
 #include "libguile/iselect.h"
 
@@ -53,9 +58,35 @@ size_t fwrite ();
 #ifdef __MINGW32__
 # include <sys/stat.h>
 # include <winsock2.h>
-# define ftruncate(fd, size) chsize (fd, size)
 #endif /* __MINGW32__ */
 
+#include <full-write.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
+
+#if SIZEOF_OFF_T == SIZEOF_INT
+#define OFF_T_MAX  INT_MAX
+#define OFF_T_MIN  INT_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG
+#define OFF_T_MAX  LONG_MAX
+#define OFF_T_MIN  LONG_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
+#define OFF_T_MAX  LONG_LONG_MAX
+#define OFF_T_MIN  LONG_LONG_MIN
+#else
+#error Oops, unknown OFF_T size
+#endif
 
 scm_t_bits scm_tc16_fport;
 
@@ -91,7 +122,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size)
 
   if (SCM_INPUT_PORT_P (port) && read_size > 0)
     {
-      pt->read_buf = scm_gc_malloc (read_size, "port buffer");
+      pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer");
       pt->read_pos = pt->read_end = pt->read_buf;
       pt->read_buf_size = read_size;
     }
@@ -103,7 +134,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size)
 
   if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
     {
-      pt->write_buf = scm_gc_malloc (write_size, "port buffer");
+      pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer");
       pt->write_pos = pt->write_buf;
       pt->write_buf_size = write_size;
     }
@@ -153,7 +184,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
     }
   else
     {
-      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) SCM_BUFLINE);
+      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
     }
 
   if (SCM_UNBNDP (size))
@@ -193,33 +224,35 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 /* Move ports with the specified file descriptor to new descriptors,
  * resetting the revealed count to 0.
  */
-
-void
-scm_evict_ports (int fd)
+static void
+scm_i_evict_port (void *closure, SCM port)
 {
-  long i;
+  int fd = * (int*) closure;
 
-  scm_mutex_lock (&scm_i_port_table_mutex);
-
-  for (i = 0; i < scm_i_port_table_size; i++)
+  if (SCM_FPORTP (port))
     {
-      SCM port = scm_i_port_table[i]->port;
+      scm_t_port *p;
+      scm_t_fport *fp;
 
-      if (SCM_FPORTP (port))
-       {
-         scm_t_fport *fp = SCM_FSTREAM (port);
+      /* XXX: In some cases, we can encounter a port with no associated ptab
+        entry.  */
+      p = SCM_PTAB_ENTRY (port);
+      fp = (p != NULL) ? (scm_t_fport *) p->stream : NULL;
 
-         if (fp->fdes == fd)
-           {
-             fp->fdes = dup (fd);
-             if (fp->fdes == -1)
-               scm_syserror ("scm_evict_ports");
-             scm_set_port_revealed_x (port, SCM_I_MAKINUM (0));
-           }
+      if ((fp != NULL) && (fp->fdes == fd))
+       {
+         fp->fdes = dup (fd);
+         if (fp->fdes == -1)
+           scm_syserror ("scm_evict_ports");
+         scm_set_port_revealed_x (port, scm_from_int (0));
        }
     }
+}
 
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+void
+scm_evict_ports (int fd)
+{
+  scm_c_port_for_each (scm_i_evict_port, (void *) &fd);
 }
 
 
@@ -262,6 +295,8 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
            "@end table\n"
            "The following additional characters can be appended:\n"
            "@table @samp\n"
+           "@item b\n"
+           "Open the underlying file in binary mode, if supported by the operating system. "
            "@item +\n"
            "Open the port for both input and output.  E.g., @code{r+}: open\n"
            "an existing file for both input and output.\n"
@@ -289,11 +324,13 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
   char *md;
   char *ptr;
 
-  SCM_VALIDATE_STRING (1, filename);
-  SCM_VALIDATE_STRING (2, mode);
+  scm_dynwind_begin (0);
+
+  file = scm_to_locale_string (filename);
+  scm_dynwind_free (file);
 
-  file = SCM_STRING_CHARS (filename);
-  md = SCM_STRING_CHARS (mode);
+  md = scm_to_locale_string (mode);
+  scm_dynwind_free (md);
 
   switch (*md)
     {
@@ -330,16 +367,19 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
        }
       ptr++;
     }
-  SCM_SYSCALL (fdes = open (file, flags, 0666));
+  SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
   if (fdes == -1)
     {
       int en = errno;
 
       SCM_SYSERROR_MSG ("~A: ~S",
-                       scm_cons (scm_makfrom0str (strerror (en)),
+                       scm_cons (scm_strerror (scm_from_int (en)),
                                  scm_cons (filename, SCM_EOL)), en);
     }
-  port = scm_fdes_to_port (fdes, md, filename);
+  port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
+
+  scm_dynwind_end ();
+
   return port;
 }
 #undef FUNC_NAME
@@ -395,10 +435,9 @@ static int getflags (int fdes)
    NAME is a string to be used as the port's filename.
 */
 SCM
-scm_fdes_to_port (int fdes, char *mode, SCM name)
+scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 #define FUNC_NAME "scm_fdes_to_port"
 {
-  long mode_bits = scm_mode_bits (mode);
   SCM port;
   scm_t_port *pt;
   int flags;
@@ -419,14 +458,15 @@ scm_fdes_to_port (int fdes, char *mode, SCM name)
       SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
     }
 
-  scm_mutex_lock (&scm_i_port_table_mutex);
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
 
   port = scm_new_port_table_entry (scm_tc16_fport);
   SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
   pt = SCM_PTAB_ENTRY(port);
   {
     scm_t_fport *fp
-      = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
+      = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
+                                                  "file port");
 
     fp->fdes = fdes;
     pt->rw_random = SCM_FDES_RANDOM_P (fdes);
@@ -437,18 +477,23 @@ scm_fdes_to_port (int fdes, char *mode, SCM name)
       scm_fport_buffer_add (port, -1, -1);
   }
   SCM_SET_FILENAME (port, name);
-  scm_mutex_unlock (&scm_i_port_table_mutex);
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
   return port;
 }
 #undef FUNC_NAME
 
+SCM
+scm_fdes_to_port (int fdes, char *mode, SCM name)
+{
+  return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
+}
+
 /* Return a lower bound on the number of bytes available for input.  */
 static int
 fport_input_waiting (SCM port)
 {
-  int fdes = SCM_FSTREAM (port)->fdes;
-
 #ifdef HAVE_SELECT
+  int fdes = SCM_FSTREAM (port)->fdes;
   struct timeval timeout;
   SELECT_TYPE read_set;
   SELECT_TYPE write_set;
@@ -468,10 +513,15 @@ fport_input_waiting (SCM port)
       < 0)
     scm_syserror ("fport_input_waiting");
   return FD_ISSET (fdes, &read_set) ? 1 : 0;
-#elif defined (FIONREAD)
+
+#elif HAVE_IOCTL && defined (FIONREAD)
+  /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
+     (for use with winsock ioctlsocket()) but not ioctl().  */
+  int fdes = SCM_FSTREAM (port)->fdes;
   int remir;
   ioctl(fdes, FIONREAD, &remir);
   return remir;
+
 #else    
   scm_misc_error ("fport_input_waiting",
                  "Not fully implemented on this platform",
@@ -489,7 +539,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
     {
       int fdes;
       SCM name = SCM_FILENAME (exp);
-      if (SCM_STRINGP (name) || SCM_SYMBOLP (name))
+      if (scm_is_string (name) || scm_is_symbol (name))
        scm_display (name, port);
       else
        scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
@@ -498,7 +548,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
       
 #ifdef HAVE_TTYNAME
       if (isatty (fdes))
-       scm_puts (ttyname (fdes), port);
+       scm_display (scm_ttyname (exp), port);
       else
 #endif /* HAVE_TTYNAME */
        scm_intprint (fdes, 10, port);
@@ -507,7 +557,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
     {
       scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
       scm_putc (' ', port);
-      scm_intprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
+      scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
     }
   scm_putc ('>', port);
   return 1;
@@ -533,7 +583,7 @@ fport_wait_for_input (SCM port)
          {
            FD_ZERO (&readfds);
            FD_SET (fdes, &readfds);
-           n = scm_internal_select (fdes + 1, &readfds, NULL, NULL, NULL);
+           n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
          }
        while (n == -1 && errno == EINTR);
     }
@@ -544,7 +594,7 @@ static void fport_flush (SCM port);
 
 /* fill a port's read-buffer with a single read.  returns the first
    char or EOF if end of file.  */
-static int
+static scm_t_wchar
 fport_fill_input (SCM port)
 {
   long count;
@@ -558,7 +608,7 @@ fport_fill_input (SCM port)
   if (count == -1)
     scm_syserror ("fport_fill_input");
   if (count == 0)
-    return EOF;
+    return (scm_t_wchar) EOF;
   else
     {
       pt->read_pos = pt->read_buf;
@@ -567,25 +617,25 @@ fport_fill_input (SCM port)
     }
 }
 
-static off_t
-fport_seek (SCM port, off_t offset, int whence)
+static scm_t_off
+fport_seek (SCM port, scm_t_off offset, int whence)
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
   scm_t_fport *fp = SCM_FSTREAM (port);
-  off_t rv;
-  off_t result;
+  off_t_or_off64_t rv;
+  off_t_or_off64_t result;
 
   if (pt->rw_active == SCM_PORT_WRITE)
     {
       if (offset != 0 || whence != SEEK_CUR)
        {
          fport_flush (port);
-         result = rv = lseek (fp->fdes, offset, whence);
+         result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
        }
       else
        {
          /* read current position without disturbing the buffer.  */
-         rv = lseek (fp->fdes, offset, whence);
+         rv = lseek_or_lseek64 (fp->fdes, offset, whence);
          result = rv + (pt->write_pos - pt->write_buf);
        }
     }
@@ -595,13 +645,13 @@ fport_seek (SCM port, off_t offset, int whence)
        {
          /* could expand to avoid a second seek.  */
          scm_end_input (port);
-         result = rv = lseek (fp->fdes, offset, whence);
+         result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
        }
       else
        {
          /* read current position without disturbing the buffer
             (particularly the unread-char buffer).  */
-         rv = lseek (fp->fdes, offset, whence);
+         rv = lseek_or_lseek64 (fp->fdes, offset, whence);
          result = rv - (pt->read_end - pt->read_pos);
 
          if (pt->read_buf == pt->putback_buf)
@@ -610,7 +660,7 @@ fport_seek (SCM port, off_t offset, int whence)
     }
   else /* SCM_PORT_NEITHER */
     {
-      result = rv = lseek (fp->fdes, offset, whence);      
+      result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
     }
 
   if (rv == -1)
@@ -620,7 +670,7 @@ fport_seek (SCM port, off_t offset, int whence)
 }
 
 static void
-fport_truncate (SCM port, off_t length)
+fport_truncate (SCM port, scm_t_off length)
 {
   scm_t_fport *fp = SCM_FSTREAM (port);
 
@@ -665,7 +715,7 @@ fport_write (SCM port, const void *data, size_t size)
     }
 
   {
-    off_t space = pt->write_end - pt->write_pos;
+    scm_t_off space = pt->write_end - pt->write_pos;
 
     if (size <= space)
       {
@@ -746,9 +796,9 @@ fport_flush (SCM port)
              const char *msg = "Error: could not flush file-descriptor ";
              char buf[11];
 
-             write (2, msg, strlen (msg));
+             full_write (2, msg, strlen (msg));
              sprintf (buf, "%d\n", fp->fdes);
-             write (2, buf, strlen (buf));
+             full_write (2, buf, strlen (buf));
 
              count = remaining;
            }
@@ -845,9 +895,9 @@ scm_init_fports ()
 {
   scm_tc16_fport = scm_make_fptob ();
 
-  scm_c_define ("_IOFBF", SCM_I_MAKINUM (_IOFBF));
-  scm_c_define ("_IOLBF", SCM_I_MAKINUM (_IOLBF));
-  scm_c_define ("_IONBF", SCM_I_MAKINUM (_IONBF));
+  scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
+  scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
+  scm_c_define ("_IONBF", scm_from_int (_IONBF));
 
 #include "libguile/fports.x"
 }