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 1f806ceb9c8b852f54c4772ecee9b34b22034af0..a04d6fa36cd6f25f2d70b4ae8cbc25c6f7fe3666 100644 (file)
--- 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
 \f
 ;;;; 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))))
-\f
-(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)))))
+\f
+(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))
 \f
 ;;;; Membership/Association Lists
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 011b21d656290a2f94631336c132b5c8443d57fd..bcab6b13438650d7c4ddb86f961b397d9a359e4a 100644 (file)
--- 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