Merge commit 'ed72201a795ac1c8d6c0288b6bb710f2bd0ebd9c'
[bpt/guile.git] / libguile / r6rs-ports.c
index fecc5bd..2c2b657 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2013-2015 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
 # include <config.h>
 #endif
 
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#endif
-
+#include <unistd.h>
 #include <string.h>
 #include <stdio.h>
 #include <assert.h>
@@ -37,6 +34,7 @@
 #include "libguile/validate.h"
 #include "libguile/values.h"
 #include "libguile/vectors.h"
+#include "libguile/ports-internal.h"
 
 
 \f
@@ -84,17 +82,14 @@ make_bip (SCM bv)
   scm_t_port *c_port;
   const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
 
-  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+  port = scm_c_make_port_with_encoding (bytevector_input_port_type,
+                                        mode_bits,
+                                        NULL, /* encoding */
+                                        SCM_FAILED_CONVERSION_ERROR,
+                                        SCM_UNPACK (bv));
 
-  port = scm_new_port_table_entry (bytevector_input_port_type);
   c_port = SCM_PTAB_ENTRY (port);
 
-  /* Match the expectation of `binary-port?'.  */
-  c_port->encoding = NULL;
-
-  /* Prevent BV from being GC'd.  */
-  SCM_SETSTREAM (port, SCM_UNPACK (bv));
-
   /* Have the port directly access the bytevector.  */
   c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
   c_len = SCM_BYTEVECTOR_LENGTH (bv);
@@ -103,11 +98,6 @@ make_bip (SCM bv)
   c_port->read_end = (unsigned char *) c_bv + c_len;
   c_port->read_buf_size = c_len;
 
-  /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
-  SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
-
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
   return port;
 }
 
@@ -224,10 +214,14 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
          result = scm_call_0 (get_position_proc);
        else
          scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
-                                 "R6RS custom binary port does not "
-                                 "support `port-position'");
-
-       offset += scm_to_int (result);
+                                 "R6RS custom binary port with "
+                                 "`port-position' support");
+       c_result = scm_to_int (result);
+       if (offset == 0)
+         /* We just want to know the current position.  */
+         break;
+
+       offset += c_result;
        /* Fall through.  */
       }
 
@@ -240,8 +234,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
          result = scm_call_1 (set_position_proc, scm_from_int (offset));
        else
          scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
-                                 "R6RS custom binary port does not "
-                                 "support `set-port-position!'");
+                                 "seekable R6RS custom binary port");
 
        /* Assuming setting the position succeeded.  */
        c_result = offset;
@@ -277,18 +270,60 @@ cbp_close (SCM port)
 
 static scm_t_bits custom_binary_input_port_type = 0;
 
-/* Size of the buffer embedded in custom binary input ports.  */
-#define CBIP_BUFFER_SIZE  4096
+/* Initial size of the buffer embedded in custom binary input ports.  */
+#define CBIP_BUFFER_SIZE  8192
 
 /* Return the bytevector associated with PORT.  */
 #define SCM_CBIP_BYTEVECTOR(_port)                             \
   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
 
+/* Set BV as the bytevector associated with PORT.  */
+#define SCM_SET_CBIP_BYTEVECTOR(_port, _bv)                            \
+  SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
+
 /* Return the various procedures of PORT.  */
 #define SCM_CBIP_READ_PROC(_port)                              \
   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
 
 
+/* Set PORT's internal buffer according to READ_SIZE.  */
+static void
+cbip_setvbuf (SCM port, long read_size, long write_size)
+{
+  SCM bv;
+  scm_t_port *pt;
+
+  pt = SCM_PTAB_ENTRY (port);
+  bv = SCM_CBIP_BYTEVECTOR (port);
+
+  switch (read_size)
+    {
+    case 0:
+      /* Unbuffered: keep using PORT's bytevector as the underlying
+        buffer (it will also be used by future 'scm_c_read' calls.)  */
+      assert (SCM_BYTEVECTOR_LENGTH (bv) >= 1);
+      pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      pt->read_buf_size = 1;
+      break;
+
+    case -1:
+      /* Preferred size: keep the current bytevector and use it as the
+        backing store.  */
+      pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      pt->read_buf_size = SCM_BYTEVECTOR_LENGTH (bv);
+      break;
+
+    default:
+      /* Fully buffered: allocate a buffer of READ_SIZE bytes.  */
+      bv = scm_c_make_bytevector (read_size);
+      SCM_SET_CBIP_BYTEVECTOR (port, bv);
+      pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      pt->read_buf_size = read_size;
+    }
+
+  pt->read_pos = pt->read_end = pt->read_buf;
+}
+
 static inline SCM
 make_cbip (SCM read_proc, SCM get_position_proc,
           SCM set_position_proc, SCM close_proc)
@@ -312,27 +347,19 @@ make_cbip (SCM read_proc, SCM get_position_proc,
   SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
   SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
 
-  scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+  port = scm_c_make_port_with_encoding (custom_binary_input_port_type,
+                                        mode_bits,
+                                        NULL, /* encoding */
+                                        SCM_FAILED_CONVERSION_ERROR,
+                                        SCM_UNPACK (method_vector));
 
-  port = scm_new_port_table_entry (custom_binary_input_port_type);
   c_port = SCM_PTAB_ENTRY (port);
 
-  /* Match the expectation of `binary-port?'.  */
-  c_port->encoding = NULL;
-
-  /* Attach it the method vector.  */
-  SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
   /* Have the port directly access the buffer (bytevector).  */
   c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
   c_port->read_end = (unsigned char *) c_bv;
   c_port->read_buf_size = c_len;
 
-  /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
-  SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
-
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
   return port;
 }
 
@@ -343,34 +370,60 @@ cbip_fill_input (SCM port)
   int result;
   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 
- again:
   if (c_port->read_pos >= c_port->read_end)
     {
       /* Invoke the user's `read!' procedure.  */
-      unsigned c_octets;
+      int buffered;
+      size_t c_octets, c_requested;
       SCM bv, read_proc, octets;
 
-      /* Use the bytevector associated with PORT as the buffer passed to the
-        `read!' procedure, thereby avoiding additional allocations.  */
-      bv = SCM_CBIP_BYTEVECTOR (port);
+      c_requested = c_port->read_buf_size;
       read_proc = SCM_CBIP_READ_PROC (port);
 
-      /* The assumption here is that C_PORT's internal buffer wasn't changed
-        behind our back.  */
-      assert (c_port->read_buf ==
-             (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
-      assert ((unsigned) c_port->read_buf_size
-             == SCM_BYTEVECTOR_LENGTH (bv));
+      bv = SCM_CBIP_BYTEVECTOR (port);
+      buffered =
+       (c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+
+      if (buffered)
+       {
+         /* Make sure the buffer isn't corrupt.  Its size can be 1 when
+            someone called 'setvbuf' with _IONBF.  BV can be passed
+            directly to READ_PROC.  */
+         assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv)
+                 || c_port->read_buf_size == 1);
+         c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+       }
+      else
+       {
+         /* This is an unbuffered port.  When called via the
+            'get-bytevector-*' procedures, and thus via 'scm_c_read', we
+            are passed the caller-provided buffer, so we need to check its
+            size.  */
+         if (SCM_BYTEVECTOR_LENGTH (bv) < c_requested)
+           {
+             /* Bad luck: we have to make another allocation.  Save that
+                bytevector for later reuse, in the hope that the application
+                has regular access patterns.  */
+             bv = scm_c_make_bytevector (c_requested);
+             SCM_SET_CBIP_BYTEVECTOR (port, bv);
+           }
+       }
 
       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
-                          SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
-      c_octets = scm_to_uint (octets);
+                          scm_from_size_t (c_requested));
+      c_octets = scm_to_size_t (octets);
+      if (SCM_UNLIKELY (c_octets > c_requested))
+       scm_out_of_range (FUNC_NAME, octets);
+
+      if (!buffered)
+       /* Copy the data back to the internal buffer.  */
+       memcpy ((char *) c_port->read_pos, SCM_BYTEVECTOR_CONTENTS (bv),
+               c_octets);
 
-      c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
 
-      if (c_octets > 0)
-       goto again;
+      if (c_octets != 0 || c_requested == 0)
+       result = (int) *c_port->read_pos;
       else
        result = EOF;
     }
@@ -419,6 +472,7 @@ initialize_custom_binary_input_ports (void)
 
   scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
   scm_set_port_close (custom_binary_input_port_type, cbp_close);
+  scm_set_port_setvbuf (custom_binary_input_port_type, cbip_setvbuf);
 }
 
 
@@ -491,7 +545,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
 
   if (SCM_LIKELY (c_count > 0))
     /* XXX: `scm_c_read ()' does not update the port position.  */
-    c_read = scm_c_read (port, c_bv, c_count);
+    c_read = scm_c_read_unlocked (port, c_bv, c_count);
   else
     /* Don't invoke `scm_c_read ()' since it may block.  */
     c_read = 0;
@@ -533,7 +587,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
     scm_out_of_range (FUNC_NAME, count);
 
   if (SCM_LIKELY (c_count > 0))
-    c_read = scm_c_read (port, c_bv + c_start, c_count);
+    c_read = scm_c_read_unlocked (port, c_bv + c_start, c_count);
   else
     /* Don't invoke `scm_c_read ()' since it may block.  */
     c_read = 0;
@@ -565,14 +619,14 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
   pt = SCM_PTAB_ENTRY (port);
 
   if (pt->rw_active == SCM_PORT_WRITE)
-    scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+    scm_flush_unlocked (port);
 
   if (pt->rw_random)
     pt->rw_active = SCM_PORT_READ;
 
   if (pt->read_pos >= pt->read_end)
     {
-      if (scm_fill_input (port) == EOF)
+      if (scm_fill_input_unlocked (port) == EOF)
        return SCM_EOF_VAL;
     }
 
@@ -620,7 +674,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 
       /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
         reached.  */
-      c_read = scm_c_read (port, c_bv + c_total, c_count);
+      c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
       c_total += c_read, c_count -= c_read;
     }
   while (c_count == 0);
@@ -640,7 +694,8 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
          c_len = (unsigned) c_total;
        }
 
-      result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+      result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
+                                         SCM_BOOL_F);
     }
 
   return result;
@@ -665,7 +720,7 @@ SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
   SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
   c_octet = scm_to_uint8 (octet);
 
-  scm_putc ((char) c_octet, port);
+  scm_putc_unlocked ((char) c_octet, port);
 
   return SCM_UNSPECIFIED;
 }
@@ -708,7 +763,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
   else
     c_start = 0, c_count = c_len;
 
-  scm_c_write (port, c_bv + c_start, c_count);
+  scm_c_write_unlocked (port, c_bv + c_start, c_count);
 
   return SCM_UNSPECIFIED;
 }
@@ -833,26 +888,19 @@ make_bop (void)
   scm_t_bop_buffer *buf;
   const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
 
-  scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
-  port = scm_new_port_table_entry (bytevector_output_port_type);
-  c_port = SCM_PTAB_ENTRY (port);
-
-  /* Match the expectation of `binary-port?'.  */
-  c_port->encoding = NULL;
-
   buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
   bop_buffer_init (buf);
 
-  c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
-  c_port->write_buf_size = 0;
-
-  SCM_SET_BOP_BUFFER (port, buf);
+  port = scm_c_make_port_with_encoding (bytevector_output_port_type,
+                                        mode_bits,
+                                        NULL, /* encoding */
+                                        SCM_FAILED_CONVERSION_ERROR,
+                                        (scm_t_bits)buf);
 
-  /* Mark PORT as open and writable.  */
-  SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+  c_port = SCM_PTAB_ENTRY (port);
 
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+  c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+  c_port->write_buf_size = 0;
 
   /* Make the bop procedure.  */
   SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
@@ -925,7 +973,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
   bop_buffer_init (buf);
 
   if (result_buf.len == 0)
-    bv = scm_c_take_gc_bytevector (NULL, 0);
+    bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F);
   else
     {
       if (result_buf.total_len > result_buf.len)
@@ -936,7 +984,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
                                            SCM_GC_BOP);
 
       bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
-                                     result_buf.len);
+                                     result_buf.len, SCM_BOOL_F);
     }
 
   return bv;
@@ -992,26 +1040,18 @@ make_cbop (SCM write_proc, SCM get_position_proc,
   SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
   SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
 
-  scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+  port = scm_c_make_port_with_encoding (custom_binary_output_port_type,
+                                        mode_bits,
+                                        NULL, /* encoding */
+                                        SCM_FAILED_CONVERSION_ERROR,
+                                        SCM_UNPACK (method_vector));
 
-  port = scm_new_port_table_entry (custom_binary_output_port_type);
   c_port = SCM_PTAB_ENTRY (port);
 
-  /* Match the expectation of `binary-port?'.  */
-  c_port->encoding = NULL;
-
-  /* Attach it the method vector.  */
-  SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
   /* Have the port directly access the buffer (bytevector).  */
   c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
   c_port->write_buf_size = c_port->read_buf_size = 0;
 
-  /* Mark PORT as open, writable and unbuffered.  */
-  SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
-
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
   return port;
 }
 
@@ -1109,13 +1149,8 @@ make_tp (SCM binary_port, unsigned long mode)
   scm_t_port *c_port;
   const unsigned long mode_bits = SCM_OPN | mode;
   
-  scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
-  port = scm_new_port_table_entry (transcoded_port_type);
-
-  SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
-
-  SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+  port = scm_c_make_port (transcoded_port_type, mode_bits,
+                          SCM_UNPACK (binary_port));
 
   if (SCM_INPUT_PORT_P (port))
     {
@@ -1128,15 +1163,13 @@ make_tp (SCM binary_port, unsigned long mode)
       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
     }
   
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
   return port;
 }
 
 static void
 tp_write (SCM port, const void *data, size_t size)
 {
-  scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+  scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size);
 }
 
 static int
@@ -1154,7 +1187,7 @@ tp_fill_input (SCM port)
     scm_force_output (bport);
 
   if (c_bport->read_pos >= c_bport->read_end)
-    scm_fill_input (bport);
+    scm_fill_input_unlocked (bport);
   
   count = c_bport->read_end - c_bport->read_pos;
   if (count > c_port->read_buf_size)
@@ -1191,7 +1224,7 @@ tp_flush (SCM port)
      We just throw away the data when the underlying port is closed.  */
   
   if (SCM_OPOUTPORTP (binary_port))
-      scm_c_write (binary_port, c_port->write_buf, count);
+      scm_c_write_unlocked (binary_port, c_port->write_buf, count);
 
   c_port->write_pos = c_port->write_buf;
   c_port->rw_active = SCM_PORT_NEITHER;
@@ -1218,6 +1251,8 @@ initialize_transcoded_ports (void)
   scm_set_port_close (transcoded_port_type, tp_close);
 }
 
+SCM_INTERNAL SCM scm_i_make_transcoded_port (SCM);
+
 SCM_DEFINE (scm_i_make_transcoded_port,
            "%make-transcoded-port", 1, 0, 0,
            (SCM port),
@@ -1273,7 +1308,7 @@ SCM_DEFINE (scm_get_string_n_x,
 
   for (j = c_start; j < c_end; j++)
     {
-      c = scm_getc (port);
+      c = scm_getc_unlocked (port);
       if (c == EOF)
         {
           size_t chars_read = j - c_start;