merge from 1.8 branch

libguile/ports.c

@@ -1,4 +1,4 @@
-/* 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
@@ -1539,7 +1539,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
 {
   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
 
@@ -1551,7 +1551,7 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
 {
   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

libguile/scmsigs.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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
@@ -610,7 +610,9 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
            (SCM i),
 	    "Wait for the given number of seconds (an integer) or until a signal\n"
 	    "arrives.  The return value is zero if the time elapses or the number\n"
-	    "of seconds remaining otherwise.")
+	    "of seconds remaining otherwise.\n"
+	    "\n"
+	    "See also @code{usleep}.")
 #define FUNC_NAME s_scm_sleep
 {
   return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
@@ -619,7 +621,17 @@ SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
 
 SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
            (SCM i),
-	    "Sleep for @var{i} microseconds.")
+	    "Wait the given period @var{usecs} microseconds (an integer).\n"
+	    "If a signal arrives the wait stops and the return value is the\n"
+	    "time remaining, in microseconds.  If the period elapses with no\n"
+	    "signal the return is zero.\n"
+	    "\n"
+	    "On most systems the process scheduler is not microsecond accurate and\n"
+	    "the actual period slept by @code{usleep} may be rounded to a system\n"
+	    "clock tick boundary.  Traditionally such ticks were 10 milliseconds\n"
+	    "apart, and that interval is often still used.\n"
+	    "\n"
+	    "See also @code{sleep}.")
 #define FUNC_NAME s_scm_usleep
 {
   return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));

libguile/sort.c

@@ -531,6 +531,9 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
 	    "This is a stable sort.")
 #define FUNC_NAME s_scm_stable_sort
 {
+  if (SCM_NULL_OR_NIL_P (items))
+    return SCM_EOL;
+
   if (scm_is_pair (items))
     return scm_stable_sort_x (scm_list_copy (items), less);
   else if (scm_is_vector (items))

libguile/struct.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -430,6 +430,26 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
   layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
   basic_size = scm_i_symbol_length (layout) / 2;
   tail_elts = scm_to_size_t (tail_array_size);
+
+  /* A tail array is only allowed if the layout fields string ends in "R",
+     "W" or "O". */
+  if (tail_elts != 0)
+    {
+      SCM layout_str, last_char;
+      
+      if (basic_size == 0)
+        {
+        bad_tail: 
+          SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
+        }
+
+      layout_str = scm_symbol_to_string (layout);
+      last_char = scm_string_ref (layout_str,
+                                  scm_from_size_t (2 * basic_size - 1));
+      if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
+        goto bad_tail;
+    }
+    
   SCM_CRITICAL_SECTION_START;
   if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
     {
@@ -446,8 +466,17 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
   handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
 			     + scm_tc3_struct),
 			    (scm_t_bits) data, 0, 0);
-  scm_struct_init (handle, layout, data, tail_elts, init);
   SCM_CRITICAL_SECTION_END;
+
+  /* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered
+     also the following scm_struct_init.  But that meant if scm_struct_init
+     finds an invalid type for a "u" field then there's an error throw in a
+     critical section, which results in an abort().  Not sure if we need any
+     protection across scm_struct_init.  The data array contains garbage at
+     this point, but until we return it's not visible to anyone except
+     `gc'.  */
+  scm_struct_init (handle, layout, data, tail_elts, init);
+
   return handle;
 }
 #undef FUNC_NAME
@@ -531,6 +560,28 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
 #undef FUNC_NAME
 
 
+static SCM scm_i_vtable_vtable_no_extra_fields;
+
+SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
+            (SCM fields, SCM printer),
+	    "Create a vtable, for creating structures with the given\n"
+	    "@var{fields}.\n"
+	    "\n"
+	    "The optional @var{printer} argument is a function to be called\n"
+	    "@code{(@var{printer} struct port)} on the structures created.\n"
+	    "It should look at @var{struct} and write to @var{port}.")
+#define FUNC_NAME s_scm_make_vtable
+{
+  if (SCM_UNBNDP (printer))
+    printer = SCM_BOOL_F;
+
+  return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+                          scm_list_2 (scm_make_struct_layout (fields),
+                                      printer));
+}
+#undef FUNC_NAME
+
+
 /* Return true if S1 and S2 are equal structures, i.e., if their vtable and
    contents are the same.  Field protections are honored.  Thus, it is an
    error to test the equality of structures that contain opaque fields.  */
@@ -850,6 +901,11 @@ scm_init_struct ()
     = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
   required_vtable_fields = scm_from_locale_string ("prsrpw");
   scm_permanent_object (required_vtable_fields);
+
+  scm_i_vtable_vtable_no_extra_fields =
+    scm_permanent_object
+    (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
+
   scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
   scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
   scm_c_define ("vtable-index-printer",

libguile/struct.h

@@ -3,7 +3,7 @@
 #ifndef SCM_STRUCT_H
 #define SCM_STRUCT_H
 
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 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
@@ -93,6 +93,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields);
 SCM_API SCM scm_struct_p (SCM x);
 SCM_API SCM scm_struct_vtable_p (SCM x);
 SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
+SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
 SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
 SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2);
 SCM_API SCM scm_struct_ref (SCM handle, SCM pos);