mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 20:05:32 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-05-05 12:59:07 +02:00
parent 89f9dd7065
commit 9e775af3bf
3 changed files with 53 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

37
libguile/srfi-1.c
View file

@ -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"

3
libguile/srfi-1.h
View file

@ -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);

63
module/srfi/srfi-1.scm
View file

@ -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,6 +752,14 @@ 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)
@ -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
;; Likewise, allow memq / memv to be used if possible.
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
(lambda (x y) (= y x))))
(set! acc (cons elem acc))))
lst)))
rest)
acc))
(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 '()))