From 9e775af3bf0db457eceb5a9a1f4a87968d011492 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2011 12:59:07 +0200 Subject: 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. --- 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 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 ;;; 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 '())) -- cgit v1.2.1