From: Chris Hanson Date: Fri, 2 Nov 2001 03:28:09 +0000 (+0000) Subject: Change names: X-Git-Tag: 20090517-FFI~2476 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5046444ded41d19d17c1eb6e599799c94deb663c;p=mit-scheme.git Change names: list-transform-positive => keep-matching-items list-transform-negative => delete-matching-items list-search-positive => find-matching-item Implement new procedures: keep-matching-items! delete-matching-items! --- diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 1f806ceb9..a04d6fa36 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: list.scm,v 14.26 2001/09/25 05:09:36 cph Exp $ +$Id: list.scm,v 14.27 2001/11/02 03:27:50 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -673,10 +673,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Generalized List Operations -(define (list-transform-positive items predicate) +(define (keep-matching-items items predicate) (let ((lose (lambda () - (error:wrong-type-argument items "list" 'LIST-TRANSFORM-POSITIVE)))) + (error:wrong-type-argument items "list" 'KEEP-MATCHING-ITEMS)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -693,10 +693,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((null? items) items) (else (lose))))) -(define (list-transform-negative items predicate) +(define (delete-matching-items items predicate) (let ((lose (lambda () - (error:wrong-type-argument items "list" 'LIST-TRANSFORM-NEGATIVE)))) + (error:wrong-type-argument items "list" 'DELETE-MATCHING-ITEMS)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -713,34 +713,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((null? items) items) (else (lose))))) -(define ((list-deletor predicate) items) - (list-transform-negative items predicate)) - -(define (list-deletor! predicate) - (lambda (items) - (letrec ((trim-initial-segment - (lambda (items*) - (if (pair? items*) - (if (predicate (car items*)) - (trim-initial-segment (cdr items*)) - (begin - (locate-initial-segment items* (cdr items*)) - items*)) - (begin - (if (not (null? items*)) - (error:wrong-type-argument items "list" #f)) - '())))) - (locate-initial-segment - (lambda (last this) - (if (pair? this) - (if (predicate (car this)) - (set-cdr! last (trim-initial-segment (cdr this))) - (locate-initial-segment this (cdr this))) - (if (not (null? this)) - (error:wrong-type-argument items "list" #f)))))) - (trim-initial-segment items)))) - -(define (list-search-positive items predicate) +(define (find-matching-item items predicate) (let loop ((items* items)) (if (pair? items*) (if (predicate (car items*)) @@ -748,19 +721,77 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (loop (cdr items*))) (begin (if (not (null? items*)) - (error:wrong-type-argument items "list" 'LIST-SEARCH-POSITIVE)) + (error:wrong-type-argument items "list" 'FIND-MATCHING-ITEM)) #f)))) +(define list-transform-positive keep-matching-items) +(define list-transform-negative delete-matching-items) +(define list-search-positive find-matching-item) + (define (list-search-negative items predicate) - (let loop ((items* items)) - (if (pair? items*) - (if (predicate (car items*)) - (loop (cdr items*)) - (car items*)) - (begin - (if (not (null? items*)) - (error:wrong-type-argument items "list" 'LIST-SEARCH-NEGATIVE)) - #f)))) + (find-matching-item items + (lambda (item) + (not (predicate item))))) + +(define (delete-matching-items! items predicate) + (letrec + ((trim-initial-segment + (lambda (items*) + (if (pair? items*) + (if (predicate (car items*)) + (trim-initial-segment (cdr items*)) + (begin + (locate-initial-segment items* (cdr items*)) + items*)) + (begin + (if (not (null? items*)) + (lose)) + '())))) + (locate-initial-segment + (lambda (last this) + (if (pair? this) + (if (predicate (car this)) + (set-cdr! last (trim-initial-segment (cdr this))) + (locate-initial-segment this (cdr this))) + (if (not (null? this)) + (lose))))) + (lose + (lambda () + (error:wrong-type-argument items "list" 'DELETE-MATCHING-ITEMS!)))) + (trim-initial-segment items))) + +(define (keep-matching-items! items predicate) + (letrec + ((trim-initial-segment + (lambda (items*) + (if (pair? items*) + (if (predicate (car items*)) + (begin + (locate-initial-segment items* (cdr items*)) + items*) + (trim-initial-segment (cdr items*))) + (begin + (if (not (null? items*)) + (lose)) + '())))) + (locate-initial-segment + (lambda (last this) + (if (pair? this) + (if (predicate (car this)) + (locate-initial-segment this (cdr this)) + (set-cdr! last (trim-initial-segment (cdr this)))) + (if (not (null? this)) + (lose))))) + (lose + (lambda () + (error:wrong-type-argument items "list" 'KEEP-MATCHING-ITEMS!)))) + (trim-initial-segment items))) + +(define ((list-deletor predicate) items) + (delete-matching-items items predicate)) + +(define ((list-deletor! predicate) items) + (delete-matching-items! items predicate)) ;;;; Membership/Association Lists diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 011b21d65..bcab6b134 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.379 2001/10/10 04:52:37 cph Exp $ +$Id: runtime.pkg,v 14.380 2001/11/02 03:28:09 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -1391,6 +1391,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA delete delete! delete-association-procedure + delete-matching-items + delete-matching-items! delete-member-procedure delq delq! @@ -1400,12 +1402,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA except-last-pair except-last-pair! fifth + find-matching-item first fold-left fold-right for-each fourth general-car-cdr + keep-matching-items last-pair length list