From e5d2c2fa4fb0586308f4d716c9ae9d3ce47ae237 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 21 Jun 2000 18:19:20 +0000 Subject: [PATCH] * Made a couple of functions (not all yet) tail recursive. Thanks to William Webber for the hint. --- THANKS | 1 + ice-9/ChangeLog | 10 ++ ice-9/common-list.scm | 62 ++++---- test-suite/ChangeLog | 4 + test-suite/tests/common-list.test | 242 ++++++++++++++++++++++++++++++ 5 files changed, 290 insertions(+), 29 deletions(-) create mode 100644 test-suite/tests/common-list.test diff --git a/THANKS b/THANKS index f2dce3777..30b01958a 100644 --- a/THANKS +++ b/THANKS @@ -10,3 +10,4 @@ Contributors since the last release: For fixes or providing information which led to a fix: Brad Knotwell + William Webber diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c79b4ad95..8c121cd2a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,13 @@ +2000-06-16 Dirk Herrmann + + * common-list.scm (intersection, set-difference, remove-if, + remove-if-not): Made tail-recursive. Thanks to William Webber + for the hint. + + (delete-if!, delete-if-not!): Renamed parameter from `list' to + `l' in order to avoid confusion. Note: These functions are not + tail recursive yet. + 2000-06-21 Mikael Djurfeldt * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*', diff --git a/ice-9/common-list.scm b/ice-9/common-list.scm index fea6b8764..02d1858e2 100644 --- a/ice-9/common-list.scm +++ b/ice-9/common-list.scm @@ -54,16 +54,18 @@ in the result list." (define-public (intersection l1 l2) "Returns a new list that is the intersection of L1 and L2. Only elements that occur in both lists will occur in the result list." - (cond ((null? l1) l1) - ((null? l2) l2) - ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) - (else (intersection (cdr l1) l2)))) + (if (null? l2) l2 + (let loop ((l1 l1) (result '())) + (cond ((null? l1) (reverse! result)) + ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result))) + (else (loop (cdr l1) result)))))) (define-public (set-difference l1 l2) "Return elements from list L1 that are not in list L2." - (cond ((null? l1) l1) - ((memv (car l1) l2) (set-difference (cdr l1) l2)) - (else (cons (car l1) (set-difference (cdr l1) l2))))) + (let loop ((l1 l1) (result '())) + (cond ((null? l1) (reverse! result)) + ((memv (car l1) l2) (loop (cdr l1) result)) + (else (loop (cdr l1) (cons (car l1) result)))))) (define-public (reduce-init p init l) "Same as `reduce' except it implicitly inserts INIT at the start of L." @@ -137,37 +139,39 @@ if PRED does not apply to any element in L." ((pred (car l)) l) (else (member-if pred (cdr l))))) -(define-public (remove-if p l) - "Removes all elements from L where (P element) is true. +(define-public (remove-if pred? l) + "Removes all elements from L where (PRED? element) is true. Returns everything that's left." - (cond ((null? l) '()) - ((p (car l)) (remove-if p (cdr l))) - (else (cons (car l) (remove-if p (cdr l)))))) + (let loop ((l l) (result '())) + (cond ((null? l) (reverse! result)) + ((pred? (car l)) (loop (cdr l) result)) + (else (loop (cdr l) (cons (car l) result)))))) -(define-public (remove-if-not p l) - "Removes all elements from L where (P element) is #f. +(define-public (remove-if-not pred? l) + "Removes all elements from L where (PRED? element) is #f. Returns everything that's left." - (cond ((null? l) '()) - ((not (p (car l))) (remove-if-not p (cdr l))) - (else (cons (car l) (remove-if-not p (cdr l)))))) + (let loop ((l l) (result '())) + (cond ((null? l) (reverse! result)) + ((not (pred? (car l))) (loop (cdr l) result)) + (else (loop (cdr l) (cons (car l) result)))))) -(define-public (delete-if! pred list) +(define-public (delete-if! pred l) "Destructive version of `remove-if'." - (let delete-if ((list list)) - (cond ((null? list) '()) - ((pred (car list)) (delete-if (cdr list))) + (let delete-if ((l l)) + (cond ((null? l) '()) + ((pred (car l)) (delete-if (cdr l))) (else - (set-cdr! list (delete-if (cdr list))) - list)))) + (set-cdr! l (delete-if (cdr l))) + l)))) -(define-public (delete-if-not! pred list) +(define-public (delete-if-not! pred l) "Destructive version of `remove-if-not'." - (let delete-if-not ((list list)) - (cond ((null? list) '()) - ((not (pred (car list))) (delete-if-not (cdr list))) + (let delete-if-not ((l l)) + (cond ((null? l) '()) + ((not (pred (car l))) (delete-if-not (cdr l))) (else - (set-cdr! list (delete-if-not (cdr list))) - list)))) + (set-cdr! l (delete-if-not (cdr l))) + l)))) (define-public (butlast lst n) "Return all but the last N elements of LST." diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 624cd2160..a6b768eab 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2000-06-21 Dirk Herrmann + + * tests/common-list.test: Added. + 2000-06-21 Dirk Herrmann * tests/eval.test: Added. diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test new file mode 100644 index 000000000..349ba9e4f --- /dev/null +++ b/test-suite/tests/common-list.test @@ -0,0 +1,242 @@ +;;;; common-list.test --- tests guile's common list functions -*- scheme -*- +;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +(use-modules (ice-9 documentation) + (ice-9 common-list)) + + +;;; +;;; miscellaneous +;;; + + +(define (documented? object) + (object-documentation object)) + + +;;; +;;; intersection +;;; + +(with-test-prefix "intersection" + + (pass-if "documented?" + (documented? intersection)) + + (pass-if "both arguments empty" + (eq? (intersection '() '()) '())) + + (pass-if "first argument empty" + (eq? (intersection '() '(1)) '())) + + (pass-if "second argument empty" + (eq? (intersection '(1) '()) '())) + + (pass-if "disjoint arguments" + (eq? (intersection '(1) '(2)) '())) + + (pass-if "equal arguments" + (equal? (intersection '(1) '(1)) '(1))) + + (pass-if "reverse argument order" + (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3))) + + (pass-if "multiple matches in first list" + (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3))) + + (pass-if "multiple matches in second list" + (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3))) + + (pass-if "mixed arguments" + (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8))) + + ) + + +;;; +;;; set-difference +;;; + +(with-test-prefix "set-difference" + + (pass-if "documented?" + (documented? set-difference)) + + (pass-if "both arguments empty" + (eq? (set-difference '() '()) '())) + + (pass-if "first argument empty" + (eq? (set-difference '() '(1)) '())) + + (pass-if "second argument empty" + (equal? (set-difference '(1) '()) '(1))) + + (pass-if "disjoint arguments" + (equal? (set-difference '(1) '(2)) '(1))) + + (pass-if "equal arguments" + (eq? (set-difference '(1) '(1)) '())) + + (pass-if "reverse argument order" + (eq? (set-difference '(1 2 3) '(3 2 1)) '())) + + (pass-if "multiple matches in first list" + (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '())) + + (pass-if "multiple matches in second list" + (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '())) + + (pass-if "mixed arguments" + (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10))) + + ) + + +;;; +;;; remove-if +;;; + +(with-test-prefix "remove-if" + + (pass-if "documented?" + (documented? remove-if)) + + (pass-if "empty list, remove all" + (eq? (remove-if (lambda (x) #t) '()) '())) + + (pass-if "empty list, remove none" + (eq? (remove-if (lambda (x) #f) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (remove-if odd? '(1 2 3 4)) '(2 4))) + + ) + + +;;; +;;; remove-if-not +;;; + + +(with-test-prefix "remove-if-not" + + (pass-if "documented?" + (documented? remove-if-not)) + + (pass-if "empty list, remove all" + (eq? (remove-if-not (lambda (x) #f) '()) '())) + + (pass-if "empty list, remove none" + (eq? (remove-if-not (lambda (x) #t) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3))) + + ) + + +;;; +;;; delete-if! +;;; + + +(with-test-prefix "delete-if!" + + (pass-if "documented?" + (documented? delete-if!)) + + (pass-if "empty list, remove all" + (eq? (delete-if! (lambda (x) #t) '()) '())) + + (pass-if "empty list, remove none" + (eq? (delete-if! (lambda (x) #f) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (delete-if! odd? '(1 2 3 4)) '(2 4))) + + ) + + +;;; +;;; delete-if-not! +;;; + + +(with-test-prefix "delete-if-not!" + + (pass-if "documented?" + (documented? delete-if-not!)) + + (pass-if "empty list, remove all" + (eq? (delete-if-not! (lambda (x) #f) '()) '())) + + (pass-if "empty list, remove none" + (eq? (delete-if-not! (lambda (x) #t) '()) '())) + + (pass-if "non-empty list, remove all" + (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '())) + + (pass-if "non-empty list, remove none" + (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) + + (pass-if "non-empty list, remove some" + (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3))) + + ) -- 2.20.1