guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-27-g9e775a


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-27-g9e775af
Date: Thu, 05 May 2011 11:01:14 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9e775af3bf0db457eceb5a9a1f4a87968d011492

The branch, stable-2.0 has been updated
       via  9e775af3bf0db457eceb5a9a1f4a87968d011492 (commit)
      from  89f9dd7065971d9d9047b42f044c06cc943f5efc (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 9e775af3bf0db457eceb5a9a1f4a87968d011492
Author: Andy Wingo <address@hidden>
Date:   Thu May 5 12:59:07 2011 +0200

    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.

-----------------------------------------------------------------------

Summary of changes:
 libguile/srfi-1.c      |   37 -----------------------
 libguile/srfi-1.h      |    3 +-
 module/srfi/srfi-1.scm |   75 +++++++++++++++++++++++++++++++++--------------
 3 files changed, 53 insertions(+), 62 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 5c07504..f67e600 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 593d9bb..85aa65d 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 8ddf271..68b62de 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 <address@hidden>
 ;;; 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 '()))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]