Fix missing port-table locking and bytevector output port segfault

* libguile/r6rs-ports.c (make_bip, make_cbip, make_bop, make_cbop): Lock
  the port table.

* libguile/r6rs-ports.c (make_bop): Let the returned extraction
  procedure refer to the port's buffer instead of the port itself.  This
  fixes a segfault if the port is closed before the extraction procedure
  is called.
  (bop_proc_apply): Adapt accordingly.
* test-suite/tests/r6rs-ports.test (8.2.10 Output ports): Add testcase
  for extraction after close.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

libguile/r6rs-ports.c

@@ -84,6 +84,8 @@ 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_new_port_table_entry (bytevector_input_port_type);
 
   /* Prevent BV from being GC'd.  */
@@ -101,6 +103,8 @@ make_bip (SCM bv)
   /* 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;
 }
 
@@ -305,6 +309,8 @@ 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_new_port_table_entry (custom_binary_input_port_type);
 
   /* Attach it the method vector.  */
@@ -319,6 +325,8 @@ make_cbip (SCM read_proc, SCM get_position_proc,
   /* 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;
 }
 
@@ -812,6 +820,8 @@ 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);
 
   buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
@@ -826,9 +836,10 @@ make_bop (void)
   /* Mark PORT as open and writable.  */
   SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
 
+  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
   /* Make the bop procedure.  */
-  SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
+  SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
-	       SCM_PACK (port));
 
   return (scm_values (scm_list_2 (port, bop_proc)));
 }
@@ -889,11 +900,10 @@ bop_seek (SCM port, scm_t_off offset, int whence)
 SCM_SMOB_APPLY (bytevector_output_port_procedure,
 		bop_proc_apply, 0, 0, 0, (SCM bop_proc))
 {
-  SCM port, bv;
+  SCM bv;
   scm_t_bop_buffer *buf, result_buf;
 
-  port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
+  buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
-  buf = SCM_BOP_BUFFER (port);
 
   result_buf = *buf;
   bop_buffer_init (buf);
@@ -966,6 +976,8 @@ 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_new_port_table_entry (custom_binary_output_port_type);
 
   /* Attach it the method vector.  */
@@ -979,6 +991,8 @@ make_cbop (SCM write_proc, SCM get_position_proc,
   /* 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;
 }
 

test-suite/tests/r6rs-ports.test

@@ -396,6 +396,14 @@
         (and (bytevector=? (get-content) source)
              (bytevector=? (get-content) (make-bytevector 0))))))
     
+  (pass-if "open-bytevector-output-port [extract after close]"
+    (let-values (((port get-content)
+                  (open-bytevector-output-port)))
+      (let ((source (make-bytevector 12345 #xFE)))
+        (put-bytevector port source)
+        (close-port port)
+        (bytevector=? (get-content) source))))
+
   (pass-if "open-bytevector-output-port [put-u8]"
     (let-values (((port get-content)
                   (open-bytevector-output-port)))