Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/bytevectors.c
	libguile/bytevectors.h
	libguile/objcodes.c
	libguile/r6rs-ports.c
	libguile/strings.c
	libguile/vm.c

doc/ref/api-io.texi

@@ -838,34 +838,34 @@ setvbuf}
 Add line-buffering to the port.  The port output buffer will be
 automatically flushed whenever a newline character is written.
 @item b
-Use binary mode.  On DOS systems the default text mode converts CR+LF
+Use binary mode, ensuring that each byte in the file will be read as one
-in the file to newline for the program, whereas binary mode reads and
+Scheme character.
-writes all bytes unchanged.  On Unix-like systems there is no such
-distinction, text files already contain just newlines and no
-conversion is ever made.  The @code{b} flag is accepted on all
-systems, but has no effect on Unix-like systems.
 
-(For reference, Guile leaves text versus binary up to the C library,
+To provide this property, the file will be opened with the 8-bit
-@code{b} here just adds @code{O_BINARY} to the underlying @code{open}
+character encoding "ISO-8859-1", ignoring any coding declaration or port
-call, when that flag is available.)
+encoding.  @xref{Ports}, for more information on port encodings.
 
-Also, open the file using the 8-bit character encoding "ISO-8859-1",
+Note that while it is possible to read and write binary data as
-ignoring any coding declaration or port encoding.
+characters or strings, it is usually better to treat bytes as octets,
+and byte sequences as bytevectors.  @xref{R6RS Binary Input}, and
+@ref{R6RS Binary Output}, for more.
 
-Note that, when reading or writing binary data with ports, the
+This option had another historical meaning, for DOS compatibility: in
-bytevector ports in the @code{(rnrs io ports)} module are preferred,
+the default (textual) mode, DOS reads a CR-LF sequence as one LF byte.
-as they return vectors, and not strings (@pxref{R6RS I/O Ports}).
+The @code{b} flag prevents this from happening, adding @code{O_BINARY}
+to the underlying @code{open} call.  Still, the flag is generally useful
+because of its port encoding ramifications.
 @end table
 
 If a file cannot be opened with the access
 requested, @code{open-file} throws an exception.
 
 When the file is opened, this procedure will scan for a coding
-declaration (@pxref{Character Encoding of Source Files}). If present
+declaration (@pxref{Character Encoding of Source Files}). If a coding
-will use that encoding for interpreting the file.  Otherwise, the
+declaration is found, it will be used to interpret the file.  Otherwise,
-port's encoding will be used.  To suppress this behavior, open
+the port's encoding will be used.  To suppress this behavior, open the
-the file in binary mode and then set the port encoding explicitly
+file in binary mode and then set the port encoding explicitly using
-using @code{set-port-encoding!}.
+@code{set-port-encoding!}.
 
 In theory we could create read/write ports which were buffered
 in one direction only.  However this isn't included in the

libguile/arrays.c

@@ -822,15 +822,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
    C is the first character read after the '#'.
 */
 
-static SCM
-tag_to_type (const char *tag, SCM port)
-{
-  if (*tag == '\0')
-    return SCM_BOOL_T;
-  else
-    return scm_from_locale_symbol (tag);
-}
-
 static int
 read_decimal_integer (SCM port, int c, ssize_t *resp)
 {
@@ -860,10 +851,10 @@ SCM
 scm_i_read_array (SCM port, int c)
 {
   ssize_t rank;
-  char tag[80];
+  scm_t_wchar tag_buf[8];
   int tag_len;
 
-  SCM shape = SCM_BOOL_F, elements;
+  SCM tag, shape = SCM_BOOL_F, elements;
 
   /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
      the array code can not deal with zero-length dimensions yet, and
@@ -887,7 +878,7 @@ scm_i_read_array (SCM port, int c)
 	  return SCM_BOOL_F;
 	}
       rank = 1;
-      tag[0] = 'f';
+      tag_buf[0] = 'f';
       tag_len = 1;
       goto continue_reading_tag;
     }
@@ -904,13 +895,22 @@ scm_i_read_array (SCM port, int c)
    */
   tag_len = 0;
  continue_reading_tag:
-  while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
+  while (c != EOF && c != '(' && c != '@' && c != ':'
+         && tag_len < sizeof tag_buf / sizeof tag_buf[0])
     {
-      tag[tag_len++] = c;
+      tag_buf[tag_len++] = c;
       c = scm_getc (port);
     }
-  tag[tag_len] = '\0';
+  if (tag_len == 0)
-  
+    tag = SCM_BOOL_T;
+  else
+    {
+      tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
+      if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
+        scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
+                           scm_list_1 (tag));
+    }
+    
   /* Read shape. 
    */
   if (c == '@' || c == ':')
@@ -983,7 +983,7 @@ scm_i_read_array (SCM port, int c)
 
   /* Construct array. 
    */
-  return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
+  return scm_list_to_typed_array (tag, shape, elements);
 }
 
 

libguile/bytevectors.c

@@ -178,7 +178,7 @@
 /* Bytevector type.  */
 
 #define SCM_BYTEVECTOR_HEADER_BYTES		\
-  (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM))
+  (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
 
 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len)            \
   SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
@@ -292,7 +292,7 @@ scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
    because it was allocated using `scm_gc_malloc ()', or because it is
    part of PARENT.  */
 SCM
-scm_c_take_bytevector (signed char *contents, size_t len, SCM parent)
+scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
 {
   SCM ret;
 

libguile/bytevectors.h

@@ -140,7 +140,7 @@ SCM_INTERNAL void scm_bootstrap_bytevectors (void);
 SCM_INTERNAL void scm_init_bytevectors (void);
 
 SCM_INTERNAL SCM scm_i_native_endianness;
-SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t, SCM);
+SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t, SCM);
 
 SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);
 

libguile/control.c

@@ -248,7 +248,8 @@ SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
 #define FUNC_NAME s_scm_at_abort
 {
   SCM *argv;
-  size_t i, n;
+  size_t i;
+  long n;
 
   SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
   argv = alloca (sizeof (SCM)*n);

libguile/gc.c

@@ -739,13 +739,7 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
 char const *
 scm_i_tag_name (scm_t_bits tag)
 {
-  if (tag >= 255)
+  switch (tag & 0x7f) /* 7 bits */
-    {
-      int k = 0xff & (tag >> 8);
-      return (scm_smobs[k].name);
-    }
-
-  switch (tag) /* 7 bits */
     {
     case scm_tcs_struct:
       return "struct";
@@ -806,7 +800,10 @@ scm_i_tag_name (scm_t_bits tag)
       return "port";
       break;
     case scm_tc7_smob:
-      return "smob";		/* should not occur. */
+      {
+        int k = 0xff & (tag >> 8);
+        return (scm_smobs[k].name);
+      }
       break; 
     }
 

libguile/hashtab.c

@@ -274,7 +274,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name)
   SCM vector;
   scm_t_hashtable *t;
   int i = 0, n = k ? k : 31;
-  while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
+  while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
     ++i;
   n = hashtable_size[i];
 

libguile/i18n.c

@@ -501,7 +501,6 @@ get_current_locale (SCM *result)
 
   c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
 
-
   lock_locale_mutex ();
 
   c_locale->category_mask = LC_ALL_MASK;
@@ -509,20 +508,16 @@ get_current_locale (SCM *result)
 
   current_locale = setlocale (LC_ALL, NULL);
   if (current_locale != NULL)
-    {
+    c_locale->locale_name = scm_gc_strdup (current_locale, "locale");
-      c_locale->locale_name = strdup (current_locale);
-      if (c_locale->locale_name == NULL)
-	err = ENOMEM;
-    }
   else
     err = EINVAL;
 
   unlock_locale_mutex ();
 
-  if (err)
+  if (err == 0)
-    scm_gc_free (c_locale, sizeof (* c_locale), "locale");
-  else
     SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale);
+  else
+    *result = SCM_BOOL_F;
 
   return err;
 }

libguile/load.c

@@ -419,63 +419,21 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
    If FILENAME is absolute, return it unchanged.
    If given, EXTENSIONS is a list of strings; for each directory 
    in PATH, we search for FILENAME concatenated with each EXTENSION.  */
-SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
+static SCM
-            (SCM path, SCM filename, SCM rest),
+search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
-	    "Search @var{path} for a directory containing a file named\n"
+             struct stat *stat_buf)
-	    "@var{filename}. The file must be readable, and not a directory.\n"
-	    "If we find one, return its full filename; otherwise, return\n"
-	    "@code{#f}.  If @var{filename} is absolute, return it unchanged.\n"
-	    "If given, @var{extensions} is a list of strings; for each\n"
-	    "directory in @var{path}, we search for @var{filename}\n"
-	    "concatenated with each @var{extension}.")
-#define FUNC_NAME s_scm_search_path
 {
   struct stringbuf buf;
   char *filename_chars;
   size_t filename_len;
-  SCM extensions, require_exts;
   SCM result = SCM_BOOL_F;
 
-  if (SCM_UNBNDP (rest) || scm_is_null (rest))
+  if (scm_ilength (path) < 0)
-    {
+    scm_misc_error ("%search-path", "path is not a proper list: ~a",
-      /* Called either by Scheme code that didn't provide the optional
+                    scm_list_1 (path));
-         arguments, or C code that used the Guile 1.8 signature (2 required,
+  if (scm_ilength (extensions) < 0)
-         1 optional arg) and passed '() or nothing as the EXTENSIONS
+    scm_misc_error ("%search-path", "bad extensions list: ~a",
-	 argument.  */
+                    scm_list_1 (extensions));
-      extensions = SCM_EOL;
-      require_exts = SCM_UNDEFINED;
-    }
-  else
-    {
-      if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
-	{
-	  /* Called by Scheme code written for 1.9.  */
-	  extensions = SCM_CAR (rest);
-	  if (scm_is_null (SCM_CDR (rest)))
-	    require_exts = SCM_UNDEFINED;
-	  else
-	    {
-	      require_exts = SCM_CADR (rest);
-	      if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
-		scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
-	    }
-	}
-      else
-	{
-	  /* Called by C code that uses the 1.8 signature, i.e., which
-	     expects the 3rd argument to be EXTENSIONS.  */
-	  extensions = rest;
-	  require_exts = SCM_UNDEFINED;
-	}
-    }
-
-  if (SCM_UNBNDP (extensions))
-    extensions = SCM_EOL;
-
-  SCM_VALIDATE_LIST (3, extensions);
-
-  if (SCM_UNBNDP (require_exts))
-    require_exts = SCM_BOOL_F;
 
   scm_dynwind_begin (0);
 
@@ -576,7 +534,6 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
       for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts))
 	{
 	  SCM ext = SCM_CAR (exts);
-	  struct stat mode;
 	  
 	  buf.ptr = buf.buf + sans_ext_len;
 	  stringbuf_cat_locale_string (&buf, ext);
@@ -584,8 +541,8 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
 	  /* If the file exists at all, we should return it.  If the
 	     file is inaccessible, then that's an error.  */
 
-	  if (stat (buf.buf, &mode) == 0
+	  if (stat (buf.buf, stat_buf) == 0
-	      && ! (mode.st_mode & S_IFDIR))
+	      && ! (stat_buf->st_mode & S_IFDIR))
 	    {
 	      result = scm_from_locale_string (buf.buf);
 	      goto end;
@@ -603,6 +560,62 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
   scm_dynwind_end ();
   return result;
 }
+
+SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
+            (SCM path, SCM filename, SCM rest),
+	    "Search @var{path} for a directory containing a file named\n"
+	    "@var{filename}. The file must be readable, and not a directory.\n"
+	    "If we find one, return its full filename; otherwise, return\n"
+	    "@code{#f}.  If @var{filename} is absolute, return it unchanged.\n"
+	    "If given, @var{extensions} is a list of strings; for each\n"
+	    "directory in @var{path}, we search for @var{filename}\n"
+	    "concatenated with each @var{extension}.")
+#define FUNC_NAME s_scm_search_path
+{
+  SCM extensions, require_exts;
+  struct stat stat_buf;
+
+  if (SCM_UNBNDP (rest) || scm_is_null (rest))
+    {
+      /* Called either by Scheme code that didn't provide the optional
+         arguments, or C code that used the Guile 1.8 signature (2 required,
+         1 optional arg) and passed '() or nothing as the EXTENSIONS
+	 argument.  */
+      extensions = SCM_EOL;
+      require_exts = SCM_UNDEFINED;
+    }
+  else
+    {
+      if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
+	{
+	  /* Called by Scheme code written for 1.9.  */
+	  extensions = SCM_CAR (rest);
+	  if (scm_is_null (SCM_CDR (rest)))
+	    require_exts = SCM_UNDEFINED;
+	  else
+	    {
+	      require_exts = SCM_CADR (rest);
+	      if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
+		scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
+	    }
+	}
+      else
+	{
+	  /* Called by C code that uses the 1.8 signature, i.e., which
+	     expects the 3rd argument to be EXTENSIONS.  */
+	  extensions = rest;
+	  require_exts = SCM_UNDEFINED;
+	}
+    }
+
+  if (SCM_UNBNDP (extensions))
+    extensions = SCM_EOL;
+
+  if (SCM_UNBNDP (require_exts))
+    require_exts = SCM_BOOL_F;
+
+  return search_path (path, filename, extensions, require_exts, &stat_buf);
+}
 #undef FUNC_NAME
 
 
@@ -621,60 +634,41 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
 	    "will try each extension automatically.")
 #define FUNC_NAME s_scm_sys_search_load_path
 {
-  SCM path = *scm_loc_load_path;
+  struct stat stat_buf;
-  SCM exts = *scm_loc_load_extensions;
+  
   SCM_VALIDATE_STRING (1, filename);
 
-  if (scm_ilength (path) < 0)
+  return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions,
-    SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
+                      SCM_BOOL_F, &stat_buf);
-  if (scm_ilength (exts) < 0)
-    SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
-  return scm_search_path (path, filename, exts);
 }
 #undef FUNC_NAME
 
 
 /* Return true if COMPILED_FILENAME is newer than source file
-   FULL_FILENAME, false otherwise.  Also return false if one of the
+   FULL_FILENAME, false otherwise.  */
-   files cannot be stat'd.  */
 static int
-compiled_is_fresh (SCM full_filename, SCM compiled_filename)
+compiled_is_fresh (SCM full_filename, SCM compiled_filename,
+                   struct stat *stat_source, struct stat *stat_compiled)
 {
-  char *source, *compiled;
-  struct stat stat_source, stat_compiled;
   int compiled_is_newer;
+  struct timespec source_mtime, compiled_mtime;
 
-  source = scm_to_locale_string (full_filename);
+  source_mtime = get_stat_mtime (stat_source);
-  compiled = scm_to_locale_string (compiled_filename);
+  compiled_mtime = get_stat_mtime (stat_compiled);
 
-  if (stat (source, &stat_source) == 0
+  if (source_mtime.tv_sec < compiled_mtime.tv_sec
-      && stat (compiled, &stat_compiled) == 0)
+      || (source_mtime.tv_sec == compiled_mtime.tv_sec
-    {
+          && source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
-      struct timespec source_mtime, compiled_mtime;
+    compiled_is_newer = 1;
-
-      source_mtime = get_stat_mtime (&stat_source);
-      compiled_mtime = get_stat_mtime (&stat_compiled);
-
-      if (source_mtime.tv_sec < compiled_mtime.tv_sec
-	  || (source_mtime.tv_sec == compiled_mtime.tv_sec
-	      && source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
-	compiled_is_newer = 1;
-      else
-	{
-	  compiled_is_newer = 0;
-	  scm_puts (";;; note: source file ", scm_current_error_port ());
-	  scm_puts (source, scm_current_error_port ());
-	  scm_puts ("\n;;;       newer than compiled ", scm_current_error_port ());
-	  scm_puts (compiled, scm_current_error_port ());
-	  scm_puts ("\n", scm_current_error_port ());
-	}
-    }
   else
-    /* At least one of the files isn't accessible.  */
+    {
-    compiled_is_newer = 0;
+      compiled_is_newer = 0;
-
+      scm_puts (";;; note: source file ", scm_current_error_port ());
-  free (source);
+      scm_display (full_filename, scm_current_error_port ());
-  free (compiled);
+      scm_puts ("\n;;;       newer than compiled ", scm_current_error_port ());
+      scm_display (compiled_filename, scm_current_error_port ());
+      scm_puts ("\n", scm_current_error_port ());
+    }
 
   return compiled_is_newer;
 }
@@ -798,9 +792,13 @@ scm_try_auto_compile (SCM source)
 
 /* See also (system base compile):compiled-file-name. */
 static SCM
-canonical_to_suffix (SCM canon)
+canonical_suffix (SCM fname)
 {
-  size_t len = scm_c_string_length (canon);
+  SCM canon;
+  size_t len;
+
+  canon = scm_canonicalize_path (fname);
+  len = scm_c_string_length (canon);
   
   if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
     return canon;
@@ -826,6 +824,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
   SCM full_filename, compiled_filename;
   int compiled_is_fallback = 0;
   SCM hook = *scm_loc_load_hook;
+  struct stat stat_source, stat_compiled;
 
   if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
     SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@@ -857,15 +856,14 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
   if (SCM_UNBNDP (exception_on_not_found))
     exception_on_not_found = SCM_BOOL_T;
 
-  full_filename = scm_sys_search_load_path (filename);
+  full_filename = search_path (*scm_loc_load_path, filename,
-  if (scm_is_string (full_filename))
+                               *scm_loc_load_extensions, SCM_BOOL_F,
-    full_filename = scm_canonicalize_path (full_filename);
+                               &stat_source);
 
   compiled_filename =
-    scm_search_path (*scm_loc_load_compiled_path,
+    search_path (*scm_loc_load_compiled_path, filename,
-		     filename,
+                 *scm_loc_load_compiled_extensions, SCM_BOOL_T,
-		     scm_list_2 (*scm_loc_load_compiled_extensions,
+                 &stat_compiled);
-				 SCM_BOOL_T));
 
   if (scm_is_false (compiled_filename)
       && scm_is_true (full_filename)
@@ -874,15 +872,21 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       && scm_is_pair (*scm_loc_load_compiled_extensions)
       && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
     {
-      SCM fallback = scm_string_append
+      SCM fallback;
+      char *fallback_chars;
+
+      fallback = scm_string_append
         (scm_list_3 (*scm_loc_compile_fallback_path,
-                     canonical_to_suffix (full_filename),
+                     canonical_suffix (full_filename),
                      scm_car (*scm_loc_load_compiled_extensions)));
-      if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
+
+      fallback_chars = scm_to_locale_string (fallback);
+      if (stat (fallback_chars, &stat_compiled) == 0)
         {
           compiled_filename = fallback;
           compiled_is_fallback = 1;
         }
+      free (fallback_chars);
     }
   
   if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
@@ -900,7 +904,8 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
 
   if (scm_is_false (full_filename)
       || (scm_is_true (compiled_filename)
-          && compiled_is_fresh (full_filename, compiled_filename)))
+          && compiled_is_fresh (full_filename, compiled_filename,
+                                &stat_source, &stat_compiled)))
     return scm_load_compiled_with_vm (compiled_filename);
 
   /* Perhaps there was the installed .go that was stale, but our fallback is
@@ -912,12 +917,21 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       && scm_is_pair (*scm_loc_load_compiled_extensions)
       && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
     {
-      SCM fallback = scm_string_append
+      SCM fallback;
+      char *fallback_chars;
+      int stat_ret;
+      
+      fallback = scm_string_append
         (scm_list_3 (*scm_loc_compile_fallback_path,
-                     canonical_to_suffix (full_filename),
+                     canonical_suffix (full_filename),
                      scm_car (*scm_loc_load_compiled_extensions)));
-      if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
+
-          && compiled_is_fresh (full_filename, fallback))
+      fallback_chars = scm_to_locale_string (fallback);
+      stat_ret = stat (fallback_chars, &stat_compiled);
+      free (fallback_chars);
+
+      if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
+                                              &stat_source, &stat_compiled))
         {
           scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
           scm_display (fallback, scm_current_error_port ());
@@ -948,15 +962,18 @@ void
 scm_init_eval_in_scheme (void)
 {
   SCM eval_scm, eval_go;
-  eval_scm = scm_search_path (*scm_loc_load_path,
+  struct stat stat_source, stat_compiled;
-                              scm_from_locale_string ("ice-9/eval.scm"),
+
-                              SCM_EOL);
+  eval_scm = search_path (*scm_loc_load_path,
-  eval_go = scm_search_path (*scm_loc_load_compiled_path,
+                          scm_from_locale_string ("ice-9/eval.scm"),
-                             scm_from_locale_string ("ice-9/eval.go"),
+                          SCM_EOL, SCM_BOOL_F, &stat_source);
-                             SCM_EOL);
+  eval_go = search_path (*scm_loc_load_compiled_path,
+                         scm_from_locale_string ("ice-9/eval.go"),
+                         SCM_EOL, SCM_BOOL_F, &stat_compiled);
   
   if (scm_is_true (eval_scm) && scm_is_true (eval_go)
-      && compiled_is_fresh (eval_scm, eval_go))
+      && compiled_is_fresh (eval_scm, eval_go,
+                            &stat_source, &stat_compiled))
     scm_load_compiled_with_vm (eval_go);
   else
     /* if we have no eval.go, we shouldn't load any compiled code at all */

libguile/numbers.c

@@ -1499,8 +1499,6 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
 		  if (SCM_LIKELY (xx >= 0))
 		    xx1 = xx + yy - 1;
 		}
-	      else if (SCM_UNLIKELY (yy == 0))
-		scm_num_overflow (s_scm_ceiling_quotient);
 	      else if (xx < 0)
 		xx1 = xx + yy + 1;
 	      qq = xx1 / yy;

libguile/objcodes.c

@@ -314,8 +314,8 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
 
   len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 
-  return scm_c_take_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
+  return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
-                                len, objcode);
+                                   len, objcode);
 }
 #undef FUNC_NAME
 

libguile/posix.c

@@ -1338,10 +1338,20 @@ SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0,
 #define FUNC_NAME s_scm_tmpfile
 {
   FILE *rv;
+  int fd;
 
   if (! (rv = tmpfile ()))
     SCM_SYSERROR;
-  return scm_fdes_to_port (fileno (rv), "w+", SCM_BOOL_F);
+
+#ifndef __MINGW32__
+  fd = dup (fileno (rv));
+  fclose (rv);
+#else
+  fd = fileno (rv);
+  /* FIXME: leaking the file, it will never be closed! */
+#endif
+
+  return scm_fdes_to_port (fd, "w+", SCM_BOOL_F);
 }
 #undef FUNC_NAME
 

libguile/r6rs-ports.c

@@ -618,8 +618,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 	  c_len = (unsigned) c_total;
 	}
 
-      result = scm_c_take_bytevector ((signed char *) c_bv, c_len,
+      result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
-                                      SCM_BOOL_F);
+                                         SCM_BOOL_F);
     }
 
   return result;
@@ -678,8 +678,8 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
 	  c_len = (unsigned) c_total;
 	}
 
-      result = scm_c_take_bytevector ((signed char *) c_bv, c_len,
+      result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
-                                      SCM_BOOL_F);
+                                         SCM_BOOL_F);
     }
 
   return result;
@@ -921,7 +921,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
   bop_buffer_init (buf);
 
   if (result_buf.len == 0)
-    bv = scm_c_take_bytevector (NULL, 0, SCM_BOOL_F);
+    bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F);
   else
     {
       if (result_buf.total_len > result_buf.len)
@@ -931,8 +931,8 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
 					    result_buf.len,
 					    SCM_GC_BOP);
 
-      bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
+      bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
-                                  result_buf.len, SCM_BOOL_F);
+                                     result_buf.len, SCM_BOOL_F);
     }
 
   return bv;

libguile/read.c

@@ -408,7 +408,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
       /* See above note about scm_sym_dot.  */
       if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
 	{
-	  SCM_SETCDR (tl, tmp = scm_read_expression (port));
+	  SCM_SETCDR (tl, scm_read_expression (port));
 
 	  c = flush_ws (port, FUNC_NAME);
 	  if (terminating_char != c)

libguile/script.c

@@ -317,6 +317,7 @@ scm_get_meta_args (int argc, char **argv)
 	    switch (getc (f))
 	      {
 	      case EOF:
+                free (nargv);
 		return 0L;
 	      default:
 		continue;
@@ -324,6 +325,7 @@ scm_get_meta_args (int argc, char **argv)
 		goto found_args;
 	      }
 	found_args:
+          /* FIXME: we leak the result of calling script_read_arg.  */
 	  while ((narg = script_read_arg (f)))
 	    if (!(nargv = (char **) realloc (nargv,
 					     (1 + ++nargc) * sizeof (char *))))

libguile/srfi-1.c

@@ -568,28 +568,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
-            (SCM lst, SCM n),
-	    "Return a new list containing all except the last @var{n}\n"
-	    "elements of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_drop_right
-{
-  SCM tail = scm_list_tail (lst, n);
-  SCM ret = SCM_EOL;
-  SCM *rend = &ret;
-  while (scm_is_pair (tail))
-    {
-      *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
-      rend = SCM_CDRLOC (*rend);
-      
-      lst = SCM_CDR (lst);
-      tail = SCM_CDR (tail);
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
-  return ret;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
             (SCM pred, SCM lst),
 	    "Return the first element of @var{lst} which satisfies the\n"
@@ -924,23 +902,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
-            (SCM lst, SCM n),
-	    "Return a list containing the @var{n} last elements of\n"
-	    "@var{lst}.")
-#define FUNC_NAME s_scm_srfi1_take_right
-{
-  SCM tail = scm_list_tail (lst, n);
-  while (scm_is_pair (tail))
-    {
-      lst = SCM_CDR (lst);
-      tail = SCM_CDR (tail);
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
-  return lst;
-}
-#undef FUNC_NAME
-
 
 void
 scm_register_srfi_1 (void)

libguile/srfi-1.h

@@ -33,7 +33,6 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_drop_right (SCM lst, SCM n);
 SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst);
 SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
 SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
@@ -44,7 +43,6 @@ SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n);
 
 SCM_INTERNAL void scm_register_srfi_1 (void);
 SCM_INTERNAL void scm_init_srfi_1 (void);

libguile/stacks.c

@@ -184,11 +184,10 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
   else
     {
       /* Cut specified number of frames. */
-      for (; outer && len ; --outer)
+      if (outer < len)
-        {
+        len -= outer;
-          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+      else
-          len--;
+        len = 0;
-        }
     }
 
   SCM_SET_STACK_LENGTH (stack, len);

libguile/strings.c

@@ -1489,7 +1489,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
 
       buf = scm_gc_malloc_pointerless (len, "bytevector");
       memcpy (buf, str, len);
-      bv = scm_c_take_bytevector (buf, len, SCM_BOOL_F);
+      bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F);
 
       scm_decoding_error (__func__, errno,
 			  "input locale conversion error", bv);

libguile/vm.c

@@ -384,14 +384,15 @@ really_make_boot_program (long nargs)
 
   text[1] = (scm_t_uint8)nargs;
 
-  bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
+  bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
+                                  "boot-program");
   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
   bp->len = sizeof(text);
   bp->metalen = 0;
 
-  u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
+  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
-                                 sizeof (struct scm_objcode) + sizeof (text),
+                                    sizeof (struct scm_objcode) + sizeof (text),
-                                 SCM_BOOL_F);
+                                    SCM_BOOL_F);
   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
                           SCM_BOOL_F, SCM_BOOL_F);
   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);

module/ice-9/boot-9.scm

@@ -2629,10 +2629,6 @@ VALUE."
               (error "expected list of integers for version"))
           (set-module-version! module version)
           (set-module-version! (module-public-interface module) version)))
-    (if (pair? duplicates)
-        (let ((handlers (lookup-duplicates-handlers duplicates)))
-          (set-module-duplicates-handlers! module handlers)))
-
     (let ((imports (resolve-imports imports)))
       (call-with-deferred-observers
        (lambda ()
@@ -2652,7 +2648,12 @@ VALUE."
              (error "expected re-exports to be a list of symbols or symbol pairs"))
          ;; FIXME
          (if (not (null? autoloads))
-             (apply module-autoload! module autoloads)))))
+             (apply module-autoload! module autoloads))
+         ;; Wait until modules have been loaded to resolve duplicates
+         ;; handlers.
+         (if (pair? duplicates)
+             (let ((handlers (lookup-duplicates-handlers duplicates)))
+               (set-module-duplicates-handlers! module handlers))))))
 
     (if transformer
         (if (and (pair? transformer) (list-of symbol? transformer))
@@ -3692,13 +3693,15 @@ module '(ice-9 q) '(make-q q-length))}."
                      ((args ...) (generate-temporaries #'(formals ...))))
          #`(begin
              (define (proc-name formals ...)
-               body ...)
+               (fluid-let-syntax ((name (identifier-syntax proc-name)))
+                 body ...))
              (define-syntax name
                (lambda (x)
                  (syntax-case x ()
                    ((_ args ...)
-                    #'((lambda (formals ...)
+                    #'((fluid-let-syntax ((name (identifier-syntax proc-name)))
-                         body ...)
+                         (lambda (formals ...)
+                           body ...))
                        args ...))
                    (_
                     (identifier? x)

module/language/tree-il.scm

@@ -408,7 +408,7 @@
          (case (car alt-expansion)
            ((lambda)
             `(case-lambda (,formals ,(tree-il->scheme body))
-                          ,@(cdr alt-expansion)))
+                          ,(cdr alt-expansion)))
            ((lambda*)
             `(case-lambda* (,formals ,(tree-il->scheme body))
                            ,(cdr alt-expansion)))

module/rnrs/base.scm

@@ -73,7 +73,7 @@
 	  let-syntax letrec-syntax
 
 	  syntax-rules identifier-syntax)
-  (import (rename (except (guile) error raise)
+  (import (rename (except (guile) error raise map)
                   (log log-internal)
                   (euclidean-quotient div)
                   (euclidean-remainder mod)
@@ -86,6 +86,76 @@
                   (inexact->exact exact))
           (srfi srfi-11))
 
+ (define map
+   (case-lambda
+     ((f l)
+      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+        (if (pair? hare)
+            (if move?
+                (if (eq? tortoise hare)
+                    (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                               (list l) #f)
+                    (map1 (cdr hare) (cdr tortoise) #f
+                          (cons (f (car hare)) out)))
+                (map1 (cdr hare) tortoise #t
+                      (cons (f (car hare)) out)))
+            (if (null? hare)
+                (reverse out)
+                (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                           (list l) #f)))))
+    
+     ((f l1 l2)
+      (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
+        (cond
+         ((pair? h1)
+          (cond
+           ((not (pair? h2))
+            (scm-error 'wrong-type-arg "map"
+                       (if (list? h2)
+                           "List of wrong length: ~S"
+                           "Not a list: ~S")
+                       (list l2) #f))
+           ((not move?)
+            (map2 (cdr h1) (cdr h2) t1 t2 #t
+                  (cons (f (car h1) (car h2)) out)))
+           ((eq? t1 h1)
+            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                       (list l1) #f))
+           ((eq? t2 h2)
+            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                       (list l2) #f))
+           (else
+            (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
+                  (cons (f (car h1) (car h2)) out)))))
+
+         ((and (null? h1) (null? h2))
+          (reverse out))
+        
+         ((null? h1)
+          (scm-error 'wrong-type-arg "map"
+                     (if (list? h2)
+                         "List of wrong length: ~S"
+                         "Not a list: ~S")
+                     (list l2) #f))
+         (else
+          (scm-error 'wrong-type-arg "map"
+                     "Not a list: ~S"
+                     (list l1) #f)))))
+
+     ((f l1 . rest)
+      (let ((len (length l1)))
+        (let mapn ((rest rest))
+          (or (null? rest)
+              (if (= (length (car rest)) len)
+                  (mapn (cdr rest))
+                  (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                             (list (car rest)) #f)))))
+      (let mapn ((l1 l1) (rest rest) (out '()))
+        (if (null? l1)
+            (reverse out)
+            (mapn (cdr l1) (map cdr rest)
+                  (cons (apply f (car l1) (map car rest)) out)))))))
+
  (define log
    (case-lambda
      ((n)

module/scripts/help.scm

@@ -29,9 +29,14 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 documentation)
   #:use-module ((srfi srfi-1) #:select (fold append-map))
-  #:export (main))
+  #:export (show-help show-summary show-usage main))
 
 (define %summary "Show a brief help message.")
+(define %synopsis "help\nhelp --all\nhelp COMMAND")
+(define %help "
+Show help on guild commands.  With --all, show arcane incantations as
+well.  With COMMAND, show more detailed help for a particular command.
+")
 
 
 (define (directory-files dir)
@@ -117,32 +122,67 @@ For complete documentation, run: info guile 'Using Guile Tools'
   (file-commentary
    (%search-load-path (module-filename mod))))
 
+(define (module-command-name mod)
+  (symbol->string (car (last-pair (module-name mod)))))
+
+(define* (show-usage mod #:optional (port (current-output-port)))
+  (let ((usages (string-split
+                 (let ((var (module-variable mod '%synopsis)))
+                   (if var
+                       (variable-ref var)
+                       (string-append (module-command-name mod)
+                                      " OPTION...")))
+                 #\newline)))
+    (display "Usage: guild " port)
+    (display (car usages))
+    (newline port)
+    (for-each (lambda (u)
+                (display "       guild " port)
+                (display u port)
+                (newline port))
+              (cdr usages))))
+
+(define* (show-summary mod #:optional (port (current-output-port)))
+  (let ((var (module-variable mod '%summary)))
+    (if var
+        (begin
+          (display (variable-ref var) port)
+          (newline port)))))
+
+(define* (show-help mod #:optional (port (current-output-port)))
+  (show-usage mod port)
+  (show-summary mod port)
+  (cond
+   ((module-variable mod '%help)
+    => (lambda (var)
+         (display (variable-ref var) port)
+         (newline port)))
+   ((module-commentary mod)
+    => (lambda (commentary)
+         (newline port)
+         (display commentary port)))
+   (else
+    (format #t "No documentation found for command \"~a\".\n"
+            (module-command-name mod)))))
+
+(define %mod (current-module))
 (define (main . args)
   (cond
    ((null? args)
     (list-commands #f))
    ((or (equal? args '("--all")) (equal? args '("-a")))
     (list-commands #t))
-   ((not (string-prefix? "-" (car args)))
+   ((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
     ;; help for particular command
-    (let* ((name (car args))
+    (let ((name (car args)))
-           (mod (resolve-module `(scripts ,(string->symbol name))
+      (cond
-                                #:ensure #f)))
+       ((resolve-module `(scripts ,(string->symbol name)) #:ensure #f)
-      (if mod
+        => (lambda (mod)
-          (let ((commentary (module-commentary mod)))
+             (show-help mod)
-            (if commentary
+             (exit 0)))
-                (display commentary)
+       (else
-                (format #t "No documentation found for command \"~a\".\n"
+        (format #t "No command named \"~a\".\n" name)
-                        name)))
+        (exit 1)))))
-          (begin
-            (format #t "No command named \"~a\".\n" name)
-            (exit 1)))))
    (else
-    (display "Usage: guild help
+    (show-help %mod (current-error-port))
-       guild help --all
-       guild help COMMAND
-
-Show a help on guild commands.  With --all, show arcane incantations as
-well.  With COMMAND, show more detailed help for a particular command.
-")
     (exit 1))))

module/srfi/srfi-1.scm

@@ -236,12 +236,15 @@
 higher-order procedures."
   (cons a d))
 
-;; internal helper, similar to (scsh utilities) check-arg.
+(define (wrong-type-arg caller arg)
-(define (check-arg-type pred arg caller)
+  (scm-error 'wrong-type-arg (symbol->string caller)
-  (if (pred arg)
+             "Wrong type argument: ~S" (list arg) '()))
-      arg
+
-      (scm-error 'wrong-type-arg caller
+(define-syntax check-arg
-		 "Wrong type argument: ~S" (list arg) '())))
+  (syntax-rules ()
+    ((_ pred arg caller)
+     (if (not (pred arg))
+         (wrong-type-arg 'caller arg)))))
 
 (define (out-of-range proc arg)
   (scm-error 'out-of-range proc
@@ -254,7 +257,7 @@ higher-order procedures."
   "Return an N-element list, where each list element is produced by applying the
 procedure INIT-PROC to the corresponding list index.  The order in which
 INIT-PROC is applied to the indices is not specified."
-  (check-arg-type non-negative-integer? n "list-tabulate")
+  (check-arg non-negative-integer? n list-tabulate)
   (let lp ((n n) (acc '()))
     (if (<= n 0)
         acc
@@ -266,7 +269,7 @@ INIT-PROC is applied to the indices is not specified."
   elts)
 
 (define* (iota count #:optional (start 0) (step 1))
-  (check-arg-type non-negative-integer? count "iota")
+  (check-arg non-negative-integer? count iota)
   (let lp ((n 0) (acc '()))
     (if (= n count)
 	(reverse! acc)
@@ -334,6 +337,8 @@ end-of-list checking in contexts where dotted lists are allowed."
 	    (else
 	     (and (elt= (car a) (car b))
 		  (lp (cdr a) (cdr b)))))))
+
+  (check-arg procedure? elt= list=)
   (or (null? rest)
       (let lp ((lists rest))
 	(or (null? (cdr lists))
@@ -360,6 +365,22 @@ end-of-list checking in contexts where dotted lists are allowed."
 (define take list-head)
 (define drop list-tail)
 
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.  Note that they diverge for circular lists.
+
+(define (take-right lis k)
+  (let lp ((lag lis)  (lead (drop lis k)))
+    (if (pair? lead)
+	(lp (cdr lag) (cdr lead))
+	lag)))
+
+(define (drop-right lis k)
+  (let recur ((lag lis) (lead (drop lis k)))
+    (if (pair? lead)
+	(cons (car lag) (recur (cdr lag) (cdr lead)))
+	'())))
+
 (define (take! lst i)
   "Linear-update variant of `take'."
   (if (= i 0)
@@ -438,6 +459,7 @@ a list of those after."
 (define (fold kons knil list1 . rest)
   "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
 that result.  See the manual for details."
+  (check-arg procedure? kons fold)
   (if (null? rest)
       (let f ((knil knil) (list1 list1))
 	(if (null? list1)
@@ -451,6 +473,7 @@ that result.  See the manual for details."
 	      (f (apply kons (append! cars (list knil))) cdrs))))))
 
 (define (fold-right kons knil clist1 . rest)
+  (check-arg procedure? kons fold-right)
   (if (null? rest)
       (let loop ((lst    (reverse clist1))
                  (result knil))
@@ -466,6 +489,7 @@ that result.  See the manual for details."
                   (apply kons (append! (map car lists) (list result))))))))
 
 (define (pair-fold kons knil clist1 . rest)
+  (check-arg procedure? kons pair-fold)
   (if (null? rest)
       (let f ((knil knil) (list1 clist1))
 	(if (null? list1)
@@ -480,6 +504,7 @@ that result.  See the manual for details."
 
 
 (define (pair-fold-right kons knil clist1 . rest)
+  (check-arg procedure? kons pair-fold-right)
   (if (null? rest)
     (let f ((list1 clist1))
       (if (null? list1)
@@ -499,6 +524,10 @@ that result.  See the manual for details."
           (loop (cdr lst)
                 (cons (car lst) result)))))
 
+  (check-arg procedure? p unfold)
+  (check-arg procedure? f unfold)
+  (check-arg procedure? g unfold)
+  (check-arg procedure? tail-gen unfold)
   (let loop ((seed   seed)
              (result '()))
     (if (p seed)
@@ -507,6 +536,9 @@ that result.  See the manual for details."
               (cons (f seed) result)))))
 
 (define* (unfold-right p f g seed #:optional (tail '()))
+  (check-arg procedure? p unfold-right)
+  (check-arg procedure? f unfold-right)
+  (check-arg procedure? g unfold-right)
   (let uf ((seed seed) (lis tail))
     (if (p seed)
         lis
@@ -517,6 +549,7 @@ that result.  See the manual for details."
 elements from LST, rather than one element and a given initial value.
 If LST is empty, RIDENTITY is returned.  If LST has just one element
 then that's the return value."
+  (check-arg procedure? f reduce)
   (if (null? lst)
       ridentity
       (fold f (car lst) (cdr lst))))
@@ -526,6 +559,7 @@ then that's the return value."
 F is on two elements from LST, rather than one element and a given
 initial value.  If LST is empty, RIDENTITY is returned.  If LST
 has just one element then that's the return value."
+  (check-arg procedure? f reduce)
   (if (null? lst)
       ridentity
       (fold-right f (last lst) (drop-right lst 1))))
@@ -533,6 +567,7 @@ has just one element then that's the return value."
 (define map
   (case-lambda
     ((f l)
+     (check-arg procedure? f map)
      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
        (if (pair? hare)
            (if move?
@@ -549,6 +584,7 @@ has just one element then that's the return value."
                           (list l) #f)))))
     
     ((f l1 . rest)
+     (check-arg procedure? f map)
      (let ((len (fold (lambda (ls len)
                         (let ((ls-len (length+ ls)))
                           (if len
@@ -571,6 +607,7 @@ has just one element then that's the return value."
 (define for-each
   (case-lambda
     ((f l)
+     (check-arg procedure? f for-each)
      (let for-each1 ((hare l) (tortoise l) (move? #f))
        (if (pair? hare)
            (if move?
@@ -589,6 +626,7 @@ has just one element then that's the return value."
                           (list l) #f)))))
     
     ((f l1 . rest)
+     (check-arg procedure? f for-each)
      (let ((len (fold (lambda (ls len)
                         (let ((ls-len (length+ ls)))
                           (if len
@@ -619,6 +657,7 @@ has just one element then that's the return value."
   "Apply PROC to to the elements of LIST1... and return a list of the
 results as per SRFI-1 `map', except that any #f results are omitted from
 the list returned."
+  (check-arg procedure? proc filter-map)
   (if (null? rest)
       (let lp ((l list1)
                (rl '()))
@@ -638,6 +677,7 @@ the list returned."
                   (lp (map cdr l) rl)))))))
 
 (define (pair-for-each f clist1 . rest)
+  (check-arg procedure? f pair-for-each)
   (if (null? rest)
     (let lp ((l clist1))
       (if (null? l)
@@ -658,6 +698,7 @@ the list returned."
 (define (take-while pred ls)
   "Return a new list which is the longest initial prefix of LS whose
 elements all satisfy the predicate PRED."
+  (check-arg procedure? pred take-while)
   (cond ((null? ls) '())
         ((not (pred (car ls))) '())
         (else
@@ -671,6 +712,7 @@ elements all satisfy the predicate PRED."
 
 (define (take-while! pred lst)
   "Linear-update variant of `take-while'."
+  (check-arg procedure? pred take-while!)
   (let loop ((prev #f)
              (rest lst))
     (cond ((null? rest)
@@ -687,6 +729,7 @@ elements all satisfy the predicate PRED."
 (define (drop-while pred lst)
   "Drop the longest initial prefix of LST whose elements all satisfy the
 predicate PRED."
+  (check-arg procedure? pred drop-while)
   (let loop ((lst lst))
     (cond ((null? lst)
            '())
@@ -697,6 +740,7 @@ predicate PRED."
 (define (span pred lst)
   "Return two values, the longest initial prefix of LST whose elements
 all satisfy the predicate PRED, and the remainder of LST."
+  (check-arg procedure? pred span)
   (let lp ((lst lst) (rl '()))
     (if (and (not (null? lst))
              (pred (car lst)))
@@ -705,6 +749,7 @@ all satisfy the predicate PRED, and the remainder of LST."
 
 (define (span! pred list)
   "Linear-update variant of `span'."
+  (check-arg procedure? pred span!)
   (let loop ((prev #f)
              (rest list))
     (cond ((null? rest)
@@ -721,6 +766,7 @@ all satisfy the predicate PRED, and the remainder of LST."
 (define (break pred clist)
   "Return two values, the longest initial prefix of LST whose elements
 all fail the predicate PRED, and the remainder of LST."
+  (check-arg procedure? pred break)
   (let lp ((clist clist) (rl '()))
     (if (or (null? clist)
 	    (pred (car clist)))
@@ -729,6 +775,7 @@ all fail the predicate PRED, and the remainder of LST."
 
 (define (break! pred list)
   "Linear-update variant of `break'."
+  (check-arg procedure? pred break!)
   (let loop ((l    list)
              (prev #f))
     (cond ((null? l)
@@ -743,6 +790,7 @@ all fail the predicate PRED, and the remainder of LST."
            (loop (cdr l) l)))))
 
 (define (any pred ls . lists)
+  (check-arg procedure? pred any)
   (if (null? lists)
       (any1 pred ls)
       (let lp ((lists (cons ls lists)))
@@ -763,6 +811,7 @@ all fail the predicate PRED, and the remainder of LST."
 	   (or (pred (car ls)) (lp (cdr ls)))))))
 
 (define (every pred ls . lists)
+  (check-arg procedure? pred every)
   (if (null? lists)
       (every1 pred ls)
       (let lp ((lists (cons ls lists)))
@@ -785,6 +834,7 @@ all fail the predicate PRED, and the remainder of LST."
 (define (list-index pred clist1 . rest)
   "Return the index of the first set of elements, one from each of
 CLIST1 ... CLISTN, that satisfies PRED."
+  (check-arg procedure? pred list-index)
   (if (null? rest)
     (let lp ((l clist1) (i 0))
       (if (null? l)
@@ -813,6 +863,7 @@ and those making the associations."
         (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
 
 (define* (alist-delete key alist #:optional (k= equal?))
+  (check-arg procedure? k= alist-delete)
   (let lp ((a alist) (rl '()))
     (if (null? a)
 	(reverse! rl)
@@ -827,13 +878,18 @@ and those making the associations."
 
 (define* (member x ls #:optional (= equal?))
   (cond
-   ((eq? = eq?)  (memq x ls))
+   ;; This might be performance-sensitive, so punt on the check here,
+   ;; relying on memq/memv to check that = is a procedure.
+   ((eq? = eq?) (memq x ls))
    ((eq? = eqv?) (memv x ls))
-   (else         (find-tail (lambda (y) (= x y)) ls))))
+   (else 
+    (check-arg procedure? = member)
+    (find-tail (lambda (y) (= x y)) ls))))
 
 ;;; Set operations on lists
 
 (define (lset<= = . rest)
+  (check-arg procedure? = lset<=)
   (if (null? rest)
       #t
       (let lp ((f (car rest)) (r (cdr rest)))
@@ -842,6 +898,7 @@ and those making the associations."
                  (lp (car r) (cdr r)))))))
 
 (define (lset= = . rest)
+  (check-arg procedure? = lset<=)
   (if (null? rest)
     #t
     (let lp ((f (car rest)) (r (cdr rest)))
@@ -870,7 +927,9 @@ given REST parameters."
   (define pred
     (if (or (eq? = eq?) (eq? = eqv?))
         =
-        (lambda (x y) (= y x))))
+        (begin
+          (check-arg procedure? = lset-adjoin)
+          (lambda (x y) (= y x)))))
   
   (let lp ((ans list) (rest rest))
     (if (null? rest)
@@ -885,7 +944,9 @@ given REST parameters."
   (define pred
     (if (or (eq? = eq?) (eq? = eqv?))
         =
-        (lambda (x y) (= y x))))
+        (begin
+          (check-arg procedure? = lset-union)
+          (lambda (x y) (= y x)))))
   
   (fold (lambda (lis ans)		; Compute ANS + LIS.
           (cond ((null? lis) ans)	; Don't copy any lists
@@ -901,6 +962,7 @@ given REST parameters."
         rest))
 
 (define (lset-intersection = list1 . rest)
+  (check-arg procedure? = lset-intersection)
   (let lp ((l list1) (acc '()))
     (if (null? l)
       (reverse! acc)
@@ -909,6 +971,7 @@ given REST parameters."
 	(lp (cdr l) acc)))))
 
 (define (lset-difference = list1 . rest)
+  (check-arg procedure? = lset-difference)
   (if (null? rest)
     list1
     (let lp ((l list1) (acc '()))
@@ -921,6 +984,7 @@ given REST parameters."
 ;(define (fold kons knil list1 . rest)
 
 (define (lset-xor = . rest)
+  (check-arg procedure? = lset-xor)
   (fold (lambda (lst res)
 	  (let lp ((l lst) (acc '()))
 	    (if (null? l)
@@ -937,6 +1001,7 @@ given REST parameters."
 	rest))
 
 (define (lset-diff+intersection = list1 . rest)
+  (check-arg procedure? = lset-diff+intersection)
   (let lp ((l list1) (accd '()) (acci '()))
     (if (null? l)
       (values (reverse! accd) (reverse! acci))
@@ -947,15 +1012,19 @@ given REST parameters."
 
 
 (define (lset-union! = . rest)
+  (check-arg procedure? = lset-union!)
   (apply lset-union = rest))		; XXX:optimize
 
 (define (lset-intersection! = list1 . rest)
+  (check-arg procedure? = lset-intersection!)
   (apply lset-intersection = list1 rest)) ; XXX:optimize
 
 (define (lset-xor! = . rest)
+  (check-arg procedure? = lset-xor!)
   (apply lset-xor = rest))		; XXX:optimize
 
 (define (lset-diff+intersection! = list1 . rest)
+  (check-arg procedure? = lset-diff+intersection!)
   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
 
 ;;; srfi-1.scm ends here

module/srfi/srfi-9.scm

@@ -95,6 +95,20 @@
                     (identifier? x)
                     #'proc-name))))))))))
 
+(define (default-record-printer s p)
+  (display "#<" p)
+  (display (record-type-name (record-type-descriptor s)) p)
+  (let loop ((fields (record-type-fields (record-type-descriptor s)))
+             (off 0))
+    (cond
+     ((not (null? fields))
+      (display " " p)
+      (display (car fields) p)
+      (display ": " p)
+      (write (struct-ref s off) p)
+      (loop (cdr fields) (+ 1 off)))))
+  (display ">" p))
+
 (define-syntax define-record-type
   (lambda (x)
     (define (field-identifiers field-specs)
@@ -177,16 +191,14 @@
               (indices     (field-indices (map syntax->datum fields))))
          #`(begin
              (define type-name
-               (make-vtable #,layout
+               (let ((rtd (make-struct/no-tail
-                            (lambda (obj port)
+                           record-type-vtable
-                              (format port "#<~A" 'type-name)
+                           '#,(datum->syntax #'here (make-struct-layout layout))
-                              #,@(map (lambda (field)
+                           default-record-printer
-                                        (let* ((f (syntax->datum field))
+                           'type-name
-                                               (i (assoc-ref indices f)))
+                           '#,fields)))
-                                          #`(format port " ~A: ~S" '#,field
+                 (set-struct-vtable-name! rtd 'type-name)
-                                                    (struct-ref obj #,i))))
+                 rtd))
-                                      fields)
-                              (format port ">"))))
              (define-inlinable (predicate-name obj)
                (and (struct? obj)
                     (eq? (struct-vtable obj) type-name)))

module/texinfo.scm

@@ -1,6 +1,6 @@
 ;;;; (texinfo) -- parsing of texinfo into SXML
 ;;;;
-;;;; 	Copyright (C) 2009, 2010  Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
 ;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
 ;;;;    Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
 ;;;;
@@ -168,6 +168,9 @@ line, received through their attribute list, and parsed text until the
 @code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in
 @code{ENVIRON}.
 
+In addition, @code{ALIAS} can alias one command to another.  The alias
+will never be seen in parsed stexinfo.
+
 There are four @@-commands that are treated specially. @code{@@include}
 is a low-level token that will not be seen by higher-level parsers, so
 it has no content-model. @code{@@para} is the paragraph command, which
@@ -210,7 +213,6 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
     (dfn                INLINE-TEXT)
     (cite               INLINE-TEXT)
     (acro               INLINE-TEXT)
-    (url                INLINE-TEXT)
     (email              INLINE-TEXT)
     (emph               INLINE-TEXT)
     (strong             INLINE-TEXT)
@@ -230,6 +232,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
     (ref                INLINE-ARGS . (node #:opt name section info-file manual))
     (xref               INLINE-ARGS . (node #:opt name section info-file manual))
     (pxref              INLINE-ARGS . (node #:opt name section info-file manual))
+    (url                ALIAS       . uref)
     (uref               INLINE-ARGS . (url #:opt title replacement))
     (anchor             INLINE-ARGS . (name))
     (dots               INLINE-ARGS . ())
@@ -255,6 +258,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
     (dircategory        EOL-ARGS . (category))
     (top		EOL-ARGS . (title))
     (printindex		EOL-ARGS . (type))
+    (paragraphindent    EOL-ARGS . (indent))
 
     ;; EOL text commands
     (*ENVIRON-ARGS*     EOL-TEXT)
@@ -654,6 +658,8 @@ Examples:
          (type (cadr spec))
          (arg-names (cddr spec)))
     (case type
+      ((ALIAS)
+       (complete-start-command arg-names port))
       ((INLINE-TEXT)
        (assert-curr-char '(#\{) "Inline element lacks {" port)
        (values command '() type))

module/texinfo/reflection.scm

@@ -288,11 +288,16 @@
           (else (lp (cdr forms))))))
 
 (define* (module-stexi-documentation sym-name
-                                     #:optional (docs-resolver
+                                     #:optional %docs-resolver
-                                                 (lambda (name def) def)))
+                                     #:key (docs-resolver
+                                            (or %docs-resolver
+                                                (lambda (name def) def))))
   "Return documentation for the module named @var{sym-name}. The
 documentation will be formatted as @code{stexi}
  (@pxref{texinfo,texinfo})."
+  (if %docs-resolver
+      (issue-deprecation-warning
+       "module-stexi-documentation: use #:docs-resolver instead of a positional argument."))
   (let* ((commentary (and=> (module-commentary sym-name)
                             (lambda (x) (string-trim-both x #\newline))))
          (stexi (string->stexi commentary))

module/web/http.scm

@@ -33,7 +33,6 @@
   #:use-module ((srfi srfi-1) #:select (append-map! map!))
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
-  #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
   #:use-module (web uri)
   #:export (string->header
@@ -622,19 +621,179 @@ ordered alist."
      (write-key-value-list item port val-writer ";"))
    ","))
 
+(define-syntax string-match?
+  (lambda (x)
+    (syntax-case x ()
+      ((_ str pat) (string? (syntax->datum #'pat))
+       (let ((p (syntax->datum #'pat)))
+         #`(let ((s str))
+             (and
+              (= (string-length s) #,(string-length p))
+              #,@(let lp ((i 0) (tests '()))
+                   (if (< i (string-length p))
+                       (let ((c (string-ref p i)))
+                         (lp (1+ i)
+                             (case c
+                               ((#\.)   ; Whatever.
+                                tests)
+                               ((#\d)   ; Digit.
+                                (cons #`(char-numeric? (string-ref s #,i))
+                                      tests))
+                               ((#\a)   ; Alphabetic.
+                                (cons #`(char-alphabetic? (string-ref s #,i))
+                                      tests))
+                               (else    ; Literal.
+                                (cons #`(eqv? (string-ref s #,i) #,c)
+                                      tests)))))
+                       tests)))))))))
+
+;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
+;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
+
+(define (parse-month str start end)
+  (define (bad)
+    (bad-header-component 'month (substring str start end)))
+  (if (not (= (- end start) 3))
+      (bad)
+      (let ((a (string-ref str (+ start 0)))
+            (b (string-ref str (+ start 1)))
+            (c (string-ref str (+ start 2))))
+        (case a
+          ((#\J)
+           (case b
+             ((#\a) (case c ((#\n) 1) (else (bad))))
+             ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
+             (else (bad))))
+          ((#\F)
+           (case b
+             ((#\e) (case c ((#\b) 2) (else (bad))))
+             (else (bad))))
+          ((#\M)
+           (case b
+             ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
+             (else (bad))))
+          ((#\A)
+           (case b
+             ((#\p) (case c ((#\r) 4) (else (bad))))
+             ((#\u) (case c ((#\g) 8) (else (bad))))
+             (else (bad))))
+          ((#\S)
+           (case b
+             ((#\e) (case c ((#\p) 9) (else (bad))))
+             (else (bad))))
+          ((#\O)
+           (case b
+             ((#\c) (case c ((#\t) 10) (else (bad))))
+             (else (bad))))
+          ((#\N)
+           (case b
+             ((#\o) (case c ((#\v) 11) (else (bad))))
+             (else (bad))))
+          ((#\D)
+           (case b
+             ((#\e) (case c ((#\c) 12) (else (bad))))
+             (else (bad))))
+          (else (bad))))))
+
+;; RFC 822, updated by RFC 1123
+;; 
+;; Sun, 06 Nov 1994 08:49:37 GMT
+;; 01234567890123456789012345678
+;; 0         1         2
+(define (parse-rfc-822-date str)
+  ;; We could verify the day of the week but we don't.
+  (if (not (string-match? str "aaa, dd aaa dddd dd:dd:dd GMT"))
+      (bad-header 'date str))
+  (let ((date (parse-non-negative-integer str 5 7))
+        (month (parse-month str 8 11))
+        (year (parse-non-negative-integer str 12 16))
+        (hour (parse-non-negative-integer str 17 19))
+        (minute (parse-non-negative-integer str 20 22))
+        (second (parse-non-negative-integer str 23 25)))
+    (make-date 0 second minute hour date month year 0)))
+
+;; RFC 850, updated by RFC 1036
+;; Sunday, 06-Nov-94 08:49:37 GMT
+;;        0123456789012345678901
+;;        0         1         2
+(define (parse-rfc-850-date str comma)
+  ;; We could verify the day of the week but we don't.
+  (let ((tail (substring str (1+ comma))))
+    (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
+        (bad-header 'date str))
+    (let ((date (parse-non-negative-integer tail 1 3))
+          (month (parse-month tail 4 7))
+          (year (parse-non-negative-integer tail 8 10))
+          (hour (parse-non-negative-integer tail 11 13))
+          (minute (parse-non-negative-integer tail 14 16))
+          (second (parse-non-negative-integer tail 17 19)))
+      (make-date 0 second minute hour date month
+                 (let* ((now (date-year (current-date)))
+                        (then (+ now year (- (modulo now 100)))))
+                   (cond ((< (+ then 50) now) (+ then 100))
+                         ((< (+ now 50) then) (- then 100))
+                         (else then)))
+                 0))))
+
+;; ANSI C's asctime() format
+;; Sun Nov  6 08:49:37 1994
+;; 012345678901234567890123
+;; 0         1         2
+(define (parse-asctime-date str)
+  (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
+      (bad-header 'date str))
+  (let ((date (parse-non-negative-integer
+               str
+               (if (eqv? (string-ref str 8) #\space) 9 8)
+               10))
+        (month (parse-month str 4 7))
+        (year (parse-non-negative-integer str 20 24))
+        (hour (parse-non-negative-integer str 11 13))
+        (minute (parse-non-negative-integer str 14 16))
+        (second (parse-non-negative-integer str 17 19)))
+    (make-date 0 second minute hour date month year 0)))
+
 (define (parse-date str)
-  ;; Unfortunately, there is no way to make string->date parse out the
+  (if (string-suffix? " GMT" str)
-  ;; "GMT" bit, so we play string games to append a format it will
+      (let ((comma (string-index str #\,)))
-  ;; understand (the +0000 bit).
+        (cond ((not comma) (bad-header 'date str))
-  (string->date
+              ((= comma 3) (parse-rfc-822-date str))
-   (if (string-suffix? " GMT" str)
+              (else (parse-rfc-850-date str comma))))
-       (string-append (substring str 0 (- (string-length str) 4))
+      (parse-asctime-date str)))
-                      " +0000")
-       (bad-header-component 'date str))
-   "~a, ~d ~b ~Y ~H:~M:~S ~z"))
 
 (define (write-date date port)
-  (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
+  (define (display-digits n digits port)
+    (define zero (char->integer #\0))
+    (let lp ((tens (expt 10 (1- digits))))
+      (if (> tens 0)
+          (begin
+            (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
+                    port)
+            (lp (floor/ tens 10))))))
+  (let ((date (if (zero? (date-zone-offset date))
+                  date
+                  (time-tai->date (date->time-tai date) 0))))
+    (display (case (date-week-day date)
+               ((0) "Sun, ") ((2) "Mon, ") ((2) "Tue, ")
+               ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
+               ((6) "Sat, ") (else (error "bad date" date)))
+             port)
+    (display-digits (date-day date) 2 port)
+    (display (case (date-month date)
+               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Ma ")
+               ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
+               ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
+               ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
+               (else (error "bad date" date)))
+             port)
+    (display-digits (date-year date) 4 port)
+    (display #\space port)
+    (display-digits (date-hour date) 2 port)
+    (display #\: port)
+    (display-digits (date-minute date) 2 port)
+    (display #\: port)
+    (display-digits (date-second date) 2 port)
+    (display " GMT" port)))
 
 (define (write-uri uri port)
   (display (uri->string uri) port))

test-suite/tests/srfi-1.test

@@ -1,6 +1,6 @@
 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 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
@@ -902,7 +902,12 @@
   (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
   (pass-if (equal? '() (drop-right '(4 5 6) 3)))
   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
-    (drop-right '(4 5 6) 4)))
+    (drop-right '(4 5 6) 4))
+
+  (pass-if "(a b . c) 0"
+    (equal? (drop-right '(a b . c) 0) '(a b)))
+  (pass-if "(a b . c) 1"
+    (equal? (drop-right '(a b . c) 1) '(a))))
 
 ;;
 ;; drop-right!
@@ -2621,7 +2626,12 @@
   (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
   (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
-    (take-right '(4 5 6) 4)))
+    (take-right '(4 5 6) 4))
+
+  (pass-if "(a b . c) 0"
+    (equal? (take-right '(a b . c) 0) 'c))
+  (pass-if "(a b . c) 1"
+    (equal? (take-right '(a b . c) 1) '(b . c))))
 
 ;;
 ;; tenth

test-suite/tests/texinfo.test

@@ -1,6 +1,6 @@
 ;;;; texinfo.test                 -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2010  Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011  Free Software Foundation, Inc.
 ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -207,6 +207,9 @@
 
   (test-body "@code{arg}"
              '((para (code "arg"))))
+  ;; FIXME: Why no enclosing para here?  Probably a bug.
+  (test-body "@url{arg}"
+             '((uref (% (url "arg")))))
   (test-body "@code{     }"
              '((para (code))))
   (test-body "@code{ @code{}    }"

test-suite/tests/tree-il.test

@@ -55,6 +55,23 @@
              (pat (guard test ...) #t)
              (else #f))))))))
 
+(define-syntax pass-if-tree-il->scheme
+  (syntax-rules ()
+    ((_ in pat)
+     (assert-scheme->tree-il->scheme in pat #t))
+    ((_ in pat guard-exp)
+     (pass-if 'in
+       (pmatch (tree-il->scheme
+                (compile 'in #:from 'scheme #:to 'tree-il))
+         (pat (guard guard-exp) #t)
+         (_ #f))))))
+
+(with-test-prefix "tree-il->scheme"
+  (pass-if-tree-il->scheme
+   (case-lambda ((a) a) ((b c) (list b c)))
+   (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
+   (and (eq? a a1) (eq? b b1) (eq? c c1))))
+
 (with-test-prefix "void"
   (assert-tree-il->glil
    (void)