srfi-1 `member' in scheme, inlines to memq / memv in some cases

* libguile/srfi-1.c:
* libguile/srfi-1.h (scm_srfi1_member): Move implementation to Scheme.

* module/srfi/srfi-1.scm (member): Implement here, with the inlining
  cases for eq? and eqv?.  Speeds up a compiled bootstrap of
  psyntax.scm, because lset-adjoin inlines to the memq case.
  (lset<=): Reindent.

  (lset-adjoin, lset-union): If the comparator is eq? or eqv?, just pass
  it through to `member', so we inline to memq / memv.  Use something
  closer to the reference implementations.

3 files changed, 53 insertions, 62 deletions

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 5c0750451..f67e60082 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -956,43 +956,6 @@ scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
-           (SCM x, SCM lst, SCM pred),
-	    "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
-	    "to @var{x}.  If @var{x} does not appear in @var{lst}, return\n"
-	    "@code{#f}.\n"
-	    "\n"
-	    "Equality is determined by @code{equal?}, or by the equality\n"
-	    "predicate @var{=} if given.  @var{=} is called @code{(= @var{x}\n"
-	    "elem)}, ie.@: with the given @var{x} first, so for example to\n"
-	    "find the first element greater than 5,\n"
-	    "\n"
-	    "@example\n"
-	    "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
-	    "@end example\n"
-	    "\n"
-	    "This version of @code{member} extends the core @code{member} by\n"
-	    "accepting an equality predicate.")
-#define FUNC_NAME s_scm_srfi1_member
-{
-  scm_t_trampoline_2 equal_p;
-  SCM_VALIDATE_LIST (2, lst);
-  if (SCM_UNBNDP (pred))
-    equal_p = equal_trampoline;
-  else
-    {
-      SCM_VALIDATE_PROC (SCM_ARG3, pred);
-      equal_p = scm_call_2;
-    }
-  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
-    {
-      if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
-	return lst;
-    }
-  return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
 	    (SCM key, SCM alist, SCM pred),
 	    "Behaves like @code{assq} but uses third argument @var{pred?}\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 593d9bb02..85aa65d0c 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -1,6 +1,6 @@
 /* srfi-1.h --- SRFI-1 procedures for Guile
  *
- * 	Copyright (C) 2002, 2003, 2005, 2006, 2010 Free Software Foundation, Inc.
+ * 	Copyright (C) 2002, 2003, 2005, 2006, 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 License
@@ -41,7 +41,6 @@ SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
 SCM_INTERNAL SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
 SCM_INTERNAL SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
-SCM_INTERNAL SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 8ddf2714b..68b62de56 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, 2010 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 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
@@ -16,6 +16,11 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
+;;; Some parts from the reference implementation, which is
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use.
+
 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 ;;; Date: 2001-06-06
 
@@ -747,15 +752,23 @@ and those making the associations."
 (define* (alist-delete! key alist #:optional (k= equal?))
   (alist-delete key alist k=))	; XXX:optimize
 
+;;; Delete / assoc / member
+
+(define* (member x ls #:optional (= equal?))
+  (cond
+   ((eq? = eq?)  (memq x ls))
+   ((eq? = eqv?) (memv x ls))
+   (else         (find-tail (lambda (y) (= x y)) ls))))
+
 ;;; Set operations on lists
 
 (define (lset<= = . rest)
   (if (null? rest)
-    #t
-    (let lp ((f (car rest)) (r (cdr rest)))
-      (or (null? r)
-	  (and (every (lambda (el) (member el (car r) =)) f)
-	       (lp (car r) (cdr r)))))))
+      #t
+      (let lp ((f (car rest)) (r (cdr rest)))
+        (or (null? r)
+            (and (every (lambda (el) (member el (car r) =)) f)
+                 (lp (car r) (cdr r)))))))
 
 (define (lset= = . rest)
   (if (null? rest)
@@ -780,25 +793,41 @@ a common tail with LIST), but the order they're added is unspecified.
 The given `=' procedure is used for comparing elements, called
 as `(@var{=} listelem elem)', i.e., the second argument is one of the
 given REST parameters."
-  (let lp ((l rest) (acc list))
-    (if (null? l)
-        acc
-        (if (member (car l) acc (lambda (x y) (= y x)))
-            (lp (cdr l) acc)
-            (lp (cdr l) (cons (car l) acc))))))
+  ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
+  ;; first, so we can pass the raw procedure through to `member',
+  ;; allowing `memq' / `memv' to be selected.
+  (define pred
+    (if (or (eq? = eq?) (eq? = eqv?))
+        =
+        (lambda (x y) (= y x))))
+  
+  (let lp ((ans list) (rest rest))
+    (if (null? rest)
+        ans
+        (lp (if (member (car rest) ans pred)
+                ans
+                (cons (car rest) ans))
+            (cdr rest)))))
 
 (define (lset-union = . rest)
-  (let ((acc '()))
-    (for-each (lambda (lst)
-		(if (null? acc)
-		    (set! acc lst)
-		    (for-each (lambda (elem)
-				(if (not (member elem acc
-						 (lambda (x y) (= y x))))
-				    (set! acc (cons elem acc))))
-			      lst)))
-	      rest)
-    acc))
+  ;; Likewise, allow memq / memv to be used if possible.
+  (define pred
+    (if (or (eq? = eq?) (eq? = eqv?))
+        =
+        (lambda (x y) (= y x))))
+  
+  (fold (lambda (lis ans)		; Compute ANS + LIS.
+          (cond ((null? lis) ans)	; Don't copy any lists
+                ((null? ans) lis) 	; if we don't have to.
+                ((eq? lis ans) ans)
+                (else
+                 (fold (lambda (elt ans)
+                         (if (member elt ans pred)
+                             ans
+                             (cons elt ans)))
+                       ans lis))))
+        '()
+        rest))
 
 (define (lset-intersection = list1 . rest)
   (let lp ((l list1) (acc '()))