SRFI-1 in Scheme

[ludo@gnu.org (Ludovic Courtès)]

[-- Attachment #1.1: Type: text/plain, Size: 1320 bytes --]

Hello!

The attached patch is a first stab at re-implementing SRFI-1 in Scheme.

Here’s a quick benchmark of ‘fold’, for large and small lists:

  - in C

    ("srfi-1.bm: fold: fold" 30 user 5.55 benchmark 5.54999599456787 bench/interp 5.54999599456787 gc 0.0)
    ("srfi-1.bm: fold: fold" 2000000 user 4.41 benchmark 4.14297119140625 bench/interp 4.14297119140625 gc 0.0)

  - in Scheme (debug engine)

    ("srfi-1.bm: fold: fold" 30 user 6.04 benchmark 6.03999599456787 bench/interp 6.03999599456787 gc 0.0)
    ("srfi-1.bm: fold: fold" 2000000 user 5.14 benchmark 4.87297119140625 bench/interp 4.87297119140625 gc 0.0)

  - in Scheme (regular engine)

    ("srfi-1.bm: fold: fold" 30 user 5.46 benchmark 5.45999656677246 bench/interp 5.45999656677246 gc 0.0)
    ("srfi-1.bm: fold: fold" 2000000 user 4.64 benchmark 4.4111181640625 bench/interp 4.4111181640625 gc 0.0)

IOW, with the debug engine (currently the default) and for large lists
‘fold’ in Scheme is ~9% slower than in C; for small lists it’s ~17%
slower.

With the regular engine, Scheme is ~2% faster for large lists and still
~5% slower for small lists.

I’m tempted to put this in and then make the regular engine the default
unless ‘--debug’ is specified.

What do you think?

Thanks,
Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: the patch --]
[-- Type: text/x-patch, Size: 21065 bytes --]

From 927b96b48d4870c768da093741af6e6bcd438cad Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 13 Jul 2010 00:07:12 +0200
Subject: [PATCH] Start rewriting SRFI-1 in Scheme.

This partially reverts commit e556f8c3c6b74ee6596e8dcbe829109d7745da2c
(Fri May 6 2005).

* module/srfi/srfi-1.scm (xcons, list-tabulate, not-pair?, car+cdr,
  last, fold, list-index): New procedures.

* srfi/srfi-1.c (srfi1_module): New variable.
  (CACHE_VAR): New macro.
  (scm_srfi1_car_plus_cdr, scm_srfi1_fold, scm_srfi1_last,
  scm_srfi1_list_index, scm_srfi1_list_tabulate, scm_srfi1_not_pair_p,
  scm_srfi1_xcons): Rewrite as proxies of the corresponding Scheme
  procedure.

* test-suite/tests/srfi-1.test ("list-tabulate")["-1"]: Change exception
  type to `exception:wrong-type-arg'.

* benchmark-suite/benchmarks/srfi-1.bm: New file.

* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add
  `benchmarks/srfi-1.bm'.
---
 benchmark-suite/Makefile.am          |    1 +
 benchmark-suite/benchmarks/srfi-1.bm |   38 ++++
 module/srfi/srfi-1.scm               |   64 +++++++-
 srfi/srfi-1.c                        |  318 ++++++----------------------------
 test-suite/tests/srfi-1.test         |    4 +-
 5 files changed, 154 insertions(+), 271 deletions(-)
 create mode 100644 benchmark-suite/benchmarks/srfi-1.bm

diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index d99e457..b58219a 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -5,6 +5,7 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm		\
                  benchmarks/if.bm			\
                  benchmarks/logand.bm			\
 		 benchmarks/read.bm			\
+		 benchmarks/srfi-1.bm			\
 		 benchmarks/srfi-13.bm			\
 		 benchmarks/structs.bm			\
 		 benchmarks/subr.bm			\
diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchmarks/srfi-1.bm
new file mode 100644
index 0000000..2888934
--- /dev/null
+++ b/benchmark-suite/benchmarks/srfi-1.bm
@@ -0,0 +1,38 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;; SRFI-1.
+;;;
+;;; Copyright 2010 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks srfi-1)
+  #:use-module (srfi srfi-1)
+  #:use-module (benchmark-suite lib))
+
+(define %big-list
+  (iota 1000000))
+
+(define %small-list
+  (iota 10))
+
+\f
+(with-benchmark-prefix "fold"
+
+  (benchmark "fold" 30
+    (fold (lambda (x y) y) #f %big-list))
+
+  (benchmark "fold" 2000000
+    (fold (lambda (x y) y) #f %small-list)))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c32eb1c..27aa39e 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
 ;;; srfi-1.scm --- List Library
 
-;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 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
@@ -225,6 +225,11 @@
 
 ;;; Constructors
 
+(define (xcons d a)
+  "Like `cons', but with interchanged arguments.  Useful mostly when passed to
+higher-order procedures."
+  (cons a d))
+
 ;; internal helper, similar to (scsh utilities) check-arg.
 (define (check-arg-type pred arg caller)
   (if (pred arg)
@@ -235,7 +240,15 @@
 ;; the srfi spec doesn't seem to forbid inexact integers.
 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 
-
+(define (list-tabulate n init-proc)
+  "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")
+  (let lp ((n n) (acc '()))
+    (if (<= n 0)
+        acc
+        (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 
 (define (circular-list elt1 . elts)
   (set! elts (cons elt1 elts))
@@ -294,6 +307,13 @@
     (else
      (error "not a proper list in null-list?"))))
 
+(define (not-pair? x)
+  "Return #t if X is not a pair, #f otherwise.
+
+This is shorthand notation `(not (pair? X))' and is supposed to be used for
+end-of-list checking in contexts where dotted lists are allowed."
+  (not (pair? x)))
+
 (define (list= elt= . rest)
   (define (lists-equal a b)
     (let lp ((a a) (b b))
@@ -317,9 +337,17 @@
 (define third caddr)
 (define fourth cadddr)
 
+(define (car+cdr x)
+  "Return two values, the `car' and the `cdr' of PAIR."
+  (values (car x) (cdr x)))
+
 (define take list-head)
 (define drop list-tail)
 
+(define (last pair)
+  "Return the last element of the non-empty, finite list PAIR."
+  (car (last-pair pair)))
+
 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 
 (define (zip clist1 . rest)
@@ -343,6 +371,21 @@
 
 ;;; Fold, unfold & map
 
+(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."
+  (if (null? rest)
+      (let f ((knil knil) (list1 list1))
+	(if (null? list1)
+	    knil
+	    (f (kons (car list1) knil) (cdr list1))))
+      (let f ((knil knil) (lists (cons list1 rest)))
+	(if (any null? lists)
+	    knil
+	    (let ((cars (map1 car lists))
+		  (cdrs (map1 cdr lists)))
+	      (f (apply kons (append! cars (list knil))) cdrs))))))
+
 (define (fold-right kons knil clist1 . rest)
   (if (null? rest)
     (let f ((list1 clist1))
@@ -463,6 +506,23 @@
 	  (else
 	   (and (pred (car ls)) (lp (cdr ls)))))))
 
+(define (list-index pred clist1 . rest)
+  "Return the index of the first set of elements, one from each of
+CLIST1 ... CLISTN, that satisfies PRED."
+  (if (null? rest)
+    (let lp ((l clist1) (i 0))
+      (if (null? l)
+	#f
+	(if (pred (car l))
+	  i
+	  (lp (cdr l) (+ i 1)))))
+    (let lp ((lists (cons clist1 rest)) (i 0))
+      (cond ((any1 null? lists)
+	     #f)
+	    ((apply pred (map1 car lists)) i)
+	    (else
+	     (lp (map1 cdr lists) (+ i 1)))))))
+
 ;;; Association lists
 
 (define alist-cons acons)
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 537c2b3..71cfcf9 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -27,13 +27,32 @@
 
 #include "srfi-1.h"
 
-/* The intent of this file is to gradually replace those Scheme
- * procedures in srfi-1.scm which extends core primitive procedures,
+/* The intent of this file was to gradually replace those Scheme
+ * procedures in srfi-1.scm that extend core primitive procedures,
  * so that using srfi-1 won't have performance penalties.
  *
- * Please feel free to contribute any new replacements!
+ * However, we now prefer to write these procedures in Scheme, let the compiler
+ * optimize them, and have the VM execute them efficiently.
  */
 
+
+/* The `(srfi srfi-1)' module.  */
+static SCM srfi1_module = SCM_BOOL_F;
+
+/* Cache variable NAME in C variable VAR.  */
+#define CACHE_VAR(var, name)						\
+  static SCM var = SCM_BOOL_F;						\
+  if (scm_is_false (var))						\
+    {									\
+      if (SCM_UNLIKELY (scm_is_false (srfi1_module)))			\
+	srfi1_module = scm_c_resolve_module ("srfi srfi-1");		\
+									\
+      var = scm_module_variable (srfi1_module,				\
+                                 scm_from_locale_symbol (name));	\
+      if (scm_is_false (var))						\
+        abort ();							\
+    }
+
 static long
 srfi1_ilength (SCM sx)
 {
@@ -253,16 +272,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
-            (SCM pair),
-	    "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
-#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+SCM
+scm_srfi1_car_plus_cdr (SCM pair)
 {
-  SCM_VALIDATE_CONS (SCM_ARG1, pair);
-  return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+  CACHE_VAR (car_plus_cdr, "car+cdr");
+  return scm_call_1 (car_plus_cdr, pair);
 }
-#undef FUNC_NAME
-
 
 SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
             (SCM lstlst),
@@ -935,131 +950,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
-            (SCM proc, SCM init, SCM list1, SCM rest),
-	    "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
-	    "@var{lstN} to build a result, and return that result.\n"
-	    "\n"
-	    "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
-	    "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
-	    "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
-	    "@var{previous} is the return from the previous call to\n"
-	    "@var{proc}, or the given @var{init} for the first call.  If any\n"
-	    "list is empty, just @var{init} is returned.\n"
-	    "\n"
-	    "@code{fold} works through the list elements from first to last.\n"
-	    "The following shows a list reversal and the calls it makes,\n"
-	    "\n"
-	    "@example\n"
-	    "(fold cons '() '(1 2 3))\n"
-	    "\n"
-	    "(cons 1 '())\n"
-	    "(cons 2 '(1))\n"
-	    "(cons 3 '(2 1)\n"
-	    "@result{} (3 2 1)\n"
-	    "@end example\n"
-	    "\n"
-	    "If @var{lst1} through @var{lstN} have different lengths,\n"
-	    "@code{fold} stops when the end of the shortest is reached.\n"
-	    "Ie.@: elements past the length of the shortest are ignored in\n"
-	    "the other @var{lst}s.  At least one @var{lst} must be\n"
-	    "non-circular.\n"
-	    "\n"
-	    "The way @code{fold} builds a result from iterating is quite\n"
-	    "general, it can do more than other iterations like say\n"
-	    "@code{map} or @code{filter}.  The following for example removes\n"
-	    "adjacent duplicate elements from a list,\n"
-	    "\n"
-	    "@example\n"
-	    "(define (delete-adjacent-duplicates lst)\n"
-	    "  (fold-right (lambda (elem ret)\n"
-	    "                (if (equal? elem (first ret))\n"
-	    "                    ret\n"
-	    "                    (cons elem ret)))\n"
-	    "              (list (last lst))\n"
-	    "              lst))\n"
-	    "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
-	    "@result{} (1 2 3 4 5)\n"
-	    "@end example\n"
-	    "\n"
-	    "Clearly the same sort of thing can be done with a\n"
-	    "@code{for-each} and a variable in which to build the result,\n"
-	    "but a self-contained @var{proc} can be re-used in multiple\n"
-	    "contexts, where a @code{for-each} would have to be written out\n"
-	    "each time.")
-#define FUNC_NAME s_scm_srfi1_fold
+SCM
+scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest)
 {
-  SCM lst;
-  int argnum;
-  SCM_VALIDATE_REST_ARGUMENT (rest);
-
-  if (scm_is_null (rest))
-    {
-      /* one list */
-      SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
-      for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
-        init = scm_call_2 (proc, SCM_CAR (list1), init);
-
-      /* check below that list1 is a proper list, and done */
-      lst = list1;
-      argnum = 2;
-    }
-  else
-    {
-      /* two or more lists */
-      SCM  vec, args, a;
-      size_t  len, i;
-
-      /* vec is the list arguments */
-      vec = scm_vector (scm_cons (list1, rest));
-      len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
-      /* args is the argument list to pass to proc, same length as vec,
-         re-used for each call */
-      args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
-
-      for (;;)
-        {
-          /* first elem of each list in vec into args, and step those
-             vec entries onto their next element */
-          for (i = 0, a = args, argnum = 2;
-               i < len;
-               i++, a = SCM_CDR (a), argnum++)
-            {
-              lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
-              if (! scm_is_pair (lst))
-                goto check_lst_and_done;
-              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for proc */
-              SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
-            }
-          SCM_SETCAR (a, init);
-
-          init = scm_apply (proc, args, SCM_EOL);
-        }
-    }
-
- check_lst_and_done:
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
-  return init;
+  CACHE_VAR (fold, "fold");
+  return scm_apply_3 (fold, proc, init, list1, rest);
 }
-#undef FUNC_NAME
-
 
-SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
-            (SCM lst),
-	    "Like @code{cons}, but with interchanged arguments.  Useful\n"
-	    "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_last
+SCM
+scm_srfi1_last (SCM lst)
 {
-  SCM pair = scm_last_pair (lst);
-  /* scm_last_pair returns SCM_EOL for an empty list */
-  SCM_VALIDATE_CONS (SCM_ARG1, pair);
-  return SCM_CAR (pair);
+  CACHE_VAR (last, "last");
+  return scm_call_1 (last, lst);
 }
-#undef FUNC_NAME
-
 
 SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
             (SCM lst),
@@ -1073,106 +976,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
-            (SCM pred, SCM list1, SCM rest),
-	    "Return the index of the first set of elements, one from each of\n"
-	    "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
-	    "\n"
-	    "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
-	    "elemN)}.  Searching stops when the end of the shortest\n"
-	    "@var{lst} is reached.  The return index starts from 0 for the\n"
-	    "first set of elements.  If no set of elements pass then the\n"
-	    "return is @code{#f}.\n"
-	    "\n"
-	    "@example\n"
-	    "(list-index odd? '(2 4 6 9))      @result{} 3\n"
-	    "(list-index = '(1 2 3) '(3 1 2))  @result{} #f\n"
-	    "@end example")
-#define FUNC_NAME s_scm_srfi1_list_index
+SCM
+scm_srfi1_list_index (SCM pred, SCM list1, SCM rest)
 {
-  long  n = 0;
-  SCM   lst;
-  int   argnum;
-  SCM_VALIDATE_REST_ARGUMENT (rest);
-
-  if (scm_is_null (rest))
-    {
-      /* one list */
-      SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
-      for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
-        if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1))))
-          return SCM_I_MAKINUM (n);
-
-      /* not found, check below that list1 is a proper list */
-    end_list1:
-      lst = list1;
-      argnum = 2;
-    }
-  else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
-    {
-      /* two lists */
-      SCM list2 = SCM_CAR (rest);
-      SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
-      for ( ; ; n++)
-        {
-          if (! scm_is_pair (list1))
-            goto end_list1;
-          if (! scm_is_pair (list2))
-            {
-              lst = list2;
-              argnum = 3;
-              break;
-            }
-          if (scm_is_true (scm_call_2 (pred,
-                                       SCM_CAR (list1), SCM_CAR (list2))))
-            return SCM_I_MAKINUM (n);
-
-          list1 = SCM_CDR (list1);
-          list2 = SCM_CDR (list2);
-        }
-    }
-  else
-    {
-      /* three or more lists */
-      SCM     vec, args, a;
-      size_t  len, i;
-
-      /* vec is the list arguments */
-      vec = scm_vector (scm_cons (list1, rest));
-      len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
-      /* args is the argument list to pass to pred, same length as vec,
-         re-used for each call */
-      args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
-      for ( ; ; n++)
-        {
-          /* first elem of each list in vec into args, and step those
-             vec entries onto their next element */
-          for (i = 0, a = args, argnum = 2;
-               i < len;
-               i++, a = SCM_CDR (a), argnum++)
-            {
-              lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
-              if (! scm_is_pair (lst))
-                goto not_found_check_lst;
-              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
-              SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
-            }
-
-          if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
-            return SCM_I_MAKINUM (n);
-        }
-    }
-
- not_found_check_lst:
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
-  return SCM_BOOL_F;
+  CACHE_VAR (list_index, "list-index");
+  return scm_apply_2 (list_index, pred, list1, rest);
 }
-#undef FUNC_NAME
-
 
 /* This routine differs from the core list-copy in allowing improper lists.
    Maybe the core could allow them similarly.  */
@@ -1206,25 +1015,12 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
-            (SCM n, SCM proc),
-	    "Return an @var{n}-element list, where each list element is\n"
-	    "produced by applying the procedure @var{init-proc} to the\n"
-	    "corresponding list index.  The order in which @var{init-proc}\n"
-	    "is applied to the indices is not specified.")
-#define FUNC_NAME s_scm_srfi1_list_tabulate
+SCM
+scm_srfi1_list_tabulate (SCM n, SCM proc)
 {
-  long i, nn;
-  SCM ret = SCM_EOL;
-  nn = scm_to_signed_integer (n, 0, LONG_MAX);
-  SCM_VALIDATE_PROC (SCM_ARG2, proc);
-  for (i = nn-1; i >= 0; i--)
-    ret = scm_cons (scm_call_1 (proc, scm_from_long (i)), ret);
-  return ret;
+  CACHE_VAR (list_tabulate, "list-tabulate");
+  return scm_call_2 (list_tabulate, n, proc);
 }
-#undef FUNC_NAME
-
 
 SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
             (SCM equal, SCM lst, SCM rest),
@@ -1609,21 +1405,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
-            (SCM obj),
-	    "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
-	    "otherwise.\n"
-	    "\n"
-	    "This is shorthand notation @code{(not (pair?  @var{obj}))} and\n"
-	    "is supposed to be used for end-of-list checking in contexts\n"
-	    "where dotted lists are allowed.")
-#define FUNC_NAME s_scm_srfi1_not_pair_p
+SCM
+scm_srfi1_not_pair_p (SCM obj)
 {
-  return scm_from_bool (! scm_is_pair (obj));
+  CACHE_VAR (not_pair_p, "not-pair?");
+  return scm_call_1 (not_pair_p, obj);
 }
-#undef FUNC_NAME
-
 
 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
 	    (SCM pred, SCM list),
@@ -2153,17 +1940,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
-            (SCM d, SCM a),
-	    "Like @code{cons}, but with interchanged arguments.  Useful\n"
-	    "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_xcons
+SCM
+scm_srfi1_xcons (SCM d, SCM a)
 {
-  return scm_cons (a, d);
+  CACHE_VAR (xcons, "xcons");
+  return scm_call_2 (xcons, d, a);
 }
-#undef FUNC_NAME
-
 
+\f
 void
 scm_init_srfi_1 (void)
 {
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index ecff82f..909f58c 100644
--- a/test-suite/tests/srfi-1.test
+++ b/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 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 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
@@ -1563,7 +1563,7 @@
 
 (with-test-prefix "list-tabulate"
 
-  (pass-if-exception "-1" exception:out-of-range
+  (pass-if-exception "-1" exception:wrong-type-arg
     (list-tabulate -1 identity))
   (pass-if "0"
     (equal? '() (list-tabulate 0 identity)))
-- 
1.7.0


[-- Attachment #2: Type: application/pgp-signature, Size: 197 bytes --]